1 C***********************************************************************
9 C ($Revision: 1.12.1.35 $, $Date: 2000/06/25 21:59:19 $)
12 C Authors: Ralph Engel
13 C (ralph.engel@fzk.de)
16 C (johannes.ranft@cern.ch)
19 C (Stefan.Roesler@cern.ch)
22 C For the latest version and documentation check
23 C http://www-ik.fzk.de/~engel/phojet.html
26 C Bug reports, questions, complaints are welcome
27 C (please send a mail to ralph.engel@fzk.de).
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***********************************************************************
397 *$ CREATE PHO_INIT.FOR
400 SUBROUTINE PHO_INIT(LINP,LOUT,IREJ)
401 C***********************************************************************
403 C main subroutine to configure and manage PHOJET calculations
405 C input: LINP input unit to read from
406 C -1 to skip reading of input file
407 C LOUT output unit to write to
409 C output: IREJ 0 success
412 C***********************************************************************
413 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
416 C input/output channels
418 COMMON /POINOU/ LI,LO
419 C event debugging information
421 PARAMETER (NMAXD=100)
422 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
423 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
424 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
425 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
426 C model switches and parameters
428 INTEGER ISWMDL,IPAMDL
429 DOUBLE PRECISION PARMDL
430 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
431 C general process information
432 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
433 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
435 C global event kinematics and particle IDs
437 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
438 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
439 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
440 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
441 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
442 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
443 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
444 C integration precision for hard cross sections (obsolete)
445 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
446 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
447 C some hadron information, will be deleted in future versions
449 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
450 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
451 C obsolete cut-off information
452 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
453 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
454 C photon flux kinematics and cuts
455 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
456 & YMIN1,YMAX1,YMIN2,YMAX2,
457 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
458 & THMIN1,THMAX1,THMIN2,THMAX2
460 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
461 & YMIN1,YMAX1,YMIN2,YMAX2,
462 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
463 & THMIN1,THMAX1,THMIN2,THMAX2,
465 C cut probability distribution
466 INTEGER IEETA1,IIMAX,KKMAX
467 PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
468 INTEGER IEEMAX,IMAX,KMAX
470 DOUBLE PRECISION EPTAB
471 COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
473 C event weights and generated cross section
474 INTEGER IPOWGC,ISWCUT,IVWGHT
475 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
476 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
477 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
478 C names of hard scattering processes
480 PARAMETER ( Max_pro_1 = 16 )
482 COMMON /POHPRO/ PROC(0:Max_pro_1)
483 C hard cross sections and MC selection weights
485 PARAMETER ( Max_pro_2 = 16 )
486 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
488 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
489 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
490 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
491 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
492 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
493 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
496 DOUBLE PRECISION PARU,PARJ
497 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
500 DOUBLE PRECISION PMAS,PARF,VCKM
501 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
503 INTEGER MDCY,MDME,KFDP
504 DOUBLE PRECISION BRAT
505 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
511 CHARACTER*70 NUMBER,FILENA
516 C define input/output units
527 WRITE(LO,*) ' ==================================================='
529 WRITE(LO,*) ' ---- PHOJET version 1.12 ---- '
531 WRITE(LO,*) ' ==================================================='
532 WRITE(LO,*) ' Authors: Ralph Engel (FZ Karlsruhe)'
533 WRITE(LO,*) ' Johannes Ranft (Siegen Univ.)'
534 WRITE(LO,*) ' Stefan Roesler (CERN)'
535 WRITE(LO,*) ' ---------------------------------------------------'
536 WRITE(LO,*) ' Manual, updates, and further information:'
537 WRITE(LO,*) ' http://www-ik.fzk.de/~engel/phojet.html'
538 WRITE(LO,*) ' ---------------------------------------------------'
539 WRITE(LO,*) ' please send suggestions / bug reports etc. to:'
540 WRITE(LO,*) ' ralph.engel@fzk.de'
541 WRITE(LO,*) ' ==================================================='
542 WRITE(LO,*) ' $Date: 2000/06/25 21:59:19 $'
543 WRITE(LO,*) ' $Revision: 1.12.1.35 $'
545 WRITE(LO,*) ' (code version with interface to PYTHIA 6.x)'
547 WRITE(LO,*) ' (code version for usage in DPMJET 3.x)'
549 WRITE(LO,*) ' ==================================================='
552 C standard initializations
555 DUM = PHO_PMASS(0,-1)
557 C initialize standard PDFs
559 CALL PHO_SETPDF(2212,IDUM,5,6,0,0,-1)
560 CALL PHO_SETPDF(-2212,IDUM,5,6,0,0,-1)
562 CALL PHO_SETPDF(2112,IDUM,5,6,0,0,-1)
563 CALL PHO_SETPDF(-2112,IDUM,5,6,0,0,-1)
565 CALL PHO_SETPDF(22,IDUM,5,3,0,0,-1)
567 CALL PHO_SETPDF(990,IDUM,4,0,0,0,-1)
569 CALL PHO_SETPDF(211,IDUM,5,2,0,0,-1)
570 CALL PHO_SETPDF(-211,IDUM,5,2,0,0,-1)
571 CALL PHO_SETPDF(111,IDUM,5,2,0,0,-1)
573 CALL PHO_SETPDF(321,IDUM,5,2,0,0,-1)
574 CALL PHO_SETPDF(-321,IDUM,5,2,0,0,-1)
575 CALL PHO_SETPDF(130,IDUM,5,2,0,0,-1)
576 CALL PHO_SETPDF(310,IDUM,5,2,0,0,-1)
581 C main loop to read input cards
583 READ(LINP,14,END=1300) CNAME,NUMBER
584 IF(CNAME.EQ.'ENDINPUT ') THEN
586 ELSE IF(CNAME.EQ.'STOP ') THEN
589 ELSE IF(CNAME.EQ.'COMMENT ') THEN
590 WRITE(LO,'(1X,A10,A69)') 'COMMENT ',NUMBER
591 ELSE IF(CNAME(1:1).EQ.'*') THEN
592 WRITE(LO,'(1X,A10,A69)') CNAME,NUMBER
593 ELSE IF(CNAME.EQ.'PTCUT ') THEN
594 READ(NUMBER,*) PARMDL(36),PARMDL(37),PARMDL(38),PARMDL(39)
595 WRITE(LO,*) 'PTCUT ',PARMDL(36),PARMDL(37),
596 & PARMDL(38),PARMDL(39)
597 ELSE IF(CNAME.EQ.'PROCESS ') THEN
598 READ(NUMBER,*) (IPRON(KK,1),KK=1,8)
599 WRITE(LO,*) 'PROCESS ',(IPRON(KK,1),KK=1,8)
600 ELSE IF(CNAME.EQ.'DIFF-PROC ') THEN
601 READ(NUMBER,*) (ITMP(KK),KK=0,11)
602 WRITE(LO,*) 'DIFF-PROC ',(ITMP(KK),KK=0,8)
604 IPRON(KK,ITMP(0)) = ITMP(KK)
606 ELSE IF(CNAME.EQ.'SUBPROCESS') THEN
607 READ(NUMBER,*) IMPRO,IP,ION
608 WRITE(LO,*) 'SUBPROCESS',IMPRO,IP,ION
609 MH_pro_on(IMPRO,IP) = ION
610 ELSE IF(CNAME.EQ.'PARTICLE1 ') THEN
611 READ(NUMBER,*) IDPDG,PVIR
614 CALL PHO_SETPAR(1,IDPDG,0,PVIR)
615 WRITE(LO,*) 'PARTICLE1 ',IDPDG,PVIR
616 ELSE IF(CNAME.EQ.'PARTICLE2 ') THEN
617 READ(NUMBER,*) IDPDG,PVIR
620 CALL PHO_SETPAR(2,IDPDG,0,PVIR)
621 WRITE(LO,*) 'PARTICLE2 ',IDPDG,PVIR
622 ELSE IF(CNAME.EQ.'REMNANT1 ') THEN
623 READ(NUMBER,*) IDPDG,IFL1,IFL2,IVAL,XSUB
629 CALL PHO_SETPAR(1,IDPDG,-1,PVIR)
630 WRITE(LO,*) 'REMNANT1 ',IDPDG,IFL1,IFL2,IVAL,XSUB
631 ELSE IF(CNAME.EQ.'REMNANT2 ') THEN
632 READ(NUMBER,*) IDPDG,IFL1,IFL2,IVAL,XSUB
638 CALL PHO_SETPAR(2,IDPDG,-1,PVIR)
639 WRITE(LO,*) 'REMNANT2 ',IDPDG,IFL1,IFL2,IVAL,XSUB
640 ELSE IF(CNAME.EQ.'PDF ') THEN
641 READ(NUMBER,*) IDPDG,IPAR,ISET,IEXT
642 WRITE(LO,*) 'PDF ',IDPDG,IPAR,ISET,IEXT
643 CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,IEXT,0,-1)
644 ELSE IF(CNAME.EQ.'SETMODEL ') THEN
645 READ(NUMBER,*) I,IVAL
646 WRITE(LO,*) 'SETMODEL ',I,IVAL
647 CALL PHO_SETMDL(I,IVAL,1)
648 ELSE IF(CNAME.EQ.'SETPARAM ') THEN
649 READ(NUMBER,*) I,PARNEW
650 WRITE(LO,*) 'SETPARAM ',I,PARNEW
652 ELSE IF(CNAME.EQ.'DEBUG ') THEN
653 READ(NUMBER,*) IDEBF,IDEBN,IDLEV
654 WRITE(LO,*) 'DEBUG ',IDEBF,IDEBN,IDLEV
655 CALL PHO_TRACE(IDEBF,IDEBN,IDLEV)
656 ELSE IF(CNAME.EQ.'TRACE ') THEN
657 READ(NUMBER,*) IDEBF,IDLEV
658 WRITE(LO,*) 'TRACE ',IDEBF,IDLEV
660 ELSE IF(CNAME.EQ.'SETICUT ') THEN
661 READ(NUMBER,*) I,ICUT
662 WRITE(LO,*) 'SETICUT ',I,ICUT
664 ELSE IF(CNAME.EQ.'SETFCUT ') THEN
665 READ(NUMBER,*) I,PARNEW
666 WRITE(LO,*) 'SETFCUT ',I,PARNEW
668 ELSE IF(CNAME.EQ.'LUND-MSTU ') THEN
669 READ(NUMBER,*) I,IVAL
670 WRITE(LO,*) 'LUND-MSTU ',I,IVAL
672 ELSE IF(CNAME.EQ.'LUND-MSTJ ') THEN
673 READ(NUMBER,*) I,IVAL
674 WRITE(LO,*) 'LUND-MSTJ ',I,IVAL
676 ELSE IF(CNAME.EQ.'LUND-PARJ ') THEN
678 WRITE(LO,*) 'LUND-PARJ ',I,EE
680 ELSE IF(CNAME.EQ.'LUND-PARU ') THEN
682 WRITE(LO,*) 'LUND-PARU ',I,EE
684 ELSE IF(CNAME.EQ.'LUND-DECAY') THEN
685 READ(NUMBER,*) ID,ION
686 WRITE(LO,*) 'LUND-DECAY ',ID,ION
691 ELSE IF(CNAME.EQ.'PSOFTMIN ') THEN
692 READ(NUMBER,*) PSOMIN
693 WRITE(LO,*) 'PSOFTMIN ',PSOMIN
694 ELSE IF(CNAME.EQ.'INTPREC ') THEN
695 READ(NUMBER,*) NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
696 WRITE(LO,*) 'INTPREC ',NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
699 ELSE IF(CNAME.EQ.'PDFTEST ') THEN
700 READ(NUMBER,*) IDPDG,SCALE2,PVIRT2
702 WRITE(LO,*) 'PDFTEST ',IDPDG,' ',SCALE2,' ',PVIRT2
703 CALL PHO_PDFTST(IDPDG,SCALE2,PVIRT2)
705 C mass cut on gamma-gamma or gamma-hadron system
706 ELSE IF(CNAME.EQ.'ECMS-CUT ') THEN
707 READ(NUMBER,*) ECMIN,ECMAX
708 WRITE(LO,*) 'ECMS-CUT ',ECMIN,ECMAX
710 C beam lepton (anti-)tagging system
711 ELSE IF(CNAME.EQ.'TAG-METHOD') THEN
712 READ(NUMBER,*) ITAG1,ITAG2
713 WRITE(LO,*) 'TAG-METHOD',ITAG1,ITAG2
714 ELSE IF(CNAME.EQ.'E-TAG1 ') THEN
716 & EEMIN1,YMIN1,YMAX1,Q2MIN1,Q2MAX1,THMIN1,THMAX1
717 WRITE(LO,*) 'E-TAG1 ',EEMIN1,YMIN1,YMAX1,
718 & Q2MIN1,Q2MAX1,THMIN1,THMAX1
719 ELSE IF(CNAME.EQ.'E-TAG2 ') THEN
721 & EEMIN2,YMIN2,YMAX2,Q2MIN2,Q2MAX2,THMIN2,THMAX2
722 WRITE(LO,*) 'E-TAG2 ',EEMIN2,YMIN2,YMAX2,
723 & Q2MIN2,Q2MAX2,THMIN2,THMAX2
725 C sampling of gamma-p events in ep (HERA)
726 ELSE IF( (CNAME.EQ.'WW-HERA ')
727 & .OR.(CNAME.EQ.'GP-HERA ')) THEN
728 READ(NUMBER,*) EE1,EE2,NEV
729 WRITE(LO,*) 'GP-HERA ',EE1,EE2,NEV
730 IF(YMAX2.LT.0.D0) THEN
731 WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGER NOT SET'
733 CALL PHO_GPHERA(NEV,EE1,EE2)
737 C sampling of gamma-gamma events in e+e- (LEP)
738 ELSE IF( (CNAME.EQ.'GG-EPEM ')
739 & .OR.(CNAME.EQ.'WW-EPEM ')) THEN
740 READ(NUMBER,*) EE1,EE2,NEV
741 WRITE(LO,*) 'GG-EPEM ',EE1,EE2,NEV
742 IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
743 WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGERS NOT SET'
745 CALL PHO_GGEPEM(-1,EE1,EE2)
746 CALL PHO_GGEPEM(NEV,EE1,EE2)
747 CALL PHO_GGEPEM(-2,sig_tot,sig_gg)
751 C sampling of gamma-gamma in heavy-ion collisions
752 ELSE IF(CNAME.EQ.'GG-HION-F ') THEN
753 READ(NUMBER,*) EE,NA,NZ,NEV
754 WRITE(LO,*) 'GG-HION-F ',EE,NA,NZ,NEV
755 IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
756 WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
758 CALL PHO_GGHIOF(NEV,EE,NA,NZ)
761 ELSE IF(CNAME.EQ.'GG-HION-G ') THEN
762 READ(NUMBER,*) EE,NA,NZ,NEV
763 WRITE(LO,*) 'GG-HION-G ',EE,NA,NZ,NEV
764 IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
765 WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
767 CALL PHO_GGHIOG(NEV,EE,NA,NZ)
771 C sampling of gamma-hadron events in heavy ion collisions
772 ELSE IF(CNAME.EQ.'GH-HION-F ') THEN
773 READ(NUMBER,*) EE,NA,NZ,NEV
774 WRITE(LO,*) 'GH-HION-F ',EE,NA,NZ,NEV
775 IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
776 WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
778 CALL PHO_GHHIOF(NEV,EE,NA,NZ)
782 C sampling of hadron-gamma events in hadron - heavy ion collisions
783 ELSE IF(CNAME.EQ.'HG-HIAS-F ') THEN
784 READ(NUMBER,*) EP,EE,NA,NZ,NEV
785 WRITE(LO,*) 'HG-HIAS-F ',EP,EE,NA,NZ,NEV
786 IF(YMAX2.LT.0.D0) THEN
787 WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
789 CALL PHO_GHHIAS(NEV,EP,EE,NA,NZ)
793 C sampling of photoproduction events e+e-, backscattered laser
794 ELSE IF(CNAME.EQ.'BLASER ') THEN
795 READ(NUMBER,*) EE1,EE2,Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A,NEV
796 WRITE(LO,*) 'BLASER ',EE1,EE2,
797 & Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A,NEV
798 CALL PHO_GGBLSR(NEV,EE1,EE2,Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A)
801 C sampling of photoproduction events beamstrahlung
802 ELSE IF(CNAME.EQ.'BEAMST ') THEN
803 READ(NUMBER,*) EE1,YPSI,SIGX,SIGY,SIGZ,AEB,NEV
804 WRITE(LO,*) 'BEAMST ',EE1,YPSI,SIGX,SIGY,SIGZ,AEB,NEV
805 IF(YMAX1.LT.0.D0) THEN
806 WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGER 1 NOT SET'
808 CALL PHO_GGBEAM(NEV,EE1,YPSI,SIGX,SIGY,SIGZ,AEB)
812 C fixed-energy events in LAB system of particle 2
813 ELSE IF(CNAME.EQ.'EVENT-LAB ') THEN
814 READ(NUMBER,*) PLAB,NEV
815 WRITE(LO,*) 'EVENT-LAB ',PLAB,NEV
816 CALL PHO_FIXLAB(PLAB,NEV)
819 C fixed-energy events in CM system
820 ELSE IF(CNAME.EQ.'EVENT-CMS ') THEN
821 READ(NUMBER,*) ECM,NEV
822 WRITE(LO,*) 'EVENT-CMS ',ECM,NEV
823 PMASS1 = PHO_PMASS(IFPAB(1),0)-SQRT(PVIRT(1))
824 PMASS2 = PHO_PMASS(IFPAB(2),0)-SQRT(PVIRT(2))
825 CALL PHO_PECMS(1,PMASS1,PMASS2,ECM,PCM,EE)
830 CALL PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
833 C fixed-energy events for collider setup with crossing angle
834 ELSE IF(CNAME.EQ.'EVENT-COLL') THEN
835 READ(NUMBER,*) E1,E2,THETA,PHI,NEV
836 WRITE(LO,*) 'EVENT-COLL',E1,E2,THETA,PHI,NEV
837 CALL PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
842 WRITE(LO,*) 'PHO_INIT: unknown data card: ',CNAME,NUMBER
847 WRITE(LO,*) ' RETURN'
851 *$ CREATE PHO_SETMDL.FOR
853 CDECK ID>, PHO_SETMDL
854 SUBROUTINE PHO_SETMDL(INDX,IVAL,IMODE)
855 C**********************************************************************
859 C input: INDX model parameter number
860 C (positive: ISWMDL, negative: IPAMDL)
862 C IMODE -1 print value of parameter INDX
864 C -2 print current settings
866 C**********************************************************************
867 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
870 C input/output channels
872 COMMON /POINOU/ LI,LO
873 C model switches and parameters
875 INTEGER ISWMDL,IPAMDL
876 DOUBLE PRECISION PARMDL
877 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
880 WRITE(LO,'(/1X,A,/1X,A,/)') 'PHO_SETMDL: current settings',
881 & '----------------------------'
883 IF(ISWMDL(I).EQ.-9999) GOTO 200
884 IF(ISWMDL(I+1).EQ.-9999) THEN
885 WRITE(LO,'(5X,I3,A1,A,I6)') I,':',MDLNA(I),ISWMDL(I)
887 ELSE IF(ISWMDL(I+2).EQ.-9999) THEN
888 WRITE(LO,'(2(5X,I3,A1,A,I6))') I,':',MDLNA(I),ISWMDL(I),
889 & I+1,':',MDLNA(I+1),ISWMDL(I+1)
892 WRITE(LO,'(3(5X,I3,A1,A,I6))')
893 & (I+K,':',MDLNA(I+K),ISWMDL(I+K),K=0,2)
897 ELSE IF(IMODE.EQ.-1) THEN
898 WRITE(LO,'(1X,A,1X,A,I6)')
899 & 'PHO_SETMDL:',MDLNA(INDX),ISWMDL(INDX)
900 ELSE IF(IMODE.EQ.1) THEN
902 IF(ISWMDL(INDX).NE.IVAL) THEN
903 WRITE(LO,'(1X,A,I4,1X,A,2I6)')
904 & 'PHO_SETMDL:ISWMDL(OLD/NEW):',
905 & INDX,MDLNA(INDX),ISWMDL(INDX),IVAL
908 ELSE IF(INDX.LT.0) THEN
909 IF(IPAMDL(-INDX).NE.IVAL) THEN
910 WRITE(LO,'(1X,A,I4,1X,2I6)') 'PHO_SETMDL:IPAMDL(OLD/NEW):',
911 & -INDX,IPAMDL(-INDX),IVAL
916 WRITE(LO,'(/1X,A,I6)')
917 & 'PHO_SETMDL:ERROR: unsupported mode',IMODE
921 *$ CREATE PHO_DATINI.FOR
923 CDECK ID>, PHO_DATINI
924 SUBROUTINE PHO_DATINI
925 C*********************************************************************
927 C initialization of variables and switches
929 C*********************************************************************
930 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
933 C input/output channels
935 COMMON /POINOU/ LI,LO
937 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
938 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
939 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
940 C event debugging information
942 PARAMETER (NMAXD=100)
943 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
944 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
945 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
946 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
947 C event weights and generated cross section
948 INTEGER IPOWGC,ISWCUT,IVWGHT
949 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
950 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
951 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
952 C scale parameters for parton model calculations
953 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
954 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
955 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
956 & NQQAL,NQQALI,NQQALF,NQQPD
957 C integration precision for hard cross sections (obsolete)
958 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
959 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
960 C hard scattering parameters used for most recent hard interaction
962 DOUBLE PRECISION ALQCD2,BQCD
963 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
964 C cut probability distribution
965 INTEGER IEETA1,IIMAX,KKMAX
966 PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
967 INTEGER IEEMAX,IMAX,KMAX
969 DOUBLE PRECISION EPTAB
970 COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
972 C gamma-lepton or gamma-hadron vertex information
973 INTEGER IGHEL,IDPSRC,IDBSRC
974 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
975 & RADSRC,AMSRC,GAMSRC
976 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
977 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
978 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
979 C photon flux kinematics and cuts
980 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
981 & YMIN1,YMAX1,YMIN2,YMAX2,
982 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
983 & THMIN1,THMAX1,THMIN2,THMAX2
985 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
986 & YMIN1,YMAX1,YMIN2,YMAX2,
987 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
988 & THMIN1,THMAX1,THMIN2,THMAX2,
990 C obsolete cut-off information
991 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
992 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
993 C global event kinematics and particle IDs
995 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
996 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
997 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
998 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
999 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
1000 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
1001 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
1002 C some hadron information, will be deleted in future versions
1004 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
1005 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
1006 C model switches and parameters
1008 INTEGER ISWMDL,IPAMDL
1009 DOUBLE PRECISION PARMDL
1010 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
1011 C general process information
1012 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
1013 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
1014 C parameters of the "simple" Vector Dominance Model
1015 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
1016 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
1017 C parameters for DGLAP backward evolution in ISR
1019 DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
1020 COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
1021 C particles created by initial state evolution
1022 INTEGER MXISR1,MXISR2
1023 PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
1024 INTEGER IFLISR,IPOISR,IMXISR
1025 DOUBLE PRECISION PHISR
1026 COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
1027 & IPOISR(2,2,MXISR2),IMXISR(2)
1028 C names of hard scattering processes
1030 PARAMETER ( Max_pro_1 = 16 )
1032 COMMON /POHPRO/ PROC(0:Max_pro_1)
1033 C hard cross sections and MC selection weights
1035 PARAMETER ( Max_pro_2 = 16 )
1036 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
1038 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
1039 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
1040 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
1041 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
1042 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
1043 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
1044 C interpolation tables for hard cross section and MC selection weights
1045 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
1046 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
1047 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
1048 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
1049 & HQ2a_tab,HQ2b_tab,HEcm_tab
1051 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1052 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1053 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1054 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1055 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
1056 & HEcm_tab(1:Max_tab_E,0:4),
1057 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
1059 C initialize /POCONS/
1060 PI = ATAN(1.D0)*4.D0
1063 C GeV**-2 --> millibarn (multiply by GEV2MB to get mb as units)
1065 C precalculate quark charges
1067 Q_ch(i) = dble(2-3*mod(i,2))/3.D0
1070 Q_ch2(i) = Q_ch(i)**2
1071 Q_ch2(-i) = Q_ch2(i)
1073 Q_ch4(i) = Q_ch2(i)**2
1074 Q_ch4(-i) = Q_ch4(i)
1080 C initialize /GLOCMS/
1088 C initialize /HADVAL/
1095 C initialize /MODELS/
1097 MDLNA(1) = 'AMPL MOD'
1099 MDLNA(2) = 'MIN-BIAS'
1101 MDLNA(3) = 'PTS DISH'
1103 MDLNA(4) = 'PTS DISP'
1105 MDLNA(5) = 'PTS ASSI'
1107 MDLNA(6) = 'HADRONIZ'
1109 MDLNA(7) = 'MASS COR'
1111 MDLNA(8) = 'PAR SHOW'
1113 MDLNA(9) = 'GLU SPLI'
1115 MDLNA(10) = 'VIRT PHO'
1117 MDLNA(11) = 'LARGE NC'
1119 MDLNA(12) = 'LIPA POM'
1121 MDLNA(13) = 'QELAS VM'
1123 MDLNA(14) = 'ENHA GRA'
1125 MDLNA(15) = 'MULT SCA'
1127 MDLNA(16) = 'MULT DIF'
1129 MDLNA(17) = 'MULT CDF'
1131 MDLNA(18) = 'BALAN PT'
1133 MDLNA(19) = 'POMV FLA'
1135 MDLNA(20) = 'SEA FLA'
1137 MDLNA(21) = 'SPIN DEC'
1139 MDLNA(22) = 'DIF.MASS'
1141 MDLNA(23) = 'DIFF RES'
1143 MDLNA(24) = 'PTS HPOM'
1145 MDLNA(25) = 'POM CORR'
1147 MDLNA(26) = 'OVERLAP '
1149 MDLNA(27) = 'MUL R/AN'
1151 MDLNA(28) = 'SUR PROB'
1153 MDLNA(29) = 'PRIMO KT'
1155 MDLNA(30) = 'DIFF. CS'
1157 C mass-independent sea flavour ratios (for low-mass strings)
1164 C suppression by energy momentum conservation
1168 PARMDL(10) = 0.866D0
1169 PARMDL(11) = 0.288D0
1170 PARMDL(12) = 0.288D0
1171 PARMDL(13) = 0.288D0
1172 PARMDL(14) = 0.866D0
1173 PARMDL(15) = 0.288D0
1174 PARMDL(16) = 0.288D0
1175 PARMDL(17) = 0.288D0
1177 C lower energy limit for initialization
1179 C soft pt for hard scattering remnants
1181 C low energy beta of soft pt distribution 1
1183 C high energy beta of soft pt distribution 1
1185 C low energy beta of soft pt distribution 0
1187 C high energy beta of soft pt distribution 0
1189 C effective quark mass in photon wave function
1191 C normalization of unevolved Pomeron PDFs
1193 C effective VDM parameters for Q**2 dependence of cross section
1198 PARMDL(31) = 0.589824D0
1199 PARMDL(32) = 0.609961D0
1200 PARMDL(33) = 1.038361D0
1202 C Q**2 suppression of multiple interactions
1204 C pt cutoff defaults
1209 C enhancement factor for diffractive cross sections
1213 C mass in soft pt distribution
1215 C maximum of x allowed for leading particle
1217 C max. mass sampled in diffraction
1218 PARMDL(45) = sqrt(0.4D0)
1219 C mass threshold in diffraction (2pi mass)
1221 C regularization of slope parameter in diffraction
1223 C renormalized intercept for enhanced graphs
1225 C coherence constraint for diff. cross sections
1226 PARMDL(49) = sqrt(0.05D0)
1227 C exponents of x distributions
1231 PARMDL(52) = -0.99D0
1232 PARMDL(53) = -0.99D0
1233 C meson (non-strangeness part)
1236 PARMDL(56) = -0.99D0
1237 PARMDL(57) = -0.99D0
1238 C meson (strangeness part)
1241 PARMDL(60) = -0.99D0
1242 PARMDL(61) = -0.99D0
1243 C particle remnant (no valence quarks)
1246 PARMDL(64) = -0.99D0
1247 PARMDL(65) = -0.99D0
1248 C ratio beetween triple-pomeron/reggeon couplings grrp/gppp
1250 C ratio beetween triple-pomeron/reggeon couplings gppr/gppp
1252 C min. abs(t) in diffraction
1254 C max. abs(t) in diffraction
1256 C min. mass for elastic pomerons in central diffraction
1258 C min. mass of diffractive blob in central diffraction
1260 C min. Feynman x cut in central diffraction
1262 C direct pomeron coupling
1264 C relative deviation allowed for energy-momentum conservation
1265 C energy-momentum relative deviation
1267 C transverse momentum deviation
1269 C couplings for unitarization in diffraction
1270 C non-unitarized pomeron coupling (sqrt(mb))
1272 C rescaling factor for pomeron PDF
1274 C coupling probabilities
1277 C scales to calculate alpha-s of matrix element
1281 C scales to calculate alpha-s of initial state radiation
1285 C scales to calculate alpha-s of final state radiation
1289 C scales to calculate PDFs
1293 C scale for ISR starting virtuality
1295 C min. virtuality to generate time-like showers in ISR
1297 C factor to scale the max. allowed time-like parton shower virtuality
1299 C max. transverse momentum for primordial kt
1301 C weight factors for pt-distribution
1309 * PARMDL(110-125) reserved for hard scattering
1310 C currently chosen scales for hard scattering
1312 PARMDL(109+I) = 0.D0
1314 C virtuality cutoff in initial state evolution
1315 PARMDL(126) = PARMDL(36)**2
1316 PARMDL(127) = PARMDL(37)**2
1317 PARMDL(128) = PARMDL(38)**2
1318 PARMDL(129) = PARMDL(39)**2
1319 C virtuality cutoff for direct contribution to photon PDF
1324 C fraction of events without popcorn
1326 C fraction of diquarks with spin 1 (relative to sum of spin 1 and 0)
1328 C soft color re-connection (fraction)
1330 PARMDL(140) = 1.D0/64.D0
1332 PARMDL(141) = 1.D0/24.D0
1334 PARMDL(142) = 1.D0/9.D0
1335 C effective scale in Drees-Godbole like suppresion in photon PDF
1336 PARMDL(144) = 0.766D0**2
1337 C QCD scales (if PDF scales are not used, 4 active flavours)
1338 PARMDL(145) = 0.2D0**2
1339 PARMDL(146) = 0.2D0**2
1340 PARMDL(147) = 0.2D0**2
1341 C threshold scales for variable flavour calculation (GeV**2)
1342 PARMDL(148) = 1.5D0**2
1343 PARMDL(149) = 4.5D0**2
1344 PARMDL(150) = 175.D0**2
1345 C constituent quark masses
1351 PARMDL(156) = 174.D0
1352 C min. masses of valence quark
1354 C min. masses of valence diquark
1356 C min. mass of sea quark
1358 C suppression of strange quarks as photon valences
1360 C min. masses for strings (used in PHO_SOFTXX)
1365 C min. momentum fraction for soft processes
1367 C min. phase space for x-sampling
1368 PARMDL(166) = 0.135D0
1369 C Ross-Stodolsky exponent
1371 C cutoff on photon-pomeron invariant mass in hadron-hadron collisions
1375 * extra factor multiplying difference between Goulianos and PHOJET-
1376 * diff. cross sections
1380 C complex amplitudes, eikonal functions
1382 C allow for Reggeon cuts
1384 C decay of hadron resonances in diffraction (0 iso, 1 trans, 2 long)
1386 C polarization of photon resonances (0 none, 1 trans, 2 long)
1388 C pt of valence partons
1390 C pt of hard scattering remnant
1392 C running cutoff for hard scattering
1394 C intercept used for the calculation of enhanced graphs
1396 C effective slope of hard scattering amplitde
1398 C mass dependence of slope parameters
1400 C lepton-photon vertex 1
1402 C lepton-photon vertex 2
1406 C method to sample x distributions
1408 C energy-momentum check
1410 C phase space correction for DPMJET interface
1412 C fragment strings from projectile/target/central diff. separately
1414 C method to construct strings for hard interactions
1416 C method to construct strings for soft sea (pomeron cuts)
1418 C method to construct strings in pomeron interactions
1420 C soft color re-connection
1422 C resummation of triple- and loop-Pomeron
1424 C resummation of X iterated triple-Pomeron
1426 C dimension of interpolation table for weights in hard scattering
1427 IPAMDL(30) = Max_tab_E
1428 C dimension of interpolation table for pomeron cut distribution
1430 C number of cut soft pomerons (restriction by field dimension)
1432 C number of cut hard pomerons (restriction by field dimension)
1434 C tau pair production in direct photon-photon collisions
1436 C currently chosen scales for hard scattering
1437 C ATTENTION: IPAMDL(65-80) reserved for hard scattering!
1439 IPAMDL(64+I) = -99999
1441 C scales to calculate alpha-s of matrix element
1445 C scales to calculate alpha-s of initial state radiation
1449 C scales to calculate alpha-s of final state radiation
1453 C scales to calculate PDFs
1457 C where to get the parameter sets from
1459 C program PHO_ABORT for fatal errors (simulation of division by zero)
1461 C initial state parton showers for all / hardest interaction(s)
1463 C final state parton showers for all / hardest interaction(s)
1465 C initial virtuality for ISR generation
1467 C qqbar-gamma coupling in initial state showers
1469 C generation of time-like showers during ISR
1471 C reweighting of multiple soft contributions for virtual photons
1473 C reweighting / use photon virtuality in photon PDF calculations
1475 C use full QPM model incl. interference terms (direct part in gam-gam)
1477 C matching sigma_tot to F2 as given by parton density at high Q2
1479 C use virtuality of target in F2 calculations (two-gamma only)
1481 C calculation of alpha_em
1483 C strict pt cutoff for gamma-gamma events
1485 C photon virtuality sampled in photon flux approximations
1487 C photon-pomeron: 0,1,2: both,left,right photon emission
1489 C keep full history information in PHOJET-JETSET interface
1491 C max. number of conservation law violations allowed in one run
1493 C selection of soft X values
1494 C max. iteration number in PHO_SELSXS
1496 C max. iteration number in PHO_SELSXR
1498 C max. iteration number in PHO_SELSX2
1500 C max. iteration number in PHO_SELSXI
1503 C initialize /PROBAB/
1509 PARMDL(300+I) = -100000.D0
1511 C initialize /POHDRN/
1512 QMASS(1) = PARMDL(151)
1513 QMASS(2) = PARMDL(152)
1514 QMASS(3) = PARMDL(153)
1515 QMASS(4) = PARMDL(154)
1516 QMASS(5) = PARMDL(155)
1517 QMASS(6) = PARMDL(156)
1522 C number of light flavours (quarks treated as massless)
1524 C initialize /POCUT1/
1525 PTCUT(1) = PARMDL(36)
1526 PTCUT(2) = PARMDL(37)
1527 PTCUT(3) = PARMDL(38)
1528 PTCUT(4) = PARMDL(39)
1531 C initialize /POHAPA/
1534 BQCD(1) = PI4/(11.D0-(2.D0/3.D0)*3)
1535 BQCD(2) = PI4/(11.D0-(2.D0/3.D0)*4)
1536 BQCD(3) = PI4/(11.D0-(2.D0/3.D0)*5)
1537 BQCD(4) = PI4/(11.D0-(2.D0/3.D0)*6)
1538 C initialize /POGAUP/
1548 C initialize /PROCES/
1553 C DPMJET default: no elastic scattering
1563 C initialize /POSVDM/
1577 RMAX(1) = VMAS(1)+TWOPIM
1578 RMAX(2) = VMAS(2)+TWOPIM
1579 RMAX(3) = VMAS(3)+TWOPIM
1580 RMAX(4) = VMAS(1)+TWOPIM
1589 C initialize /PODGL1/
1590 Q2MISR(1) = PARMDL(36)**2
1591 Q2MISR(2) = PARMDL(36)**2
1599 C initialize /POPISR/
1604 C initialize /POHPRO/
1605 PROC(0) = 'sum over processes'
1606 PROC(1) = 'G +G --> G +G '
1607 PROC(2) = 'Q +QB --> G +G '
1608 PROC(3) = 'G +Q --> G +Q '
1609 PROC(4) = 'G +G --> Q +QB '
1610 PROC(5) = 'Q +QB --> Q +QB '
1611 PROC(6) = 'Q +QB --> QP +QBP'
1612 PROC(7) = 'Q +Q --> Q +Q '
1613 PROC(8) = 'Q +QP --> Q +QP '
1614 PROC(9) = 'resolved processes'
1615 PROC(10) = 'gam+Q --> G +Q '
1616 PROC(11) = 'gam+G --> Q +QB '
1617 PROC(12) = 'Q +gam--> G +Q '
1618 PROC(13) = 'G +gam--> Q +QB '
1619 PROC(14) = 'gam+gam--> Q +QB '
1620 PROC(15) = 'direct processes '
1621 PROC(16) = 'gam+gam--> l+ +l- '
1623 C initialize /POHRCS/
1631 C switch all hard subprocesses on
1633 C reset all counters
1641 C initialize /POHTAB/
1646 HEcm_tab(1,I) = 0.D0
1652 C initialize /POFSRC/
1655 C initialize /LEPCUT/
1668 C initialize /POWGHT/
1682 *$ CREATE PHO_PARDAT.FOR
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 *$ CREATE PHO_PRESEL.FOR
2483 CDECK ID>, PHO_PRESEL
2484 SUBROUTINE PHO_PRESEL(MODE,IREJ)
2485 C**********************************************************************
2487 C user specific function to pre-select events during generation
2489 C input: MODE 5 electron and photon kinematics
2490 C 10 process and number of cut Pomerons
2491 C 15 partons without construction of strings
2492 C 20 partons assigned to strings
2493 C 25 after fragmentation, complete final state
2495 C output: IREJ 0 event accepted
2498 C**********************************************************************
2499 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2502 C input/output channels
2504 COMMON /POINOU/ LI,LO
2505 C event debugging information
2507 PARAMETER (NMAXD=100)
2508 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2509 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2510 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2511 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2513 C standard particle data interface
2516 PARAMETER (NMXHEP=4000)
2518 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
2519 DOUBLE PRECISION PHEP,VHEP
2520 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2521 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
2523 C extension to standard particle data interface (PHOJET specific)
2524 INTEGER IMPART,IPHIST,ICOLOR
2525 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
2527 C global event kinematics and particle IDs
2529 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
2530 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
2531 C gamma-lepton or gamma-hadron vertex information
2532 INTEGER IGHEL,IDPSRC,IDBSRC
2533 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
2534 & RADSRC,AMSRC,GAMSRC
2535 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
2536 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
2537 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
2538 C hard scattering data
2540 PARAMETER ( MSCAHD = 50 )
2541 INTEGER LSCAHD,LSC1HD,LSIDX,
2542 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
2543 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
2544 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
2545 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
2546 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
2547 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
2548 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
2549 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
2550 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
2551 C event weights and generated cross section
2552 INTEGER IPOWGC,ISWCUT,IVWGHT
2553 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2554 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2555 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2559 * XBJ = GQ2(2)/(GGECM**2+GQ2(2))
2560 * IF(XBJ.LT.0.002D0) IREJ = 1
2564 *$ CREATE PHO_FIXCOL.FOR
2566 CDECK ID>, PHO_FIXCOL
2567 SUBROUTINE PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
2568 C**********************************************************************
2570 C interface to call PHOJET (fixed energy run) with
2571 C collider kinematics
2573 C equivalen photon approximation to get photon flux
2575 C input: NEV number of events to generate
2576 C THETA azimuthal angle (micro radians)
2577 C PHI beam crossing angle
2578 C (with respect to x, in degrees)
2579 C E1 energy of particle 1 (+z direction, GeV)
2580 C E2 energy of particle 2 (-z direction, GeV)
2582 C note: particle types have to be specified before
2585 C**********************************************************************
2586 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2589 PARAMETER(TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
2591 C input/output channels
2593 COMMON /POINOU/ LI,LO
2594 C event debugging information
2596 PARAMETER (NMAXD=100)
2597 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2598 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2599 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2600 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2601 C general process information
2602 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
2603 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
2604 C global event kinematics and particle IDs
2606 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
2607 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
2608 C model switches and parameters
2610 INTEGER ISWMDL,IPAMDL
2611 DOUBLE PRECISION PARMDL
2612 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
2613 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
2614 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
2615 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
2616 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
2617 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
2618 C integration precision for hard cross sections (obsolete)
2619 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2620 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2621 C event weights and generated cross section
2622 INTEGER IPOWGC,ISWCUT,IVWGHT
2623 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2624 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2625 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2627 DIMENSION P1(4),P2(4)
2629 C remnant initialization (only needed for DPMJET)
2632 IF(IFPAP(1).EQ.81) THEN
2638 IF(IFPAP(2).EQ.82) THEN
2642 PMASS1 = PHO_PMASS(IFPAB(1),0)-SQRT(PVIRT(1))
2643 PMASS2 = PHO_PMASS(IFPAB(2),0)-SQRT(PVIRT(2))
2644 PP1 = SQRT(E1**2-PMASS1**2)
2645 PP2 = SQRT(E2**2-PMASS2**2)
2646 C beam crossing angle
2647 TH = 1.D-6*THETA/2.D0
2649 P1(1) = PP1*SIN(TH)*COS(PH)
2650 P1(2) = PP1*SIN(TH)*SIN(PH)
2653 P2(1) = PP2*SIN(TH)*COS(PH)
2654 P2(2) = PP2*SIN(TH)*SIN(PH)
2655 P2(3) = -PP2*COS(TH)
2657 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
2663 CALL PHO_PHIST(-1,SIGMAX)
2664 CALL PHO_LHIST(-1,SIGMAX)
2665 C test of DPMJET interface (default is IPAMDL(13)=0)
2666 if(IPAMDL(13).gt.0) then
2672 C main generation loop
2676 CALL PHO_EVENT(MODE,P1,P2,SIGCUR,IREJ)
2677 IF(IREJ.NE.0) GOTO 55
2678 CALL PHO_PHIST(1,HSWGHT(0))
2679 CALL PHO_LHIST(1,HSWGHT(0))
2683 SIGMAX = SIGMAX*DBLE(NEV)/DBLE(ITRY)
2684 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
2685 & '=========================================================',
2686 & ' ***** simulated cross section: ',SIGMAX,' mb *****',
2687 & '========================================================='
2688 CALL PHO_EVENT(-2,P1,P2,SIGCUR,IREJ)
2689 CALL PHO_PHIST(-2,SIGMAX)
2690 CALL PHO_LHIST(-2,SIGMAX)
2692 WRITE(LO,'(1X,A,I5)') 'POFCOL: no events simulated',NEV
2697 *$ CREATE PHO_FIXLAB.FOR
2699 CDECK ID>, PHO_FIXLAB
2700 SUBROUTINE PHO_FIXLAB(PLAB,NEV)
2701 C**********************************************************************
2703 C interface to call PHOJET (fixed energy run) with
2704 C LAB kinematics (second particle as target)
2706 C equivalent photon approximation to get photon flux
2708 C input: NEV number of events to generate
2709 C PLAB LAB momentum of particle 1
2711 C note: particle types have to be specified before
2714 C**********************************************************************
2715 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2718 C input/output channels
2720 COMMON /POINOU/ LI,LO
2721 C event debugging information
2723 PARAMETER (NMAXD=100)
2724 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2725 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2726 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2727 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2728 C general process information
2729 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
2730 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
2731 C global event kinematics and particle IDs
2733 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
2734 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
2735 C model switches and parameters
2737 INTEGER ISWMDL,IPAMDL
2738 DOUBLE PRECISION PARMDL
2739 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
2740 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
2741 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
2742 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
2743 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
2744 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
2745 C integration precision for hard cross sections (obsolete)
2746 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2747 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2748 C event weights and generated cross section
2749 INTEGER IPOWGC,ISWCUT,IVWGHT
2750 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2751 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2752 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2754 DIMENSION P1(4),P2(4)
2756 C remnant initialization (only needed for DPMJET)
2760 IF(IFPAP(1).EQ.81) THEN
2766 IF(IFPAP(2).EQ.82) THEN
2770 C get momenta in LAB system
2771 PMASS1 = PHO_PMASS(IFPAB(1),0)**2-PVIRT(1)
2772 PMASS2 = PHO_PMASS(IFPAB(2),0)**2-PVIRT(2)
2773 IF(PMASS2.LT.0.1D0) THEN
2774 WRITE(LO,'(/1X,2A,2I7)') 'PHO_FIXLAB:ERROR: ',
2775 & 'no LAB system possible',IFPAB(1),IFPAB(2)
2780 P1(4) = SQRT(PMASS1+PLAB**2)
2784 P2(4) = SQRT(PMASS2)
2785 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
2791 CALL PHO_PHIST(-1,SIGMAX)
2792 CALL PHO_LHIST(-1,SIGMAX)
2793 C event generation loop
2797 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
2798 IF(IREJ.NE.0) GOTO 45
2799 CALL PHO_LHIST(1,HSWGHT(0))
2801 CALL PHO_PHIST(10,HSWGHT(0))
2805 SIGMAX = SIGMAX*DBLE(NEV)/DBLE(ITRY)
2806 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
2807 & '=========================================================',
2808 & ' ***** simulated cross section: ',SIGMAX,' mb *****',
2809 & '========================================================='
2810 CALL PHO_EVENT(-2,P1,P2,SIGCUR,IREJ)
2811 CALL PHO_PHIST(-2,SIGMAX)
2812 CALL PHO_LHIST(-2,SIGMAX)
2814 WRITE(LO,'(1X,A,I5)')
2815 & 'PHO_FIXLAB: no events simulated',NEV
2821 *$ CREATE PHO_GPHERA.FOR
2823 CDECK ID>, PHO_GPHERA
2824 SUBROUTINE PHO_GPHERA(NEVENT,EE1,EE2)
2825 C**********************************************************************
2827 C interface to call PHOJET (variable energy run) with
2828 C HERA kinematics, photon as particle 2
2830 C equivalent photon approximation to get photon flux
2832 C input: NEVENT number of events to generate
2833 C EE1 proton energy (LAB system)
2834 C EE2 electron energy (LAB system)
2836 C YMIN2 lower limit of Y
2837 C (energy fraction taken by photon from electron)
2838 C YMAX2 upper limit of Y
2839 C Q2MIN2 lower limit of photon virtuality
2840 C Q2MAX2 upper limit of photon virtuality
2842 C**********************************************************************
2843 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2846 PARAMETER ( DEPS = 1.D-10,
2847 & PI = 3.14159265359D0 )
2849 C input/output channels
2851 COMMON /POINOU/ LI,LO
2852 C event debugging information
2854 PARAMETER (NMAXD=100)
2855 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2856 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2857 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2858 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2859 C model switches and parameters
2861 INTEGER ISWMDL,IPAMDL
2862 DOUBLE PRECISION PARMDL
2863 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
2864 C photon flux kinematics and cuts
2865 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
2866 & YMIN1,YMAX1,YMIN2,YMAX2,
2867 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
2868 & THMIN1,THMAX1,THMIN2,THMAX2
2870 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
2871 & YMIN1,YMAX1,YMIN2,YMAX2,
2872 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
2873 & THMIN1,THMAX1,THMIN2,THMAX2,
2875 C gamma-lepton or gamma-hadron vertex information
2876 INTEGER IGHEL,IDPSRC,IDBSRC
2877 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
2878 & RADSRC,AMSRC,GAMSRC
2879 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
2880 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
2881 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
2882 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
2883 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
2884 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
2885 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
2886 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
2887 C event weights and generated cross section
2888 INTEGER IPOWGC,ISWCUT,IVWGHT
2889 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2890 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2891 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2893 DIMENSION P1(4),P2(4)
2895 WRITE(LO,'(//1X,A,I10)') 'PHO_GPHERA: events to process',NEVENT
2896 C assign particle momenta according to HERA kinematics
2898 PROM = PHO_PMASS(2212,1)
2907 IDBSRC(2) = ipho_pdg2id(11)
2916 IF(Q2MIN.GT.ELEM2*YMIN2**2/(1.D0-YMIN2))
2917 & WRITE(LO,'(/1X,A,1P2E11.4)')
2918 & 'PHO_GPHERA: lower Q2 cutoff larger than kin. limit:',
2919 & Q2MIN,ELEM2*YMIN2**2/(1.D0-YMIN2)
2922 DELLY = LOG(YMAX2/YMIN2)/DBLE(Max_tab-1)
2925 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
2926 & 'PHO_GPHERA: table of photon flux (trans/long)',Max_tab
2928 Y = EXP(XIMIN+DELLY*DBLE(I-1))
2929 Q2LOW = MAX(Q2MIN,ELEM2*Y**2/(1.D0-Y))
2930 FFT = ((1.D0+(1.D0-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2931 & -2.D0*ELEM2*Y*(1.D0/Q2LOW-1.D0/Q2MAX))/(2.D0*PI*137.D0)
2932 FFL = 2.D0*(1.D0-Y)/Y*LOG(Q2MAX/Q2LOW)/(2.D0*PI*137.D0)
2933 FLUXT = FLUXT + Y*FFT
2934 FLUXL = FLUXL + Y*FFL
2935 IF(IDEB(30).GE.1) WRITE(LO,'(5X,1P3E14.4)') Y,FFT,FFL
2939 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,1P2E12.4)')
2940 & 'PHO_GPHERA: integrated flux (trans./long.):',FLUXT,FLUXL
2945 Q2LOW = MAX(Q2MIN,ELEM2*YY**2/(1.D0-YY))
2946 WGMAX = (1.D0+(1.D0-YY)**2)*LOG(Q2MAX/Q2LOW)
2947 & -2.D0*ELEM2*YY*(1.D0/Q2LOW-1.D0/Q2MAX)*YY
2948 IF(ISWMDL(10).GE.2) WGMAX = WGMAX+2.D0*(1.D0-YY)*LOG(Q2MAX/Q2LOW)
2950 C initialization of PHOJET at upper energy limit
2954 P1(3) = SQRT(EE1**2-PROM2+DEPS)
2962 C sum of both photon polarizations
2965 CALL PHO_SETPAR(1,2212,0,0.D0)
2966 CALL PHO_SETPAR(2,22,0,0.D0)
2967 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
2968 CALL PHO_PHIST(-1,SIGMAX)
2969 CALL PHO_LHIST(-1,SIGMAX)
2971 C generation of events, flux calculation
2994 YY = EXP(XIDEL*DT_RNDM(AY)+XIMIN)
2995 IF(ISWMDL(10).GE.2) THEN
2996 YEFF = 1.D0+(1.D0-YY)**2+2.D0*(1.D0-YY)
2998 YEFF = 1.D0+(1.D0-YY)**2
3000 Q2LOW = MAX(Q2MIN,ELEM2*YY**2/(1.D0-YY))
3001 Q2LOG = LOG(Q2MAX/Q2LOW)
3002 WGH = YEFF*Q2LOG-2.D0*ELEM2*YY**2*(1.D0/Q2LOW-1.D0/Q2MAX)
3003 IF(WGMAX.LT.WGH) THEN
3004 WRITE(LO,'(1X,A,3E12.5)')
3005 & 'PHO_GPHERA: inconsistent weight:',YY,WGMAX,WGH
3007 IF(DT_RNDM(AY2)*WGMAX.GT.WGH) GOTO 175
3009 IF(IPAMDL(174).EQ.1) THEN
3011 Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
3012 WEIGHT = (YEFF-2.D0*ELEM2*YY**2/Q2)/YEFF
3013 IF(WEIGHT.LT.DT_RNDM(Q2)) GOTO 185
3026 YQ2 = SQRT((1.D0-YY)*Q2)
3029 CALL PHO_SFECFE(SIF,COF)
3032 PFIN(3,2) = -E1Y+Q2E
3039 PFTHE(2) = ACOS(PFIN(3,2)/PFIN(4,2))
3041 IF(PFIN(4,2).GT.EEMIN2) THEN
3042 IF((PFTHE(2).LT.THMIN2).OR.(PFTHE(2).GT.THMAX2)) GOTO 175
3045 PFPHI(2) = ATAN2(COF,SIF)
3049 P2(3) = PINI(3,2)-PFIN(3,2)
3050 P2(4) = PINI(4,2)-PFIN(4,2)
3054 P1(3) = SQRT(EE1**2-PROM2)
3057 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
3058 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
3059 IF((GGECM.LT.ECMIN2).OR.(GGECM.GT.ECMAX2)) GOTO 175
3066 PGAM(5,2) = -SQRT(Q2)
3068 IF(ISWMDL(10).GE.2) THEN
3069 WGH = YEFF-2.D0*ELEM2*YY**2/Q2
3071 IF(DT_RNDM(YY).GE.WGHL/WGH) THEN
3080 CALL PHO_PRESEL(5,IREJ)
3081 IF(IREJ.NE.0) GOTO 175
3083 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
3084 IF(IREJ.NE.0) GOTO 150
3089 YY2MIN = MIN(YY2MIN,YY)
3090 YY2MAX = MAX(YY2MAX,YY)
3091 Q22MIN = MIN(Q22MIN,Q2)
3092 Q22MAX = MAX(Q22MAX,Q2)
3094 Q22AV2 = Q22AV2+Q2*Q2
3095 AN2MIN = MIN(AN2MIN,PFTHE(2))
3096 AN2MAX = MAX(AN2MAX,PFTHE(2))
3098 CALL PHO_PHIST(1,HSWGHT(0))
3099 CALL PHO_LHIST(1,HSWGHT(0))
3102 WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW)/(137.D0*2.D0*PI)
3103 WGY = WGY*LOG(YMAX2/YMIN2)
3105 AY2 = AY2/DBLE(NITER)
3106 DAY = SQRT((AY2-AY**2)/DBLE(NITER))
3107 Q22AVE = Q22AVE/DBLE(NITER)
3108 Q22AV2 = Q22AV2/DBLE(NITER)
3109 Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
3110 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
3111 C output of histograms
3112 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
3113 &'=========================================================',
3114 &' ***** simulated cross section: ',WEIGHT,' mb *****',
3115 &'========================================================='
3116 WRITE(LO,'(//1X,A,3I10)')
3117 & 'PHO_GPHERA:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
3118 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
3120 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y,DY ',AY,DAY
3121 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON ',
3123 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 ',
3125 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON ',
3127 WRITE(LO,'(1X,A,1P4E12.4)') 'SAMPLED THETA RANGE ELECTRON ',
3128 & AN2MIN,AN2MAX,PI-AN2MAX,PI-AN2MIN
3130 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
3132 CALL PHO_PHIST(-2,WEIGHT)
3133 CALL PHO_LHIST(-2,WEIGHT)
3135 WRITE(LO,'(1X,A,I4)') 'PHO_GPHERA:NO OUTPUT OF HISTOGRAMS',NITER
3140 *$ CREATE PHO_GGEPEM.FOR
3142 CDECK ID>, PHO_GGEPEM
3143 SUBROUTINE PHO_GGEPEM(NEVENT,EE1,EE2)
3144 C**********************************************************************
3146 C interface to call PHOJET (variable energy run) for
3147 C gamma-gamma collisions on e+e- collider
3149 C fully differential equivalent (improved) photon approximation
3150 C to get photon flux
3152 C input: EE1 LAB system energy of electron/positron 1
3153 C EE2 LAB system energy of electron/positron 2
3154 C NEVENT >0 number of events to generate
3156 C -2 final call (cross section calculation)
3158 C YMIN1 lower limit of Y1
3159 C (energy fraction taken by photon from electron)
3160 C YMAX1 upper limit of Y1
3161 C Q2MIN1 lower limit of photon virtuality
3162 C Q2MAX1 upper limit of photon virtuality
3163 C THMIN1 lower limit of scattered electron
3164 C THMAX1 upper limit of scattered electron
3165 C YMIN2 lower limit of Y2
3166 C (energy fraction taken by photon from electron)
3167 C YMAX2 upper limit of Y2
3168 C Q2MIN2 lower limit of photon virtuality
3169 C Q2MAX2 upper limit of photon virtuality
3170 C THMIN2 lower limit of scattered electron
3171 C THMAX2 upper limit of scattered electron
3173 C output: after final call with NEVENT=-2
3174 C EE1 e+ e- cross section (mb)
3175 C EE2 gamma-gamma cross section (mb)
3177 C**********************************************************************
3183 DOUBLE PRECISION EE1,EE2
3186 C input/output channels
3188 COMMON /POINOU/ LI,LO
3189 C event debugging information
3191 PARAMETER (NMAXD=100)
3192 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3193 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3194 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3195 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3196 C model switches and parameters
3198 INTEGER ISWMDL,IPAMDL
3199 DOUBLE PRECISION PARMDL
3200 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3202 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
3203 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
3204 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
3205 C photon flux kinematics and cuts
3206 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
3207 & YMIN1,YMAX1,YMIN2,YMAX2,
3208 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
3209 & THMIN1,THMAX1,THMIN2,THMAX2
3211 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
3212 & YMIN1,YMAX1,YMIN2,YMAX2,
3213 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
3214 & THMIN1,THMAX1,THMIN2,THMAX2,
3216 C gamma-lepton or gamma-hadron vertex information
3217 INTEGER IGHEL,IDPSRC,IDBSRC
3218 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
3219 & RADSRC,AMSRC,GAMSRC
3220 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
3221 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
3222 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
3223 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
3224 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3225 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3226 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3227 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3228 C event weights and generated cross section
3229 INTEGER IPOWGC,ISWCUT,IVWGHT
3230 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
3231 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
3232 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
3234 C external functions
3235 DOUBLE PRECISION DT_RNDM
3238 DOUBLE PRECISION AN1MAX,AN1MIN,AN2MAX,AN2MIN,AY1,AY2,AYS1,AYS2,
3239 & COF1,COF2,CPFTHE,DAY1,DAY2,DELLY,DITRY,DITRW,
3240 & ECFRAC,ECMAX2,ECMIN2,EGAM,ELEM,ELEM2,FFL,FFT,FLUXL,FLUXT,
3241 & FLXAPP,FLXQPM,GGECM2,P1,P2,PP,PT,PT2,Q21AV2,Q21AVE,Q21MAX,
3242 & Q21MIN,Q22AV2,Q22AVE,Q22MAX,Q22MIN,Q2LOG1,Q2LOG2,Q2LOW1,
3243 & Q2LOW2,Q2P1,Q2P2,SIF1,SIF2,SIGCUR,SIGMAX,THMAC1,
3244 & THMAC2,THMIC1,THMIC2,WEIGHT,WG,WGFX,WGH,WGHAPP,WGHL,WGHQPM,
3245 & WGMAX,WGY,X1DEL,X1MAX,X1MIN,X2DEL,X2MAX,X2MIN,Y1,Y2,YEFF1,YEFF2,
3246 & YMI,YY1MAX,YY1MIN,YY2MAX,YY2MIN
3248 INTEGER I,IHEAC1,IHEAC2,IHETRY,IREJ,ITRW_low,ITRW_high,ITRY_low,
3249 & ITRY_high,K,Max_tab,NITER,ITG1,ITG2
3251 DIMENSION P1(4),P2(4),IHETRY(4),IHEAC1(4),IHEAC2(4)
3254 C initialization of event generation
3256 if(NEVENT.eq.-1) then
3264 WRITE(LO,'(//1X,A)') 'PHO_GGEPEM: initialization'
3274 IDBSRC(1) = ipho_pdg2id(11)
3275 IDBSRC(2) = ipho_pdg2id(-11)
3277 C check/update kinematic limitations
3279 Ymi = min(Ymax1,1.D0-ELEM/EE1)
3280 if(Ymi.lt.Ymax1) then
3281 WRITE(LO,'(/1X,A,2E12.5)')
3282 & 'PHO_GGEPEM: Ymax1 decreased (old/new)',Ymax1,Ymi
3285 Ymi = min(Ymax2,1.D0-ELEM/EE2)
3286 if(Ymi.lt.Ymax2) then
3287 WRITE(LO,'(/1X,A,2E12.5)')
3288 & 'PHO_GGEPEM: Ymax2 decreased (old/new)',Ymax2,Ymi
3292 YMI = ECMIN**2/(4.D0*EE1*EE2*YMAX2)
3293 IF(YMIN1.LT.YMI) THEN
3294 WRITE(LO,'(/1X,A,2E12.5)')
3295 & 'PHO_GGEPEM: Ymin1 increased (old/new)',YMIN1,YMI
3297 ELSE IF(YMIN1.GT.YMI) THEN
3298 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
3299 & 'PHO_GGEPEM:','ECM-CUT corresponds to YMIN1 of',YMI,
3300 & ' INSTEAD OF',YMIN1
3302 YMI = ECMIN**2/(4.D0*EE1*EE2*YMAX1)
3303 IF(YMIN2.LT.YMI) THEN
3304 WRITE(LO,'(/1X,A,2E12.5)')
3305 & 'PHO_GGEPEM: Ymin2 increased (old/new)',YMIN2,YMI
3307 ELSE IF(YMIN2.GT.YMI) THEN
3308 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
3309 & 'PHO_GGEPEM:','ECM-CUT corresponds to YMIN2 of',YMI,
3310 & ' INSTEAD OF',YMIN2
3313 C store COS of angular tagging range
3314 THMIC1 = COS(MAX(0.D0,THMIN1))
3315 THMAC1 = COS(MIN(THMAX1,PI))
3316 THMIC2 = COS(MAX(0.D0,THMIN2))
3317 THMAC2 = COS(MIN(THMAX2,PI))
3326 C debug: integrated photon flux
3328 if(IDEB(30).ge.1) then
3332 DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
3333 IF(IDEB(30).GE.2) WRITE(LO,'(1X,2A,I5)') 'PHO_GGEPEM: ',
3334 & 'table of photon flux (trans/long side 1)',Max_tab
3336 Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
3337 if((1.D0-Y1).gt.1.D-8) then
3338 Q2LOW1 = MAX(Q2MIN1,ELEM2*Y1*Y1/(1.D0-Y1))
3340 Q2low1 = 2.D0*Q2max1
3342 if(Q2low1.lt.Q2max1) then
3343 FFT = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
3344 & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))/(2.D0*PI*137.D0)
3345 FFL = 2.D0*(1.D0-Y1)*LOG(Q2MAX1/Q2LOW1)/(2.D0*PI*137.D0)
3350 FLUXT = FLUXT + Y1*FFL
3351 FLUXL = FLUXL + Y1*FFT
3352 IF(IDEB(30).GE.2) WRITE(LO,'(5X,1P3E14.4)') Y1,FFT,FFL
3356 WRITE(LO,'(1X,2A,1P2E12.4)') 'PHO_GGEPEM: ',
3357 & 'integrated flux (trans/long side 1):',FLUXT,FLUXL
3362 Q2LOW1 = MAX(Q2MIN1,ELEM2*YMIN1**2/(1.D0-YMIN1))
3363 Q2LOW2 = MAX(Q2MIN2,ELEM2*YMIN2**2/(1.D0-YMIN2))
3366 IF(ISWMDL(10).GE.2) THEN
3367 C long. and transversely polarized photons
3368 WGMAX = ((1.D0+(1.D0-Y1)**2+2.D0*(1.D0-Y1))*LOG(Q2MAX1/Q2LOW1)
3369 & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
3370 & *((1.D0+(1.D0-Y2)**2+2.D0*(1.D0-Y2))*LOG(Q2MAX2/Q2LOW2)
3371 & -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
3373 C transversely polarized photons only
3374 WGMAX = ((1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
3375 & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
3376 & *((1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
3377 & -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
3380 C initialize gamma-gamma event generator
3386 P1(3) = SQRT(EGAM**2-Q2LOW1)
3392 P2(3) = -SQRT(EGAM**2-Q2LOW2)
3398 C set min. energy for interpolation tables
3399 parmdl(19) = min(parmdl(19),ecmin)
3401 C initialize event gneration
3402 CALL PHO_SETPAR(1,22,0,0.D0)
3403 CALL PHO_SETPAR(2,22,0,0.D0)
3404 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
3405 CALL PHO_PHIST(-1,SIGMAX)
3406 CALL PHO_LHIST(-1,SIGMAX)
3408 C generation of events, flux calculation
3412 ECFRAC = ECMIN2/(4.D0*EE1*EE2)
3439 C generate NEVENT events (might be just 1 per call)
3441 else if(NEVENT.gt.0) then
3443 NITER = NITER+NEVENT
3449 ITRY_low = ITRY_low+1
3450 if(ITRY_low.eq.1000000) then
3452 ITRY_high = ITRY_high+1
3456 ITRW_low = ITRW_low+1
3457 if(ITRW_low.eq.1000000) then
3459 ITRW_high = ITRW_high+1
3462 Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
3463 Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
3464 IF(Y1*Y2.LT.ECFRAC) GOTO 175
3465 IF(ISWMDL(10).GE.2) THEN
3466 YEFF1 = 1.D0+(1.D0-Y1)**2+2.D0*(1.D0-Y1)
3467 YEFF2 = 1.D0+(1.D0-Y2)**2+2.D0*(1.D0-Y2)
3469 YEFF1 = 1.D0+(1.D0-Y1)**2
3470 YEFF2 = 1.D0+(1.D0-Y2)**2
3473 Q2LOW1 = MAX(Q2MIN1,ELEM2*Y1**2/(1.D0-Y1))
3474 Q2LOW2 = MAX(Q2MIN2,ELEM2*Y2**2/(1.D0-Y2))
3475 Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
3476 Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
3478 & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
3480 & -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
3481 IF(WGMAX.LT.WGH) THEN
3482 WRITE(LO,'(1X,A,4E12.5)')
3483 & 'PHO_GGEPEM: inconsistent weight:',Y1,Y2,WGMAX,WGH
3485 IF(DT_RNDM(AYS1)*WGMAX.GT.WGH) GOTO 175
3487 C limit on Ecm_gg (app. cut, precise cut applied later)
3488 GGECM2 = 4.D0*Y1*Y2*EE1*EE2
3489 if(GGECM2.lt.ECMIN2) goto 175
3492 IF(IPAMDL(174).EQ.1) THEN
3494 Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
3495 WEIGHT = (YEFF1-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF1
3496 IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
3501 IF(IPAMDL(174).EQ.1) THEN
3503 Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
3504 WEIGHT = (YEFF2-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF2
3505 IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
3515 C incoming electron 1
3518 PINI(3,1) = EE1*(1.D0-0.5D0*ELEM2/EE1**2)
3522 PP = (2.D0*EE1**2*Y1+Q2P1)/(2.D0*PINI(3,1))
3523 PT2 = (EE1**2*(Q2P1*(1.D0-Y1)-ELEM2*Y1**2)
3524 & -0.25D0*Q2P1**2-Q2P1*ELEM2)/PINI(3,1)**2
3525 IF(PT2.LT.0.D0) GOTO 175
3527 CALL PHO_SFECFE(SIF1,COF1)
3532 C outgoing electron 1
3535 PFIN(3,1) = PINI(3,1)-P1(3)
3536 PFIN(4,1) = PINI(4,1)-P1(4)
3538 C incoming electron 2
3541 PINI(3,2) = -EE2*(1.D0-0.5D0*ELEM2/EE2**2)
3545 PP = (2.D0*EE2**2*Y2+Q2P2)/(2.D0*PINI(3,2))
3546 PT2 = (EE2**2*(Q2P2*(1.D0-Y2)-ELEM2*Y2**2)
3547 & -0.25D0*Q2P2**2-Q2P2*ELEM2)/PINI(3,2)**2
3548 IF(PT2.LT.0.D0) GOTO 175
3550 CALL PHO_SFECFE(SIF2,COF2)
3555 C outgoing electron 2
3558 PFIN(3,2) = PINI(3,2)-P2(3)
3559 PFIN(4,2) = PINI(4,2)-P2(4)
3564 GGECM2 = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
3565 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
3566 IF((GGECM2.LT.ECMIN2).OR.(GGECM2.GT.ECMAX2)) GOTO 175
3567 GGECM = SQRT(GGECM2)
3569 C beam lepton detector acceptance
3572 CPFTHE = PFIN(3,1)/PFIN(4,1)
3574 IF(PFIN(4,1).GE.EEMIN1) THEN
3575 IF((CPFTHE.LE.THMIC1).AND.(CPFTHE.GE.THMAC1)) ITG1 = 1
3579 CPFTHE = PFIN(3,2)/PFIN(4,2)
3581 IF(PFIN(4,2).GE.EEMIN2) THEN
3582 IF((CPFTHE.LE.THMIC2).AND.(CPFTHE.GE.THMAC2)) ITG2 = 1
3585 C beam lepton taggers
3588 IF((ITAG1.EQ.-1).AND.(ITG1.NE.0)) GOTO 175
3589 IF((ITAG2.EQ.-1).AND.(ITG2.NE.0)) GOTO 175
3591 IF((ITAG1.EQ.1).AND.(ITG1.EQ.0)) GOTO 175
3592 IF((ITAG2.EQ.1).AND.(ITG2.EQ.0)) GOTO 175
3593 C single-tag inclusive
3594 IF((ITAG1.EQ.0).AND.(ITAG2.EQ.0).AND.(ITG1+ITG2.EQ.0))
3596 C single-tag/anti-tag
3597 IF((ITAG1.EQ.2).AND.(ITAG2.EQ.2).AND.(ITG1+ITG2.NE.1))
3604 PGAM(5,1) = -SQRT(Q2P1)
3609 PGAM(5,2) = -SQRT(Q2P2)
3612 IF(ISWMDL(10).GE.2) THEN
3613 WGH = YEFF1-2.D0*ELEM2*Y1**2/Q2P1
3615 IF(DT_RNDM(Y1).GT.WGHL/WGH) THEN
3620 WGH = YEFF2-2.D0*ELEM2*Y2**2/Q2P2
3622 IF(DT_RNDM(Y2).GT.WGHL/WGH) THEN
3627 K = 2*IGHEL(1)+IGHEL(2)+1
3628 IHETRY(K) = IHETRY(K)+1
3635 CALL PHO_PRESEL(5,IREJ)
3636 IF(IREJ.NE.0) GOTO 175
3639 C reweight according to LO photon emission diagrams (Budnev et al.)
3640 IF(IPAMDL(116).GE.1) THEN
3641 CALL PHO_WGEPEM(FLXAPP,FLXQPM,0)
3642 WGFX = FLXQPM/FLXAPP
3643 if(WGFX.gt.1.D0) then
3644 WRITE(LO,'(1x,a,/,5x,1p,5e11.4)')
3645 & ' PHO_GGEPEM: flux weight > 1 (y1/2,Q21/2,W)',
3646 & Y1,Y2,Q2P1,Q2P2,GGECM
3652 * EVWGHT(1) = MAX(WGFX,1.D0)
3653 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
3654 IF(IREJ.NE.0) GOTO 150
3655 IF(ISWMDL(10).GE.2) THEN
3656 K = 2*IGHEL(1)+IGHEL(2)+1
3657 IHEAC1(K) = IHEAC1(K)+1
3660 C reweight according to QPM model (e+e- collider only)
3661 IF((KHDIR.GT.0).AND.
3662 & (IPAMDL(116).GE.2).AND.(ISWMDL(10).GE.2)) THEN
3663 CALL PHO_WGEPEM(WGHAPP,WGHQPM,1)
3664 WG = WGHQPM/WGHAPP/MAX(1.D0,WGFX)
3665 IF(DT_RNDM(WG).GT.WG) GOTO 150
3666 ELSE IF(IPAMDL(116).GE.1) THEN
3667 IF(DT_RNDM(WG).GT.WGFX) GOTO 150
3671 PFTHE(1) = ACOS(PFIN(3,1)/PFIN(4,1))
3672 PFTHE(2) = ACOS(PFIN(3,2)/PFIN(4,2))
3674 PFPHI(1) = ATAN2(COF1,SIF1)
3675 PFPHI(2) = ATAN2(COF2,SIF2)
3682 Q21MIN = MIN(Q21MIN,Q2P1)
3683 Q22MIN = MIN(Q22MIN,Q2P2)
3684 Q21MAX = MAX(Q21MAX,Q2P1)
3685 Q22MAX = MAX(Q22MAX,Q2P2)
3686 AN1MIN = MIN(AN1MIN,PFTHE(1))
3687 AN2MIN = MIN(AN2MIN,PFTHE(2))
3688 AN1MAX = MAX(AN1MAX,PFTHE(1))
3689 AN2MAX = MAX(AN2MAX,PFTHE(2))
3690 YY1MIN = MIN(YY1MIN,Y1)
3691 YY2MIN = MIN(YY2MIN,Y2)
3692 YY1MAX = MAX(YY1MAX,Y1)
3693 YY2MAX = MAX(YY2MAX,Y2)
3694 Q21AVE = Q21AVE+Q2P1
3695 Q22AVE = Q22AVE+Q2P2
3696 Q21AV2 = Q21AV2+Q2P1*Q2P1
3697 Q22AV2 = Q22AV2+Q2P2*Q2P2
3698 IF(ISWMDL(10).GE.2) THEN
3699 K = 2*IGHEL(1)+IGHEL(2)+1
3700 IHEAC2(K) = IHEAC2(K)+1
3703 C external histograms
3704 CALL PHO_PHIST(1,HSWGHT(0))
3705 CALL PHO_LHIST(1,HSWGHT(0))
3708 C final cross section calculation and event generation summary
3710 else if(NEVENT.eq.-2) then
3714 DITRY = dble(ITRY_high)*1.D+6+dble(ITRY_low)
3715 DITRW = dble(ITRW_high)*1.D+6+dble(ITRW_low)
3716 WGY = WGMAX*DITRY/DITRW/(137.D0*2.D0*PI)**2
3717 WGY = WGY*LOG(YMAX1/YMIN1)*LOG(YMAX2/YMIN2)
3718 AY1 = AY1/DBLE(NITER)
3719 AYS1 = AYS1/DBLE(NITER)
3720 DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
3721 AY2 = AY2/DBLE(NITER)
3722 AYS2 = AYS2/DBLE(NITER)
3723 DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
3724 Q21AVE = Q21AVE/DBLE(NITER)
3725 Q21AV2 = Q21AV2/DBLE(NITER)
3726 Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(NITER))
3727 Q22AVE = Q22AVE/DBLE(NITER)
3728 Q22AV2 = Q22AV2/DBLE(NITER)
3729 Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
3730 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DITRY
3732 EE2 = SIGMAX*DBLE(NITER)/DITRY
3734 C output of statistics, histograms
3735 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
3736 & '=========================================================',
3737 & ' ***** simulated cross section: ',WEIGHT,' mb *****',
3738 & '========================================================='
3739 WRITE(LO,'(//1X,A,I10,1p,2e14.6)')
3740 & 'PHO_GGEPEM:summary: NITER,ITRY,ITRW',NITER,DITRY,DITRW
3741 WRITE(LO,'(1X,A,1P2E12.4)') 'effective weight (FLUX,TOTAL)',
3743 WRITE(LO,'(1X,A,1P2E12.4)') 'average Y1,DY1 ',
3745 WRITE(LO,'(1X,A,1P2E12.4)') 'average Y2,DY2 ',
3747 WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Y range photon 1 ',
3749 WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Y range photon 2 ',
3751 WRITE(LO,'(1X,A,1P2E12.4)') 'average Q2,DQ2 photon 1 ',
3753 WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Q2 range photon 1 ',
3755 WRITE(LO,'(1X,A,1P2E12.4)') 'average Q2,DQ2 photon 2 ',
3757 WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Q2 range photon 2 ',
3759 WRITE(LO,'(1X,A,1P2E12.4)') 'sampled THETA range electron1',
3761 WRITE(LO,'(1X,A,1P4E12.4)') 'sampled THETA range electron2',
3762 & AN2MIN,AN2MAX,PI-AN2MAX,PI-AN2MIN
3764 IF(ISWMDL(10).GE.2) THEN
3765 WRITE(LO,'(/1X,A,3(/1X,A,4I12))')
3766 & 'Helicity decomposition: 0 0 0 1 1 0 1 1',
3768 & 'accepted (1): ',IHEAC1,
3769 & 'accepted (2): ',IHEAC2
3772 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
3774 CALL PHO_PHIST(-2,WEIGHT)
3775 CALL PHO_LHIST(-2,WEIGHT)
3777 WRITE(LO,'(1X,A,I4)')
3778 & 'PHO_GGEPEM: no output of histograms',NITER
3785 *$ CREATE PHO_WGEPEM.FOR
3787 CDECK ID>, PHO_WGEPEM
3788 SUBROUTINE PHO_WGEPEM(WGHAPP,WGHQPM,IMODE)
3789 C**********************************************************************
3791 C calculate cross section weights for
3792 C fully differential equivalent (improved) photon approximation
3794 C fully differential QPM model with exact one-photon exchange graphs
3796 C (unpolarized lepton beams)
3798 C input: IMODE 0 flux calculation only
3799 C 1 flux folded with QPM cross section
3800 C /POFSRC/ photon and electron momenta
3801 C /POPRCS/ process type
3802 C /POCKIN/ kinematics of hard scattering
3804 C output: WGHAPP weight of event according to approximation
3805 C WGHQPM weight of event according to one-photon exchange
3807 C**********************************************************************
3813 DOUBLE PRECISION WGHAPP,WGHQPM
3816 C input/output channels
3818 COMMON /POINOU/ LI,LO
3819 C event debugging information
3821 PARAMETER (NMAXD=100)
3822 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3823 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3824 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3825 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3826 C model switches and parameters
3828 INTEGER ISWMDL,IPAMDL
3829 DOUBLE PRECISION PARMDL
3830 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3832 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
3833 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
3834 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
3835 C gamma-lepton or gamma-hadron vertex information
3836 INTEGER IGHEL,IDPSRC,IDBSRC
3837 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
3838 & RADSRC,AMSRC,GAMSRC
3839 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
3840 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
3841 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
3842 C general process information
3843 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3844 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3845 C data on most recent hard scattering
3846 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
3847 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
3848 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
3849 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
3850 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
3851 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
3852 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
3853 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
3854 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
3855 C hard scattering parameters used for most recent hard interaction
3857 DOUBLE PRECISION ALQCD2,BQCD
3858 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
3859 C currently activated parton density parametrizations
3861 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
3862 DOUBLE PRECISION PDFLAM,PDFQ2M
3863 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
3864 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
3866 C standard particle data interface
3869 PARAMETER (NMXHEP=4000)
3871 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
3872 DOUBLE PRECISION PHEP,VHEP
3873 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
3874 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
3876 C extension to standard particle data interface (PHOJET specific)
3877 INTEGER IMPART,IPHIST,ICOLOR
3878 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
3880 DOUBLE PRECISION AA,ALPHA1,ALPHA2,BB,CC,CCAP,DD,FAC,HELFLX,
3881 & P1,P1P2,P1Q2,P2,P2Q1,Q1KK,Q1Q2,Q2,Q2KK,QC2,RHO100,RHO1PP,
3882 & RHO200,RHO2PP,RHOP08,RHOPM2,RR,SH,SIGQPM,SP,SS,SW0000,SW0P0M,
3883 & SW0P0P,SW0PM0,SWP00P,SWP0M0,SWP0P0,SWPMPM,SWPP00,SWPPMM,SWPPPP,
3884 & TH,TP,UH,W2,WGHEQ,WGHQQ,XCAP,XK1,XK2,XKAM,XKAP,
3885 & XM2,XQ2,XTM1,XTM2,XTM3,YCAP
3886 DOUBLE PRECISION PHO_ALPHAS,pho_alphae
3888 INTEGER I,I1,I2,IDIR,IPFL1,IPFL2,IPOS,K
3890 DIMENSION WGHEQ(2),XM2(2),P1(4),P2(4),XK1(4),XK2(4)
3891 DIMENSION HELFLX(6),SIGQPM(6)
3896 C strict pt cutoff after putting partons on mass shell,
3897 C calculated in gamma-gamma CMS
3898 if((Imode.eq.1).and.(ipamdl(121).gt.0)) then
3899 if(PTfin.lt.PTwant) then
3900 if(ipamdl(121).gt.1) return
3901 if((ipamdl(121).eq.1).and.(MSPR.eq.14)) return
3905 C cross section of sampled event (approximate treatment)
3909 XM2(K) = AMSRC(K)**2
3910 IF(abs(IGHEL(K)).EQ.1) THEN
3911 WGHEQ(K) = ((1.D0+(1.D0-GYY(K))**2)/GYY(K)
3912 & -2.D0*XM2(K)*GYY(K)/GQ2(K))/(137.D0*2.D0*PI*GQ2(K))
3914 WGHEQ(K) = (1.D0-GYY(K))/GYY(K)/(137.D0*PI*GQ2(K))
3922 C direct or single-resolved gam-gam interaction
3923 IF((IMODE.GE.1).AND.
3924 & (IPROCE.EQ.8).AND.(MSPR.GE.10)) THEN
3927 C determine final state partons
3929 IF(ISTHEP(I).EQ.25) GOTO 110
3931 WRITE(LO,'(/1X,2A,I5)') 'PHO_WGEPEM:ERROR: ',
3932 & 'inconsistent process information (MSPR)',MSPR
3936 C final state flavors
3937 IPFL1 = ABS(IDHEP(IPOS+3))
3938 IPFL2 = ABS(IDHEP(IPOS+4))
3940 C calculate alpha-em
3941 ALPHA1 = pho_alphae(QQAL)
3944 ALPHA2 = PHO_ALPHAS(QQAL,3)
3946 C LO matrix element (8 pi s dsig/dt)
3947 * QC2 = 4.D0/9.D0 - DBLE(MOD(IPFL2,2))*3.D0/9.D0
3950 WRITE(LO,'(1X,2A,/,5X,A,I12,I3,4I4)') 'PHO_WGEPEM:ERROR: ',
3951 & 'invalid hard process - flavor combination',
3952 & 'EVENT,MSPR,IA,IB,IC,ID:',KEVENT,MSPR,IA,IB,IC,ID
3955 WGHQQ = -8.D0*PI/(3.D0*SH**2)*ALPHA1*QC2*ALPHA2*(U**2+1.D0)/U
3957 ELSE IF(MSPR.EQ.11) THEN
3958 WGHQQ = PI/SH**2*ALPHA1*QC2*ALPHA2*(V**2+U**2)/(U*V)
3960 ELSE IF(MSPR.EQ.12) THEN
3961 WGHQQ = -8.D0*PI/(3.D0*SH**2)*ALPHA1*QC2*ALPHA2*(V**2+1.D0)/V
3963 ELSE IF(MSPR.EQ.13) THEN
3964 WGHQQ = PI/SH**2*ALPHA1*QC2*ALPHA2*(V**2+U**2)/(U*V)
3966 ELSE IF(MSPR.EQ.14) THEN
3967 WGHQQ = 6.D0*PI/SH**2*(ALPHA1*QC2)**2*(V**2+U**2)/(U*V)
3972 C fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
3973 WGHAPP = WGHEQ(1)*WGHEQ(2)*WGHQQ/(2.D0*PI)
3975 C full leading-order QPM prediction (Budnev et al.)
3977 C full two-gamma flux
3979 P1Q2 = PINI(4,1)*PGAM(4,2)-PINI(1,1)*PGAM(1,2)
3980 & -PINI(2,1)*PGAM(2,2)-PINI(3,1)*PGAM(3,2)
3981 P2Q1 = PINI(4,2)*PGAM(4,1)-PINI(1,2)*PGAM(1,1)
3982 & -PINI(2,2)*PGAM(2,1)-PINI(3,2)*PGAM(3,1)
3983 Q1Q2 = PGAM(4,1)*PGAM(4,2)-PGAM(1,1)*PGAM(1,2)
3984 & -PGAM(2,1)*PGAM(2,2)-PGAM(3,1)*PGAM(3,2)
3985 P1P2 = PINI(4,1)*PINI(4,2)-PINI(1,1)*PINI(1,2)
3986 & -PINI(2,1)*PINI(2,2)-PINI(3,1)*PINI(3,2)
3988 P1(I) = 2.D0*PINI(I,1)-PGAM(I,1)
3989 P2(I) = 2.D0*PINI(I,2)-PGAM(I,2)
3991 XTM1 = 2.D0*P1Q2-Q1Q2
3992 XTM2 = 2.D0*P2Q1-Q1Q2
3993 XTM3 = P1(4)*P2(4)-P1(1)*P2(1)-P1(2)*P2(2)-P1(3)*P2(3)
3994 XCAP = Q1Q2**2-GQ2(1)*GQ2(2)
3995 YCAP = P1P2**2-XM2(1)*XM2(2)
3996 CCAP = -XTM3 + Q1Q2*XTM1*XTM2/XCAP
3998 RHO1PP = (XTM1**2/XCAP+1.D0-4.D0*XM2(1)/GQ2(1))/2.D0
3999 RHO2PP = (XTM2**2/XCAP+1.D0-4.D0*XM2(2)/GQ2(2))/2.D0
4000 RHO100 = XTM1**2/XCAP-1.D0
4001 RHO200 = XTM2**2/XCAP-1.D0
4002 RHOPM2 = CCAP**2/(GQ2(1)*GQ2(2))-2.D0*(RHO1PP-1.D0)*(RHO2PP-1.D0)
4003 RHOP08 = 4.D0*XTM1*XTM2*CCAP/XCAP/SQRT(GQ2(1)*GQ2(2))
4004 SS = 2.D0*P1P2+XM2(1)+XM2(2)
4006 HELFLX(1) = 4.D0*RHO1PP*RHO2PP
4008 HELFLX(3) = 2.D0*RHO1PP*RHO200
4009 HELFLX(4) = 2.D0*RHO100*RHO2PP
4010 HELFLX(5) = RHO100*RHO200
4013 C only flux calculation
4016 IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.1)) THEN
4018 ELSE IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.0)) THEN
4020 ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.1)) THEN
4022 ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.0)) THEN
4024 ELSE IF((IGHEL(1).EQ.-1).AND.(IGHEL(2).EQ.-1)) THEN
4027 WRITE(LO,'(/1X,A,2I3)')
4028 & 'PHO_GGEPEM:ERROR: invalid photon helicities: ',IGHEL
4029 WRITE(LO,'(1X,A,I12)')
4030 & 'PHO_GGEPEM: event rejected (KEVENT)',KEVENT
4034 C fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
4035 WGHQPM = WEIGHT/(137.D0**2*16.D0*PI**4*GQ2(1)*GQ2(2))
4036 & *SQRT(XCAP/YCAP)*PI*SS/(2.D0*YCAP)*PINI(4,1)*PINI(4,2)
4040 C flux folded with cross section
4041 C polarized, leading order gam gam --> q qbar cross sections
4046 C momenta of produced parton pair
4056 C direct photon-photon interaction
4057 XKAP = XQ2-(PGAM(4,1)-XK1(4))**2
4058 & +(PGAM(1,1)-XK1(1))**2+(PGAM(2,1)-XK1(2))**2
4059 & +(PGAM(3,1)-XK1(3))**2
4060 XKAM = XQ2-(PGAM(4,1)-XK2(4))**2
4061 & +(PGAM(1,1)-XK2(1))**2+(PGAM(2,1)-XK2(2))**2
4062 & +(PGAM(3,1)-XK2(3))**2
4064 AA = XKAP*XKAM-GQ2(1)*GQ2(2)
4065 BB = CC**2-XKAP*XKAM
4066 DD = CC**2-GQ2(1)*GQ2(2)
4067 RR = -XQ2+W2*AA/(4.D0*DD)
4070 FAC = 192.D0*(PI*ALPHA1*QC2/(XKAP*XKAM))**2/(4.D0*SQRT(XCAP))
4073 C single-resolved photon-hadron interactions
4074 C Mandelstam variables
4076 TH = (PGAM(4,1)-XK1(4))**2-(PGAM(1,1)-XK1(1))**2
4077 & -(PGAM(2,1)-XK1(2))**2-(PGAM(3,1)-XK1(3))**2
4078 UH = (PGAM(4,1)-XK2(4))**2-(PGAM(1,1)-XK2(1))**2
4079 & -(PGAM(2,1)-XK2(2))**2-(PGAM(3,1)-XK2(3))**2
4081 TH = (PGAM(4,2)-XK2(4))**2-(PGAM(1,2)-XK2(1))**2
4082 & -(PGAM(2,2)-XK2(2))**2-(PGAM(3,2)-XK2(3))**2
4083 UH = (PGAM(4,2)-XK1(4))**2-(PGAM(1,2)-XK1(1))**2
4084 & -(PGAM(2,2)-XK1(2))**2-(PGAM(3,2)-XK1(3))**2
4091 IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.1)) THEN
4092 IF((MSPR.EQ.10).OR.(MSPR.EQ.12)) THEN
4102 SIGQPM(1)= -32.D0*PI**2*4.D0/3.D0*ALPHA1*QC2*ALPHA2
4103 & *(SP*TP*(2.D0*Q2**4-4.D0*Q2*SP**3-2.D0*Q2**3*(3*SP+TP)
4104 & +SP**2*(SP**2+TP**2)+Q2**2*(7.D0*SP**2+2.D0*SP*TP+TP**2))
4105 & -2.D0*(2.D0*SP**3*TP*(SP+TP)+Q2**3*(SP**2+6.D0*SP*TP+TP**2)
4106 & -2.D0*Q2**2*SP*(SP**2+4.D0*SP*TP+3.D0*TP**2)+Q2*SP*
4107 & (SP**3+SP**2*TP-SP*TP**2+TP**3))*XQ2 +
4108 & 4.D0*(2.D0*Q2**2-SP**2)*(SP+TP)**2*XQ2**2)/
4109 & (SP**2*TP**2*((Q2-SP)**2-4.D0*Q2*XQ2))
4110 WEIGHT = HELFLX(1)*SIGQPM(1)/(2.D0*(SH+GQ2(1)+GQ2(2)))
4111 ELSE IF((MSPR.EQ.11).OR.(MSPR.EQ.13)) THEN
4119 SIGQPM(1) = -32.D0*PI**2/2.D0*ALPHA1*QC2*ALPHA2
4120 & *(-((Q2**2+SP**2)*TP*(Q2**3-SP**3-3.D0*SP**2*TP
4121 & - 4.D0*SP*TP**2 - 2.D0*TP**3 - 3.D0*Q2**2*(SP + TP) + Q2*
4122 & (3.D0*SP**2 + 6.D0*SP*TP + 4.D0*TP**2))) +
4123 & (3.D0*Q2**5 - Q2**4*(11.D0*SP + 10.D0*TP) +
4124 & 4.D0*Q2**3*(4.D0*SP**2 + 5.D0*SP*TP + 4.D0*TP**2)
4125 & +Q2*SP**2*(5.D0*SP**2+4.D0*SP*TP+8.D0*TP**2)-4.D0*Q2**2
4126 & *(3.D0*SP**3+3.D0*SP**2*TP+4.D0*SP*TP**2+2.D0*TP**3)-
4127 & SP**2*(SP**3+2.D0*SP**2*TP+8.D0*SP*TP**2+8.D0*TP**3))*XQ2+
4128 & (11.D0*Q2**4-10.D0*Q2**3*(3.D0*SP+2.D0*TP)-2.D0*Q2*SP**2
4129 & *(7.D0*SP+2.D0*TP)+2.D0*Q2**2*(15.D0*SP**2+10.D0*SP*TP
4130 & +6.D0*TP**2)+SP**2*(3.D0*SP**2+4.D0*SP*TP+12.D0*TP**2))
4131 & *XQ2**2+8.D0*(Q2**3-SP**2*TP-Q2**2*(SP+TP))*XQ2**3+
4132 & 2.D0*(Q2**2+SP**2)*XQ2**4)/((Q2-SP)**2*(-TP+XQ2)**2*
4133 & (Q2-SP-TP+XQ2)**2)
4134 WEIGHT = HELFLX(1)*SIGQPM(1)/(2.D0*(SH+GQ2(1)+GQ2(2)))
4135 ELSE IF(MSPR.EQ.14) THEN
4136 SWPMPM = 4.D0*CC**2*RR*(W2-2.D0*RR)
4137 SWPPPP = SWPMPM +2.D0*(CC**2+BB)*(AA-4.D0*RR*CC)
4138 SWPPMM = 8.D0*RR*CC*(XKAP*XKAM-RR*CC)
4139 & -2.D0*XKAP*XKAM*AA
4140 SIGQPM(1) = (SWPPPP+SWPMPM)/2.D0*FAC
4141 SIGQPM(2) = SWPPMM*FAC
4142 WEIGHT = HELFLX(1)*SIGQPM(1)
4143 & +HELFLX(2)*SIGQPM(2)
4145 ELSE IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.0)) THEN
4150 SIGQPM(3) = 32.D0*PI**2*8.D0/3.D0*ALPHA1*QC2*ALPHA2
4151 & *Q2*(-(SP**2*TP**2*(-Q2 + SP + TP)) +
4152 & SP*TP*(2.D0*Q2**2 + 3.D0*SP**2 + 2.D0*SP*TP -
4153 & TP**2 - 2.D0*Q2*(3*SP + TP))*XQ2 -
4154 & 2.D0*(Q2*(SP**2 + 6.D0*SP*TP + TP**2) -
4155 & 2.D0*SP*(SP**2 + 4.D0*SP*TP + 3.D0*TP**2))*
4156 & XQ2**2 + 8.D0*(SP + TP)**2*XQ2**3)/
4157 & (SP**2*TP**2*((Q2 - SP)**2 - 4.D0*Q2*XQ2))
4158 WEIGHT = HELFLX(3)*SIGQPM(3)/(2.D0*(SH+GQ2(2)))
4159 ELSE IF(MSPR.EQ.13) THEN
4163 SIGQPM(3) = 32.D0*PI**2*2.D0*ALPHA1*QC2*ALPHA2
4164 & *(-Q2*(SP*TP*(-Q2+SP+TP)+(Q2**2-Q2*SP-2*SP*TP)*XQ2 +
4165 & SP*XQ2**2))/((Q2-SP)**2*(-TP+XQ2)*(Q2-SP-TP+XQ2))
4166 WEIGHT = HELFLX(3)*SIGQPM(3)/(2.D0*(SH+GQ2(2)))
4167 ELSE IF(MSPR.EQ.14) THEN
4168 SWP0M0 = 4.D0*RR*GQ2(2)*(-CC**2*GQ2(1)*W2
4169 & -XKAP*XKAM*Q1KK**2)/DD
4170 SWP0P0 = - SWP0M0+2.D0*GQ2(2)*GQ2(1)**2*W2*BB/DD
4171 SWPP00 = 2.D0*W2*BB*(AA-2.D0*CC*RR)
4172 & *SQRT(GQ2(1)*GQ2(2))/DD
4173 SWP00P = 4.D0*RR*(CC**2*(GQ2(1)*Q2KK+GQ2(2)*Q1KK)
4174 & +XKAP*XKAM*Q1KK*Q2KK)*SQRT(GQ2(1)*GQ2(2))/DD
4175 SW0PM0 = -SWP00P-2.D0*GQ2(1)*GQ2(2)*W2*BB
4176 & *SQRT(GQ2(1)*GQ2(2))/DD
4177 SIGQPM(3) = SWP0P0*FAC
4178 SIGQPM(6) = (SWPP00+SW0PM0)/2.D0*FAC
4179 WEIGHT = HELFLX(3)*SIGQPM(3)
4180 & +HELFLX(6)*SIGQPM(6)/2.D0
4182 ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.1)) THEN
4187 SIGQPM(4) = 32.D0*PI**2*8.D0/3.D0*ALPHA1*QC2*ALPHA2
4188 & *Q2*(-(SP**2*TP**2*(-Q2 + SP + TP)) +
4189 & SP*TP*(2.D0*Q2**2 + 3.D0*SP**2 + 2.D0*SP*TP -
4190 & TP**2 - 2.D0*Q2*(3*SP + TP))*XQ2 -
4191 & 2.D0*(Q2*(SP**2 + 6.D0*SP*TP + TP**2) -
4192 & 2.D0*SP*(SP**2 + 4.D0*SP*TP + 3.D0*TP**2))*
4193 & XQ2**2 + 8.D0*(SP + TP)**2*XQ2**3)/
4194 & (SP**2*TP**2*((Q2 - SP)**2 - 4.D0*Q2*XQ2))
4195 WEIGHT = HELFLX(4)*SIGQPM(4)/(2.D0*(SH+GQ2(1)))
4196 ELSE IF(MSPR.EQ.11) THEN
4200 SIGQPM(4) = 32.D0*PI**2*2.D0*ALPHA1*QC2*ALPHA2
4201 & *(-Q2*(SP*TP*(-Q2+SP+TP)+(Q2**2-Q2*SP-2*SP*TP)*XQ2 +
4202 & SP*XQ2**2))/((Q2-SP)**2*(-TP+XQ2)*(Q2-SP-TP+XQ2))
4203 WEIGHT = HELFLX(4)*SIGQPM(4)/(2.D0*(SH+GQ2(2)))
4204 ELSE IF(MSPR.EQ.14) THEN
4205 SW0P0M = 4.D0*RR*GQ2(1)*(-CC**2*GQ2(2)*W2
4206 & -XKAP*XKAM*Q2KK**2)/DD
4207 SW0P0P = - SW0P0M+2.D0*GQ2(1)*GQ2(2)**2*W2*BB/DD
4208 SWPP00 = 2.D0*W2*BB*(AA-2.D0*CC*RR)
4209 & *SQRT(GQ2(1)*GQ2(2))/DD
4210 SWP00P = 4.D0*RR*(CC**2*(GQ2(1)*Q2KK+GQ2(2)*Q1KK)
4211 & +XKAP*XKAM*Q1KK*Q2KK)*SQRT(GQ2(1)*GQ2(2))/DD
4212 SW0PM0 = -SWP00P-2.D0*GQ2(1)*GQ2(2)*W2*BB
4213 & *SQRT(GQ2(1)*GQ2(2))/DD
4214 SIGQPM(4) = SW0P0P*FAC
4215 SIGQPM(6) = (SWPP00+SW0PM0)/2.D0*FAC
4216 WEIGHT = HELFLX(4)*SIGQPM(4)
4217 & +HELFLX(6)*SIGQPM(6)/2.D0
4219 ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.0)) THEN
4221 SW0000 = 2.D0*GQ2(1)*GQ2(2)*W2*W2*AA*BB/DD**2
4222 SIGQPM(5) = SW0000*FAC
4223 WEIGHT = HELFLX(5)*SIGQPM(5)
4226 WRITE(LO,'(/1X,A,2I3)')
4227 & 'PHO_GGEPEM:ERROR: invalid photon helicities: ',IGHEL
4228 WRITE(LO,'(1X,A,I12)')
4229 & 'PHO_GGEPEM: event rejected (KEVENT)',KEVENT
4233 C fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
4235 WGHQPM = WEIGHT/(137.D0**2*16.D0*PI**4*GQ2(1)*GQ2(2))
4236 & *SQRT(XCAP/YCAP)*PI*SS/(2.D0*YCAP)*PINI(4,1)*PINI(4,2)
4242 *$ CREATE PHO_GGBLSR.FOR
4244 CDECK ID>, PHO_GGBLSR
4245 SUBROUTINE PHO_GGBLSR(NEVENT,EE1,EE2,
4246 & Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A)
4247 C***********************************************************************
4249 C interface to call PHOJET (variable energy run) for
4250 C gamma-gamma collisions via laser backscattering
4252 C input: EE1 lab. system energy of electron/positron 1
4253 C EE2 lab. system energy of electron/positron 2
4254 C NEVENT number of events to generate
4255 C Pl_lam_1/2 product of electron and photon pol.
4256 C X_1/2 standard X parameter
4257 C rho ratio of distance to conversion point and
4258 C transverse beam size
4259 C A ellipticity of electon beam
4261 C (see Ginzburg & Kotkin hep-ph/9905462)
4264 C YMIN1 lower limit of Y1
4265 C (energy fraction taken by photon from electron)
4266 C YMAX1 upper limit of Y1
4267 C YMIN2 lower limit of Y2
4268 C (energy fraction taken by photon from electron)
4269 C YMAX2 upper limit of Y2
4271 C***********************************************************************
4272 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4275 PARAMETER ( PI = 3.14159265359D0 )
4277 C input/output channels
4279 COMMON /POINOU/ LI,LO
4280 C event debugging information
4282 PARAMETER (NMAXD=100)
4283 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4284 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4285 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4286 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4287 C photon flux kinematics and cuts
4288 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
4289 & YMIN1,YMAX1,YMIN2,YMAX2,
4290 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4291 & THMIN1,THMAX1,THMIN2,THMAX2
4293 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
4294 & YMIN1,YMAX1,YMIN2,YMAX2,
4295 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4296 & THMIN1,THMAX1,THMIN2,THMAX2,
4298 C gamma-lepton or gamma-hadron vertex information
4299 INTEGER IGHEL,IDPSRC,IDBSRC
4300 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
4301 & RADSRC,AMSRC,GAMSRC
4302 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
4303 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
4304 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
4305 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
4306 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
4307 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
4308 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
4309 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
4310 C event weights and generated cross section
4311 INTEGER IPOWGC,ISWCUT,IVWGHT
4312 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
4313 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
4314 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
4316 parameter (N_dim=100)
4317 dimension X_inp_1(N_dim),F_inp_1(N_dim),F_int_1(N_dim),
4318 & X_inp_2(N_dim),F_inp_2(N_dim),F_int_2(N_dim),
4319 & Xgrid(96),Wgrid(96)
4321 DIMENSION P1(4),P2(4)
4325 WRITE(LO,'(//1X,A,I10)') 'PHO_GGBLSR: events to process',NEVENT
4327 YMAX1 = MIN(X_1/(1.D0+X_1),YMAX1)
4328 YMAX2 = MIN(X_2/(1.D0+X_2),YMAX2)
4329 IF((YMIN1.GT.YMAX1).OR.(YMIN2.GT.YMAX2)) THEN
4330 WRITE(LO,'(/1X,2A,2E12.4)') 'PHO_GGBLSR:ERROR: ',
4331 & 'invalid Ymin1,Ymin2',YMIN1,YMIN2
4339 C initialize sampling
4342 DELY1 = (YMAX1-YMIN1)/DBLE(Max_tab-1)
4343 DELY2 = (YMAX2-YMIN2)/DBLE(Max_tab-1)
4345 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
4346 & 'PHO_GGBLSR: table of photon flux ',Max_tab
4350 y1 = YMIN1+DELY1*DBLE(I-1)
4351 r1 = y1/(X_1*(1.D0-y1))
4353 F_inp_1(i) = 1.D0/(1.D0-y1)-y1+(2.D0*r1-1.D0)**2
4354 & -Pl_lam_1*X_1*r1*(2.D0*r1-1.D0)*(2.D0-y1)
4356 y2 = YMIN2+DELY2*DBLE(I-1)
4357 r2 = y2/(X_2*(1.D0-y2))
4359 F_inp_2(i) = 1.D0/(1.D0-y2)-y2+(2.D0*r2-1.D0)**2
4360 & -Pl_lam_2*X_2*r2*(2.D0*r2-1.D0)*(2.D0-y2)
4362 IF(IDEB(30).GE.1) WRITE(LO,'(5X,1p,2E13.4,5x,2E13.4)')
4363 & y1,F_inp_1(i),y2,F_inp_2(i)
4367 call pho_samp1d(-1,X_inp_1,F_inp_1,F_int_1,Max_tab,X_out_1)
4368 call pho_samp1d(-1,X_inp_2,F_inp_2,F_int_2,Max_tab,X_out_2)
4370 C initialize event generator
4384 CALL PHO_SETPAR(1,22,0,0.D0)
4385 CALL PHO_SETPAR(2,22,0,0.D0)
4386 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
4387 CALL PHO_PHIST(-1,SIGMAX)
4388 CALL PHO_LHIST(-1,SIGMAX)
4390 C generation of events
4405 call pho_samp1d(1,X_inp_1,F_inp_1,F_int_1,Max_tab,X_out_1)
4406 call pho_samp1d(1,X_inp_2,F_inp_2,F_int_2,Max_tab,X_out_2)
4408 g_1 = sqrt(max(0.D0,X_1/(X_out_1+1.D-6)-X_1-1.D0))
4409 g_2 = sqrt(max(0.D0,X_2/(X_out_2+1.D-6)-X_2-1.D0))
4410 if(abs(1.D0-A).lt.1.D-3) then
4411 v = rho**2/4.D0*g_1*g_2
4412 Wght = exp(-rho**2/8.D0*(g_1-g_2)**2)*pho_ExpBessI0(v)
4415 call pho_gauset(0.D0,Pi2,Nint,Xgrid,Wgrid)
4417 fac = rho**2/(4.D0*(1.D0+A2))
4424 & +exp(-fac*(A2*(g_1*cos(phi_1)+g_2*cos(phi_2))**2
4425 & +(g_1*sin(phi_1)+g_2*sin(phi_2))**2))
4426 & *Wgrid(i1)*Wgrid(i2)
4432 IF(Wght.GT.1.D0) THEN
4433 WRITE(LO,'(1X,A,5E11.4)')
4434 & 'PHO_GGBLSR:WEIGHT ERROR:',Y1,Y2,Wght
4436 IF(DT_RNDM(dum).GT.Wght) GOTO 175
4447 C incoming electron 1
4453 C outgoing electron 1
4454 YQ2 = SQRT((1.D0-Y1)*Q2P2)
4455 Q2E = Q2P1/(4.D0*EE1)
4457 CALL PHO_SFECFE(SIF,COF)
4466 P1(3) = PINI(3,1)-PFIN(3,1)
4467 P1(4) = PINI(4,1)-PFIN(4,1)
4468 C incoming electron 2
4474 C outgoing electron 2
4475 YQ2 = SQRT((1.D0-Y2)*Q2P2)
4476 Q2E = Q2P2/(4.D0*EE2)
4478 CALL PHO_SFECFE(SIF,COF)
4481 PFIN(3,2) = -E1Y+Q2E
4487 P2(3) = PINI(3,2)-PFIN(3,2)
4488 P2(4) = PINI(4,2)-PFIN(4,2)
4490 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
4491 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
4492 IF(GGECM.LT.0.1D0) GOTO 175
4494 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
4510 CALL PHO_PRESEL(5,IREJ)
4511 IF(IREJ.NE.0) GOTO 175
4513 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
4514 IF(IREJ.NE.0) GOTO 150
4522 CALL PHO_PHIST(1,HSWGHT(0))
4523 CALL PHO_LHIST(1,HSWGHT(0))
4526 WGY = DBLE(ITRY)/DBLE(ITRW)
4527 AY1 = AY1/DBLE(NITER)
4528 AYS1 = AYS1/DBLE(NITER)
4529 DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
4530 AY2 = AY2/DBLE(NITER)
4531 AYS2 = AYS2/DBLE(NITER)
4532 DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
4533 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
4534 C output of statistics, histograms
4535 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
4536 &'=========================================================',
4537 &' ***** simulated cross section: ',WEIGHT,' mb *****',
4538 &'========================================================='
4539 WRITE(LO,'(//1X,A,3I10)')
4540 & 'PHO_GGBLSR:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
4541 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
4543 WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBLSR:AVERAGE Y1,DY1 ',AY1,DAY1
4544 WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBLSR:AVERAGE Y2,DY2 ',AY2,DAY2
4546 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
4548 CALL PHO_PHIST(-2,WEIGHT)
4549 CALL PHO_LHIST(-2,WEIGHT)
4551 WRITE(LO,'(1X,A,I4)') 'PHO_GGBLSR:NO OUTPUT OF HISTOGRAMS',NITER
4556 *$ CREATE pho_samp1d.FOR
4558 CDECK ID>, pho_samp1d
4559 SUBROUTINE pho_samp1d(Imode,X_inp,F_inp,F_int,N_dim,X_out)
4560 C***********************************************************************
4562 C Monte Carlo sampling from arbitrary 1d distribution
4563 C (linear interpolation to improve reproduction of initial function)
4565 C input: Imode -1 initialization
4566 C 1 sampling (after initialization)
4567 C X_inp(N_dim) array with x values
4568 C F_inp(N_dim) array with function values
4569 C F_int(N_dim) array with integral
4571 C output: X_out sampled value (Imode=1)
4575 C***********************************************************************
4579 C input/output channels
4581 COMMON /POINOU/ LI,LO
4584 double precision X_inp,F_inp,F_int,X_out
4585 dimension X_inp(N_dim),F_inp(N_dim),F_int(N_dim)
4589 double precision dum,xi,a,b
4591 C external functions
4592 double precision DT_RNDM
4595 if(Imode.eq.-1) then
4601 F_int(i) = F_int(i-1)
4602 & +0.5D0*(F_inp(i)+F_inp(i-1))*(X_inp(i)-X_inp(i-1))
4605 else if(Imode.eq.1) then
4607 C sample from previously calculated integral
4609 xi = DT_RNDM(dum)*F_int(N_dim)
4612 if(xi.lt.F_int(i)) then
4613 a = (F_inp(i)-F_inp(i-1))/(X_inp(i)-X_inp(i-1))
4614 b = F_inp(i)-a*X_inp(i)
4615 xi = xi-F_int(i-1)+0.5D0*a*X_inp(i-1)**2+b*X_inp(i-1)
4616 X_out = (sqrt(b**2+2.D0*a*xi)-b)/a
4620 X_out = X_inp(N_dim)
4624 C invalid option Imode
4626 WRITE(LO,'(1x,a,i6)') 'PHO_SAMP1D: invalid option Imode: ',Imode
4633 *$ CREATE pho_ExpBessI0.FOR
4635 CDECK ID>, pho_ExpBessI0
4636 DOUBLE PRECISION FUNCTION pho_ExpBessI0(X)
4637 C**********************************************************************
4639 C Bessel Function I0 times exponential function from neg. arg.
4640 C (defined for pos. arguments only)
4642 C**********************************************************************
4643 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4647 IF (AX .LT. 3.75D0) THEN
4650 & (1.0D0+Y*(3.5156229D0+Y*(3.0899424D0+Y*(1.2067492D0
4651 & +Y*(0.2659732D0+Y*(0.360768D-1+Y*0.45813D-2))))))*EXP(-AX)
4655 & (1.D0/SQRT(AX))*(0.39894228D0+Y*(0.1328592D-1
4656 & +Y*(0.225319D-2+Y*(-0.157565D-2+Y*(0.916281D-2
4657 & +Y*(-0.2057706D-1+Y*(0.2635537D-1+Y*(-0.1647633D-1
4658 & +Y*0.392377D-2))))))))
4663 *$ CREATE PHO_GGBEAM.FOR
4665 CDECK ID>, PHO_GGBEAM
4666 SUBROUTINE PHO_GGBEAM(NEVENT,EE,YPSI,SIGX,SIGY,SIGZ,AEB)
4667 C**********************************************************************
4669 C interface to call PHOJET (variable energy run) for
4670 C gamma-gamma collisions via beamstrahlung
4672 C input: EE LAB system energy of electron/positron
4673 C YPSI beamstrahlung parameter
4674 C SIGX,Y transverse bunch dimensions
4675 C SIGZ longitudinal bunch dimension
4676 C AEB number of electrons/positrons in a bunch
4677 C NEVENT number of events to generate
4679 C YMIN1 lower limit of Y
4680 C (energy fraction taken by photon from electron)
4681 C YMAX1 upper cutoff for Y, necessary to avoid
4684 C**********************************************************************
4685 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4688 PARAMETER ( DEPS = 1.D-20,
4689 & PI = 3.14159265359D0 )
4691 C input/output channels
4693 COMMON /POINOU/ LI,LO
4694 C event debugging information
4696 PARAMETER (NMAXD=100)
4697 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4698 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4699 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4700 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4701 C photon flux kinematics and cuts
4702 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
4703 & YMIN1,YMAX1,YMIN2,YMAX2,
4704 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4705 & THMIN1,THMAX1,THMIN2,THMAX2
4707 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
4708 & YMIN1,YMAX1,YMIN2,YMAX2,
4709 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4710 & THMIN1,THMAX1,THMIN2,THMAX2,
4712 C gamma-lepton or gamma-hadron vertex information
4713 INTEGER IGHEL,IDPSRC,IDBSRC
4714 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
4715 & RADSRC,AMSRC,GAMSRC
4716 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
4717 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
4718 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
4719 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
4720 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
4721 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
4722 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
4723 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
4724 C event weights and generated cross section
4725 INTEGER IPOWGC,ISWCUT,IVWGHT
4726 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
4727 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
4728 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
4730 PARAMETER (Max_tab=100)
4731 DIMENSION P1(4),P2(4),TABCU(0:Max_tab),TABYL(0:Max_tab)
4734 WRITE(LO,'(//1X,A,I10)') 'PHO_GGBEAM: events to process',NEVENT
4742 C table of flux function, log interpolation
4743 IF(YPSI.LE.0.D0) THEN
4744 YPSI = 5.D0*RE**2*EE*AEB*137.D0/(6.D0*SIGZ*(SIGX+SIGY)*ELEM)
4746 WRITE(LO,'(/1X,A,E12.4)')
4747 & 'PHO_GGBEAM: beamstrahlung parameter:',YPSI
4748 WRITE(LO,'(/1X,A,2E12.4)')
4749 & 'PHO_GGBEAM: sigma-z,ne-bunch:',SIGZ,AEB
4753 GAOT = 2.6789385347D0
4755 WW = 1.D0/(6.D0*SQRT(AKAP))
4756 ANGAM = 5.D0*SIGZ*ELEM/(137.D0**2*2.D0*RE*EE)
4757 & *YPSI/SQRT(1.D0+YPSI**TT)
4760 YMAX = MIN(YMAX1,0.9D0)
4762 TABYL(0) = LOG(YMIN)
4763 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
4765 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
4766 & 'PHO_GGBEAM: table of photon flux',Max_tab
4768 Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
4769 GG = 1.D0-0.5D0*(1-Y)**TT*(1.D0-Y+(1.D0+Y)*SQRT(1.D0+YPSI**TT))
4770 FF = AKAP**OT/GAOT/Y**TT/(1.D0-Y)**OT*EXP(-AKAP*Y/(1.D0-Y))
4771 & *((1.D0-WW)/GG*(1.D0-(1.D0-EXP(-ANGAM*GG))/(ANGAM*GG))
4772 & +WW*(1.D0-(1.D0-EXP(-ANGAM))/ANGAM))
4773 TABCU(I) = TABCU(I-1)+FF*Y
4776 IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y,FF
4779 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
4780 & 'PHO_GGBEAM: integrated flux (one side):',FLUX
4796 CALL PHO_SETPAR(1,22,0,0.D0)
4797 CALL PHO_SETPAR(2,22,0,0.D0)
4798 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
4799 CALL PHO_PHIST(-1,SIGMAX)
4800 CALL PHO_LHIST(-1,SIGMAX)
4802 C generation of events
4816 XI = DT_RNDM(AY1)*TABCU(Max_tab)
4818 IF(TABCU(K).GE.XI) THEN
4819 Y1 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
4826 XI = DT_RNDM(AY2)*TABCU(Max_tab)
4828 IF(TABCU(K).GE.XI) THEN
4829 Y2 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
4843 C incoming electron 1
4849 C outgoing electron 1
4850 YQ2 = SQRT((1.D0-Y1)*Q2P2)
4851 Q2E = Q2P1/(4.D0*EE1)
4853 CALL PHO_SFECFE(SIF,COF)
4862 P1(3) = PINI(3,1)-PFIN(3,1)
4863 P1(4) = PINI(4,1)-PFIN(4,1)
4864 C incoming electron 2
4870 C outgoing electron 2
4871 YQ2 = SQRT((1.D0-Y2)*Q2P2)
4872 Q2E = Q2P2/(4.D0*EE2)
4874 CALL PHO_SFECFE(SIF,COF)
4877 PFIN(3,2) = -E1Y+Q2E
4883 P2(3) = PINI(3,2)-PFIN(3,2)
4884 P2(4) = PINI(4,2)-PFIN(4,2)
4886 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
4887 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
4888 IF(GGECM.LT.0.1D0) GOTO 175
4890 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
4906 CALL PHO_PRESEL(5,IREJ)
4907 IF(IREJ.NE.0) GOTO 175
4909 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
4910 IF(IREJ.NE.0) GOTO 150
4911 **sr leading tab removed
4921 CALL PHO_PHIST(1,HSWGHT(0))
4922 CALL PHO_LHIST(1,HSWGHT(0))
4925 WGY = FLUX**2*DBLE(ITRY)/DBLE(ITRW)
4926 AY1 = AY1/DBLE(NITER)
4927 AYS1 = AYS1/DBLE(NITER)
4928 DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
4929 AY2 = AY2/DBLE(NITER)
4930 AYS2 = AYS2/DBLE(NITER)
4931 DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
4932 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
4933 C output of statistics, histograms
4934 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
4935 &'=========================================================',
4936 &' ***** simulated cross section: ',WEIGHT,' mb *****',
4937 &'========================================================='
4938 WRITE(LO,'(//1X,A,2I10)')
4939 & 'PHO_GGBEAM:SUMMARY:NITER,ITRY',NITER,ITRY
4940 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
4942 WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBEAM:AVERAGE Y1,DY1 ',AY1,DAY1
4943 WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBEAM:AVERAGE Y2,DY2 ',AY2,DAY2
4945 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
4947 CALL PHO_PHIST(-2,WEIGHT)
4948 CALL PHO_LHIST(-2,WEIGHT)
4950 WRITE(LO,'(1X,A,I4)') 'PHO_GGBEAM:NO OUTPUT OF HISTOGRAMS',NITER
4955 *$ CREATE PHO_GGHIOF.FOR
4957 CDECK ID>, PHO_GGHIOF
4958 SUBROUTINE PHO_GGHIOF(NEVENT,EEN,NA,NZ)
4959 C**********************************************************************
4961 C interface to call PHOJET (variable energy run) for
4962 C gamma-gamma collisions via heavy ions (form factor approach)
4964 C input: EEN LAB system energy per nucleon
4965 C NA atomic number of ion/hadron
4966 C NZ charge number of ion/hadron
4967 C NEVENT number of events to generate
4969 C YMIN1,2 lower limit of Y
4970 C (energy fraction taken by photon from hadron)
4971 C YMAX1,2 upper cutoff for Y, necessary to avoid
4973 C Q2MIN1,2 minimum Q**2 of photons (should be set to 0)
4974 C Q2MAX1,2 maximum Q**2 of photons (if necessary,
4975 C corrected according size of hadron)
4977 C currently implemented approximation similar to:
4978 C E.Papageorgiu PhysLettB250(1990)155
4980 C**********************************************************************
4981 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4984 PARAMETER ( PI = 3.14159265359D0 )
4986 C input/output channels
4988 COMMON /POINOU/ LI,LO
4989 C model switches and parameters
4991 INTEGER ISWMDL,IPAMDL
4992 DOUBLE PRECISION PARMDL
4993 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4994 C event debugging information
4996 PARAMETER (NMAXD=100)
4997 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4998 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4999 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
5000 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
5001 C photon flux kinematics and cuts
5002 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
5003 & YMIN1,YMAX1,YMIN2,YMAX2,
5004 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
5005 & THMIN1,THMAX1,THMIN2,THMAX2
5007 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
5008 & YMIN1,YMAX1,YMIN2,YMAX2,
5009 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
5010 & THMIN1,THMAX1,THMIN2,THMAX2,
5012 C gamma-lepton or gamma-hadron vertex information
5013 INTEGER IGHEL,IDPSRC,IDBSRC
5014 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
5015 & RADSRC,AMSRC,GAMSRC
5016 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
5017 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
5018 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
5019 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
5020 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
5021 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
5022 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
5023 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
5024 C event weights and generated cross section
5025 INTEGER IPOWGC,ISWCUT,IVWGHT
5026 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
5027 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
5028 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
5030 DIMENSION P1(4),P2(4),BIMP(2,2)
5033 WRITE(LO,'(2(/1X,A))') 'PHO_GGHIOF:GAMMA-GAMMA EVENT GENERATION',
5034 & '--------------------------------------'
5035 C hadron size and mass
5037 HIMASS = DBLE(NA)*0.938D0
5039 HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
5040 ALPHA = DBLE(NZ**2)/137.D0
5041 C correct Q2MAX1,2 according to hadron size
5042 Q2MAXH = 2.D0/HIRADI**2
5043 Q2MAX1 = MIN(Q2MAX1,Q2MAXH)
5044 Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
5045 IF(Q2MAX1.LT.1.D-20) Q2MAX1 = Q2MAXH
5046 IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
5047 C total hadron / heavy ion energy
5057 C kinematic limitations
5058 YMI = (ECMIN/(2.D0*EE))**2
5059 IF(YMIN1.LT.YMI) THEN
5060 WRITE(LO,'(/1X,A,2E12.5)')
5061 & 'PHO_GGHIOF: ymin1 increased to (old/new)',YMIN1,YMI
5063 ELSE IF(YMIN1.GT.YMI) THEN
5064 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5065 & 'PHO_GGHIOF:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
5066 & ' INSTEAD OF',YMIN1
5068 IF(YMIN2.LT.YMI) THEN
5069 WRITE(LO,'(/1X,A,2E12.5)')
5070 & 'PHO_GGHIOF: ymin2 increased to (old/new)',YMIN2,YMI
5072 ELSE IF(YMIN2.GT.YMI) THEN
5073 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5074 & 'PHO_GGHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
5075 & ' INSTEAD OF',YMIN2
5077 C kinematic limitation
5078 Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
5079 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
5081 WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
5082 WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV) ',HIMASS
5083 WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1) ',HIRADI
5084 WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 1 (GEV**2)',Q2LOW1,
5086 WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
5088 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1 ',YMIN1,
5090 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
5092 WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
5094 WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
5095 IF(Q2LOW1.GE.Q2MAX1) THEN
5096 WRITE(LO,'(/1X,A,2E12.4)')
5097 & 'PHO_GGHIOF:ERROR:INCONSISTENT Q**2 RANGE 1',Q2LOW1,Q2MAX1
5100 IF(Q2LOW2.GE.Q2MAX2) THEN
5101 WRITE(LO,'(/1X,A,2E12.4)')
5102 & 'PHO_GGHIOF:ERROR:INCONSISTENT Q**2 RANGE 2',Q2LOW2,Q2MAX2
5105 C hadron numbers set to 0
5117 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5119 Y1 = EXP(XMIN+DELLY*DBLE(I-1))
5120 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
5121 IF(Q2LOW1.GE.Q2MAX1) THEN
5122 WRITE(LO,'(/1X,A,2E12.4)')
5123 & 'PHO_GGHIOF: ymax1 changed from/to',YMAX1,Y1
5124 YMAX1 = MIN(Y1,YMAX1)
5134 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5136 Y1 = EXP(XMIN+DELLY*DBLE(I-1))
5137 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
5138 IF(Q2LOW2.GE.Q2MAX2) THEN
5139 WRITE(LO,'(/1X,A,2E12.4)')
5140 & 'PHO_GGHIOF: ymax2 changed from/to',YMAX2,Y1
5141 YMAX2 = MIN(Y1,YMAX2)
5146 YMI = (ECMIN/(2.D0*EE))**2/YMAX2
5147 IF(YMI.GT.YMIN1) THEN
5148 WRITE(LO,'(/1X,A,2E12.4)')
5149 & 'PHO_GGHIOF: ymin1 changed from/to',YMIN1,YMI
5152 YMI = (ECMIN/(2.D0*EE))**2/YMAX1
5153 IF(YMI.GT.YMIN2) THEN
5154 WRITE(LO,'(/1X,A,2E12.4)')
5155 & 'PHO_GGHIOF: ymin2 changed from/to',YMIN2,YMI
5165 DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
5167 IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
5168 & 'PHO_GGHIOF: table of raw photon flux (side 1)',Max_tab
5170 Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
5171 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
5172 FF = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
5173 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))*ALPHA/(2.D0*PI)
5175 IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y1,FF
5178 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
5179 & 'PHO_GGHIOF: integrated flux (one side):',FLUX
5181 Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
5182 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
5185 WGMAX = ((1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
5186 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
5187 & *((1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
5188 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
5202 CALL PHO_SETPAR(1,22,0,0.D0)
5203 CALL PHO_SETPAR(2,22,0,0.D0)
5204 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
5205 CALL PHO_PHIST(-1,SIGMAX)
5206 CALL PHO_LHIST(-1,SIGMAX)
5208 C generation of events, flux calculation
5210 ECFRAC = ECMIN**2/(4.D0*EE*EE)
5236 Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
5237 Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
5238 IF(Y1*Y2.LT.ECFRAC) GOTO 175
5240 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1**2/(1.D0-Y1))
5241 IF(Q2LOW1.GE.Q2MAX1) GOTO 175
5242 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
5243 IF(Q2LOW2.GE.Q2MAX2) GOTO 175
5244 Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
5245 Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
5246 WGH = ((1.D0+(1.D0-Y1)**2)*Q2LOG1
5247 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
5248 & *((1.D0+(1.D0-Y2)**2)*Q2LOG2
5249 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
5250 IF(WGMAX.LT.WGH) THEN
5251 WRITE(LO,'(1X,A,4E12.5)')
5252 & 'PHO_GGHIOF:WEIGHT ERROR:',Y1,Y2,WGMAX,WGH
5254 IF(DT_RNDM(AYS1)*WGMAX.GT.WGH) GOTO 175
5256 IF(IPAMDL(174).EQ.1) THEN
5257 YEFF = 1.D0+(1.D0-Y1)**2
5259 Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
5260 WEIGHT = (YEFF-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF
5261 IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
5265 IF(IPAMDL(174).EQ.1) THEN
5266 YEFF = 1.D0+(1.D0-Y2)**2
5268 Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
5269 WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
5270 IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
5275 GAIMP(1) = 1.D0/SQRT(Q2P1)
5276 GAIMP(2) = 1.D0/SQRT(Q2P2)
5277 C form factor (squared)
5279 IF(GAIMP(1).LT.HIRADI) FF21 = 0.D0
5281 IF(GAIMP(2).LT.HIRADI) FF22 = 0.D0
5282 IF(DT_RNDM(Q2P1).GE.FF21*FF22) GOTO 175
5283 C do the hadrons overlap?
5284 IF(ISWMDL(26).GT.0) THEN
5286 CALL PHO_SFECFE(SIF,COF)
5287 BIMP(1,K) = SIF*GAIMP(K)
5288 BIMP(2,K) = COF*GAIMP(K)
5290 BBABS = SQRT((BIMP(1,1)-BIMP(1,2))**2
5291 & +(BIMP(2,1)-BIMP(2,2))**2)
5292 IF(BBABS.LT.HIRADI+HIRADI) GOTO 175
5308 YQ2 = SQRT((1.D0-Y1)*Q2P1)
5309 Q2E = Q2P1/(4.D0*EE)
5311 CALL PHO_SFECFE(SIF,COF)
5317 PFPHI(1) = ATAN2(COF,SIF)
5318 PFTHE(1) = ACOS((E1Y-Q2E)/(Q2E+E1Y))
5322 P1(3) = PINI(3,1)-PFIN(3,1)
5323 P1(4) = PINI(4,1)-PFIN(4,1)
5331 YQ2 = SQRT((1.D0-Y2)*Q2P2)
5332 Q2E = Q2P2/(4.D0*EE)
5334 CALL PHO_SFECFE(SIF,COF)
5337 PFIN(3,2) = -E1Y+Q2E
5340 PFPHI(2) = ATAN2(COF,SIF)
5341 PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
5345 P2(3) = PINI(3,2)-PFIN(3,2)
5346 P2(4) = PINI(4,2)-PFIN(4,2)
5348 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
5349 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
5350 IF(GGECM.LT.0.1D0) GOTO 175
5352 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
5358 PGAM(5,1) = -SQRT(Q2P1)
5363 PGAM(5,2) = -SQRT(Q2P2)
5368 CALL PHO_PRESEL(5,IREJ)
5369 IF(IREJ.NE.0) GOTO 175
5371 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
5372 IF(IREJ.NE.0) GOTO 150
5379 Q21MIN = MIN(Q21MIN,Q2P1)
5380 Q22MIN = MIN(Q22MIN,Q2P2)
5381 Q21MAX = MAX(Q21MAX,Q2P1)
5382 Q22MAX = MAX(Q22MAX,Q2P2)
5383 YY1MIN = MIN(YY1MIN,Y1)
5384 YY2MIN = MIN(YY2MIN,Y2)
5385 YY1MAX = MAX(YY1MAX,Y1)
5386 YY2MAX = MAX(YY2MAX,Y2)
5387 Q21AVE = Q21AVE+Q2P1
5388 Q22AVE = Q22AVE+Q2P2
5389 Q21AV2 = Q21AV2+Q2P1*Q2P1
5390 Q22AV2 = Q22AV2+Q2P2*Q2P2
5392 CALL PHO_PHIST(1,HSWGHT(0))
5393 CALL PHO_LHIST(1,HSWGHT(0))
5396 WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW)*(ALPHA/(2.D0*PI))**2
5397 WGY = WGY*LOG(YMAX1/YMIN1)*LOG(YMAX2/YMIN2)
5398 AY1 = AY1/DBLE(NITER)
5399 AYS1 = AYS1/DBLE(NITER)
5400 DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
5401 AY2 = AY2/DBLE(NITER)
5402 AYS2 = AYS2/DBLE(NITER)
5403 DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
5404 Q21AVE = Q21AVE/DBLE(NITER)
5405 Q21AV2 = Q21AV2/DBLE(NITER)
5406 Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(NITER))
5407 Q22AVE = Q22AVE/DBLE(NITER)
5408 Q22AV2 = Q22AV2/DBLE(NITER)
5409 Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
5410 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
5411 C output of statistics, histograms
5412 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
5413 &'=========================================================',
5414 &' ***** simulated cross section: ',WEIGHT,' mb *****',
5415 &'========================================================='
5416 WRITE(LO,'(//1X,A,3I10)')
5417 & 'PHO_GGHIOF:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
5418 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
5420 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1 ',
5422 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
5424 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1 ',
5426 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
5428 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 1 ',
5430 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 1 ',
5432 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 2 ',
5434 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2 ',
5437 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
5439 CALL PHO_PHIST(-2,WEIGHT)
5440 CALL PHO_LHIST(-2,WEIGHT)
5442 WRITE(LO,'(1X,A,I4)') 'PHO_GGHIOF:NO OUTPUT OF HISTOGRAMS',NITER
5447 *$ CREATE PHO_GGHIOG.FOR
5449 CDECK ID>, PHO_GGHIOG
5450 SUBROUTINE PHO_GGHIOG(NEVENT,EEN,NA,NZ)
5451 C**********************************************************************
5453 C interface to call PHOJET (variable energy run) for
5454 C gamma-gamma collisions via heavy ions (geometrical approach)
5457 C input: EEN LAB system energy per nucleon
5458 C NA atomic number of ion/hadron
5459 C NZ charge number of ion/hadron
5460 C NEVENT number of events to generate
5462 C YMIN1,2 lower limit of Y
5463 C (energy fraction taken by photon from hadron)
5464 C YMAX1,2 upper cutoff for Y, necessary to avoid
5467 C currently implemented approximation similar to:
5470 C**********************************************************************
5471 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5474 PARAMETER ( DEPS = 1.D-20,
5475 & PI = 3.14159265359D0 )
5477 C input/output channels
5479 COMMON /POINOU/ LI,LO
5480 C event debugging information
5482 PARAMETER (NMAXD=100)
5483 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
5484 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
5485 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
5486 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
5487 C photon flux kinematics and cuts
5488 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
5489 & YMIN1,YMAX1,YMIN2,YMAX2,
5490 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
5491 & THMIN1,THMAX1,THMIN2,THMAX2
5493 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
5494 & YMIN1,YMAX1,YMIN2,YMAX2,
5495 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
5496 & THMIN1,THMAX1,THMIN2,THMAX2,
5498 C gamma-lepton or gamma-hadron vertex information
5499 INTEGER IGHEL,IDPSRC,IDBSRC
5500 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
5501 & RADSRC,AMSRC,GAMSRC
5502 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
5503 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
5504 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
5505 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
5506 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
5507 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
5508 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
5509 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
5510 C event weights and generated cross section
5511 INTEGER IPOWGC,ISWCUT,IVWGHT
5512 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
5513 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
5514 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
5516 PARAMETER (Max_tab=100)
5517 DIMENSION P1(4),P2(4),TABCU(0:Max_tab),TABYL(0:Max_tab)
5520 WRITE(LO,'(2(/1X,A))') 'PHO_GGHIOG: gamma-gamma event generation',
5521 & '---------------------------------------'
5522 C hadron size and mass
5524 HIMASS = DBLE(NA)*0.938D0
5526 HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
5527 ALPHA = DBLE(NZ**2)/137.D0
5528 C total hadron / heavy ion energy
5538 C kinematic limitations
5539 YMI = (ECMIN/(2.D0*EE))**2
5540 IF(YMIN1.LT.YMI) THEN
5541 WRITE(LO,'(/1X,A,2E12.5)')
5542 & 'PHO_GGHIOG: ymin1 increased to (old/new)',YMIN1,YMI
5544 ELSE IF(YMIN1.GT.YMI) THEN
5545 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5546 & 'PHO_GGHIOG:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
5547 & ' INSTEAD OF',YMIN1
5549 IF(YMIN2.LT.YMI) THEN
5550 WRITE(LO,'(/1X,A,2E12.5)')
5551 & 'PHO_GGHIOG: ymin2 increased to (old/new)',YMIN2,YMI
5553 ELSE IF(YMIN2.GT.YMI) THEN
5554 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5555 & 'PHO_GGHIOG:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
5556 & ' INSTEAD OF',YMIN2
5559 WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
5560 WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV) ',HIMASS
5561 WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1) ',HIRADI
5562 WRITE(LO,'(6X,A,E12.5)') 'LORENTZ GAMMA ',GAMMA
5563 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1 ',YMIN1,
5565 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
5567 WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
5569 WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
5570 C hadron numbers set to 0
5575 C table of flux function, log interpolation
5578 YMAX = MIN(YMAX,0.9999999D0)
5579 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5580 TABYL(0) = LOG(YMIN)
5583 Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
5585 XI = WG*HIRADI/GAMMA
5586 FF = ALPHA*PHO_GGFLCL(XI)/Y
5587 FFMAX = MAX(FF,FFMAX)
5588 IF(FF.LT.1.D-10*FFMAX) THEN
5589 WRITE(LO,'(/1X,A,2E12.4)')
5590 & 'PHO_GGHIOG: ymax1 changed from/to',YMAX1,Y
5591 YMAX1 = MIN(Y,YMAX1)
5598 YMAX = MIN(YMAX,0.9999999D0)
5599 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5600 TABYL(0) = LOG(YMIN)
5603 Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
5605 XI = WG*HIRADI/GAMMA
5606 FF = ALPHA*PHO_GGFLCL(XI)/Y
5607 FFMAX = MAX(FF,FFMAX)
5608 IF(FF.LT.1.D-10*FFMAX) THEN
5609 WRITE(LO,'(/1X,A,2E12.4)')
5610 & 'PHO_GGHIOG: ymax2 changed from/to',YMAX2,Y
5611 YMAX2 = MIN(Y,YMAX2)
5616 YMI = (ECMIN/(2.D0*EE))**2/YMAX2
5617 IF(YMI.GT.YMIN1) THEN
5618 WRITE(LO,'(/1X,A,2E12.4)')
5619 & 'PHO_GGHIOG: ymin1 changed from/to',YMIN1,YMI
5622 YMAX1 = MIN(YMAX,YMAX1)
5623 YMI = (ECMIN/(2.D0*EE))**2/YMAX1
5624 IF(YMI.GT.YMIN2) THEN
5625 WRITE(LO,'(/1X,A,2E12.4)')
5626 & 'PHO_GGHIOG: ymin2 changed from/to',YMIN2,YMI
5632 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5634 TABYL(0) = LOG(YMIN)
5636 IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
5637 & 'PHO_GGHIOG: table of raw photon flux (side 1)',Max_tab
5639 Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
5641 XI = WG*HIRADI/GAMMA
5642 FF = ALPHA*PHO_GGFLCL(XI)/Y
5643 FFMAX = MAX(FF,FFMAX)
5644 TABCU(I) = TABCU(I-1)+FF*Y
5647 IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y,FF
5650 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
5651 & 'PHO_GGHIOG: integrated flux (one side):',FLUX
5666 CALL PHO_SETPAR(1,22,0,0.D0)
5667 CALL PHO_SETPAR(2,22,0,0.D0)
5668 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
5669 CALL PHO_PHIST(-1,SIGMAX)
5670 CALL PHO_LHIST(-1,SIGMAX)
5672 C generation of events
5690 XI = DT_RNDM(AY1)*TABCU(Max_tab)
5692 IF(TABCU(K).GE.XI) THEN
5693 Y1 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
5700 XI = DT_RNDM(AY2)*TABCU(Max_tab)
5702 IF(TABCU(K).GE.XI) THEN
5703 Y2 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
5716 C incoming electron 1
5722 C outgoing electron 1
5732 P1(3) = PINI(3,1)-PFIN(3,1)
5733 P1(4) = PINI(4,1)-PFIN(4,1)
5734 C incoming electron 2
5740 C outgoing electron 2
5750 P2(3) = PINI(3,2)-PFIN(3,2)
5751 P2(4) = PINI(4,2)-PFIN(4,2)
5753 GGECM = (P1(4)+P2(4))**2-(P1(3)+P2(3))**2
5754 IF(GGECM.LT.0.1D0) GOTO 175
5756 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
5767 C impact parameter constraints
5768 XI1 = P1(4)*HIRADI/GAMMA
5769 XI2 = P2(4)*HIRADI/GAMMA
5770 FLX = PHO_GGFLCL(XI1)*PHO_GGFLCL(XI2)
5771 FCORR = PHO_GGFLCR(HIRADI)
5772 WGX = (FLX-FCORR)/FLX
5773 IF(DT_RNDM(Y2).GT.WGX) GOTO 175
5778 CALL PHO_PRESEL(5,IREJ)
5779 IF(IREJ.NE.0) GOTO 175
5781 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
5782 IF(IREJ.NE.0) GOTO 150
5789 YY1MIN = MIN(YY1MIN,Y1)
5790 YY2MIN = MIN(YY2MIN,Y2)
5791 YY1MAX = MAX(YY1MAX,Y1)
5792 YY2MAX = MAX(YY2MAX,Y2)
5794 CALL PHO_PHIST(1,HSWGHT(0))
5795 CALL PHO_LHIST(1,HSWGHT(0))
5798 WGY = FLUX**2*DBLE(ITRY)/DBLE(ITRW)
5799 AY1 = AY1/DBLE(NITER)
5800 AYS1 = AYS1/DBLE(NITER)
5801 DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
5802 AY2 = AY2/DBLE(NITER)
5803 AYS2 = AYS2/DBLE(NITER)
5804 DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
5805 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
5806 C output of statistics, histograms
5807 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
5808 &'=========================================================',
5809 &' ***** simulated cross section: ',WEIGHT,' mb *****',
5810 &'========================================================='
5811 WRITE(LO,'(//1X,A,3I12)')
5812 & 'PHO_GGHIOG:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
5813 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
5815 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1 ',
5817 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
5819 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1 ',
5821 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
5825 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
5827 CALL PHO_PHIST(-2,WEIGHT)
5828 CALL PHO_LHIST(-2,WEIGHT)
5830 WRITE(LO,'(1X,A,I4)') 'PHO_GGHIOG:NO OUTPUT OF HISTOGRAMS',NITER
5835 *$ CREATE PHO_GGFLCL.FOR
5837 CDECK ID>, PHO_GGFLCL
5838 DOUBLE PRECISION FUNCTION PHO_GGFLCL(XI)
5839 C*********************************************************************
5841 C semi-classical photon flux (geometrical model)
5843 C*********************************************************************
5844 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5847 PHO_GGFLCL = 2.D0/3.1415927D0*(XI*PHO_BESSK0(XI)*PHO_BESSK1(XI)
5848 & -XI**2/2.D0*(PHO_BESSK1(XI)**2-PHO_BESSK0(XI)**2))
5852 *$ CREATE PHO_GGFLCR.FOR
5854 CDECK ID>, PHO_GGFLCR
5855 DOUBLE PRECISION FUNCTION PHO_GGFLCR(XI)
5856 C*********************************************************************
5858 C semi-classical photon flux correction due to
5859 C overlap in impact parameter space (geometrical model)
5861 C*********************************************************************
5862 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5865 PARAMETER (PI = 3.14159265359D0, ACCUR = 1D-2)
5867 C input/output channels
5869 COMMON /POINOU/ LI,LO
5870 C gamma-lepton or gamma-hadron vertex information
5871 INTEGER IGHEL,IDPSRC,IDBSRC
5872 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
5873 & RADSRC,AMSRC,GAMSRC
5874 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
5875 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
5876 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
5878 DIMENSION XGAUSS(126),WGAUSS(126)
5880 DATA XGAUSS(1)/ .57735026918962576D0/
5881 DATA XGAUSS(2)/-.57735026918962576D0/
5882 DATA WGAUSS(1)/ 1.00000000000000000D0/
5883 DATA WGAUSS(2)/ 1.00000000000000000D0/
5885 DATA XGAUSS(3)/ .33998104358485627D0/
5886 DATA XGAUSS(4)/ .86113631159405258D0/
5887 DATA XGAUSS(5)/-.33998104358485627D0/
5888 DATA XGAUSS(6)/-.86113631159405258D0/
5889 DATA WGAUSS(3)/ .65214515486254613D0/
5890 DATA WGAUSS(4)/ .34785484513745385D0/
5891 DATA WGAUSS(5)/ .65214515486254613D0/
5892 DATA WGAUSS(6)/ .34785484513745385D0/
5894 DATA XGAUSS(7)/ .18343464249564981D0/
5895 DATA XGAUSS(8)/ .52553240991632899D0/
5896 DATA XGAUSS(9)/ .79666647741362674D0/
5897 DATA XGAUSS(10)/ .96028985649753623D0/
5898 DATA XGAUSS(11)/-.18343464249564981D0/
5899 DATA XGAUSS(12)/-.52553240991632899D0/
5900 DATA XGAUSS(13)/-.79666647741362674D0/
5901 DATA XGAUSS(14)/-.96028985649753623D0/
5902 DATA WGAUSS(7)/ .36268378337836198D0/
5903 DATA WGAUSS(8)/ .31370664587788727D0/
5904 DATA WGAUSS(9)/ .22238103445337448D0/
5905 DATA WGAUSS(10)/ .10122853629037627D0/
5906 DATA WGAUSS(11)/ .36268378337836198D0/
5907 DATA WGAUSS(12)/ .31370664587788727D0/
5908 DATA WGAUSS(13)/ .22238103445337448D0/
5909 DATA WGAUSS(14)/ .10122853629037627D0/
5911 DATA XGAUSS(15)/ .0950125098376374402D0/
5912 DATA XGAUSS(16)/ .281603550779258913D0/
5913 DATA XGAUSS(17)/ .458016777657227386D0/
5914 DATA XGAUSS(18)/ .617876244402643748D0/
5915 DATA XGAUSS(19)/ .755404408355003034D0/
5916 DATA XGAUSS(20)/ .865631202387831744D0/
5917 DATA XGAUSS(21)/ .944575023073232576D0/
5918 DATA XGAUSS(22)/ .989400934991649933D0/
5919 DATA XGAUSS(23)/-.0950125098376374402D0/
5920 DATA XGAUSS(24)/-.281603550779258913D0/
5921 DATA XGAUSS(25)/-.458016777657227386D0/
5922 DATA XGAUSS(26)/-.617876244402643748D0/
5923 DATA XGAUSS(27)/-.755404408355003034D0/
5924 DATA XGAUSS(28)/-.865631202387831744D0/
5925 DATA XGAUSS(29)/-.944575023073232576D0/
5926 DATA XGAUSS(30)/-.989400934991649933D0/
5927 DATA WGAUSS(15)/ .189450610455068496D0/
5928 DATA WGAUSS(16)/ .182603415044923589D0/
5929 DATA WGAUSS(17)/ .169156519395002538D0/
5930 DATA WGAUSS(18)/ .149595988816576732D0/
5931 DATA WGAUSS(19)/ .124628971255533872D0/
5932 DATA WGAUSS(20)/ .0951585116824927848D0/
5933 DATA WGAUSS(21)/ .0622535239386478929D0/
5934 DATA WGAUSS(22)/ .0271524594117540949D0/
5935 DATA WGAUSS(23)/ .189450610455068496D0/
5936 DATA WGAUSS(24)/ .182603415044923589D0/
5937 DATA WGAUSS(25)/ .169156519395002538D0/
5938 DATA WGAUSS(26)/ .149595988816576732D0/
5939 DATA WGAUSS(27)/ .124628971255533872D0/
5940 DATA WGAUSS(28)/ .0951585116824927848D0/
5941 DATA WGAUSS(29)/ .0622535239386478929D0/
5942 DATA WGAUSS(30)/ .0271524594117540949D0/
5944 DATA XGAUSS(31)/ .0483076656877383162D0/
5945 DATA XGAUSS(32)/ .144471961582796493D0/
5946 DATA XGAUSS(33)/ .239287362252137075D0/
5947 DATA XGAUSS(34)/ .331868602282127650D0/
5948 DATA XGAUSS(35)/ .421351276130635345D0/
5949 DATA XGAUSS(36)/ .506899908932229390D0/
5950 DATA XGAUSS(37)/ .587715757240762329D0/
5951 DATA XGAUSS(38)/ .663044266930215201D0/
5952 DATA XGAUSS(39)/ .732182118740289680D0/
5953 DATA XGAUSS(40)/ .794483795967942407D0/
5954 DATA XGAUSS(41)/ .849367613732569970D0/
5955 DATA XGAUSS(42)/ .896321155766052124D0/
5956 DATA XGAUSS(43)/ .934906075937739689D0/
5957 DATA XGAUSS(44)/ .964762255587506430D0/
5958 DATA XGAUSS(45)/ .985611511545268335D0/
5959 DATA XGAUSS(46)/ .997263861849481564D0/
5960 DATA XGAUSS(47)/-.0483076656877383162D0/
5961 DATA XGAUSS(48)/-.144471961582796493D0/
5962 DATA XGAUSS(49)/-.239287362252137075D0/
5963 DATA XGAUSS(50)/-.331868602282127650D0/
5964 DATA XGAUSS(51)/-.421351276130635345D0/
5965 DATA XGAUSS(52)/-.506899908932229390D0/
5966 DATA XGAUSS(53)/-.587715757240762329D0/
5967 DATA XGAUSS(54)/-.663044266930215201D0/
5968 DATA XGAUSS(55)/-.732182118740289680D0/
5969 DATA XGAUSS(56)/-.794483795967942407D0/
5970 DATA XGAUSS(57)/-.849367613732569970D0/
5971 DATA XGAUSS(58)/-.896321155766052124D0/
5972 DATA XGAUSS(59)/-.934906075937739689D0/
5973 DATA XGAUSS(60)/-.964762255587506430D0/
5974 DATA XGAUSS(61)/-.985611511545268335D0/
5975 DATA XGAUSS(62)/-.997263861849481564D0/
5976 DATA WGAUSS(31)/ .0965400885147278006D0/
5977 DATA WGAUSS(32)/ .0956387200792748594D0/
5978 DATA WGAUSS(33)/ .0938443990808045654D0/
5979 DATA WGAUSS(34)/ .0911738786957638847D0/
5980 DATA WGAUSS(35)/ .0876520930044038111D0/
5981 DATA WGAUSS(36)/ .0833119242269467552D0/
5982 DATA WGAUSS(37)/ .0781938957870703065D0/
5983 DATA WGAUSS(38)/ .0723457941088485062D0/
5984 DATA WGAUSS(39)/ .0658222227763618468D0/
5985 DATA WGAUSS(40)/ .0586840934785355471D0/
5986 DATA WGAUSS(41)/ .0509980592623761762D0/
5987 DATA WGAUSS(42)/ .0428358980222266807D0/
5988 DATA WGAUSS(43)/ .0342738629130214331D0/
5989 DATA WGAUSS(44)/ .0253920653092620595D0/
5990 DATA WGAUSS(45)/ .0162743947309056706D0/
5991 DATA WGAUSS(46)/ .00701861000947009660D0/
5992 DATA WGAUSS(47)/ .0965400885147278006D0/
5993 DATA WGAUSS(48)/ .0956387200792748594D0/
5994 DATA WGAUSS(49)/ .0938443990808045654D0/
5995 DATA WGAUSS(50)/ .0911738786957638847D0/
5996 DATA WGAUSS(51)/ .0876520930044038111D0/
5997 DATA WGAUSS(52)/ .0833119242269467552D0/
5998 DATA WGAUSS(53)/ .0781938957870703065D0/
5999 DATA WGAUSS(54)/ .0723457941088485062D0/
6000 DATA WGAUSS(55)/ .0658222227763618468D0/
6001 DATA WGAUSS(56)/ .0586840934785355471D0/
6002 DATA WGAUSS(57)/ .0509980592623761762D0/
6003 DATA WGAUSS(58)/ .0428358980222266807D0/
6004 DATA WGAUSS(59)/ .0342738629130214331D0/
6005 DATA WGAUSS(60)/ .0253920653092620595D0/
6006 DATA WGAUSS(61)/ .0162743947309056706D0/
6007 DATA WGAUSS(62)/ .00701861000947009660D0/
6009 DATA XGAUSS(63)/ .02435029266342443250D0/
6010 DATA XGAUSS(64)/ .0729931217877990394D0/
6011 DATA XGAUSS(65)/ .121462819296120554D0/
6012 DATA XGAUSS(66)/ .169644420423992818D0/
6013 DATA XGAUSS(67)/ .217423643740007084D0/
6014 DATA XGAUSS(68)/ .264687162208767416D0/
6015 DATA XGAUSS(69)/ .311322871990210956D0/
6016 DATA XGAUSS(70)/ .357220158337668116D0/
6017 DATA XGAUSS(71)/ .402270157963991604D0/
6018 DATA XGAUSS(72)/ .446366017253464088D0/
6019 DATA XGAUSS(73)/ .489403145707052957D0/
6020 DATA XGAUSS(74)/ .531279464019894546D0/
6021 DATA XGAUSS(75)/ .571895646202634034D0/
6022 DATA XGAUSS(76)/ .611155355172393250D0/
6023 DATA XGAUSS(77)/ .648965471254657340D0/
6024 DATA XGAUSS(78)/ .685236313054233243D0/
6025 DATA XGAUSS(79)/ .719881850171610827D0/
6026 DATA XGAUSS(80)/ .752819907260531897D0/
6027 DATA XGAUSS(81)/ .783972358943341408D0/
6028 DATA XGAUSS(82)/ .813265315122797560D0/
6029 DATA XGAUSS(83)/ .840629296252580363D0/
6030 DATA XGAUSS(84)/ .865999398154092820D0/
6031 DATA XGAUSS(85)/ .889315445995114106D0/
6032 DATA XGAUSS(86)/ .910522137078502806D0/
6033 DATA XGAUSS(87)/ .929569172131939576D0/
6034 DATA XGAUSS(88)/ .946411374858402816D0/
6035 DATA XGAUSS(89)/ .961008799652053719D0/
6036 DATA XGAUSS(90)/ .973326827789910964D0/
6037 DATA XGAUSS(91)/ .983336253884625957D0/
6038 DATA XGAUSS(92)/ .991013371476744321D0/
6039 DATA XGAUSS(93)/ .996340116771955279D0/
6040 DATA XGAUSS(94)/ .999305041735772139D0/
6041 DATA XGAUSS(95)/-.02435029266342443250D0/
6042 DATA XGAUSS(96)/-.0729931217877990394D0/
6043 DATA XGAUSS(97)/-.121462819296120554D0/
6044 DATA XGAUSS(98)/-.169644420423992818D0/
6045 DATA XGAUSS(99)/-.217423643740007084D0/
6046 DATA XGAUSS(100)/-.264687162208767416D0/
6047 DATA XGAUSS(101)/-.311322871990210956D0/
6048 DATA XGAUSS(102)/-.357220158337668116D0/
6049 DATA XGAUSS(103)/-.402270157963991604D0/
6050 DATA XGAUSS(104)/-.446366017253464088D0/
6051 DATA XGAUSS(105)/-.489403145707052957D0/
6052 DATA XGAUSS(106)/-.531279464019894546D0/
6053 DATA XGAUSS(107)/-.571895646202634034D0/
6054 DATA XGAUSS(108)/-.611155355172393250D0/
6055 DATA XGAUSS(109)/-.648965471254657340D0/
6056 DATA XGAUSS(110)/-.685236313054233243D0/
6057 DATA XGAUSS(111)/-.719881850171610827D0/
6058 DATA XGAUSS(112)/-.752819907260531897D0/
6059 DATA XGAUSS(113)/-.783972358943341408D0/
6060 DATA XGAUSS(114)/-.813265315122797560D0/
6061 DATA XGAUSS(115)/-.840629296252580363D0/
6062 DATA XGAUSS(116)/-.865999398154092820D0/
6063 DATA XGAUSS(117)/-.889315445995114106D0/
6064 DATA XGAUSS(118)/-.910522137078502806D0/
6065 DATA XGAUSS(119)/-.929569172131939576D0/
6066 DATA XGAUSS(120)/-.946411374858402816D0/
6067 DATA XGAUSS(121)/-.961008799652053719D0/
6068 DATA XGAUSS(122)/-.973326827789910964D0/
6069 DATA XGAUSS(123)/-.983336253884625957D0/
6070 DATA XGAUSS(124)/-.991013371476744321D0/
6071 DATA XGAUSS(125)/-.996340116771955279D0/
6072 DATA XGAUSS(126)/-.999305041735772139D0/
6073 DATA WGAUSS(63)/ .0486909570091397204D0/
6074 DATA WGAUSS(64)/ .0485754674415034269D0/
6075 DATA WGAUSS(65)/ .0483447622348029572D0/
6076 DATA WGAUSS(66)/ .0479993885964583077D0/
6077 DATA WGAUSS(67)/ .0475401657148303087D0/
6078 DATA WGAUSS(68)/ .0469681828162100173D0/
6079 DATA WGAUSS(69)/ .0462847965813144172D0/
6080 DATA WGAUSS(70)/ .0454916279274181445D0/
6081 DATA WGAUSS(71)/ .0445905581637565631D0/
6082 DATA WGAUSS(72)/ .0435837245293234534D0/
6083 DATA WGAUSS(73)/ .0424735151236535890D0/
6084 DATA WGAUSS(74)/ .0412625632426235286D0/
6085 DATA WGAUSS(75)/ .0399537411327203414D0/
6086 DATA WGAUSS(76)/ .0385501531786156291D0/
6087 DATA WGAUSS(77)/ .0370551285402400460D0/
6088 DATA WGAUSS(78)/ .0354722132568823838D0/
6089 DATA WGAUSS(79)/ .0338051618371416094D0/
6090 DATA WGAUSS(80)/ .0320579283548515535D0/
6091 DATA WGAUSS(81)/ .0302346570724024789D0/
6092 DATA WGAUSS(82)/ .0283396726142594832D0/
6093 DATA WGAUSS(83)/ .0263774697150546587D0/
6094 DATA WGAUSS(84)/ .0243527025687108733D0/
6095 DATA WGAUSS(85)/ .0222701738083832542D0/
6096 DATA WGAUSS(86)/ .0201348231535302094D0/
6097 DATA WGAUSS(87)/ .0179517157756973431D0/
6098 DATA WGAUSS(88)/ .0157260304760247193D0/
6099 DATA WGAUSS(89)/ .0134630478967186426D0/
6100 DATA WGAUSS(90)/ .0111681394601311288D0/
6101 DATA WGAUSS(91)/ .00884675982636394772D0/
6102 DATA WGAUSS(92)/ .00650445796897836286D0/
6103 DATA WGAUSS(93)/ .00414703326056246764D0/
6104 DATA WGAUSS(94)/ .00178328072169643295D0/
6105 DATA WGAUSS(95)/ .0486909570091397204D0/
6106 DATA WGAUSS(96)/ .0485754674415034269D0/
6107 DATA WGAUSS(97)/ .0483447622348029572D0/
6108 DATA WGAUSS(98)/ .0479993885964583077D0/
6109 DATA WGAUSS(99)/ .0475401657148303087D0/
6110 DATA WGAUSS(100)/ .0469681828162100173D0/
6111 DATA WGAUSS(101)/ .0462847965813144172D0/
6112 DATA WGAUSS(102)/ .0454916279274181445D0/
6113 DATA WGAUSS(103)/ .0445905581637565631D0/
6114 DATA WGAUSS(104)/ .0435837245293234534D0/
6115 DATA WGAUSS(105)/ .0424735151236535890D0/
6116 DATA WGAUSS(106)/ .0412625632426235286D0/
6117 DATA WGAUSS(107)/ .0399537411327203414D0/
6118 DATA WGAUSS(108)/ .0385501531786156291D0/
6119 DATA WGAUSS(109)/ .0370551285402400460D0/
6120 DATA WGAUSS(110)/ .0354722132568823838D0/
6121 DATA WGAUSS(111)/ .0338051618371416094D0/
6122 DATA WGAUSS(112)/ .0320579283548515535D0/
6123 DATA WGAUSS(113)/ .0302346570724024789D0/
6124 DATA WGAUSS(114)/ .0283396726142594832D0/
6125 DATA WGAUSS(115)/ .0263774697150546587D0/
6126 DATA WGAUSS(116)/ .0243527025687108733D0/
6127 DATA WGAUSS(117)/ .0222701738083832542D0/
6128 DATA WGAUSS(118)/ .0201348231535302094D0/
6129 DATA WGAUSS(119)/ .0179517157756973431D0/
6130 DATA WGAUSS(120)/ .0157260304760247193D0/
6131 DATA WGAUSS(121)/ .0134630478967186426D0/
6132 DATA WGAUSS(122)/ .0111681394601311288D0/
6133 DATA WGAUSS(123)/ .00884675982636394772D0/
6134 DATA WGAUSS(124)/ .00650445796897836286D0/
6135 DATA WGAUSS(125)/ .00414703326056246764D0/
6136 DATA WGAUSS(126)/ .00178328072169643295D0/
6138 C integrate first over b1
6140 C Loop incrementing the boundary
6149 C Loop for the Gauss integration
6155 DO 200 I=2**N-1,2**(N+1)-2
6156 t = (tmax-tmin)/2.D0*XGAUSS(I)+(tmax+tmin)/2.D0
6157 b1 = RADSRC(1) * EXP (t)
6158 XINT=XINT+WGAUSS(I) * PHO_GGFAUX(b1) * b1**2
6160 XINT = (tmax-tmin)/2.D0*XINT
6161 IF (ABS ((XINT2-XINT)/XINT) .LT. ACCUR) GOTO 300
6163 WRITE(LO,*) ' (b1) GAUSS MAY BE INACCURATE'
6167 IF (ABS (XINT2/Sum) .GT. ACCUR) THEN
6173 PHO_GGFLCR = 4.D0*Pi * Sum
6177 *$ CREATE PHO_GGFAUX.FOR
6179 CDECK ID>, PHO_GGFAUX
6180 DOUBLE PRECISION FUNCTION PHO_GGFAUX(b1)
6181 C*********************************************************************
6183 C auxiliary function for integration over b2,
6184 C semi-classical photon flux correction due to
6185 C overlap in impact parameter space (geometrical model)
6187 C*********************************************************************
6188 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6191 PARAMETER (PI = 3.14159265359D0, ACCUR = 1D-2)
6193 C input/output channels
6195 COMMON /POINOU/ LI,LO
6196 C gamma-lepton or gamma-hadron vertex information
6197 INTEGER IGHEL,IDPSRC,IDBSRC
6198 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
6199 & RADSRC,AMSRC,GAMSRC
6200 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
6201 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
6202 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
6204 DIMENSION XGAUSS(126),WGAUSS(126)
6206 DATA XGAUSS(1)/ .57735026918962576D0/
6207 DATA XGAUSS(2)/-.57735026918962576D0/
6208 DATA WGAUSS(1)/ 1.00000000000000000D0/
6209 DATA WGAUSS(2)/ 1.00000000000000000D0/
6211 DATA XGAUSS(3)/ .33998104358485627D0/
6212 DATA XGAUSS(4)/ .86113631159405258D0/
6213 DATA XGAUSS(5)/-.33998104358485627D0/
6214 DATA XGAUSS(6)/-.86113631159405258D0/
6215 DATA WGAUSS(3)/ .65214515486254613D0/
6216 DATA WGAUSS(4)/ .34785484513745385D0/
6217 DATA WGAUSS(5)/ .65214515486254613D0/
6218 DATA WGAUSS(6)/ .34785484513745385D0/
6220 DATA XGAUSS(7)/ .18343464249564981D0/
6221 DATA XGAUSS(8)/ .52553240991632899D0/
6222 DATA XGAUSS(9)/ .79666647741362674D0/
6223 DATA XGAUSS(10)/ .96028985649753623D0/
6224 DATA XGAUSS(11)/-.18343464249564981D0/
6225 DATA XGAUSS(12)/-.52553240991632899D0/
6226 DATA XGAUSS(13)/-.79666647741362674D0/
6227 DATA XGAUSS(14)/-.96028985649753623D0/
6228 DATA WGAUSS(7)/ .36268378337836198D0/
6229 DATA WGAUSS(8)/ .31370664587788727D0/
6230 DATA WGAUSS(9)/ .22238103445337448D0/
6231 DATA WGAUSS(10)/ .10122853629037627D0/
6232 DATA WGAUSS(11)/ .36268378337836198D0/
6233 DATA WGAUSS(12)/ .31370664587788727D0/
6234 DATA WGAUSS(13)/ .22238103445337448D0/
6235 DATA WGAUSS(14)/ .10122853629037627D0/
6237 DATA XGAUSS(15)/ .0950125098376374402D0/
6238 DATA XGAUSS(16)/ .281603550779258913D0/
6239 DATA XGAUSS(17)/ .458016777657227386D0/
6240 DATA XGAUSS(18)/ .617876244402643748D0/
6241 DATA XGAUSS(19)/ .755404408355003034D0/
6242 DATA XGAUSS(20)/ .865631202387831744D0/
6243 DATA XGAUSS(21)/ .944575023073232576D0/
6244 DATA XGAUSS(22)/ .989400934991649933D0/
6245 DATA XGAUSS(23)/-.0950125098376374402D0/
6246 DATA XGAUSS(24)/-.281603550779258913D0/
6247 DATA XGAUSS(25)/-.458016777657227386D0/
6248 DATA XGAUSS(26)/-.617876244402643748D0/
6249 DATA XGAUSS(27)/-.755404408355003034D0/
6250 DATA XGAUSS(28)/-.865631202387831744D0/
6251 DATA XGAUSS(29)/-.944575023073232576D0/
6252 DATA XGAUSS(30)/-.989400934991649933D0/
6253 DATA WGAUSS(15)/ .189450610455068496D0/
6254 DATA WGAUSS(16)/ .182603415044923589D0/
6255 DATA WGAUSS(17)/ .169156519395002538D0/
6256 DATA WGAUSS(18)/ .149595988816576732D0/
6257 DATA WGAUSS(19)/ .124628971255533872D0/
6258 DATA WGAUSS(20)/ .0951585116824927848D0/
6259 DATA WGAUSS(21)/ .0622535239386478929D0/
6260 DATA WGAUSS(22)/ .0271524594117540949D0/
6261 DATA WGAUSS(23)/ .189450610455068496D0/
6262 DATA WGAUSS(24)/ .182603415044923589D0/
6263 DATA WGAUSS(25)/ .169156519395002538D0/
6264 DATA WGAUSS(26)/ .149595988816576732D0/
6265 DATA WGAUSS(27)/ .124628971255533872D0/
6266 DATA WGAUSS(28)/ .0951585116824927848D0/
6267 DATA WGAUSS(29)/ .0622535239386478929D0/
6268 DATA WGAUSS(30)/ .0271524594117540949D0/
6270 DATA XGAUSS(31)/ .0483076656877383162D0/
6271 DATA XGAUSS(32)/ .144471961582796493D0/
6272 DATA XGAUSS(33)/ .239287362252137075D0/
6273 DATA XGAUSS(34)/ .331868602282127650D0/
6274 DATA XGAUSS(35)/ .421351276130635345D0/
6275 DATA XGAUSS(36)/ .506899908932229390D0/
6276 DATA XGAUSS(37)/ .587715757240762329D0/
6277 DATA XGAUSS(38)/ .663044266930215201D0/
6278 DATA XGAUSS(39)/ .732182118740289680D0/
6279 DATA XGAUSS(40)/ .794483795967942407D0/
6280 DATA XGAUSS(41)/ .849367613732569970D0/
6281 DATA XGAUSS(42)/ .896321155766052124D0/
6282 DATA XGAUSS(43)/ .934906075937739689D0/
6283 DATA XGAUSS(44)/ .964762255587506430D0/
6284 DATA XGAUSS(45)/ .985611511545268335D0/
6285 DATA XGAUSS(46)/ .997263861849481564D0/
6286 DATA XGAUSS(47)/-.0483076656877383162D0/
6287 DATA XGAUSS(48)/-.144471961582796493D0/
6288 DATA XGAUSS(49)/-.239287362252137075D0/
6289 DATA XGAUSS(50)/-.331868602282127650D0/
6290 DATA XGAUSS(51)/-.421351276130635345D0/
6291 DATA XGAUSS(52)/-.506899908932229390D0/
6292 DATA XGAUSS(53)/-.587715757240762329D0/
6293 DATA XGAUSS(54)/-.663044266930215201D0/
6294 DATA XGAUSS(55)/-.732182118740289680D0/
6295 DATA XGAUSS(56)/-.794483795967942407D0/
6296 DATA XGAUSS(57)/-.849367613732569970D0/
6297 DATA XGAUSS(58)/-.896321155766052124D0/
6298 DATA XGAUSS(59)/-.934906075937739689D0/
6299 DATA XGAUSS(60)/-.964762255587506430D0/
6300 DATA XGAUSS(61)/-.985611511545268335D0/
6301 DATA XGAUSS(62)/-.997263861849481564D0/
6302 DATA WGAUSS(31)/ .0965400885147278006D0/
6303 DATA WGAUSS(32)/ .0956387200792748594D0/
6304 DATA WGAUSS(33)/ .0938443990808045654D0/
6305 DATA WGAUSS(34)/ .0911738786957638847D0/
6306 DATA WGAUSS(35)/ .0876520930044038111D0/
6307 DATA WGAUSS(36)/ .0833119242269467552D0/
6308 DATA WGAUSS(37)/ .0781938957870703065D0/
6309 DATA WGAUSS(38)/ .0723457941088485062D0/
6310 DATA WGAUSS(39)/ .0658222227763618468D0/
6311 DATA WGAUSS(40)/ .0586840934785355471D0/
6312 DATA WGAUSS(41)/ .0509980592623761762D0/
6313 DATA WGAUSS(42)/ .0428358980222266807D0/
6314 DATA WGAUSS(43)/ .0342738629130214331D0/
6315 DATA WGAUSS(44)/ .0253920653092620595D0/
6316 DATA WGAUSS(45)/ .0162743947309056706D0/
6317 DATA WGAUSS(46)/ .00701861000947009660D0/
6318 DATA WGAUSS(47)/ .0965400885147278006D0/
6319 DATA WGAUSS(48)/ .0956387200792748594D0/
6320 DATA WGAUSS(49)/ .0938443990808045654D0/
6321 DATA WGAUSS(50)/ .0911738786957638847D0/
6322 DATA WGAUSS(51)/ .0876520930044038111D0/
6323 DATA WGAUSS(52)/ .0833119242269467552D0/
6324 DATA WGAUSS(53)/ .0781938957870703065D0/
6325 DATA WGAUSS(54)/ .0723457941088485062D0/
6326 DATA WGAUSS(55)/ .0658222227763618468D0/
6327 DATA WGAUSS(56)/ .0586840934785355471D0/
6328 DATA WGAUSS(57)/ .0509980592623761762D0/
6329 DATA WGAUSS(58)/ .0428358980222266807D0/
6330 DATA WGAUSS(59)/ .0342738629130214331D0/
6331 DATA WGAUSS(60)/ .0253920653092620595D0/
6332 DATA WGAUSS(61)/ .0162743947309056706D0/
6333 DATA WGAUSS(62)/ .00701861000947009660D0/
6335 DATA XGAUSS(63)/ .02435029266342443250D0/
6336 DATA XGAUSS(64)/ .0729931217877990394D0/
6337 DATA XGAUSS(65)/ .121462819296120554D0/
6338 DATA XGAUSS(66)/ .169644420423992818D0/
6339 DATA XGAUSS(67)/ .217423643740007084D0/
6340 DATA XGAUSS(68)/ .264687162208767416D0/
6341 DATA XGAUSS(69)/ .311322871990210956D0/
6342 DATA XGAUSS(70)/ .357220158337668116D0/
6343 DATA XGAUSS(71)/ .402270157963991604D0/
6344 DATA XGAUSS(72)/ .446366017253464088D0/
6345 DATA XGAUSS(73)/ .489403145707052957D0/
6346 DATA XGAUSS(74)/ .531279464019894546D0/
6347 DATA XGAUSS(75)/ .571895646202634034D0/
6348 DATA XGAUSS(76)/ .611155355172393250D0/
6349 DATA XGAUSS(77)/ .648965471254657340D0/
6350 DATA XGAUSS(78)/ .685236313054233243D0/
6351 DATA XGAUSS(79)/ .719881850171610827D0/
6352 DATA XGAUSS(80)/ .752819907260531897D0/
6353 DATA XGAUSS(81)/ .783972358943341408D0/
6354 DATA XGAUSS(82)/ .813265315122797560D0/
6355 DATA XGAUSS(83)/ .840629296252580363D0/
6356 DATA XGAUSS(84)/ .865999398154092820D0/
6357 DATA XGAUSS(85)/ .889315445995114106D0/
6358 DATA XGAUSS(86)/ .910522137078502806D0/
6359 DATA XGAUSS(87)/ .929569172131939576D0/
6360 DATA XGAUSS(88)/ .946411374858402816D0/
6361 DATA XGAUSS(89)/ .961008799652053719D0/
6362 DATA XGAUSS(90)/ .973326827789910964D0/
6363 DATA XGAUSS(91)/ .983336253884625957D0/
6364 DATA XGAUSS(92)/ .991013371476744321D0/
6365 DATA XGAUSS(93)/ .996340116771955279D0/
6366 DATA XGAUSS(94)/ .999305041735772139D0/
6367 DATA XGAUSS(95)/-.02435029266342443250D0/
6368 DATA XGAUSS(96)/-.0729931217877990394D0/
6369 DATA XGAUSS(97)/-.121462819296120554D0/
6370 DATA XGAUSS(98)/-.169644420423992818D0/
6371 DATA XGAUSS(99)/-.217423643740007084D0/
6372 DATA XGAUSS(100)/-.264687162208767416D0/
6373 DATA XGAUSS(101)/-.311322871990210956D0/
6374 DATA XGAUSS(102)/-.357220158337668116D0/
6375 DATA XGAUSS(103)/-.402270157963991604D0/
6376 DATA XGAUSS(104)/-.446366017253464088D0/
6377 DATA XGAUSS(105)/-.489403145707052957D0/
6378 DATA XGAUSS(106)/-.531279464019894546D0/
6379 DATA XGAUSS(107)/-.571895646202634034D0/
6380 DATA XGAUSS(108)/-.611155355172393250D0/
6381 DATA XGAUSS(109)/-.648965471254657340D0/
6382 DATA XGAUSS(110)/-.685236313054233243D0/
6383 DATA XGAUSS(111)/-.719881850171610827D0/
6384 DATA XGAUSS(112)/-.752819907260531897D0/
6385 DATA XGAUSS(113)/-.783972358943341408D0/
6386 DATA XGAUSS(114)/-.813265315122797560D0/
6387 DATA XGAUSS(115)/-.840629296252580363D0/
6388 DATA XGAUSS(116)/-.865999398154092820D0/
6389 DATA XGAUSS(117)/-.889315445995114106D0/
6390 DATA XGAUSS(118)/-.910522137078502806D0/
6391 DATA XGAUSS(119)/-.929569172131939576D0/
6392 DATA XGAUSS(120)/-.946411374858402816D0/
6393 DATA XGAUSS(121)/-.961008799652053719D0/
6394 DATA XGAUSS(122)/-.973326827789910964D0/
6395 DATA XGAUSS(123)/-.983336253884625957D0/
6396 DATA XGAUSS(124)/-.991013371476744321D0/
6397 DATA XGAUSS(125)/-.996340116771955279D0/
6398 DATA XGAUSS(126)/-.999305041735772139D0/
6399 DATA WGAUSS(63)/ .0486909570091397204D0/
6400 DATA WGAUSS(64)/ .0485754674415034269D0/
6401 DATA WGAUSS(65)/ .0483447622348029572D0/
6402 DATA WGAUSS(66)/ .0479993885964583077D0/
6403 DATA WGAUSS(67)/ .0475401657148303087D0/
6404 DATA WGAUSS(68)/ .0469681828162100173D0/
6405 DATA WGAUSS(69)/ .0462847965813144172D0/
6406 DATA WGAUSS(70)/ .0454916279274181445D0/
6407 DATA WGAUSS(71)/ .0445905581637565631D0/
6408 DATA WGAUSS(72)/ .0435837245293234534D0/
6409 DATA WGAUSS(73)/ .0424735151236535890D0/
6410 DATA WGAUSS(74)/ .0412625632426235286D0/
6411 DATA WGAUSS(75)/ .0399537411327203414D0/
6412 DATA WGAUSS(76)/ .0385501531786156291D0/
6413 DATA WGAUSS(77)/ .0370551285402400460D0/
6414 DATA WGAUSS(78)/ .0354722132568823838D0/
6415 DATA WGAUSS(79)/ .0338051618371416094D0/
6416 DATA WGAUSS(80)/ .0320579283548515535D0/
6417 DATA WGAUSS(81)/ .0302346570724024789D0/
6418 DATA WGAUSS(82)/ .0283396726142594832D0/
6419 DATA WGAUSS(83)/ .0263774697150546587D0/
6420 DATA WGAUSS(84)/ .0243527025687108733D0/
6421 DATA WGAUSS(85)/ .0222701738083832542D0/
6422 DATA WGAUSS(86)/ .0201348231535302094D0/
6423 DATA WGAUSS(87)/ .0179517157756973431D0/
6424 DATA WGAUSS(88)/ .0157260304760247193D0/
6425 DATA WGAUSS(89)/ .0134630478967186426D0/
6426 DATA WGAUSS(90)/ .0111681394601311288D0/
6427 DATA WGAUSS(91)/ .00884675982636394772D0/
6428 DATA WGAUSS(92)/ .00650445796897836286D0/
6429 DATA WGAUSS(93)/ .00414703326056246764D0/
6430 DATA WGAUSS(94)/ .00178328072169643295D0/
6431 DATA WGAUSS(95)/ .0486909570091397204D0/
6432 DATA WGAUSS(96)/ .0485754674415034269D0/
6433 DATA WGAUSS(97)/ .0483447622348029572D0/
6434 DATA WGAUSS(98)/ .0479993885964583077D0/
6435 DATA WGAUSS(99)/ .0475401657148303087D0/
6436 DATA WGAUSS(100)/ .0469681828162100173D0/
6437 DATA WGAUSS(101)/ .0462847965813144172D0/
6438 DATA WGAUSS(102)/ .0454916279274181445D0/
6439 DATA WGAUSS(103)/ .0445905581637565631D0/
6440 DATA WGAUSS(104)/ .0435837245293234534D0/
6441 DATA WGAUSS(105)/ .0424735151236535890D0/
6442 DATA WGAUSS(106)/ .0412625632426235286D0/
6443 DATA WGAUSS(107)/ .0399537411327203414D0/
6444 DATA WGAUSS(108)/ .0385501531786156291D0/
6445 DATA WGAUSS(109)/ .0370551285402400460D0/
6446 DATA WGAUSS(110)/ .0354722132568823838D0/
6447 DATA WGAUSS(111)/ .0338051618371416094D0/
6448 DATA WGAUSS(112)/ .0320579283548515535D0/
6449 DATA WGAUSS(113)/ .0302346570724024789D0/
6450 DATA WGAUSS(114)/ .0283396726142594832D0/
6451 DATA WGAUSS(115)/ .0263774697150546587D0/
6452 DATA WGAUSS(116)/ .0243527025687108733D0/
6453 DATA WGAUSS(117)/ .0222701738083832542D0/
6454 DATA WGAUSS(118)/ .0201348231535302094D0/
6455 DATA WGAUSS(119)/ .0179517157756973431D0/
6456 DATA WGAUSS(120)/ .0157260304760247193D0/
6457 DATA WGAUSS(121)/ .0134630478967186426D0/
6458 DATA WGAUSS(122)/ .0111681394601311288D0/
6459 DATA WGAUSS(123)/ .00884675982636394772D0/
6460 DATA WGAUSS(124)/ .00650445796897836286D0/
6461 DATA WGAUSS(125)/ .00414703326056246764D0/
6462 DATA WGAUSS(126)/ .00178328072169643295D0/
6466 bmin = b1 - 2.D0*RADSRC(1)
6467 IF (RADSRC(1) .GT. bmin) THEN
6470 bmax = b1 + 2.D0 * RADSRC(1)
6476 DO 200 I=2**N-1,2**(N+1)-2
6477 b2 = (bmax-bmin)/2.D0*XGAUSS(I)+(bmax+bmin)/2.D0
6478 XINT3 = PHO_GGFNUC(W1,b1,GAMSRC(1))
6479 & * PHO_GGFNUC(W2,b2,GAMSRC(2))
6480 & * ACOS ((b1**2+b2**2-4.D0*RADSRC(1)**2)/(2.D0*b1*b2))
6481 XINT = XINT +WGAUSS(I) * b2 * XINT3
6483 XINT = (bmax-bmin)/2.D0*XINT
6484 IF (ABS((XINT2 - XINT)/XINT) .LT. ACCUR) GOTO 300
6486 WRITE(LO,*) ' (b2) GAUSS MAY BE INACCURATE'
6493 *$ CREATE PHO_GGFNUC.FOR
6495 CDECK ID>, PHO_GGFNUC
6496 DOUBLE PRECISION FUNCTION PHO_GGFNUC(W,Rho,Gamma)
6497 C**********************************************************************
6499 C differential photonnumber for a nucleus (geometrical model)
6500 C (without form factor)
6502 C*********************************************************************
6503 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6506 PARAMETER (PI = 3.14159265359D0)
6509 Wphib = WGamma * PHO_BESSK1(WGamma*Rho)
6511 PHO_GGFNUC = 1.D0/PI**2 * Wphib**2
6515 *$ CREATE PHO_GHHIOF.FOR
6517 CDECK ID>, PHO_GHHIOF
6518 SUBROUTINE PHO_GHHIOF(NEVENT,EEN,NA,NZ)
6519 C**********************************************************************
6521 C interface to call PHOJET (variable energy run) for
6522 C gamma-hadron collisions in heavy ion collisions
6523 C (form factor approach)
6525 C input: EEN LAB system energy per nucleon
6526 C NA atomic number of ion/hadron
6527 C NZ charge number of ion/hadron
6528 C NEVENT number of events to generate
6530 C YMIN1,2 lower limit of Y
6531 C (energy fraction taken by photon from hadron)
6532 C YMAX1,2 upper cutoff for Y, necessary to avoid
6534 C Q2MIN1,2 minimum Q**2 of photons (should be set to 0)
6535 C Q2MAX1,2 maximum Q**2 of photons (if necessary,
6536 C corrected according size of hadron)
6538 C**********************************************************************
6539 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6542 PARAMETER ( PI = 3.14159265359D0 )
6544 C input/output channels
6546 COMMON /POINOU/ LI,LO
6547 C model switches and parameters
6549 INTEGER ISWMDL,IPAMDL
6550 DOUBLE PRECISION PARMDL
6551 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
6552 C event debugging information
6554 PARAMETER (NMAXD=100)
6555 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
6556 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
6557 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
6558 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
6559 C photon flux kinematics and cuts
6560 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
6561 & YMIN1,YMAX1,YMIN2,YMAX2,
6562 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
6563 & THMIN1,THMAX1,THMIN2,THMAX2
6565 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
6566 & YMIN1,YMAX1,YMIN2,YMAX2,
6567 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
6568 & THMIN1,THMAX1,THMIN2,THMAX2,
6570 C gamma-lepton or gamma-hadron vertex information
6571 INTEGER IGHEL,IDPSRC,IDBSRC
6572 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
6573 & RADSRC,AMSRC,GAMSRC
6574 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
6575 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
6576 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
6577 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
6578 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
6579 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
6580 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
6581 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
6583 C standard particle data interface
6586 PARAMETER (NMXHEP=4000)
6588 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
6589 DOUBLE PRECISION PHEP,VHEP
6590 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
6591 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
6593 C extension to standard particle data interface (PHOJET specific)
6594 INTEGER IMPART,IPHIST,ICOLOR
6595 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
6597 C event weights and generated cross section
6598 INTEGER IPOWGC,ISWCUT,IVWGHT
6599 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
6600 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
6601 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
6603 DIMENSION P1(4),P2(4)
6604 DIMENSION NITERS(2),ITRW(2)
6606 WRITE(LO,'(2(/1X,A))')
6607 & 'PHO_GHHIOF: gamma-hadron event generation',
6608 & '-----------------------------------------'
6609 C hadron size and mass
6611 HIMASS = DBLE(NA)*0.938D0
6613 HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
6614 ALPHA = DBLE(NZ**2)/137.D0
6617 C correct Q2MAX1,2 according to hadron size
6618 Q2MAXH = 2.D0/HIRADI**2
6619 Q2MAX1 = MIN(Q2MAX1,Q2MAXH)
6620 Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
6621 IF(Q2MAX1.LT.1.D-20) Q2MAX1 = Q2MAXH
6622 IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
6623 C total hadron / heavy ion energy
6633 C check cuts on photon-hadron mass
6634 IF((0.765D0+PARMDL(46)).GT.(PARMDL(45)*ECMIN)) THEN
6636 ECMIN = PARMDL(46)/PARMDL(45)+0.1D0
6637 WRITE(LO,'(/1X,A,2E12.5)')
6638 & 'PHO_GHHIOF: ecmin corrected to (old/new)',YMI,ECMIN
6640 C check kinematic limitations
6641 YMI = ECMIN**2/(4.D0*EE*EEN)
6642 IF(YMIN1.LT.YMI) THEN
6643 WRITE(LO,'(/1X,A,2E12.5)')
6644 & 'PHO_GHHIOF: ymin1 increased to (old/new)',YMIN1,YMI
6646 ELSE IF(YMIN1.GT.YMI) THEN
6647 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
6648 & 'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
6649 & ' INSTEAD OF',YMIN1
6651 IF(YMIN2.LT.YMI) THEN
6652 WRITE(LO,'(/1X,A,2E12.5)')
6653 & 'PHO_GHHIOF: ymin2 increased to (old/new)',YMIN2,YMI
6655 ELSE IF(YMIN2.GT.YMI) THEN
6656 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
6657 & 'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
6658 & ' INSTEAD OF',YMIN2
6660 C kinematic limitation
6661 Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
6662 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
6664 WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
6665 WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV) ',HIMASS
6666 WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1) ',HIRADI
6667 WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 1 (GEV**2)',Q2LOW1,
6669 WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
6671 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1 ',YMIN1,
6673 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
6675 WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
6677 WRITE(LO,'(6X,A,2E12.5)') 'INV.MASS PHOTON-HADRON ',ECMIN,
6679 WRITE(LO,'(6X,A,E12.5)') 'MIN. INV.MASS PHOTON-POMERON',
6681 WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
6682 IF(Q2LOW1.GE.Q2MAX1) THEN
6683 WRITE(LO,'(/1X,A,2E12.4)')
6684 & 'PHO_GHHIOF:ERROR:INCONSISTENT Q**2 RANGE 1',Q2LOW1,Q2MAX1
6687 IF(Q2LOW2.GE.Q2MAX2) THEN
6688 WRITE(LO,'(/1X,A,2E12.4)')
6689 & 'PHO_GHHIOF:ERROR:INCONSISTENT Q**2 RANGE 2',Q2LOW2,Q2MAX2
6692 C hadron numbers set to 0
6704 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
6706 Y1 = EXP(XMIN+DELLY*DBLE(I-1))
6707 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
6708 IF(Q2LOW1.GE.Q2MAX1) THEN
6709 WRITE(LO,'(/1X,A,2E12.4)')
6710 & 'PHO_GHHIOF: ymax1 changed from/to',YMAX1,Y1
6711 YMAX1 = MIN(Y1,YMAX1)
6721 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
6723 Y1 = EXP(XMIN+DELLY*DBLE(I-1))
6724 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
6725 IF(Q2LOW2.GE.Q2MAX2) THEN
6726 WRITE(LO,'(/1X,A,2E12.4)')
6727 & 'PHO_GHHIOF: ymax2 changed from/to',YMAX2,Y1
6728 YMAX2 = MIN(Y1,YMAX2)
6740 DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
6742 IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
6743 & 'PHO_GHHIOF: table of raw photon flux (side 1)',Max_tab
6745 Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
6746 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
6747 FF = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
6748 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))*ALPHA/(2.D0*PI)
6750 IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y1,FF
6753 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
6754 & 'PHO_GHHIOF: integrated flux (one side):',FLUX
6757 EGAM = MAX(YMAX1,YMAX2)*EE
6765 P2(3) = -SQRT(EEN**2-AMP2)
6767 CALL PHO_SETPAR(1,22,0,0.D0)
6768 CALL PHO_SETPAR(2,2212,0,0.D0)
6769 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
6771 Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
6772 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
6775 WGMAX1 = (1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
6776 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1
6777 WGMAX2 = (1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
6778 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
6780 IF(IPAMDL(175).EQ.1) WGMAX2 = 0.D0
6781 IF(IPAMDL(175).EQ.2) WGMAX1 = 0.D0
6783 FAC12 = WGMAX1*LOG(YMAX1/YMIN1)
6784 & /(WGMAX1*LOG(YMAX1/YMIN1)+WGMAX2*LOG(YMAX2/YMIN2))
6786 CALL PHO_PHIST(-1,SIGMAX)
6787 CALL PHO_LHIST(-1,SIGMAX)
6789 C generation of events, flux calculation
6819 C select side of photon emission
6820 IF(DT_RNDM(AY1).LT.FAC12) THEN
6823 Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
6824 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1**2/(1.D0-Y1))
6825 IF(Q2LOW1.GE.Q2MAX1) GOTO 175
6826 Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
6827 WGH = (1.D0+(1.D0-Y1)**2)*Q2LOG1
6828 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1
6829 IF(WGMAX1.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
6830 & 'PHO_GHHIOF:WEIGHT ERROR (1):',Y1,WGMAX1,WGH
6831 IF(DT_RNDM(AYS1)*WGMAX1.GT.WGH) GOTO 175
6833 IF(IPAMDL(174).EQ.1) THEN
6834 YEFF = 1.D0+(1.D0-Y1)**2
6836 Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
6837 WEIGHT = (YEFF-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF
6838 IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
6843 GAIMP(1) = 1.D0/SQRT(Q2P1)
6844 C form factor (squared)
6846 IF(GAIMP(1).LT.2.D0*HIRADI) FF2 = 0.D0
6847 IF(DT_RNDM(Q2P1).GE.FF2) GOTO 175
6856 PINI(3,1) = SQRT(EE**2-AMP2)
6860 YQ2 = SQRT((1.D0-Y1)*Q2P1)
6861 Q2E = Q2P1/(4.D0*EE)
6863 CALL PHO_SFECFE(SIF,COF)
6869 PFPHI(1) = ATAN2(COF,SIF)
6870 PFTHE(1) = ACOS((E1Y-Q2E)/(Q2E+E1Y))
6874 PINI(3,2) = -SQRT(EE**2-AMP2)
6880 P1(3) = PINI(3,1)-PFIN(3,1)
6881 P1(4) = PINI(4,1)-PFIN(4,1)
6885 P2(3) = -SQRT(EEN**2-AMP2)
6893 Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
6894 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
6895 IF(Q2LOW2.GE.Q2MAX2) GOTO 175
6896 Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
6897 WGH = (1.D0+(1.D0-Y2)**2)*Q2LOG2
6898 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
6899 IF(WGMAX2.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
6900 & 'PHO_GHHIOF:WEIGHT ERROR (2):',Y2,WGMAX2,WGH
6901 IF(DT_RNDM(AYS1)*WGMAX2.GT.WGH) GOTO 175
6903 IF(IPAMDL(174).EQ.1) THEN
6904 YEFF = 1.D0+(1.D0-Y2)**2
6906 Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
6907 WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
6908 IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
6913 GAIMP(2) = 1.D0/SQRT(Q2P2)
6914 C form factor (squared)
6916 IF(GAIMP(2).LT.2.D0*HIRADI) FF2 = 0.D0
6917 IF(DT_RNDM(Q2P2).GE.FF2) GOTO 175
6926 PINI(3,1) = SQRT(EE**2-AMP2)
6932 PINI(3,2) = -SQRT(EE**2-AMP2)
6936 YQ2 = SQRT((1.D0-Y2)*Q2P2)
6937 Q2E = Q2P2/(4.D0*EE)
6939 CALL PHO_SFECFE(SIF,COF)
6942 PFIN(3,2) = -E1Y+Q2E
6945 PFPHI(2) = ATAN2(COF,SIF)
6946 PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
6950 P2(3) = SQRT(EEN**2-AMP2)
6955 P1(3) = PINI(3,2)-PFIN(3,2)
6956 P1(4) = PINI(4,2)-PFIN(4,2)
6960 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
6961 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
6962 IF(GGECM.LT.0.1D0) GOTO 175
6964 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
6970 PGAM(5,1) = -SQRT(Q2P1)
6975 PGAM(5,2) = -SQRT(Q2P2)
6976 CALL PHO_PRESEL(5,IREJ)
6981 IF(IREJ.NE.0) GOTO 175
6983 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
6984 IF(IREJ.NE.0) GOTO 150
6985 C cut on diffractive mass
6987 IF(ISTHEP(K).EQ.30) THEN
6989 IF(GHDIFF.GE.PARMDL(175)) THEN
6996 WRITE(LO,'(/,1X,A)')
6997 & 'PHO_GHHIOF: no diffractive entry found'
7001 C remove quasi-elastically scattered hadron
7003 IF((ISTHEP(K).EQ.1).AND.(IDHEP(K).EQ.2212)) THEN
7004 XF = ABS(PHEP(3,K)/EEN)
7005 IF(XF.LT.PARMDL(72)) GOTO 150
7014 NITERS(ISIDE) = NITERS(ISIDE)+1
7019 Q21AVE = Q21AVE+Q2P1
7020 Q21AV2 = Q21AV2+Q2P1*Q2P1
7021 Q21MIN = MIN(Q21MIN,Q2P1)
7022 Q21MAX = MAX(Q21MAX,Q2P1)
7023 YY1MIN = MIN(YY1MIN,Y1)
7024 YY1MAX = MAX(YY1MAX,Y1)
7029 Q22AVE = Q22AVE+Q2P2
7030 Q22AV2 = Q22AV2+Q2P2*Q2P2
7031 Q22MIN = MIN(Q22MIN,Q2P2)
7032 Q22MAX = MAX(Q22MAX,Q2P2)
7033 YY2MIN = MIN(YY2MIN,Y2)
7034 YY2MAX = MAX(YY2MAX,Y2)
7037 CALL PHO_PHIST(1,HSWGHT(0))
7038 CALL PHO_LHIST(1,HSWGHT(0))
7041 WGMAX = WGMAX1*LOG(YMAX1/YMIN1)*FAC12
7042 WGY1 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW(1),1))*ALPHA/(2.D0*PI)
7043 WGMAX = WGMAX2*LOG(YMAX2/YMIN2)*(1.D0-FAC12)
7044 WGY2 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW(2),1))*ALPHA/(2.D0*PI)
7045 AY1 = AY1/DBLE(MAX(NITERS(1),1))
7046 AYS1 = AYS1/DBLE(MAX(NITERS(1),1))
7047 DAY1 = SQRT((AYS1-AY1**2)/DBLE(MAX(NITERS(1),1)))
7048 AY2 = AY2/DBLE(MAX(NITERS(2),1))
7049 AYS2 = AYS2/DBLE(MAX(NITERS(2),1))
7050 DAY2 = SQRT((AYS2-AY2**2)/DBLE(MAX(NITERS(2),1)))
7051 Q21AVE = Q21AVE/DBLE(MAX(NITERS(1),1))
7052 Q21AV2 = Q21AV2/DBLE(MAX(NITERS(1),1))
7053 Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(MAX(NITERS(1),1)))
7054 Q22AVE = Q22AVE/DBLE(MAX(NITERS(2),1))
7055 Q22AV2 = Q22AV2/DBLE(MAX(NITERS(2),1))
7056 Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(MAX(NITERS(2),1)))
7057 WGMAX = WGMAX1*LOG(YMAX1/YMIN1)+WGMAX2*LOG(YMAX2/YMIN2)
7058 WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW(1)+ITRW(2))*ALPHA/(2.D0*PI)
7059 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
7060 C output of statistics, histograms
7061 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
7062 &'=========================================================',
7063 &' ***** simulated cross section: ',WEIGHT,' mb *****',
7064 &'========================================================='
7065 WRITE(LO,'(//1X,A,/3X,6I12)')
7066 & 'PHO_GHHIOF:SUMMARY: NITER, NITERS1/2, ITRY, ITRW1,2',
7067 & NITER,NITERS,ITRY,ITRW
7068 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
7070 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1 ',
7072 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
7074 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1 ',
7076 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
7078 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 1 ',
7080 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 1 ',
7082 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 2 ',
7084 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2 ',
7087 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
7089 CALL PHO_PHIST(-2,WEIGHT)
7090 CALL PHO_LHIST(-2,WEIGHT)
7092 WRITE(LO,'(1X,A,I4)') 'PHO_GHHIOF:NO OUTPUT OF HISTOGRAMS',NITER
7097 *$ CREATE PHO_GHHIAS.FOR
7099 CDECK ID>, PHO_GHHIAS
7100 SUBROUTINE PHO_GHHIAS(NEVENT,EEP,EEN,NA,NZ)
7101 C**********************************************************************
7103 C interface to call PHOJET (variable energy run) for
7104 C gamma-hadron collisions in heavy ion - hadron
7105 C collisions (form factor approach)
7107 C input: EEP LAB system energy of proton (GeV)
7108 C EEN LAB system energy per nucleon (GeV)
7109 C NA atomic number of ion/hadron
7110 C NZ charge number of ion/hadron
7111 C NEVENT number of events to generate
7113 C YMIN2 lower limit of Y
7114 C (energy fraction taken by photon from hadron)
7115 C YMAX2 upper cutoff for Y, necessary to avoid
7117 C Q2MIN2 minimum Q**2 of photons (should be set to 0)
7118 C Q2MAX2 maximum Q**2 of photons (if necessary,
7119 C corrected according size of hadron)
7121 C**********************************************************************
7122 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7125 PARAMETER ( PI = 3.14159265359D0 )
7127 C input/output channels
7129 COMMON /POINOU/ LI,LO
7130 C model switches and parameters
7132 INTEGER ISWMDL,IPAMDL
7133 DOUBLE PRECISION PARMDL
7134 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
7135 C event debugging information
7137 PARAMETER (NMAXD=100)
7138 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
7139 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7140 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
7141 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7142 C photon flux kinematics and cuts
7143 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
7144 & YMIN1,YMAX1,YMIN2,YMAX2,
7145 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
7146 & THMIN1,THMAX1,THMIN2,THMAX2
7148 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
7149 & YMIN1,YMAX1,YMIN2,YMAX2,
7150 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
7151 & THMIN1,THMAX1,THMIN2,THMAX2,
7153 C gamma-lepton or gamma-hadron vertex information
7154 INTEGER IGHEL,IDPSRC,IDBSRC
7155 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
7156 & RADSRC,AMSRC,GAMSRC
7157 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
7158 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
7159 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
7160 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
7161 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
7162 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
7163 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
7164 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
7166 C standard particle data interface
7169 PARAMETER (NMXHEP=4000)
7171 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
7172 DOUBLE PRECISION PHEP,VHEP
7173 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
7174 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
7176 C extension to standard particle data interface (PHOJET specific)
7177 INTEGER IMPART,IPHIST,ICOLOR
7178 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
7180 C event weights and generated cross section
7181 INTEGER IPOWGC,ISWCUT,IVWGHT
7182 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
7183 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
7184 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
7186 DIMENSION P1(4),P2(4)
7188 WRITE(LO,'(2(/1X,A))')
7189 & 'PHO_GHHIAS: hadron-gamma event generation',
7190 & '-----------------------------------------'
7191 C hadron size and mass
7193 HIMASS = DBLE(NA)*0.938D0
7195 HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
7196 ALPHA = DBLE(NZ**2)/137.D0
7199 C correct Q2MAX2 according to hadron size
7200 Q2MAXH = 2.D0/HIRADI**2
7201 Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
7202 IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
7203 C total hadron / heavy ion energy
7210 C check kinematic limitations
7211 YMI = ECMIN**2/(4.D0*EE*EEP)
7212 IF(YMIN2.LT.YMI) THEN
7213 WRITE(LO,'(/1X,A,2E12.5)')
7214 & 'PHO_GHHIOF: ymin2 increased to (old/new)',YMIN2,YMI
7216 ELSE IF(YMIN2.GT.YMI) THEN
7217 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
7218 & 'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
7219 & ' INSTEAD OF',YMIN2
7221 C kinematic limitation
7222 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
7224 WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
7225 WRITE(LO,'(6X,A,E12.5)') 'HEAVY ION MASS (GeV) ',HIMASS
7226 WRITE(LO,'(6X,A,E12.5)') 'HEAVY ION RADIUS (GeV**-1) ',HIRADI
7227 WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
7229 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
7231 WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
7232 & 2.D0*SQRT(EEN*EEP),2.D0*SQRT(EE*EEP)
7233 WRITE(LO,'(6X,A,2E12.5)') 'INV.MASS HADRON-PHOTON ',ECMIN,
7235 WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
7236 IF(Q2LOW2.GE.Q2MAX2) THEN
7237 WRITE(LO,'(/1X,A,2E12.4)')
7238 & 'PHO_GHHIOF:ERROR:inconsistent Q**2 range 2',Q2LOW2,Q2MAX2
7241 C hadron numbers set to 0
7253 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
7255 Y1 = EXP(XMIN+DELLY*DBLE(I-1))
7256 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
7257 IF(Q2LOW2.GE.Q2MAX2) THEN
7258 WRITE(LO,'(/1X,A,2E12.4)')
7259 & 'PHO_GHHIOF: ymax2 changed from/to',YMAX2,Y1
7260 YMAX2 = MIN(Y1,YMAX2)
7269 DELLY = LOG(YMAX2/YMIN2)/DBLE(Max_tab-1)
7271 IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
7272 & 'PHO_GHHIAS: table of raw photon flux (side 2)',Max_tab
7274 Y2 = EXP(X2MIN+DELLY*DBLE(I-1))
7275 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2*Y2/(1.D0-Y2))
7276 FF = ((1.D0+(1.D0-Y2)**2)/Y2*LOG(Q2MAX2/Q2LOW2)
7277 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2))*ALPHA/(2.D0*PI)
7279 IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y2,FF
7282 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
7283 & 'PHO_GHHIAS: integrated flux:',FLUX
7288 P1(3) = -SQRT(EEP**2-AMP2)
7296 CALL PHO_SETPAR(1,2212,0,0.D0)
7297 CALL PHO_SETPAR(2,22,0,0.D0)
7298 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
7300 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
7302 WGMAX2 = (1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
7303 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
7305 CALL PHO_PHIST(-1,SIGMAX)
7306 CALL PHO_LHIST(-1,SIGMAX)
7308 C generation of events, flux calculation
7325 C sample photon flux
7332 Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
7333 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
7334 IF(Q2LOW2.GE.Q2MAX2) GOTO 175
7335 Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
7336 WGH = (1.D0+(1.D0-Y2)**2)*Q2LOG2
7337 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
7338 IF(WGMAX2.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
7339 & 'PHO_GHHIOF:WEIGHT ERROR (2):',Y2,WGMAX2,WGH
7340 IF(DT_RNDM(AYS1)*WGMAX2.GT.WGH) GOTO 175
7342 IF(IPAMDL(174).EQ.1) THEN
7343 YEFF = 1.D0+(1.D0-Y2)**2
7345 Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
7346 WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
7347 IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
7352 GAIMP(2) = 1.D0/SQRT(Q2P2)
7353 C form factor (squared)
7355 IF(GAIMP(2).LT.2.D0*HIRADI) FF2 = 0.D0
7356 IF(DT_RNDM(Q2P2).GE.FF2) GOTO 175
7365 PINI(3,1) = SQRT(EEP**2-AMP2)
7371 PINI(3,2) = -SQRT(EE**2-AMP2)
7375 YQ2 = SQRT((1.D0-Y2)*Q2P2)
7376 Q2E = Q2P2/(4.D0*EE)
7378 CALL PHO_SFECFE(SIF,COF)
7381 PFIN(3,2) = -E1Y+Q2E
7384 PFPHI(2) = ATAN2(COF,SIF)
7385 PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
7389 P1(3) = SQRT(EEP**2-AMP2)
7395 P2(3) = PINI(3,2)-PFIN(3,2)
7396 P2(4) = PINI(4,2)-PFIN(4,2)
7400 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
7401 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
7402 IF(GGECM.LT.0.1D0) GOTO 175
7404 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
7415 PGAM(5,2) = -SQRT(Q2P2)
7419 CALL PHO_PRESEL(5,IREJ)
7420 IF(IREJ.NE.0) GOTO 175
7422 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
7423 IF(IREJ.NE.0) GOTO 150
7424 C cut on diffractive mass
7426 IF(ISTHEP(K).EQ.30) THEN
7428 IF(GHDIFF.GE.PARMDL(175)) THEN
7435 WRITE(LO,'(/,1X,A)')
7436 & 'PHO_GHHIOF: no diffractive entry found'
7440 C remove quasi-elastically scattered hadron
7442 IF((ISTHEP(K).EQ.1).AND.(IDHEP(K).EQ.2212)) THEN
7443 XF = ABS(PHEP(3,K)/EEN)
7444 IF(XF.LT.PARMDL(72)) GOTO 150
7457 Q22AVE = Q22AVE+Q2P2
7458 Q22AV2 = Q22AV2+Q2P2*Q2P2
7459 Q22MIN = MIN(Q22MIN,Q2P2)
7460 Q22MAX = MAX(Q22MAX,Q2P2)
7461 YY2MIN = MIN(YY2MIN,Y2)
7462 YY2MAX = MAX(YY2MAX,Y2)
7464 CALL PHO_PHIST(1,HSWGHT(0))
7465 CALL PHO_LHIST(1,HSWGHT(0))
7468 WGMAX = WGMAX2*LOG(YMAX2/YMIN2)
7469 WGY2 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW,1))*ALPHA/(2.D0*PI)
7470 AY2 = AY2/DBLE(MAX(NITERS,1))
7471 AYS2 = AYS2/DBLE(MAX(NITERS,1))
7472 DAY2 = SQRT((AYS2-AY2**2)/DBLE(MAX(NITERS,1)))
7473 Q22AVE = Q22AVE/DBLE(MAX(NITERS,1))
7474 Q22AV2 = Q22AV2/DBLE(MAX(NITERS,1))
7475 Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(MAX(NITERS,1)))
7476 WGMAX = WGMAX2*LOG(YMAX2/YMIN2)
7477 WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW)*ALPHA/(2.D0*PI)
7478 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
7479 C output of statistics, histograms
7480 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
7481 &'=========================================================',
7482 &' ***** simulated cross section: ',WEIGHT,' mb *****',
7483 &'========================================================='
7484 WRITE(LO,'(//1X,A,/3X,4I12)')
7485 & 'PHO_GHHIOF:SUMMARY: NITER, NITERS, ITRY, ITRW',
7486 & NITER,NITERS,ITRY,ITRW
7487 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
7489 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
7491 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
7493 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 2 ',
7495 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2 ',
7498 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
7500 CALL PHO_PHIST(-2,WEIGHT)
7501 CALL PHO_LHIST(-2,WEIGHT)
7503 WRITE(LO,'(1X,A,I4)')
7504 & 'PHO_GHHIOF: no output of histograms',NITER
7509 *$ CREATE PHO_FITPAR.FOR
7511 CDECK ID>, PHO_FITPAR
7512 SUBROUTINE PHO_FITPAR(IOUTP)
7513 C**********************************************************************
7515 C read input parameters according to PDFs
7517 C**********************************************************************
7518 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7521 PARAMETER ( DEFA=-99999.D0,
7525 C input/output channels
7527 COMMON /POINOU/ LI,LO
7528 C event debugging information
7530 PARAMETER (NMAXD=100)
7531 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
7532 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7533 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
7534 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7535 C model switches and parameters
7537 INTEGER ISWMDL,IPAMDL
7538 DOUBLE PRECISION PARMDL
7539 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
7540 C global event kinematics and particle IDs
7542 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
7543 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
7544 C currently activated parton density parametrizations
7546 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
7547 DOUBLE PRECISION PDFLAM,PDFQ2M
7548 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
7549 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
7550 C Reggeon phenomenology parameters
7551 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
7552 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
7553 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
7554 & ALREG,ALREGP,GR(2),B0REG(2),
7555 & GPPP,GPPR,B0PPP,B0PPR,
7556 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
7557 C parameters of 2x2 channel model
7558 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
7559 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
7561 DIMENSION INUM(3),IFPAS(2)
7562 CHARACTER*8 CNAME8,PDFNA1,PDFNA2
7565 PARAMETER ( Max_tab = 22 )
7566 DIMENSION XDPtab(27,Max_tab),IDPtab(8,Max_tab)
7570 C parameter set for 2212 (GRV94 LO) 2212 (GRV94 LO)
7571 DATA (IDPtab(k, 1),k=1,8) /
7572 & 2212, 5, 6, 0, 2212, 5, 6, 0 /
7573 DATA (XDPtab(k, 1),k=1,27) /
7574 &1.1000E+00,2.5000E-01,6.3870E+00,6.3870E+00,1.1610E+00,1.1610E+00,
7575 &4.5000E-01,9.0000E-01,1.0263E+01,1.0263E+01,1.1710E+00,1.1710E+00,
7576 &1.5600E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7577 &1.0000E+00,0.0000E+00,1.0000E+00,0.0000E+00,3.5000E+00,2.0000E+00,
7578 &6.0000E-01,6.0000E-01,1.1000E+00,1.1000E+00,3.000E+00 /
7580 C parameter set for 2212 (GRV94 LO) -2212 (GRV94 LO)
7581 DATA (IDPtab(k, 2),k=1,8) /
7582 & 2212, 5, 6, 0, -2212, 5, 6, 0 /
7583 DATA (XDPtab(k, 2),k=1,27) /
7584 &1.1000E+00,2.5000E-01,6.3870E+00,6.3870E+00,1.1610E+00,1.1610E+00,
7585 &4.5000E-01,9.0000E-01,1.5174E+01,1.5174E+01,1.5400E+00,1.5400E+00,
7586 &1.5600E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7587 &1.0000E+00,0.0000E+00,1.0000E+00,0.0000E+00,3.5000E+00,2.0000E+00,
7588 &6.0000E-01,6.0000E-01,1.1000E+00,1.1000E+00,3.000E+00 /
7590 C parameter set for 22 (GRV-G LO) 2212 (GRV94 LO)
7591 DATA (IDPtab(k, 3),k=1,8) /
7592 & 22, 5, 3, 0, 2212, 5, 6, 0 /
7593 DATA (XDPtab(k, 3),k=1,27) /
7594 &1.0970E+00,2.5000E-01,2.7450E+00,6.8270E+00,1.2250E+00,1.1360E+00,
7595 &5.0000E-01,1.0000E+00,4.7210E+00,1.1740E+01,4.6200E-01,4.2800E-01,
7596 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7597 &4.3100E-03,8.0000E-05,1.0000E+00,0.0000E+00,3.2000E+00,1.0000E+00,
7598 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7600 C parameter set for 22 (GRV-G LO) 22 (GRV-G LO)
7601 DATA (IDPtab(k, 4),k=1,8) /
7602 & 22, 5, 3, 0, 22, 5, 3, 0 /
7603 DATA (XDPtab(k, 4),k=1,27) /
7604 &1.0970E+00,2.5000E-01,2.7450E+00,2.7450E+00,1.2250E+00,1.2250E+00,
7605 &5.0000E-01,1.0000E+00,4.7210E+00,4.7210E+00,4.6200E-01,4.6200E-01,
7606 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7607 &4.3100E-03,8.0000E-05,4.3100E-03,8.0000E-05,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 (GRS-G LO) 2212 (GRV94 LO)
7611 DATA (IDPtab(k, 5),k=1,8) /
7612 & 22, 5, 4, 4, 2212, 5, 6, 0 /
7613 DATA (XDPtab(k, 5),k=1,27) /
7614 &1.0970E+00,2.5000E-01,2.7450E+00,6.8270E+00,1.2250E+00,1.1360E+00,
7615 &5.0000E-01,1.0000E+00,4.7210E+00,1.1740E+01,4.6200E-01,4.2800E-01,
7616 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7617 &4.3100E-03,8.0000E-05,1.0000E+00,0.0000E+00,3.2000E+00,1.0000E+00,
7618 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7620 C parameter set for 22 (GRS-G LO) 22 (GRS-G LO)
7621 DATA (IDPtab(k, 6),k=1,8) /
7622 & 22, 5, 4, 4, 22, 5, 4, 4 /
7623 DATA (XDPtab(k, 6),k=1,27) /
7624 &1.0970E+00,2.5000E-01,2.7450E+00,2.7450E+00,1.2250E+00,1.2250E+00,
7625 &5.0000E-01,1.0000E+00,4.7210E+00,4.7210E+00,4.6200E-01,4.6200E-01,
7626 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7627 &4.3100E-03,8.0000E-05,4.3100E-03,8.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 (SaS-1D ) 22 (SaS-1D )
7631 DATA (IDPtab(k, 7),k=1,8) /
7632 & 22, 1, 1, 4, 22, 1, 1, 4 /
7633 DATA (XDPtab(k, 7),k=1,27) /
7634 &1.0970E+00,2.5000E-01,3.1170E+00,3.1170E+00,1.3450E+00,1.3450E+00,
7635 &3.0200E-01,1.0000E+00,6.6050E+00,6.6050E+00,1.7500E-01,1.7500E-01,
7636 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7637 &4.0900E-03,9.0000E-05,4.0900E-03,9.0000E-05,3.2000E+00,1.0000E+00,
7638 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7640 C parameter set for 22 (SaS-1M ) 22 (SaS-1M )
7641 DATA (IDPtab(k, 8),k=1,8) /
7642 & 22, 1, 2, 4, 22, 1, 2, 4 /
7643 DATA (XDPtab(k, 8),k=1,27) /
7644 &1.0970E+00,2.5000E-01,2.5540E+00,2.5540E+00,1.0910E+00,1.0910E+00,
7645 &5.0000E-01,1.0000E+00,4.2580E+00,4.2580E+00,4.9000E-01,4.9000E-01,
7646 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7647 &4.5700E-03,1.0000E-04,4.5700E-03,1.0000E-04,3.2000E+00,1.0000E+00,
7648 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7650 C parameter set for 22 (SaS-2D ) 22 (SaS-2D )
7651 DATA (IDPtab(k, 9),k=1,8) /
7652 & 22, 1, 3, 4, 22, 1, 3, 4 /
7653 DATA (XDPtab(k, 9),k=1,27) /
7654 &1.0970E+00,2.5000E-01,2.5330E+00,2.5330E+00,1.1340E+00,1.1340E+00,
7655 &5.0100E-01,1.0000E+00,4.2300E+00,4.2300E+00,4.9300E-01,4.9300E-01,
7656 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7657 &4.5900E-03,1.0000E-04,4.5900E-03,1.0000E-04,3.2000E+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 (SaS-2M ) 22 (SaS-2M )
7661 DATA (IDPtab(k, 10),k=1,8) /
7662 & 22, 1, 4, 4, 22, 1, 4, 4 /
7663 DATA (XDPtab(k, 10),k=1,27) /
7664 &1.0970E+00,2.5000E-01,2.8220E+00,2.8220E+00,1.0910E+00,1.0910E+00,
7665 &4.9100E-01,1.0000E+00,4.6870E+00,4.6870E+00,4.5800E-01,4.5800E-01,
7666 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7667 &4.6600E-03,3.0000E-05,4.6600E-03,3.0000E-05,3.2000E+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, 11),k=1,8) /
7672 & 22, 3, 1, 3, 2212, 5, 6, 0 /
7673 DATA (XDPtab(k, 11),k=1,27) /
7674 &1.0970E+00,2.5000E-01,3.3050E+00,6.8270E+00,9.4500E-01,1.1360E+00,
7675 &4.5000E-01,1.0000E+00,6.7120E+00,1.1740E+01,2.5800E-01,4.6200E-01,
7676 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7677 &3.3400E-03,2.4000E-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, 12),k=1,8) /
7682 & 22, 3, 1, 2, 2212, 5, 6, 0 /
7683 DATA (XDPtab(k, 12),k=1,27) /
7684 &1.0970E+00,2.5000E-01,3.3050E+00,6.8270E+00,9.4500E-01,1.1360E+00,
7685 &4.5000E-01,1.0000E+00,6.7120E+00,1.1740E+01,2.5800E-01,4.6200E-01,
7686 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7687 &3.3400E-03,2.4000E-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, 13),k=1,8) /
7692 & 22, 3, 1, 3, 22, 3, 1, 3 /
7693 DATA (XDPtab(k, 13),k=1,27) /
7694 &1.0970E+00,2.5000E-01,3.3050E+00,3.3050E+00,9.4500E-01,9.4500E-01,
7695 &4.5000E-01,1.0000E+00,6.7120E+00,6.7120E+00,2.5800E-01,2.5800E-01,
7696 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7697 &3.3400E-03,2.4000E-04,3.3400E-03,2.4000E-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, 14),k=1,8) /
7702 & 22, 3, 1, 2, 22, 3, 1, 2 /
7703 DATA (XDPtab(k, 14),k=1,27) /
7704 &1.0970E+00,2.5000E-01,3.3050E+00,3.3050E+00,9.4500E-01,9.4500E-01,
7705 &4.5000E-01,1.0000E+00,6.7120E+00,6.7120E+00,2.5800E-01,2.5800E-01,
7706 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7707 &3.3400E-03,2.4000E-04,3.3400E-03,2.4000E-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, 15),k=1,8) /
7712 & 22, 3, 2, 3, 2212, 5, 6, 0 /
7713 DATA (XDPtab(k, 15),k=1,27) /
7714 &1.0970E+00,2.5000E-01,3.1450E+00,6.8270E+00,1.0490E+00,1.1360E+00,
7715 &4.5000E-01,1.0000E+00,6.3680E+00,1.1740E+01,1.4700E-01,4.6200E-01,
7716 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7717 &3.8700E-03,1.1000E-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, 16),k=1,8) /
7722 & 22, 3, 2, 2, 2212, 5, 6, 0 /
7723 DATA (XDPtab(k, 16),k=1,27) /
7724 &1.0970E+00,2.5000E-01,3.1450E+00,6.8270E+00,1.0490E+00,1.1360E+00,
7725 &4.5000E-01,1.0000E+00,6.3680E+00,1.1740E+01,1.4700E-01,4.6200E-01,
7726 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7727 &3.8700E-03,1.1000E-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, 17),k=1,8) /
7732 & 22, 3, 2, 3, 22, 3, 2, 3 /
7733 DATA (XDPtab(k, 17),k=1,27) /
7734 &1.0970E+00,2.5000E-01,3.1450E+00,3.1450E+00,1.0490E+00,1.0490E+00,
7735 &4.5000E-01,1.0000E+00,6.3680E+00,6.3680E+00,1.4700E-01,1.4700E-01,
7736 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7737 &3.8700E-03,1.1000E-04,3.8700E-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, 18),k=1,8) /
7742 & 22, 3, 2, 2, 22, 3, 2, 2 /
7743 DATA (XDPtab(k, 18),k=1,27) /
7744 &1.0970E+00,2.5000E-01,3.1450E+00,3.1450E+00,1.0490E+00,1.0490E+00,
7745 &4.5000E-01,1.0000E+00,6.3680E+00,6.3680E+00,1.4700E-01,1.4700E-01,
7746 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7747 &3.8700E-03,1.1000E-04,3.8700E-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 /
7750 C parameter set for 22 (LAC ) 2212 (GRV94 LO)
7751 DATA (IDPtab(k, 19),k=1,8) /
7752 & 22, 3, 3, 3, 2212, 5, 6, 0 /
7753 DATA (XDPtab(k, 19),k=1,27) /
7754 &1.0970E+00,2.5000E-01,3.0510E+00,6.8270E+00,1.0500E+00,1.1360E+00,
7755 &4.5000E-01,1.0000E+00,6.0060E+00,1.1740E+01,2.0500E-01,4.6200E-01,
7756 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7757 &4.0200E-03,1.0000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7758 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7760 C parameter set for 22 (PDFLIB2 ) 2212 (GRV94 LO)
7761 DATA (IDPtab(k, 20),k=1,8) /
7762 & 22, 3, 3, 2, 2212, 5, 6, 0 /
7763 DATA (XDPtab(k, 20),k=1,27) /
7764 &1.0970E+00,2.5000E-01,3.0510E+00,6.8270E+00,1.0500E+00,1.1360E+00,
7765 &4.5000E-01,1.0000E+00,6.0060E+00,1.1740E+01,2.0500E-01,4.6200E-01,
7766 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7767 &4.0200E-03,1.0000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7768 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7770 C parameter set for 22 (LAC ) 22 (LAC )
7771 DATA (IDPtab(k, 21),k=1,8) /
7772 & 22, 3, 3, 3, 22, 3, 3, 3 /
7773 DATA (XDPtab(k, 21),k=1,27) /
7774 &1.0970E+00,2.5000E-01,3.0510E+00,3.0510E+00,1.0500E+00,1.0500E+00,
7775 &4.5000E-01,1.0000E+00,6.0060E+00,6.0060E+00,2.0500E-01,2.0500E-01,
7776 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7777 &4.0200E-03,1.0000E-04,4.0200E-03,1.0000E-04,2.0000E+00,1.0000E+00,
7778 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7780 C parameter set for 22 (PDFLIB2 ) 22 (PDFLIB2 )
7781 DATA (IDPtab(k, 22),k=1,8) /
7782 & 22, 3, 3, 2, 22, 3, 3, 2 /
7783 DATA (XDPtab(k, 22),k=1,27) /
7784 &1.0970E+00,2.5000E-01,3.0510E+00,3.0510E+00,1.0500E+00,1.0500E+00,
7785 &4.5000E-01,1.0000E+00,6.0060E+00,6.0060E+00,2.0500E-01,2.0500E-01,
7786 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7787 &4.0200E-03,1.0000E-04,4.0200E-03,1.0000E-04,2.0000E+00,1.0000E+00,
7788 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7796 & (IFPAP(1).EQ.IFPAS(1)).AND.(IFPAP(2).EQ.IFPAS(2))) GOTO 1300
7802 C parton distribution functions
7803 CALL PHO_ACTPDF(IFPAP(1),1)
7804 CALL PHO_GETPDF(1,PDFNA1,ALAM2,Q2MIN,Q2MAX,XMIN,XMAX)
7805 CALL PHO_ACTPDF(IFPAP(2),2)
7806 CALL PHO_GETPDF(2,PDFNA2,ALAM2,Q2MIN,Q2MAX,XMIN,XMAX)
7807 C initialize alpha_s calculation
7808 DUMMY = PHO_ALPHAS(0.D0,-4)
7810 IF(IDEB(54).GE.0) THEN
7811 WRITE(LO,'(/1X,A,I7,2X,A,3I7)') 'PHO_FITPAR: looking for PDF',
7812 & IFPAP(1),PDFNA1,IGRP(1),ISET(1),IEXT(1)
7813 WRITE(LO,'(1X,A,I7,2X,A,3I7)') 'PHO_FITPAR: looking for PDF',
7814 & IFPAP(2),PDFNA2,IGRP(2),ISET(2),IEXT(2)
7819 C load parameter set from internal tables
7825 IF((IFPAP(I1).EQ.IDPtab(1,I))
7826 & .AND.(IGRP(I1).EQ.IDPtab(2,I))
7827 & .AND.(ISET(I1).EQ.IDPtab(3,I))
7828 & .AND.(IEXT(I1).EQ.IDPtab(4,I))) THEN
7829 IF((IFPAP(I2).EQ.IDPtab(5,I))
7830 & .AND.(IGRP(I2).EQ.IDPtab(6,I))
7831 & .AND.(ISET(I2).EQ.IDPtab(7,I))
7832 & .AND.(IEXT(I2).EQ.IDPtab(8,I))) THEN
7834 & 'PHO_FITPAR: parameter set found in internal table'
7836 ALPOMP = XDPtab(2,I)
7837 GP(I1) = XDPtab(3,I)
7838 GP(I2) = XDPtab(4,I)
7839 B0POM(I1) = XDPtab(5,I)
7840 B0POM(I2) = XDPtab(6,I)
7842 ALREGP = XDPtab(8,I)
7843 GR(I1) = XDPtab(9,I)
7844 GR(I2) = XDPtab(10,I)
7845 B0REG(I1) = XDPtab(11,I)
7846 B0REG(I2) = XDPtab(12,I)
7848 B0PPP = XDPtab(14,I)
7850 B0PPR = XDPtab(16,I)
7851 VDMFAC(2*I1-1) = XDPtab(17,I)
7852 VDMFAC(2*I1) = XDPtab(18,I)
7853 VDMFAC(2*I2-1) = XDPtab(19,I)
7854 VDMFAC(2*I2) = XDPtab(20,I)
7855 B0HAR = XDPtab(21,I)
7856 AKFAC = XDPtab(22,I)
7857 PHISUP(I1) = XDPtab(23,I)
7858 PHISUP(I2) = XDPtab(24,I)
7859 RMASS(I1) = XDPtab(25,I)
7860 RMASS(I2) = XDPtab(26,I)
7874 & 'PHO_FITPAR: parameter set not found in internal table'
7879 C get parameters of soft cross sections from fitpar.dat
7880 IF(IPAMDL(99).GT.IFOUND) THEN
7883 & 'PHO_FITPAR: loading parameter set from file fitpar.dat'
7884 OPEN(12,FILE='fitpar.dat',ERR=1010,STATUS='OLD')
7887 READ(12,'(A8)',ERR=1020,END=1010) CNAME8
7888 IF(CNAME8.EQ.'STOP') GOTO 1010
7889 IF(CNAME8.EQ.'NEXTDATA') THEN
7890 READ(12,'(I8,2X,A8,3I6)',ERR=1020,END=1010)
7892 IF((IDPA1.EQ.IFPAP(1)).AND.(CNAME8.EQ.PDFNA1)
7893 & .AND.(INUM(1).EQ.IGRP(1)).AND.(INUM(2).EQ.ISET(1))) THEN
7894 READ(12,'(I8,2X,A8,3I6)',ERR=1020,END=1010)
7896 IF((IDPA2.EQ.IFPAP(2)).AND.(CNAME8.EQ.PDFNA2).AND.
7897 & (INUM(1).EQ.IGRP(2)).AND.(INUM(2).EQ.ISET(2))) THEN
7898 WRITE(LO,'(/1X,A)') 'PHO_FITPAR: parameter set found'
7899 READ(12,*) ALPOM,ALPOMP,GP,B0POM
7900 READ(12,*) ALREG,ALREGP,GR,B0REG
7901 READ(12,*) GPPP,B0PPP,GPPR,B0PPR
7902 READ(12,*) VDMFAC(1),VDMFAC(2),VDMFAC(3),VDMFAC(4)
7906 READ(12,*) RMASS,VAR
7915 WRITE(LO,'(/A)') ' PHO_FITPAR: cannot read file fitpar.dat'
7916 WRITE(LO,'(A,A10,A8)') ' last data card: ',CNAM10,CNAME8
7919 & ' PHO_FITPAR: cannot find parameter set in file fitpar.dat'
7927 IF(IFOUND.EQ.0) THEN
7928 WRITE(LO,'(/A)') ' PHO_FITPAR: could not find parameter set'
7929 WRITE(LO,'(3(10X,A,/))')
7930 & '(copy fitpar.dat into the working directory and/or',
7931 & ' request the missing parameter set via e-mail from',
7932 & ' ralph.engel@fzk.de)'
7938 C overwrite parameters with user settings
7939 IF(PARMDL(301).GT.DEFA) THEN
7943 IF(PARMDL(302).GT.DEFA) THEN
7944 ALPOMP = PARMDL(302)
7947 IF(PARMDL(303).GT.DEFA) THEN
7951 IF(PARMDL(304).GT.DEFA) THEN
7955 IF(PARMDL(305).GT.DEFA) THEN
7956 B0POM(1) = PARMDL(305)
7959 IF(PARMDL(306).GT.DEFA) THEN
7960 B0POM(2) = PARMDL(306)
7963 IF(PARMDL(307).GT.DEFA) THEN
7967 IF(PARMDL(308).GT.DEFA) THEN
7968 ALREGP = PARMDL(308)
7971 IF(PARMDL(309).GT.DEFA) THEN
7975 IF(PARMDL(310).GT.DEFA) THEN
7979 IF(PARMDL(311).GT.DEFA) THEN
7980 B0REG(1) = PARMDL(311)
7983 IF(PARMDL(312).GT.DEFA) THEN
7984 B0REG(2) = PARMDL(312)
7987 IF(PARMDL(313).GT.DEFA) THEN
7991 IF(PARMDL(314).GT.DEFA) THEN
7995 IF(PARMDL(315).GT.DEFA) THEN
7996 VDMFAC(1) = PARMDL(315)
7999 IF(PARMDL(316).GT.DEFA) THEN
8000 VDMFAC(2) = PARMDL(316)
8003 IF(PARMDL(317).GT.DEFA) THEN
8004 VDMFAC(3) = PARMDL(317)
8007 IF(PARMDL(318).GT.DEFA) THEN
8008 VDMFAC(4) = PARMDL(318)
8011 IF(PARMDL(319).GT.DEFA) THEN
8015 IF(PARMDL(320).GT.DEFA) THEN
8019 IF(PARMDL(321).GT.DEFA) THEN
8020 PHISUP(1) = PARMDL(321)
8023 IF(PARMDL(322).GT.DEFA) THEN
8024 PHISUP(2) = PARMDL(322)
8027 IF(PARMDL(323).GT.DEFA) THEN
8028 RMASS(1) = PARMDL(323)
8031 IF(PARMDL(324).GT.DEFA) THEN
8032 RMASS(2) = PARMDL(324)
8035 IF(PARMDL(325).GT.DEFA) THEN
8039 IF(PARMDL(327).GT.DEFA) THEN
8043 IF(PARMDL(328).GT.DEFA) THEN
8048 VDMQ2F(1) = VDMFAC(1)
8049 VDMQ2F(2) = VDMFAC(2)
8050 VDMQ2F(3) = VDMFAC(3)
8051 VDMQ2F(4) = VDMFAC(4)
8053 C output of parameter set
8054 IF((IDEB(54).GE.5).OR.(IOUTP.GT.0)) THEN
8055 WRITE(LO,'(/,A,/,A)') ' PHO_FITPAR: parameter set',
8056 & ' -------------------------'
8057 WRITE(LO,'(2(A,F7.3),2(A,2F9.3))')
8058 & ' ALPOM:',ALPOM,' ALPOMP:',ALPOMP,' GP:',GP,' B0POM:',
8060 WRITE(LO,'(2(A,F7.3),2(A,2F9.3))')
8061 & ' ALREG:',ALREG,' ALREGP:',ALREGP,' GR:',GR,' B0REG:',
8063 WRITE(LO,'(4(A,F7.3))')
8064 & ' GPPP :',GPPP,' B0PPP:',B0PPP,' GPPR :',GPPR,' B0PPR:',B0PPR
8065 WRITE(LO,'(A,4F10.5)') ' VDMFAC:',VDMFAC
8066 WRITE(LO,'(A,4F10.5)') ' VDMQ2F:',VDMQ2F
8067 WRITE(LO,'(A,F8.3)') ' B0HAR:',B0HAR
8068 WRITE(LO,'(A,F8.3)') ' AKFAC:',AKFAC
8069 WRITE(LO,'(A,2F8.3)') ' PHISUP:',PHISUP
8070 WRITE(LO,'(A,3F8.3)') ' RMASS:',RMASS,VAR
8073 CALL PHO_HARINI(1,IFPAP(1),IFPAP(2),PVIRT(1),PVIRT(2),6,IOUTP-1)
8077 *$ CREATE PHO_BORNCS.FOR
8079 CDECK ID>, PHO_BORNCS
8080 SUBROUTINE PHO_BORNCS(IP,IFHARD,XM1,XM2,XM3,XM4)
8081 C*********************************************************************
8083 C calculation of Born graph cross sections and slopes
8085 C input: IP particle combination
8086 C IFHARD -1 calculate hard Born graph cross section
8087 C 0 take hard Born graph cross section
8088 C from interpolation table if available
8089 C 1 assume that correct hard cross
8090 C sections are already stored in /POSBRN/
8091 C XM1,XM2,XM3,XM4 masses of external lines
8092 C /GLOCMS/ energy and PT cut-off
8093 C /POPREG/ soft and hard parameters
8094 C /POSBRN/ input cross sections
8095 C /POZBRN/ scaled input values
8096 C IFHARD 0 calculate hard input cross sections
8097 C 1 assume hard input cross sections exist
8099 C output: ZPOM scaled pomeron cross section
8100 C ZIGR scaled reggeon cross section
8101 C ZIGHR scaled hard resolved cross section
8102 C ZIGHD scaled hard direct cross section
8103 C ZIGT1 scaled triple-Pomeron cross section
8104 C ZIGT2 scaled triple-Pomeron cross section
8105 C ZIGL scaled loop-Pomeron cross section
8107 C*********************************************************************
8108 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8120 C input/output channels
8122 COMMON /POINOU/ LI,LO
8124 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
8125 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
8126 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
8127 C event debugging information
8129 PARAMETER (NMAXD=100)
8130 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
8131 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8132 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
8133 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8134 C model switches and parameters
8136 INTEGER ISWMDL,IPAMDL
8137 DOUBLE PRECISION PARMDL
8138 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
8139 C names of hard scattering processes
8141 PARAMETER ( Max_pro_1 = 16 )
8143 COMMON /POHPRO/ PROC(0:Max_pro_1)
8144 C hard cross sections and MC selection weights
8146 PARAMETER ( Max_pro_2 = 16 )
8147 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
8149 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
8150 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
8151 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
8152 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
8153 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
8154 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
8155 C interpolation tables for hard cross section and MC selection weights
8156 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
8157 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
8158 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
8159 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
8160 & HQ2a_tab,HQ2b_tab,HEcm_tab
8162 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8163 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8164 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8165 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8166 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
8167 & HEcm_tab(1:Max_tab_E,0:4),
8168 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
8169 C Born graph cross sections and slopes
8171 PARAMETER ( Max_pro_3 = 16 )
8172 COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
8174 COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
8175 & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
8176 C scaled cross sections and slopes
8177 COMPLEX*16 ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1,ZIGT2,ZIGL,ZIGDP,
8179 & BPOM,BREG,BHAR,BHAD,BTR1,BTR2,BLOO,BDP,BD1,BD2
8180 COMMON /POZBRN/ ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1(2),ZIGT2(2),ZIGL,
8181 & ZIGDP(4),ZIGD1(2),ZIGD2(2),
8182 & BPOM,BREG,BHAR,BHAD,BTR1(2),BTR2(2),BLOO,BDP(4),
8184 C Reggeon phenomenology parameters
8185 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
8186 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
8187 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
8188 & ALREG,ALREGP,GR(2),B0REG(2),
8189 & GPPP,GPPR,B0PPP,B0PPR,
8190 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
8191 C parameters of 2x2 channel model
8192 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
8193 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
8194 C data of c.m. system of Pomeron / Reggeon exchange
8195 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
8196 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
8197 & SIDP,CODP,SIFP,COFP
8198 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
8199 & SIDP,CODP,SIFP,COFP,NPOSP(2),
8200 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
8201 C obsolete cut-off information
8202 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
8203 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
8204 C data needed for soft-pt calculation
8205 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
8206 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
8208 COMPLEX*16 CZERO,BP4,BR4,BHR4,BHD4,BT14,BT24,BD4,SP,SR,SS,
8209 & BPOM1,BPOM2,BREG1,BREG2,B0HARD
8210 DIMENSION SCB1(4),SCB2(4),SCG1(4),SCG2(4)
8211 DIMENSION BT14(2),BT24(2),BD4(4)
8212 DIMENSION DSPT(0:Max_pro_2)
8214 DATA XMPOM / 0.766D0 /
8215 DATA CZERO /(0.D0,0.D0)/
8218 DCMPLX(X,Y) = CMPLX(X,Y)
8221 IF(IDEB(48).GE.10) WRITE(LO,'(/1X,A,I3,4E12.3,I3)')
8222 & 'PHO_BORNCS: IP,M1..M4,IFHARD',IP,XM1,XM2,XM3,XM4,IFHARD
8224 CALL PHO_SCALES(XM1,XM2,XM3,XM4,SCALE1,SCALE2,SCALB1,SCALB2)
8226 C calculate hard input cross sections (output in mb)
8227 IF(IFHARD.NE.1) THEN
8228 IF((IFHARD.EQ.0).AND.(HEcm_tab(1,IP).GT.1.D0)) THEN
8229 C double-log interpolation
8230 CALL PHO_HARINT(IP,ECMP,0.D0,0.D0,0,Max_pro_2,3,4,1)
8237 CALL PHO_HARINT(IP,ECMP,0.D0,0.D0,0,-2,0,0,1)
8238 CALL PHO_HARXTO(ECMP,PTCUT(IP),PTCUT(IP),DSIGH,DSPT)
8241 C save values to calculate soft pt distribution
8243 VDMQ2F(1) = VDMFAC(1)
8244 VDMQ2F(2) = VDMFAC(2)
8245 VDMQ2F(3) = VDMFAC(3)
8246 VDMQ2F(4) = VDMFAC(4)
8247 ELSE IF(IP.EQ.2) THEN
8248 VDMQ2F(1) = VDMFAC(1)
8249 VDMQ2F(2) = VDMFAC(2)
8252 ELSE IF(IP.EQ.3) THEN
8253 VDMQ2F(1) = VDMFAC(3)
8254 VDMQ2F(2) = VDMFAC(4)
8264 AMPFAC(1) = SQRT(VDMQ2F(1)*VDMQ2F(3))
8265 AMPFAC(2) = SQRT(VDMQ2F(2)*VDMQ2F(3))
8266 AMPFAC(3) = SQRT(VDMQ2F(1)*VDMQ2F(4))
8267 AMPFAC(4) = SQRT(VDMQ2F(2)*VDMQ2F(4))
8268 ELAFAC(1) = VDMQ2F(1)*VDMQ2F(3)+VDMQ2F(2)*VDMQ2F(3)
8269 & +VDMQ2F(1)*VDMQ2F(4)+VDMQ2F(2)*VDMQ2F(4)
8270 ELAFAC(2) = 2.D0*(AMPFAC(1)*AMPFAC(2)+AMPFAC(3)*AMPFAC(4))
8271 ELAFAC(3) = 2.D0*(AMPFAC(1)*AMPFAC(3)+AMPFAC(2)*AMPFAC(4))
8272 ELAFAC(4) = 4.D0*AMPFAC(1)*AMPFAC(4)
8273 VFAC = ELAFAC(1)+PHISUP(1)*PHISUP(2)*ELAFAC(4)
8274 & +PHISUP(1)*ELAFAC(2)+PHISUP(2)*ELAFAC(3)
8275 DSIGHP = DSPT(9)/VFAC
8276 SIGH = DSIGH(9)/VFAC
8278 IF(IPAMDL(1).EQ.0) THEN
8280 DSIGH(I)=DCMPLX(DREAL(DSIGH(I)),0.D0)
8284 IF(IDEB(48).GE.15) THEN
8285 WRITE(LO,'(/1X,A,1P,2E11.3)')
8286 & 'PHO_BORNCS: QCD-PM cross sections (mb)',ECMP,PTCUT(IP)
8287 DO 200 I=0,Max_pro_2
8288 WRITE(LO,'(10X,A,2E14.4)') PROC(I),DSIGH(I)
8293 C DPMJET interface: subtract anomalous part
8294 IF((IP.EQ.1).AND.(IPAMDL(13).GT.0))
8295 & DSIGH(9) = DSIGH(9)-DCMPLX(DT_SANO(ECMP),0.D0)
8297 SCALE = CDABS(DSIGH(15))
8298 IF(SCALE.LT.DEPS) THEN
8303 SCALE = CDABS(DSIGH(9))
8304 IF(SCALE.LT.DEPS) THEN
8307 SIGHR=DSIGH(9)*SCALE1*SCALE2/VFAC
8310 C calculate soft input cross sections (output in mb)
8311 SS=DCMPLX(ECMP**2-PMASSP(1)**2-PMASSP(2)**2+0.01D0,0.D0)
8312 IF(IPAMDL(1).EQ.1) THEN
8314 SP=SS*DCMPLX(0.D0,-1.D0)
8316 SR=SS*DCMPLX(0.D0,1.D0)
8321 C coupling constants (mb**1/2)
8322 C particle dependent slopes (GeV**-2)
8335 ELSE IF(IP.EQ.2) THEN
8339 GR2 = PARMDL(77)*GPPR/GPPP
8344 B0HARD = B0POM1+B0POM2
8347 ELSE IF(IP.EQ.3) THEN
8351 GR2 = PARMDL(77)*GPPR/GPPP
8356 B0HARD = B0POM1+B0POM2
8359 ELSE IF(IP.EQ.4) THEN
8362 GR1 = PARMDL(77)*GPPR/GPPP
8368 B0HARD = B0POM1+B0POM2
8372 WRITE(LO,'(/1X,A,I7)') 'PHO_BORNCS:ERROR:invalid IP',IP
8379 C input slope parameters (GeV**-2)
8380 BPOM1 = B0POM1*SCALB1
8381 BPOM2 = B0POM2*SCALB2
8382 BREG1 = B0REG1*SCALB1
8383 BREG2 = B0REG2*SCALB2
8385 XMR2 = (2.D0*MIN(XM1,XM3)*MIN(XM2,XM4))**2
8386 SCALE = SS*XMR2/((XM1**2+XM3**2)*(XM2**2+XM4**2))+2.D0
8387 BPOM = BPOM1 + BPOM2 + ALPOMP*LOG(SCALE)
8388 BREG = BREG1 + BREG2 + ALREGP*LOG(SCALE)
8389 IF(IPAMDL(9).EQ.0) THEN
8392 ELSE IF(IPAMDL(9).EQ.1) THEN
8393 BHAR = B0HARD*(SCALB1+SCALB2)/2.D0
8395 ELSE IF(IPAMDL(9).EQ.2) THEN
8402 C input cross section pomeron
8403 SIGP=GP1*GP2*EXP((ALPOM-1.D0)*LOG(SP))
8404 SIGR=GR1*GR2*EXP((ALREG-1.D0)*LOG(SR))
8405 C save value to calculate soft pt distribution
8406 SIGS = (SIGR+SIGP)/(SCALE1*SCALE2)
8408 C higher order graphs
8411 C bare/renormalized intercept for enhanced graphs
8412 IF(IPAMDL(8).EQ.0) THEN
8415 DELTAP = PARMDL(48)-1.D0
8420 C input cross section high-mass double diffraction
8421 CALL PHO_LOOREG(SD,GP1,BP1,GP2,BP2,
8422 & DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,VIRT2,SIGTR,BTR)
8423 SIGL = DCMPLX(SIGTR,0.D0)
8424 BLOO = DCMPLX(BTR,0.D0)
8426 C input cross section high mass diffraction particle 1
8428 CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
8429 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8430 CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
8431 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8432 SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8433 SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8434 BP1 = 2.D0*BPOM1*SCALB1
8435 BP2 = 2.D0*BPOM2*SCALB2
8436 C input cross section high mass diffraction
8437 CALL PHO_TRIREG(SD,GP1,BP1,GP2,BP2,
8438 & DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,SIGTR,BTR)
8439 SIGT1(1) = SCG1(1)*SCG2(1)*SCG2(2)*DCMPLX(SIGTR,0.D0)
8440 BTR1(1) = DCMPLX(BTR,0.D0)
8441 C second possibility: high-low mass double diffraction
8442 CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
8443 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8444 CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
8445 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8446 SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8447 SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8448 BP1 = 2.D0*BPOM1*SCALB1
8449 BP2 = 2.D0*BPOM2*SCALB2
8450 C input cross section high mass diffraction
8451 CALL PHO_TRIREG(SD,GP1,BP1,GP2,BP2,
8452 & DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,SIGTR,BTR)
8453 SIGT1(2) = SCG1(1)*SCG2(1)*SCG2(2)*DCMPLX(SIGTR,0.D0)
8454 BTR1(2) = DCMPLX(BTR,0.D0)
8456 C input cross section high mass diffraction particle 2
8458 CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
8459 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8460 CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
8461 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8462 SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8463 SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8464 BP1 = 2.D0*BPOM1*SCALB1
8465 BP2 = 2.D0*BPOM2*SCALB2
8466 C input cross section high mass diffraction
8467 CALL PHO_TRIREG(SD,GP2,BP2,GP1,BP1,
8468 & DELTAP,ALPOMP,GPPP,B0PPP,VIRT2,SIGTR,BTR)
8469 SIGT2(1) = SCG1(1)*SCG1(2)*SCG2(1)*DCMPLX(SIGTR,0.D0)
8470 BTR2(1) = DCMPLX(BTR,0.D0)
8471 C second possibility: high-low mass double diffraction
8472 CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
8473 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8474 CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
8475 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8476 SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8477 SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8478 BP1 = 2.D0*BPOM1*SCALB1
8479 BP2 = 2.D0*BPOM2*SCALB2
8480 C input cross section high mass diffraction
8481 CALL PHO_TRIREG(SD,GP2,BP2,GP1,BP1,
8482 & DELTAP,ALPOMP,GPPP,B0PPP,VIRT2,SIGTR,BTR)
8483 SIGT2(2) = SCG1(1)*SCG1(2)*SCG2(1)*DCMPLX(SIGTR,0.D0)
8484 BTR2(2) = DCMPLX(BTR,0.D0)
8486 C input cross section for loop-pomeron
8488 CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
8489 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8490 CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
8491 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8492 CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
8493 & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8494 CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
8495 & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8496 SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8497 SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8500 CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8502 SIGDP(1) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8503 BDP(1) = DCMPLX(BTX,0.D0)
8504 C second possibility
8505 CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
8506 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8507 CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
8508 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8509 CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
8510 & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8511 CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
8512 & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8513 SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8514 SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8517 CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8519 SIGDP(2) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8520 BDP(2) = DCMPLX(BTX,0.D0)
8522 CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
8523 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8524 CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
8525 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8526 CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
8527 & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8528 CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
8529 & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8530 SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8531 SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8534 CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8536 SIGDP(3) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8537 BDP(3) = DCMPLX(BTX,0.D0)
8538 C fourth possibility
8539 CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
8540 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8541 CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
8542 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8543 CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
8544 & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8545 CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
8546 & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8547 SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8548 SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8551 CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8553 SIGDP(4) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8554 BDP(4) = DCMPLX(BTX,0.D0)
8556 C input cross section for YY-iterated triple-pomeron
8559 C write out input cross sections
8560 IF(IDEB(48).GE.5) THEN
8561 WRITE(LO,'(2(/1X,A))')
8562 & 'Born graph input cross sections and slopes',
8563 & '------------------------------------------'
8564 WRITE(LO,'(1X,A,3E12.3)') 'energy ',ECMP,PVIRTP
8565 WRITE(LO,'(1X,A,4E12.3)') 'external masses 1,2,3,4 ',
8567 WRITE(LO,'(A)') ' input cross sections (millibarn):'
8568 WRITE(LO,'(A,2E12.3)') ' SIGR ',SIGR
8569 WRITE(LO,'(A,2E12.3)') ' (soft) SIGP ',SIGP
8570 WRITE(LO,'(A,2E12.3)') ' (hard) SIGHR ',SIGHR
8571 WRITE(LO,'(A,2E12.3)') ' SIGHD ',SIGHD
8572 WRITE(LO,'(A,4E12.3)') ' SIGT1 ',SIGT1
8573 WRITE(LO,'(A,4E12.3)') ' SIGT2 ',SIGT2
8574 WRITE(LO,'(A,2E12.3)') ' SIGL ',SIGL
8575 WRITE(LO,'(A,4E12.3)') ' SIGDP(1-2) ',SIGDP(1),SIGDP(2)
8576 WRITE(LO,'(A,4E12.3)') ' SIGDP(3-4) ',SIGDP(3),SIGDP(4)
8577 WRITE(LO,'(A)') ' input slopes (GeV**-2)'
8578 WRITE(LO,'(A,2E12.3)') ' BREG ',BREG
8579 WRITE(LO,'(A,2E12.3)') ' BREG1 ',BREG1
8580 WRITE(LO,'(A,2E12.3)') ' BREG2 ',BREG2
8581 WRITE(LO,'(A,2E12.3)') ' BPOM ',BPOM
8582 WRITE(LO,'(A,2E12.3)') ' BPOM1 ',BPOM1
8583 WRITE(LO,'(A,2E12.3)') ' BPOM2 ',BPOM2
8584 WRITE(LO,'(A,2E12.3)') ' BHAR ',BHAR
8585 WRITE(LO,'(A,2E12.3)') ' BHAD ',BHAD
8586 WRITE(LO,'(A,E12.3)') ' B0PPP ',B0PPP
8587 WRITE(LO,'(A,4E12.3)') ' BTR1 ',BTR1
8588 WRITE(LO,'(A,4E12.3)') ' BTR2 ',BTR2
8589 WRITE(LO,'(A,2E12.3)') ' BLOO ',BLOO
8590 WRITE(LO,'(A,4E12.3)') ' BDP(1-2) ',BDP(1),BDP(2)
8591 WRITE(LO,'(A,4E12.3)') ' BDP(3-4) ',BDP(3),BDP(4)
8598 BTR1(1) = BTR1(1)*GEV2MB
8599 BTR1(2) = BTR1(2)*GEV2MB
8600 BTR2(1) = BTR2(1)*GEV2MB
8601 BTR2(2) = BTR2(2)*GEV2MB
8608 BT14(1)=BTR1(1)*4.D0
8609 BT14(2)=BTR1(2)*4.D0
8610 BT24(1)=BTR2(1)*4.D0
8611 BT24(2)=BTR2(2)*4.D0
8614 ZIGP = SIGP/(PI2*BP4)
8615 ZIGR = SIGR/(PI2*BR4)
8616 ZIGHR = SIGHR/(PI2*BHR4)
8617 ZIGHD = SIGHD/(PI2*BHD4)
8618 ZIGT1(1) = SIGT1(1)/(PI2*BT14(1))
8619 ZIGT1(2) = SIGT1(2)/(PI2*BT14(2))
8620 ZIGT2(1) = SIGT2(1)/(PI2*BT24(1))
8621 ZIGT2(2) = SIGT2(2)/(PI2*BT24(2))
8622 ZIGL = SIGL/(PI2*BL4)
8624 BDP(I) = BDP(I)*GEV2MB
8625 BD4(I) = BDP(I)*4.D0
8626 ZIGDP(I) = SIGDP(I)/(PI2*BD4(I))
8629 IF(IDEB(48).GE.10) THEN
8630 WRITE(LO,'(A)') ' normalized input values:'
8631 WRITE(LO,'(A,2E12.3)') ' ZIGR ',ZIGR
8632 WRITE(LO,'(A,2E12.3)') ' BREG ',BREG
8633 WRITE(LO,'(A,2E12.3)') ' ZIGP ',ZIGP
8634 WRITE(LO,'(A,2E12.3)') ' BPOM ',BPOM
8635 WRITE(LO,'(A,2E12.3)') ' ZIGHR ',ZIGHR
8636 WRITE(LO,'(A,2E12.3)') ' BHAR ',BHAR
8637 WRITE(LO,'(A,2E12.3)') ' ZIGHD ',ZIGHD
8638 WRITE(LO,'(A,2E12.3)') ' BHAD ',BHAD
8639 WRITE(LO,'(A,4E12.3)') ' ZIGT1 ',ZIGT1
8640 WRITE(LO,'(A,4E12.3)') ' ZIGT2 ',ZIGT2
8641 WRITE(LO,'(A,2E12.3)') ' ZIGL ',ZIGL
8642 WRITE(LO,'(A,4E12.3)') ' ZIGDP(1-2) ',ZIGDP(1),ZIGDP(2)
8643 WRITE(LO,'(A,4E12.3)') ' ZIGDP(3-4) ',ZIGDP(3),ZIGDP(4)
8647 *$ CREATE PHO_SCALES.FOR
8649 CDECK ID>, PHO_SCALES
8650 SUBROUTINE PHO_SCALES(XM1,XM2,XM3,XM4,SCG1,SCG2,SCB1,SCB2)
8651 C**********************************************************************
8653 C calculation of scale factors
8654 C (mass dependent couplings and slopes)
8656 C input: XM1..XM4 external masses
8658 C output: SCG1,SCG2 scales of coupling constants
8659 C SCB1,SCB2 scales of coupling slope parameter
8661 C*********************************************************************
8662 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8665 PARAMETER ( EPS = 1.D-3 )
8667 C input/output channels
8669 COMMON /POINOU/ LI,LO
8670 C event debugging information
8672 PARAMETER (NMAXD=100)
8673 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
8674 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8675 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
8676 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8677 C Reggeon phenomenology parameters
8678 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
8679 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
8680 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
8681 & ALREG,ALREGP,GR(2),B0REG(2),
8682 & GPPP,GPPR,B0PPP,B0PPR,
8683 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
8684 C parameters of 2x2 channel model
8685 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
8686 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
8687 C data of c.m. system of Pomeron / Reggeon exchange
8688 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
8689 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
8690 & SIDP,CODP,SIFP,COFP
8691 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
8692 & SIDP,CODP,SIFP,COFP,NPOSP(2),
8693 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
8694 C model switches and parameters
8696 INTEGER ISWMDL,IPAMDL
8697 DOUBLE PRECISION PARMDL
8698 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
8700 C scale factors for couplings
8704 IF(ABS(XM1-XM3).GT.EPS) THEN
8705 IF(ECMP.LT.ECMTP) THEN
8706 SCG1 = PHISUP(1)*LOG(ECMP**2/ECMMIN)/LOG(ECMTP**2/ECMMIN)
8713 IF(ABS(XM2-XM4).GT.EPS) THEN
8714 IF(ECMP.LT.ECMTP) THEN
8715 SCG2 = PHISUP(2)*LOG(ECMP**2/ECMMIN)/LOG(ECMTP**2/ECMMIN)
8723 C scale factors for slope parameters
8724 IF((ISWMDL(1).LT.2).OR.(IPAMDL(10).EQ.1)) THEN
8727 ELSE IF(ISWMDL(1).EQ.2) THEN
8729 SCB1 = 2.D0*PMASSP(1)**2/(XM1**2+XM3**2)
8730 SCB2 = 2.D0*PMASSP(2)**2/(XM2**2+XM4**2)
8731 ELSE IF(ISWMDL(1).GE.3) THEN
8732 C symmetric gaussian
8733 SCB1 = VAR*(XM1-XM3)**2
8734 IF(SCB1.LT.25.D0) THEN
8739 SCB2 = VAR*(XM2-XM4)**2
8740 IF(SCB2.LT.25.D0) THEN
8746 WRITE(LO,'(/,1X,A,I4)') 'PHO_SCALES:ERROR:invalid ISWMDL(1)',
8751 IF(IDEB(65).GE.10) THEN
8752 WRITE(LO,'(1X,A,4E11.3)') 'PHO_SCALES: M1..M4 ',
8754 WRITE(LO,'(5X,A,4E11.3)') 'SCB1,SCB2,SCG1,SCG2',
8755 & SCB1,SCB2,SCG1,SCG2
8759 *$ CREATE PHO_EIKON.FOR
8761 CDECK ID>, PHO_EIKON
8762 SUBROUTINE PHO_EIKON(IP,IFHARD,B)
8763 C*********************************************************************
8765 C calculation of unitarized amplitudes
8767 C input: IP particle combination
8768 C IFHARD -1 ignore previously calculated Born
8770 C 0 calculate hard Born cross sections or
8771 C take them from interpolation table
8773 C 1 take hard cross sections from /POSBRN/
8774 C B impact parameter (mb**(1/2))
8775 C /POSBRN/ input cross sections
8776 C /GLOCMS/ cm energy
8777 C /POPREG/ soft and hard parameters
8780 C AMPEL purely elastic amplitude
8781 C AMPVM quasi-elastically vectormeson prod.
8782 C AMLMSD(2) amplitudes of low mass sing. diffr.
8783 C AMHMSD(2) amplitudes of high mass sing. diffr.
8784 C AMLMDD amplitude of low mass double diffr.
8785 C AMHMDD amplitude of high mass double diffr.
8787 C*********************************************************************
8788 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8801 C input/output channels
8803 COMMON /POINOU/ LI,LO
8804 C event debugging information
8806 PARAMETER (NMAXD=100)
8807 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
8808 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8809 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
8810 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8811 C complex Born graph amplitudes used for unitarization
8812 COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
8814 COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
8815 & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
8817 INTEGER IPFIL,IFAFIL,IFBFIL
8818 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
8819 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
8820 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
8821 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
8822 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
8823 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
8824 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
8825 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
8826 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
8827 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
8828 & IPFIL,IFAFIL,IFBFIL
8829 C Born graph cross sections and slopes
8831 PARAMETER ( Max_pro_3 = 16 )
8832 COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
8834 COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
8835 & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
8836 C scaled cross sections and slopes
8837 COMPLEX*16 ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1,ZIGT2,ZIGL,ZIGDP,
8839 & BPOM,BREG,BHAR,BHAD,BTR1,BTR2,BLOO,BDP,BD1,BD2
8840 COMMON /POZBRN/ ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1(2),ZIGT2(2),ZIGL,
8841 & ZIGDP(4),ZIGD1(2),ZIGD2(2),
8842 & BPOM,BREG,BHAR,BHAD,BTR1(2),BTR2(2),BLOO,BDP(4),
8844 C Born graph cross sections after applying diffraction model
8845 DOUBLE PRECISION SBOPOM,SBOREG,SBOHAR,SBOHAD,SBOTR1,SBOTR2,
8847 COMMON /POINT1/ SBOPOM(0:4),SBOREG(0:4),SBOHAR(0:4),SBOHAD(0:4),
8848 & SBOTR1(0:4,2),SBOTR2(0:4,2),SBOLPO(0:4),
8850 C global event kinematics and particle IDs
8852 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
8853 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
8854 C data of c.m. system of Pomeron / Reggeon exchange
8855 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
8856 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
8857 & SIDP,CODP,SIFP,COFP
8858 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
8859 & SIDP,CODP,SIFP,COFP,NPOSP(2),
8860 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
8861 C Reggeon phenomenology parameters
8862 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
8863 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
8864 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
8865 & ALREG,ALREGP,GR(2),B0REG(2),
8866 & GPPP,GPPR,B0PPP,B0PPR,
8867 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
8868 C parameters of 2x2 channel model
8869 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
8870 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
8871 C model switches and parameters
8873 INTEGER ISWMDL,IPAMDL
8874 DOUBLE PRECISION PARMDL
8875 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
8876 C unitarized amplitudes for different diffraction channels
8877 DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
8878 & ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
8879 & ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
8881 COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
8882 & ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
8883 & ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
8884 & ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
8885 & ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
8886 & ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
8889 COMPLEX*16 CZERO,CONE,B24,AUXP,AUXR,AUXH,AUXD,AUXT1,AUXT2,
8890 & AUXL,AMPR,AMPO,AMPP,AMPQ
8896 DATA PVOLD / -1.D0, -1.D0 /
8897 DATA XMPOM / 0.766D0 /
8898 DATA XMVDM / 0.766D0 /
8900 DCMPLX(X,Y) = CMPLX(X,Y)
8902 C calculation of scaled cross sections and slopes
8904 C test for redundant calculation
8905 IF((ECM.NE.ELAST).OR.(IFHARD.EQ.-1).OR.(PVIRT(1).NE.PVOLD(1))
8906 & .OR.(PVIRT(2).NE.PVOLD(2)).OR.(IP.NE.IPOLD)) THEN
8907 C effective particle masses, VDM assumption
8912 IF(IFPAP(1).EQ.22) THEN
8914 ELSE IF(IFPAP(1).EQ.990) THEN
8917 IF(IFPAP(2).EQ.22) THEN
8919 ELSE IF(IFPAP(2).EQ.990) THEN
8922 C different particle combinations
8926 ELSE IF(IP.EQ.4) THEN
8934 C update pomeron CM system
8939 CZERO = DCMPLX(0.D0,0.D0)
8940 CONE = DCMPLX(1.D0,0.D0)
8946 C purely elastic scattering
8947 CALL PHO_BORNCS(IP,IFHARD,XMASS1,XMASS2,XMASS1,XMASS2)
8956 ZXT1A(1,1) = ZIGT1(1)
8957 BXT1A(1,1) = BTR1(1)
8958 ZXT1B(1,1) = ZIGT1(2)
8959 BXT1B(1,1) = BTR1(2)
8960 ZXT2A(1,1) = ZIGT2(1)
8961 BXT2A(1,1) = BTR2(1)
8962 ZXT2B(1,1) = ZIGT2(2)
8963 BXT2B(1,1) = BTR2(2)
8966 ZXDPE(1,1) = ZIGDP(1)
8968 ZXDPA(1,1) = ZIGDP(2)
8970 ZXDPB(1,1) = ZIGDP(3)
8972 ZXDPD(1,1) = ZIGDP(4)
8978 SBOTR1(1,1) = SIGT1(1)
8979 SBOTR1(1,2) = SIGT1(2)
8980 SBOTR2(1,1) = SIGT2(1)
8981 SBOTR2(1,2) = SIGT2(2)
8983 SBODPO(1,1) = SIGDP(1)
8984 SBODPO(1,2) = SIGDP(2)
8985 SBODPO(1,3) = SIGDP(3)
8986 SBODPO(1,4) = SIGDP(4)
8988 C low mass single diffractive scattering 1
8989 CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,RMASS1,XMASS2)
8998 ZXT1A(1,2) = ZIGT1(1)
8999 BXT1A(1,2) = BTR1(1)
9000 ZXT1B(1,2) = ZIGT1(2)
9001 BXT1B(1,2) = BTR1(2)
9002 ZXT2A(1,2) = ZIGT2(1)
9003 BXT2A(1,2) = BTR2(1)
9004 ZXT2B(1,2) = ZIGT2(2)
9005 BXT2B(1,2) = BTR2(2)
9008 ZXDPE(1,2) = ZIGDP(1)
9010 ZXDPA(1,2) = ZIGDP(2)
9012 ZXDPB(1,2) = ZIGDP(3)
9014 ZXDPD(1,2) = ZIGDP(4)
9020 SBOTR1(2,1) = SIGT1(1)
9021 SBOTR1(2,2) = SIGT1(2)
9022 SBOTR2(2,1) = SIGT2(1)
9023 SBOTR2(2,2) = SIGT2(2)
9025 SBODPO(2,1) = SIGDP(1)
9026 SBODPO(2,2) = SIGDP(2)
9027 SBODPO(2,3) = SIGDP(3)
9028 SBODPO(2,4) = SIGDP(4)
9030 C low mass single diffractive scattering 2
9031 CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,XMASS1,RMASS2)
9040 ZXT1A(1,3) = ZIGT1(1)
9041 BXT1A(1,3) = BTR1(1)
9042 ZXT1B(1,3) = ZIGT1(2)
9043 BXT1B(1,3) = BTR1(2)
9044 ZXT2A(1,3) = ZIGT2(1)
9045 BXT2A(1,3) = BTR2(1)
9046 ZXT2B(1,3) = ZIGT2(2)
9047 BXT2B(1,3) = BTR2(2)
9050 ZXDPE(1,3) = ZIGDP(1)
9052 ZXDPA(1,3) = ZIGDP(2)
9054 ZXDPB(1,3) = ZIGDP(3)
9056 ZXDPD(1,3) = ZIGDP(4)
9062 SBOTR1(3,1) = SIGT1(1)
9063 SBOTR1(3,2) = SIGT1(2)
9064 SBOTR2(3,1) = SIGT2(1)
9065 SBOTR2(3,2) = SIGT2(2)
9067 SBODPO(3,1) = SIGDP(1)
9068 SBODPO(3,2) = SIGDP(2)
9069 SBODPO(3,3) = SIGDP(3)
9070 SBODPO(3,4) = SIGDP(4)
9072 C low mass double diffractive scattering
9073 CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,RMASS1,RMASS2)
9082 ZXT1A(1,4) = ZIGT1(1)
9083 BXT1A(1,4) = BTR1(1)
9084 ZXT1B(1,4) = ZIGT1(2)
9085 BXT1B(1,4) = BTR1(2)
9086 ZXT2A(1,4) = ZIGT2(1)
9087 BXT2A(1,4) = BTR2(1)
9088 ZXT2B(1,4) = ZIGT2(2)
9089 BXT2B(1,4) = BTR2(2)
9092 ZXDPE(1,4) = ZIGDP(1)
9094 ZXDPA(1,4) = ZIGDP(2)
9096 ZXDPB(1,4) = ZIGDP(3)
9098 ZXDPD(1,4) = ZIGDP(4)
9104 SBOTR1(4,1) = SIGT1(1)
9105 SBOTR1(4,2) = SIGT1(2)
9106 SBOTR2(4,1) = SIGT2(1)
9107 SBOTR2(4,2) = SIGT2(2)
9109 SBODPO(4,1) = SIGDP(1)
9110 SBODPO(4,2) = SIGDP(2)
9111 SBODPO(4,3) = SIGDP(3)
9112 SBODPO(4,4) = SIGDP(4)
9114 C calculate Born graph cross sections
9129 SBOPOM(0) = SBOPOM(0) + ELAFAC(I)*SBOPOM(I)
9130 SBOREG(0) = SBOREG(0) + ELAFAC(I)*SBOREG(I)
9131 SBOHAR(0) = SBOHAR(0) + ELAFAC(I)*SBOHAR(I)
9132 SBOHAD(0) = SBOHAD(0) + ELAFAC(I)*SBOHAD(I)
9133 SBOTR1(0,1) = SBOTR1(0,1) + ELAFAC(I)*SBOTR1(I,1)
9134 SBOTR1(0,2) = SBOTR1(0,2) + ELAFAC(I)*SBOTR1(I,2)
9135 SBOTR2(0,1) = SBOTR2(0,1) + ELAFAC(I)*SBOTR2(I,1)
9136 SBOTR2(0,2) = SBOTR2(0,2) + ELAFAC(I)*SBOTR2(I,2)
9137 SBOLPO(0) = SBOLPO(0) + ELAFAC(I)*SBOLPO(I)
9138 SBODPO(0,1) = SBODPO(0,1) + ELAFAC(I)*SBODPO(I,1)
9139 SBODPO(0,2) = SBODPO(0,2) + ELAFAC(I)*SBODPO(I,2)
9140 SBODPO(0,3) = SBODPO(0,3) + ELAFAC(I)*SBODPO(I,3)
9141 SBODPO(0,4) = SBODPO(0,4) + ELAFAC(I)*SBODPO(I,4)
9146 SIGTR1(1) = SBOTR1(0,1)
9147 SIGTR1(2) = SBOTR1(0,2)
9148 SIGTR2(1) = SBOTR2(0,1)
9149 SIGTR2(2) = SBOTR2(0,2)
9151 SIGDPO(1) = SBODPO(0,1)
9152 SIGDPO(2) = SBODPO(0,2)
9153 SIGDPO(3) = SBODPO(0,3)
9154 SIGDPO(4) = SBODPO(0,4)
9159 B24=DCMPLX(B**2,0.D0)/4.D0
9175 IF(ISWMDL(1).LT.3) THEN
9177 AUXP = ZXP(1,1)*EXP(-B24/BXP(1,1))
9179 AUXR = ZXR(1,1)*EXP(-B24/BXR(1,1))
9180 C hard resolved processes
9181 AUXH = ZXH(1,1)*EXP(-B24/BXH(1,1))
9182 C hard direct processes
9183 AUXD = ZXD(1,1)*EXP(-B24/BXD(1,1))
9184 C triple-Pomeron: baryon high mass diffraction
9185 AUXT1 = ZXT1A(1,1)*EXP(-B24/BXT1A(1,1))
9186 & + ZXT1B(1,1)*EXP(-B24/BXT1B(1,1))
9187 C triple-Pomeron: photon/meson high mass diffraction
9188 AUXT2 = ZXT2A(1,1)*EXP(-B24/BXT2A(1,1))
9189 & + ZXT2B(1,1)*EXP(-B24/BXT2B(1,1))
9191 AUXL = ZXL(1,1)*EXP(-B24/BXL(1,1))
9194 IF(ISWMDL(1).EQ.0) THEN
9195 AMPEL = 0.5D0*((VDMQ2F(1)+VDMQ2F(2)+VDMQ2F(3)+VDMQ2F(4))
9196 & *(CONE-EXP(-AUXR-AUXP-AUXH+AUXT1+AUXT2+AUXL))
9197 & +(CONE-(VDMQ2F(1)-VDMQ2F(2)-VDMQ2F(3)-VDMQ2F(4)))*AUXD
9199 AMPR = 0.5D0*SQRT(VDMQ2F(1))*(CONE-EXP(-AUXR-AUXP-AUXH
9200 & +AUXT1+AUXT2+AUXL))
9201 AMPO = 0.5D0*SQRT(VDMQ2F(2))*(CONE-EXP(-AUXR-AUXP-AUXH
9202 & +AUXT1+AUXT2+AUXL))
9203 AMPP = 0.5D0*SQRT(VDMQ2F(3))*(CONE-EXP(-AUXR-AUXP-AUXH
9204 & +AUXT1+AUXT2+AUXL))
9205 AMPQ = 0.5D0*SQRT(VDMQ2F(4))*(CONE-EXP(-AUXR-AUXP-AUXH
9206 & +AUXT1+AUXT2+AUXL))
9208 ELSE IF(ISWMDL(1).EQ.1) THEN
9209 AMPR = 0.5D0*SQRT(VDMQ2F(1))*
9210 & ( CONE-EXP(-AUXR-AUXP-AUXH*VDMQ2F(1)) )
9211 AMPO = 0.5D0*SQRT(VDMQ2F(2))*
9212 & ( CONE-EXP(-3.D0*AUXR-AUXP-AUXH*VDMQ2F(2)) )
9213 AMPP = 0.5D0*SQRT(VDMQ2F(3))*
9214 & ( CONE-EXP(-AUXP-AUXH*VDMQ2F(3)) )
9215 AMPQ = 0.5D0*SQRT(VDMQ2F(4))*
9216 & ( CONE-EXP(-AUXR-AUXP-AUXH*VDMQ2F(4)) )
9217 AMPEL = SQRT(VDMQ2F(1))*AMPR
9218 & + SQRT(VDMQ2F(2))*AMPO
9219 & + SQRT(VDMQ2F(3))*AMPP
9220 & + SQRT(VDMQ2F(4))*AMPQ
9223 C simple analytic two channel model (version A)
9224 ELSE IF(ISWMDL(1).EQ.3) THEN
9228 WRITE(LO,'(1X,A,I2)')
9229 & 'EIKON: ERROR: unsupported model ISWMDL(1) ',ISWMDL(1)
9235 *$ CREATE PHO_DSIGDT.FOR
9237 CDECK ID>, PHO_DSIGDT
9238 SUBROUTINE PHO_DSIGDT(EE,XTA,NFILL)
9239 C*********************************************************************
9241 C calculation of unitarized amplitude
9242 C and differential cross section
9244 C input: EE cm energy (GeV)
9245 C XTA(1,*) t values (GeV**2)
9246 C NFILL entries in t table
9248 C output: XTA(2,*) DSIG/DT g p --> g h/V (mub/GeV**2)
9249 C XTA(3,*) DSIG/DT g p --> rho0 h/V
9250 C XTA(4,*) DSIG/DT g p --> omega0 h/V
9251 C XTA(5,*) DSIG/DT g p --> phi h/V
9252 C XTA(6,*) DSIG/DT g p --> pi+ pi- h/V (continuum)
9254 C*********************************************************************
9255 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9263 DIMENSION XTA(6,NFILL)
9265 C input/output channels
9267 COMMON /POINOU/ LI,LO
9269 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
9270 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
9271 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
9272 C integration precision for hard cross sections (obsolete)
9273 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9274 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9275 C event debugging information
9277 PARAMETER (NMAXD=100)
9278 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9279 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9280 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9281 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9282 C global event kinematics and particle IDs
9284 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
9285 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
9286 C complex Born graph amplitudes used for unitarization
9287 COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
9289 COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
9290 & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
9292 COMPLEX*16 XT,AMP,CZERO
9293 DIMENSION AMP(5),XPNT(96),WGHT(96),XT(5,100)
9296 CDABS(AMPEL) = ABS(AMPEL)
9297 DCMPLX(X,Y) = CMPLX(X,Y)
9299 CZERO=DCMPLX(0.D0,0.D0)
9304 IF(NFILL.GT.100) THEN
9305 WRITE(LO,'(1X,A,I4)')
9306 & 'PHO_DSIGDT:ERROR: too many entries in table',NFILL
9316 C impact parameter integration
9317 C BMAX=12.D0*SQRT(MAX(BPOM,BREG))
9319 CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
9321 IF((IFPAP(1).EQ.22).AND.(IFPAP(2).NE.22)) THEN
9324 ELSE IF((IFPAP(1).NE.22).AND.(IFPAP(2).EQ.22)) THEN
9327 ELSE IF((IFPAP(1).EQ.22).AND.(IFPAP(2).EQ.22)) THEN
9344 C calculate amplitudes
9346 CALL PHO_EIKON(1,-1,XPNT(I))
9348 CALL PHO_EIKON(1,1,XPNT(I))
9351 AMP(2) = AMPVM(I1,I2)
9352 AMP(3) = AMPVM(J1,J2)
9353 AMP(4) = AMPVM(K1,K2)
9354 AMP(5) = AMPVM(L1,L2)
9357 XX=XPNT(I)*SQRT(XTA(1,J)/GEV2MB)
9358 FAC = PHO_BESSJ0(XX)*WG
9360 XT(1,J)=XT(1,J)+AMP(K)*FAC
9365 C change units to mb/GeV**2
9366 FAC = 4.D0*PI/GEV2MB
9367 FNA = '(mb/GeV**2) '
9370 FNA = '(mub/GeV**2)'
9371 ELSE IF(I1+I2.EQ.2) THEN
9372 FAC = FAC*THOUS*THOUS
9373 FNA = '(nb/GeV**2) '
9375 IF(IDEB(56).GE.5) THEN
9376 WRITE(LO,'(1X,A,A12,/1X,A)') 'table: -T (GeV**2) DSIG/DT ',
9377 & FNA,'------------------------------------------'
9381 XTA(K+1,J)=CDABS(XT(K,J))**2*FAC
9383 IF(IDEB(56).GE.5) THEN
9384 WRITE(LO,'(5X,6E12.3)') (XTA(I,J),I=1,IAMP+1)
9391 *$ CREATE PHO_XSECT.FOR
9393 CDECK ID>, PHO_XSECT
9394 SUBROUTINE PHO_XSECT(IP,IFHARD,EE)
9395 C*********************************************************************
9397 C calculation of physical cross sections
9399 C input: IP particle combination
9400 C IFHARD -1 reset Born graph cross section tables
9401 C 0 calculate hard cross sections or take them
9402 C from interpolation table (if available)
9403 C 1 assume that hard cross sections are already
9404 C calculated and stored in /POSBRN/
9405 C EE cms energy (GeV)
9407 C output: /POSBRN/ input cross sections
9408 C /POZBRN/ scaled input cross values
9409 C /POCSEC/ physical cross sections and slopes
9411 C slopes in GeV**-2, cross sections in mb
9413 C*********************************************************************
9414 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9417 PARAMETER(ONEM=-1.D0,
9421 C input/output channels
9423 COMMON /POINOU/ LI,LO
9425 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
9426 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
9427 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
9428 C event debugging information
9430 PARAMETER (NMAXD=100)
9431 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9432 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9433 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9434 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9435 C integration precision for hard cross sections (obsolete)
9436 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9437 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9438 C model switches and parameters
9440 INTEGER ISWMDL,IPAMDL
9441 DOUBLE PRECISION PARMDL
9442 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
9443 C Born graph cross sections and slopes
9445 PARAMETER ( Max_pro_3 = 16 )
9446 COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
9448 COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
9449 & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
9451 INTEGER IPFIL,IFAFIL,IFBFIL
9452 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
9453 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
9454 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
9455 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
9456 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
9457 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
9458 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
9459 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
9460 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
9461 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
9462 & IPFIL,IFAFIL,IFBFIL
9463 C global event kinematics and particle IDs
9465 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
9466 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
9468 CHARACTER*15 PHO_PNAME
9470 C complex Born graph amplitudes used for unitarization
9471 COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
9473 COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
9474 & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
9476 DIMENSION XPNT(96),WGHT(96),SLVM1(4,4),SLVM2(4,4)
9477 CHARACTER*8 VMESA(0:4),VMESB(0:4)
9478 DATA VMESA / 'vmeson ','rho ','omega ','phi ',
9480 DATA VMESB / 'vmeson ','rho ','omega ','phi ',
9483 CDABS(AMPEL) = ABS(AMPEL)
9486 IF(EE.LT.0.D0) GOTO 500
9489 C impact parameter integration
9490 C BMAX=12.D0*SQRT(MAX(BPOM,BREG))
9492 CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
9519 WG = WGHT(I)*XPNT(I)
9522 C calculate impact parameter amplitude, results in /POINT4/
9524 CALL PHO_EIKON(IP,IFHARD,XPNT(I))
9526 CALL PHO_EIKON(IP,1,XPNT(I))
9529 SIGTOT = SIGTOT + DREAL(AMPEL)*WG
9530 SIGELA = SIGELA + CDABS(AMPEL)**2*WG
9531 SLEL1 = SLEL1 + AMPEL*WGB
9532 SLEL2 = SLEL2 + AMPEL*WG
9536 SIGVM(J,K) = SIGVM(J,K) + CDABS(AMPVM(J,K))**2*WG
9537 SLVM1(J,K) = SLVM1(J,K) + AMPVM(J,K)*WGB
9538 SLVM2(J,K) = SLVM2(J,K) + AMPVM(J,K)*WG
9540 SIGCDF(J) = SIGCDF(J) + DREAL(AMPDP(J))*WG
9543 SIGLSD(1) = SIGLSD(1) + CDABS(AMLMSD(1))**2*WG
9544 SIGLSD(2) = SIGLSD(2) + CDABS(AMLMSD(2))**2*WG
9545 SIGLDD = SIGLDD + CDABS(AMLMDD)**2*WG
9546 SIG1SO = SIG1SO + DREAL(AMPSOF)*WG
9547 SIG1HA = SIG1HA + DREAL(AMPHAR)*WG
9548 SIGHSD(1) = SIGHSD(1) + DREAL(AMHMSD(1))*WG
9549 SIGHSD(2) = SIGHSD(2) + DREAL(AMHMSD(2))*WG
9550 SIGHDD = SIGHDD + DREAL(AMHMDD)*WG
9554 SIGDIR = DREAL(SIGHD)
9558 FACSL = 0.5D0/GEV2MB
9559 SLOEL = SLEL1/MAX(DEPS,SLEL2)*FACSL
9561 IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22)) THEN
9564 SIGVM(I,J) = SIGVM(I,J)*FAC
9565 SLOVM(I,J) = SLVM1(I,J)/MAX(DEPS,SLVM2(I,J))*FACSL
9573 SIGVM(0,I) = SIGVM(0,I) + SIGVM(J,I)
9574 SIGVM(I,0) = SIGVM(I,0) + SIGVM(I,J)
9576 SIGVM(0,0) = SIGVM(0,0) + SIGVM(I,0)
9580 C diffractive cross sections
9582 SIGLSD(1) = SIGLSD(1)*FAC*PARMDL(40)
9583 SIGLSD(2) = SIGLSD(2)*FAC*PARMDL(41)
9584 SIGLDD = SIGLDD *FAC*PARMDL(42)
9585 SIGHSD(1) = (SIGHSD(1)-2.D0*(SIGCDF(1)+SIGCDF(2)))*FAC*PARMDL(40)
9586 SIGHSD(2) = (SIGHSD(2)-2.D0*(SIGCDF(1)+SIGCDF(3)))*FAC*PARMDL(41)
9587 SIGHDD = (SIGHDD-2.D0*(SIGCDF(2)+SIGCDF(3)+2.D0*SIGCDF(4)))
9590 C double pomeron scattering
9594 SIGCDF(I) = SIGCDF(I)*FAC
9595 SIGCDF(0) = SIGCDF(0)+SIGCDF(I)
9598 SIG1SO = SIG1SO *FAC
9599 SIG1HA = SIG1HA *FAC
9601 SIGINE = SIGTOT - SIGELA
9603 C user-forced change of diffractive cross section
9605 IF((IP.EQ.1).AND.(ISWMDL(30).GE.1)) THEN
9607 C use optional explicit parametrization for single-diffraction
9609 SIGSD1 = SIGLSD(1)+SIGHSD(1)
9610 SIGSD2 = SIGLSD(2)+SIGHSD(2)
9613 XI_MAX = PARMDL(45)**2
9614 CALL PHO_CSDIFF(IFPAP(1),IFPAP(2),SS,XI_MIN,XI_MAX,
9615 & SIG_SD1,SIG_SD2,SIG_DD)
9616 SIG_SD1 = SIG_SD1*PARMDL(40)
9617 SIG_SD2 = SIG_SD2*PARMDL(41)
9620 C DEL_SD1 = SIG_SD1-SIGSD1
9621 DEL_SD1 = PARMDL(200)*(SIG_SD1-SIGSD1)
9624 FAC = SIGLSD(1)/SIGSD1
9625 SIGLSD(1) = SIGLSD(1)+FAC*DEL_SD1
9626 SIGHSD(1) = SIGHSD(1)+(1.D0-FAC)*DEL_SD1
9628 C DEL_SD2 = SIG_SD2-SIGSD2
9629 DEL_SD2 = PARMDL(200)*(SIG_SD2-SIGSD2)
9631 FAC = SIGLSD(2)/SIGSD2
9632 SIGLSD(2) = SIGLSD(2)+FAC*DEL_SD2
9633 SIGHSD(2) = SIGHSD(2)+(1.D0-FAC)*DEL_SD2
9635 IF(ISWMDL(30).GE.2) THEN
9637 C use explicit parametrization also for double diffraction diss.
9638 SIGDD = SIGLDD+SIGHDD
9639 SIG_DD = SIG_DD*PARMDL(42)
9640 DEL_DD = SIG_DD-SIGDD
9642 SIGLDD = SIGLDD+FAC*DEL_DD
9643 SIGHDD = SIGHDD+(1.D0-FAC)*DEL_DD
9644 SIGCOR = DEL_SD1 + DEL_SD2 + DEL_DD
9648 C rescale double diffraction cross sections
9649 SIGLDD = SIGLDD *PARMDL(42)
9650 SIGHDD = SIGHDD *PARMDL(42)
9651 SIGCOR = DEL_SD1 + DEL_SD2
9652 & +(SIGLDD+SIGHDD)*(PARMDL(42)-1.D0)
9658 C rescale unitarized cross sections for diffraction dissociation
9660 SIGLSD(1) = SIGLSD(1)*PARMDL(40)
9661 SIGHSD(1) = SIGHSD(1)*PARMDL(40)
9662 SIGLSD(2) = SIGLSD(2)*PARMDL(41)
9663 SIGHSD(2) = SIGHSD(2)*PARMDL(41)
9664 SIGLDD = SIGLDD *PARMDL(42)
9665 SIGHDD = SIGHDD *PARMDL(42)
9666 SIGCOR = (SIGLSD(1)+SIGHSD(1))*(PARMDL(40)-1.D0)
9667 & +(SIGLSD(2)+SIGHSD(2))*(PARMDL(41)-1.D0)
9668 & +(SIGLDD+SIGHDD)*(PARMDL(42)-1.D0)
9672 C non-diffractive inelastic cross section
9674 SIGNDF = SIGTOT-SIGELA-SIGVM(0,0)-SIGCDF(0)-SIGDIR
9675 & -SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
9678 C specify elastic scattering channel
9681 IF(IFPAP(1).NE.22) THEN
9682 VMESA(1) = PHO_PNAME(IFPAB(1),0)
9686 IF(IFPAP(2).NE.22) THEN
9687 VMESB(1) = PHO_PNAME(IFPAB(2),0)
9692 C write out physical cross sections
9694 IF(IDEB(57).GE.5) THEN
9695 WRITE(LO,'(/1X,A,I3,/1X,A)')
9696 & 'PHO_XSECT: cross sections (mb) for combination',IP,
9697 & '----------------------------------------------'
9698 WRITE(LO,'(5X,A,E12.3,2E11.3)')'energy,virtualities',ECM,PVIRT
9699 WRITE(LO,'(5X,A,E12.3)') ' total ',SIGTOT
9700 WRITE(LO,'(5X,A,E12.3)') ' purely elastic ',SIGELA
9701 WRITE(LO,'(5X,A,E12.3)') ' inelastic ',SIGINE
9702 WRITE(LO,'(5X,A,E12.3)') ' s-diff.particle 1 ',
9703 & SIGLSD(1)+SIGHSD(1)
9704 IF(IDEB(57).GE.7) THEN
9705 WRITE(LO,'(5X,A,E12.3)') ' low-mass part ',SIGLSD(1)
9706 WRITE(LO,'(5X,A,E12.3)') ' high-mass part ',SIGHSD(1)
9708 WRITE(LO,'(5X,A,E12.3)') ' s-diff.particle 2 ',
9709 & SIGLSD(2)+SIGHSD(2)
9710 IF(IDEB(57).GE.7) THEN
9711 WRITE(LO,'(5X,A,E12.3)') ' low-mass part ',SIGLSD(2)
9712 WRITE(LO,'(5X,A,E12.3)') ' high-mass part ',SIGHSD(2)
9714 WRITE(LO,'(5X,A,E12.3)') ' double diff ',SIGLDD+SIGHDD
9715 IF(IDEB(57).GE.7) THEN
9716 WRITE(LO,'(5X,A,E12.3)') ' low-mass part ',SIGLDD
9717 WRITE(LO,'(5X,A,E12.3)') ' high-mass part ',SIGHDD
9719 WRITE(LO,'(5X,A,E12.3)') ' double pomeron ',SIGCDF(0)
9720 IF(IDEB(57).GE.7) THEN
9721 WRITE(LO,'(5X,A,E12.3)') ' purely elastic ',SIGCDF(1)
9722 WRITE(LO,'(5X,A,E12.3)') ' excitation part.1 ',SIGCDF(2)
9723 WRITE(LO,'(5X,A,E12.3)') ' excitation part.2 ',SIGCDF(3)
9724 WRITE(LO,'(5X,A,E12.3)') ' excitation both ',SIGCDF(4)
9726 WRITE(LO,'(5X,A,E12.3)') ' elastic slope ',SLOEL
9729 IF(SIGVM(I,J).GT.DEPS) THEN
9730 WRITE(LO,'(1X,3A)') 'q-elastic production of ',
9732 WRITE(LO,'(10X,A,E12.3)') 'cross section ',SIGVM(I,J)
9733 IF((I.NE.0).AND.(J.NE.0))
9734 & WRITE(LO,'(18X,A,E12.3)') 'slope ',SLOVM(I,J)
9738 IF(IDEB(57).GE.7) THEN
9739 WRITE(LO,'(5X,A,E12.3)') ' vmeson production ',SIGVM(0,0)
9740 WRITE(LO,'(5X,A,E12.3)') ' one-pomeron soft ',SIG1SO
9741 WRITE(LO,'(5X,A,E12.3)') ' one-pomeron hard ',SIG1HA
9742 WRITE(LO,'(5X,A,E12.3)') ' pomeron exchange ',SIGPOM
9743 WRITE(LO,'(5X,A,E12.3)') ' reggeon exchange ',SIGREG
9744 WRITE(LO,'(5X,A,E12.3)') ' hard resolved QCD ',DREAL(DSIGH(9))
9745 WRITE(LO,'(5X,A,E12.3/)')' hard direct QCD ',
9754 *$ CREATE PHO_IMPAMP.FOR
9756 CDECK ID>, PHO_IMPAMP
9757 SUBROUTINE PHO_IMPAMP(EE,BMIN,BMAX,NSTEP)
9758 C*********************************************************************
9760 C calculation of physical impact parameter amplitude
9762 C input: EE cm energy (GeV)
9763 C BMIN lower bound in B
9764 C BMAX upper bound in B
9765 C NSTEP number of values (linear)
9767 C output: values written to output unit
9769 C*********************************************************************
9770 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9773 PARAMETER(ONEM=-1.D0,
9777 C input/output channels
9779 COMMON /POINOU/ LI,LO
9780 C event debugging information
9782 PARAMETER (NMAXD=100)
9783 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9784 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9785 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9786 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9787 C model switches and parameters
9789 INTEGER ISWMDL,IPAMDL
9790 DOUBLE PRECISION PARMDL
9791 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
9792 C global event kinematics and particle IDs
9794 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
9795 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
9796 C complex Born graph amplitudes used for unitarization
9797 COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
9799 COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
9800 & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
9803 BSTEP = (BMAX-BMIN)/DBLE(NSTEP-1)
9805 WRITE(LO,'(3(/,1X,A))')
9806 & 'impact parameter amplitudes:',
9807 & ' B AMP-EL AMP-LMSD(1,2) AMP-HMSD(1,2) AMP-LMDD AMP-HMDD',
9808 & '-------------------------------------------------------------'
9812 C calculate impact parameter amplitudes
9814 CALL PHO_EIKON(1,-1,BMIN)
9816 CALL PHO_EIKON(1,1,BB)
9818 WRITE(LO,'(1X,8E12.4)') BB,DREAL(AMPEL),
9819 & DREAL(AMLMSD(1)),DREAL(AMLMSD(2)),
9820 & DREAL(AMHMSD(1)),DREAL(AMHMSD(2)),DREAL(AMLMDD),DREAL(AMHMDD)
9826 *$ CREATE PHO_PRBDIS.FOR
9828 CDECK ID>, PHO_PRBDIS
9829 SUBROUTINE PHO_PRBDIS(IP,ECM,IE)
9830 C*********************************************************************
9832 C calculation of multi interactions probabilities
9834 C input: IP particle combination to scatter
9836 C IE index for weight storing
9838 C IMAX max. number of soft pomeron interactions
9839 C KMAX max. number of hard pomeron interactions
9842 C PROB field of probabilities
9844 C*********************************************************************
9845 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9848 PARAMETER ( EPS=1.D-10 )
9850 C input/output channels
9852 COMMON /POINOU/ LI,LO
9853 C event debugging information
9855 PARAMETER (NMAXD=100)
9856 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9857 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9858 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9859 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9860 C Reggeon phenomenology parameters
9861 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
9862 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
9863 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
9864 & ALREG,ALREGP,GR(2),B0REG(2),
9865 & GPPP,GPPR,B0PPP,B0PPR,
9866 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
9867 C parameters of 2x2 channel model
9868 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
9869 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
9870 C Born graph cross sections and slopes
9872 PARAMETER ( Max_pro_3 = 16 )
9873 COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
9875 COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
9876 & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
9877 C obsolete cut-off information
9878 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
9879 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
9880 C Born graph cross sections after applying diffraction model
9881 DOUBLE PRECISION SBOPOM,SBOREG,SBOHAR,SBOHAD,SBOTR1,SBOTR2,
9883 COMMON /POINT1/ SBOPOM(0:4),SBOREG(0:4),SBOHAR(0:4),SBOHAD(0:4),
9884 & SBOTR1(0:4,2),SBOTR2(0:4,2),SBOLPO(0:4),
9887 INTEGER IPFIL,IFAFIL,IFBFIL
9888 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
9889 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
9890 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
9891 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
9892 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
9893 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
9894 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
9895 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
9896 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
9897 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
9898 & IPFIL,IFAFIL,IFBFIL
9899 C cut probability distribution
9900 INTEGER IEETA1,IIMAX,KKMAX
9901 PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
9902 INTEGER IEEMAX,IMAX,KMAX
9904 DOUBLE PRECISION EPTAB
9905 COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
9907 C energy-interpolation table
9909 PARAMETER ( IEETA2 = 20 )
9911 DOUBLE PRECISION SIGTAB,SIGECM
9912 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
9913 C average number of cut soft and hard ladders (obsolete)
9914 DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
9915 COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
9917 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
9918 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
9919 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
9920 C integration precision for hard cross sections (obsolete)
9921 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9922 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9923 C model switches and parameters
9925 INTEGER ISWMDL,IPAMDL
9926 DOUBLE PRECISION PARMDL
9927 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
9928 C unitarized amplitudes for different diffraction channels
9929 DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
9930 & ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
9931 & ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
9933 COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
9934 & ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
9935 & ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
9936 & ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
9937 & ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
9938 & ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
9942 DIMENSION AB(4,4),CHI2(4),ABSUM2(4,4),ABSTMP(4),CHITMP(4)
9943 PARAMETER (ICHMAX=40)
9944 DIMENSION CHIFAC(4,4),AMPCOF(4)
9945 DIMENSION PCHAIN(2,ICHMAX),XPNT(96),WGHT(96)
9946 DIMENSION FACLOG(0:30),PSOFT(0:30),PHARD(0:30)
9948 C combinatorical factors
9949 DATA CHIFAC / 1.D0, 1.D0,-1.D0,-1.D0,
9950 & 1.D0,-1.D0, 1.D0,-1.D0,
9951 & 1.D0,-1.D0,-1.D0, 1.D0,
9952 & 1.D0, 1.D0, 1.D0, 1.D0 /
9954 DATA FACLOG / .000000000000000D+00,
9955 & .000000000000000D+00, .693147180559945D+00,
9956 & .109861228866811D+01, .138629436111989D+01,
9957 & .160943791243410D+01, .179175946922805D+01,
9958 & .194591014905531D+01, .207944154167984D+01,
9959 & .219722457733622D+01, .230258509299405D+01,
9960 & .239789527279837D+01, .248490664978800D+01,
9961 & .256494935746154D+01, .263905732961526D+01,
9962 & .270805020110221D+01, .277258872223978D+01,
9963 & .283321334405622D+01, .289037175789616D+01,
9964 & .294443897916644D+01, .299573227355399D+01,
9965 & .304452243772342D+01, .309104245335832D+01,
9966 & .313549421592915D+01, .317805383034795D+01,
9967 & .321887582486820D+01, .325809653802148D+01,
9968 & .329583686600433D+01, .333220451017520D+01,
9969 & .336729582998647D+01, .340119738166216D+01 /
9974 C test for redundant calculation: skip cs calculation
9975 IF((ECM.NE.ELAST).OR.(IP.NE.IPLAST)) THEN
9978 CALL PHO_XSECT(IP,0,ELAST)
9981 SIGTAB(IP,1,IE) = SIGTOT
9982 SIGTAB(IP,2,IE) = SIGELA
9987 SIGTAB(IP,J,IE) = SIGVM(I,K)
9990 SIGTAB(IP,28,IE) = SIGINE
9991 SIGTAB(IP,29,IE) = SIGDIR
9992 SIGTAB(IP,30,IE) = SIGLSD(1)
9993 SIGTAB(IP,31,IE) = SIGLSD(2)
9994 SIGTAB(IP,32,IE) = SIGHSD(1)
9995 SIGTAB(IP,33,IE) = SIGHSD(2)
9996 SIGTAB(IP,34,IE) = SIGLDD
9997 SIGTAB(IP,35,IE) = SIGHDD
9998 SIGTAB(IP,36,IE) = SIGCDF(0)
9999 SIGTAB(IP,37,IE) = SIG1SO
10000 SIGTAB(IP,38,IE) = SIG1HA
10001 SIGTAB(IP,39,IE) = SLOEL
10006 SIGTAB(IP,J,IE) = SLOVM(I,K)
10009 SIGTAB(IP,56,IE) = SIGPOM
10010 SIGTAB(IP,57,IE) = SIGREG
10011 SIGTAB(IP,58,IE) = SIGHAR
10012 SIGTAB(IP,59,IE) = SIGDIR
10013 SIGTAB(IP,60,IE) = SIGTR1(1)
10014 SIGTAB(IP,61,IE) = SIGTR1(2)
10015 SIGTAB(IP,62,IE) = SIGTR2(1)
10016 SIGTAB(IP,63,IE) = SIGTR2(2)
10017 SIGTAB(IP,64,IE) = SIGLOO
10018 SIGTAB(IP,65,IE) = SIGDPO(1)
10019 SIGTAB(IP,66,IE) = SIGDPO(2)
10020 SIGTAB(IP,67,IE) = SIGDPO(3)
10021 SIGTAB(IP,68,IE) = SIGDPO(4)
10023 C consistency check
10024 SIGNDF = SIGTOT-SIGELA-SIGVM(0,0)-SIGCDF(0)-SIGDIR
10025 & -SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
10028 IF(SIGNDF.LE.0.D0) THEN
10029 WRITE(LO,'(//1X,A,/)')
10030 & 'PHO_PRBDIS:ERROR: neg.cross section for unitarization!'
10031 WRITE(LO,'(1X,A,I3,1P,2E12.4)')
10032 & 'PHO_PRBDIS: IP,ECM,SIGNDF:',IP,ECM,SIGNDF
10033 WRITE(LO,'(4X,A,/1P,8E10.3)')
10034 &'(SIGTOT,SIGELA,SIGVM,SIGCDF,SIGDIR,SIGLSD(1),SIGLSD(2),SIGLDD):',
10035 & SIGTOT,SIGELA,SIGVM(0,0),SIGCDF(0),SIGDIR,SIGLSD(1),
10040 IF((IDEB(55).GE.2).AND.(IP.EQ.1)) THEN
10041 write(LO,*) '------------------------------------------------'
10042 write(LO,*) 'IP,ECM:',IP,ECM
10043 write(LO,*) 'SIGTOT:',SIGTOT
10044 write(LO,*) 'SIGELA:',SIGELA
10045 write(LO,*) 'SIGVM :',SIGVM(0,0)
10046 write(LO,*) 'SIGCDF:',SIGCDF(0)
10047 write(LO,*) 'SIGDIR:',SIGDIR
10048 write(LO,*) 'SIGLSD:',SIGLSD
10049 write(LO,*) 'SIGHSD:',SIGHSD
10050 write(LO,*) 'SIGLDD:',SIGLDD
10051 write(LO,*) 'SIGHDD:',SIGHDD
10052 write(LO,*) 'SIGNDF:',SIGNDF
10054 write(LO,*) 'SIGPOM:',SIGPOM
10055 write(LO,*) 'SIGREG:',SIGREG
10056 write(LO,*) 'SIGHAR:',SIGHAR
10057 write(LO,*) 'SIGDIR:',SIGDIR
10058 write(LO,*) 'SIGTR1:',SIGTR1
10059 write(LO,*) 'SIGTR2:',SIGTR2
10060 write(LO,*) 'SIGLOO:',SIGLOO
10061 write(LO,*) 'SIGDPO:',SIGDPO
10062 write(LO,*) 'SIG1SO:',SIG1SO
10063 write(LO,*) 'SIG1HA:',SIG1HA
10066 SIGTAB(IP,77,IE) = PTCUT(IP)
10067 SIGTAB(IP,78,IE) = SIGNDF
10069 AUXFAC = PI2/SIGNDF
10070 IF(ISWMDL(1).EQ.3) THEN
10074 AMPCOF(I) = AMPCOF(I) + 0.25D0*ELAFAC(K)*CHIFAC(K,I)
10076 AMPCOF(I) = AMPCOF(I)*AUXFAC
10080 * BMAX=5.D0*SQRT(DBLE(BPOM))
10083 CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
10089 PROB(IP,IE,I,K) = 0.D0
10097 C main cross section loop
10098 C**********************************************************
10099 DO 5000 IB=1,NGAUSO
10100 B24=XPNT(IB)**2/4.D0
10101 FAC = XPNT(IB)*WGHT(IB)
10103 IF((ISWMDL(1).EQ.3).OR.(ISWMDL(1).EQ.4)) THEN
10105 C amplitude construction
10107 AB(1,I)=ZXP(1,I)*EXP(-B24/BXP(1,I))
10108 & +ZXR(1,I)*EXP(-B24/BXR(1,I))
10109 AB(2,I)=ZXH(1,I)*EXP(-B24/BXH(1,I))
10110 AB(3,I)=-ZXT1A(1,I)*EXP(-B24/BXT1A(1,I))
10111 & -ZXT1B(1,I)*EXP(-B24/BXT1B(1,I))
10112 & -ZXT2A(1,I)*EXP(-B24/BXT2A(1,I))
10113 & -ZXT2B(1,I)*EXP(-B24/BXT2B(1,I))
10114 & -ZXL(1,I)*EXP(-B24/BXL(1,I))
10115 AB(4,I)=ZXDPE(1,I)*EXP(-B24/BXDPE(1,I))
10116 & +ZXDPA(1,I)*EXP(-B24/BXDPA(1,I))
10117 & +ZXDPB(1,I)*EXP(-B24/BXDPB(1,I))
10118 & +ZXDPD(1,I)*EXP(-B24/BXDPD(1,I))
10119 AB(1,I) = AB(1,I)+AB(3,I)+AB(4,I)
10130 ABSUM2(I,K) = ABSUM2(I,K) + CHIFAC(L,K)*AB(I,L)
10132 ABSUM2(I,K) = 2.D0*ABSUM2(I,K)
10138 CHI2(I) = CHI2(I) + ABSUM2(K,I)
10141 C sums instead of products
10144 DTMP = ABS(ABSUM2(I,KD))
10145 IF(DTMP.LT.1.D-30) THEN
10146 ABSUM2(I,KD) = -50.D0
10148 ABSUM2(I,KD) = LOG(DTMP)
10153 IF(MAX(IMAX,KMAX).GT.30) THEN
10154 WRITE(LO,'(1X,2A,3I6)') 'PHO_PRBDIS: internal field ',
10155 & 'dimension too small (IMAX,KMAX,int):',IMAX,KMAX,30
10161 ABSTMP(I) = ABSUM2(I,KD)
10164 CHITMP(1) = -ABSUM2(1,KD)
10166 CHITMP(1) = CHITMP(1)+ABSTMP(1)-FACLOG(I)
10167 CHITMP(2) = -ABSTMP(2)
10169 CHITMP(2) = CHITMP(2)+ABSTMP(2)-FACLOG(K)
10170 C calculation of elastic part
10171 DTMP = -CHI2(KD)+CHITMP(1)+CHITMP(2)
10172 IF(DTMP.LT.-30.D0) THEN
10175 DTMP = EXP(DTMP)*FAC*AMPCOF(KD)
10177 PROB(IP,IE,I,K) = PROB(IP,IE,I,K) + DTMP
10181 PROB(IP,IE,0,0) = 0.D0
10183 C**********************************************************
10185 WRITE(LO,'(1X,A,I3)')
10186 & 'PHO_PRBDIS:ERROR: invalid setting of ISWMDL(1)',ISWMDL(1)
10192 IF(IDEB(55).GE.15) THEN
10193 WRITE(LO,'(/,1X,A,I3,E11.4)')
10194 & 'PHO_PRBDIS: list of probabilities (uncorrected,IP,ECM)',
10196 DO 905 I=0,MIN(IMAX,5)
10197 DO 915 K=0,MIN(KMAX,5)
10198 IF(ABS(PROB(IP,IE,I,K)).GT.1.D-10)
10199 & WRITE(LO,'(10X,2I3,5X,E12.3)') I,K,PROB(IP,IE,I,K)
10203 C string probability (uncorrected)
10204 IF(IDEB(55).GE.5) THEN
10208 IF((INDX.LE.ICHMAX).AND.(INDX.GT.0)) THEN
10209 PCHAIN(1,INDX) = PCHAIN(1,INDX) + PROB(IP,IE,I,K)
10213 WRITE(LO,'(/1X,2A,E11.4)') 'PHO_PRBDIS: ',
10214 & 'list of selected probabilities (uncorr,ECM)',ECM
10215 WRITE(LO,'(10X,A)') 'I, 0HPOM, 1HPOM, 2HPOM'
10217 IF(ABS(PROB(IP,IE,I,0)).GT.1.D-10)
10218 & WRITE(LO,'(5X,I4,3E12.4)') I,PROB(IP,IE,I,0),
10219 & PROB(IP,IE,I,1),PROB(IP,IE,I,2)
10222 C substract high-mass single and double diffraction
10223 PROB(IP,IE,1,0) = PROB(IP,IE,1,0)
10224 & -(SIGHSD(1)+SIGHSD(2)+SIGHDD+SIGCDF(0))/SIGNDF
10225 PROB(IP,IE,1,0) = MAX(0.01,PROB(IP,IE,1,0))
10227 C probability check
10247 TMP = PROB(IP,IE,I,K)
10248 IF(TMP.LT.0.D0) THEN
10249 IF((IDEB(55).GE.0).AND.(TMP.LT.-EPS)) THEN
10250 WRITE(LO,'(1X,A,4I4,E14.4)')
10251 & 'PHO_PRBDIS: neg.probability:',
10252 & IP,IE,I,K,PROB(IP,IE,I,K)
10254 PRONEG = PRONEG+TMP
10257 CHKSUM = CHKSUM+TMP
10258 AVERI = AVERI+DBLE(I)*TMP
10259 AVERK = AVERK+DBLE(K)*TMP
10260 SIGMI = SIGMI+DBLE(I**2)*TMP
10261 SIGMK = SIGMK+DBLE(K**2)*TMP
10262 PSOFT(I) = PSOFT(I)+PROB(IP,IE,I,K)
10263 PHARD(K) = PHARD(K)+PROB(IP,IE,I,K)
10264 PROB(IP,IE,I,K) = CHKSUM
10268 IF(IDEB(55).GE.1) WRITE(LO,'(/,1X,A,2E15.6)')
10269 & 'PHO_PRBDIS: first sum of probabilities',CHKSUM,PRONEG
10270 C cut probabilites output
10271 IF(IDEB(55).GE.5) THEN
10272 WRITE(LO,'(/1X,A)') 'list of cut probabilities (uncorr/corr)'
10274 IF(ABS(PCHAIN(1,I)).GT.1.D-10)
10275 & WRITE(LO,'(5X,I4,2E12.3)') I,PCHAIN(1,I),PCHAIN(1,I)/CHKSUM
10278 C rescaling necessary
10279 IF(ABS(CHKSUM-1.D0).GT.1.D-15) THEN
10281 IF(IDEB(55).GE.1) WRITE(LO,'(/,1X,A,E15.6)')
10282 & 'PHO_PRBDIS: rescaling of probabilities with factor',FAC
10285 PROB(IP,IE,I,K) = PROB(IP,IE,I,K)*FAC
10292 SIGMI = SIGMI*FAC**2
10293 SIGMK = SIGMK*FAC**2
10294 SIGML = SIGML*FAC**2
10295 SIGMM = SIGMM*FAC**2
10298 C probability to find Reggeon/Pomeron
10299 PROB(IP,IE,0,0) = -SIGREG/(SIGPOM+SIGREG)
10300 AVERJ = -PROB(IP,IE,0,0)*AVERI
10301 AVERII = AVERI-AVERJ
10303 SIGTAB(IP,74,IE) = AVERII
10304 SIGTAB(IP,75,IE) = AVERK
10305 SIGTAB(IP,76,IE) = AVERJ
10307 SIGTAB(IP,79,IE) = PROB(IP,IE,IMAX,0)*SIGNDF
10308 SIGTAB(IP,80,IE) = SIGNDF-SIGTAB(IP,79,IE)
10310 IF(IDEB(55).GE.1) THEN
10312 C average interaction probabilities
10313 WRITE(LO,'(/1X,A,/1X,A)')
10314 & 'PHO_PRBDIS: expected interaction statistics',
10315 & '-------------------------------------------'
10316 WRITE(LO,'(1X,A,E12.4,2I3)')
10317 & 'energy,IP,table index:',EPTAB(IP,IE),IP,IE
10318 WRITE(LO,'(1X,A,2I4)') 'current limitations (soft,hard):',
10320 WRITE(LO,'(1X,A,E12.4/,4X,A,/,1X,6E11.3)')
10321 & 'averaged number of cuts per event (eff. cs):',SIGNDF,
10322 & ' (Pom / Pom-h / Reg / enh-tri-loop / enh-dble / sum):',
10323 & AVERII,AVERK,AVERJ,AVERL,AVERM,
10324 & AVERI+AVERK+AVERL+AVERM
10325 WRITE(LO,'(1X,A,/,4X,A,/,1X,4E11.3)')
10326 & 'standard deviation ( sqrt(sigma) ):',
10327 & ' (Pomeron / Pomeron-h / enh-tri-loop / enh-dble):',
10328 & SQRT(ABS(SIGMI-AVERI**2)),SQRT(ABS(SIGMK-AVERK**2)),
10329 & SQRT(ABS(SIGML-AVERL**2)),SQRT(ABS(SIGMM-AVERM**2))
10330 WRITE(LO,'(1X,A)') 'cross section / probability soft, hard'
10331 DO I=0,MIN(IMAX,KMAX)
10332 WRITE(LO,'(I5,2E12.4,3X,2E12.4)')
10333 & I,PSOFT(I)*SIGNDF,PSOFT(I),PHARD(I)*SIGNDF,PHARD(I)
10336 C cross check of probability distribution and inclusive cross section
10342 PSsum_1 = PSsum_1+PSOFT(i)*FAC
10343 PSsum_2 = PSsum_2+PSOFT(i)*FAC*dble(i)
10346 PHsum_1 = PHsum_1+PHARD(k)
10347 PHsum_2 = PHsum_2+PHARD(k)*FAC*dble(k)
10349 WRITE(LO,'(1x,a,2E12.4,3X,2E12.4)') 'sum:',
10350 & PSsum_2*SIGNDF,PSsum_1,PHsum_2*SIGNDF,PHsum_1
10356 *$ CREATE PHO_SAMPRO.FOR
10358 CDECK ID>, PHO_SAMPRO
10359 SUBROUTINE PHO_SAMPRO(IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB,IPROC)
10360 C***********************************************************************
10362 C routine to sample kind of process
10364 C input: IP particle combination
10365 C IFP1/2 PDG number of particle 1/2
10366 C ECM c.m. energy (GeV)
10367 C PVIR1/2 virtuality of particle 1/2 (GeV**2, positive)
10368 C SPROB suppression factor for processes 1-7
10369 C due to rapidity gap survival probability
10371 C -2 output of statistics
10372 C -1 initialization
10373 C 0 sampling of process
10375 C output: IPROC kind of interaction process:
10376 C 1 non-diffractive resolved process
10377 C 2 elastic scattering
10378 C 3 quasi-elastic rho/omega/phi production
10379 C 4 central diffraction
10380 C 5 single diffraction according to IDIFF1
10381 C 6 single diffraction according to IDIFF2
10382 C 7 double diffraction
10383 C 8 single-resolved / direct processes
10385 C***********************************************************************
10391 INTEGER IP,IFP1,IFP2,IPROC
10392 DOUBLE PRECISION ECM,PVIR1,PVIR2,SPROB
10394 C input/output channels
10396 COMMON /POINOU/ LI,LO
10397 C event debugging information
10399 PARAMETER (NMAXD=100)
10400 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
10401 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10402 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
10403 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10405 INTEGER IPFIL,IFAFIL,IFBFIL
10406 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
10407 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
10408 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
10409 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
10410 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
10411 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
10412 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
10413 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
10414 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
10415 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
10416 & IPFIL,IFAFIL,IFBFIL
10417 C model switches and parameters
10419 INTEGER ISWMDL,IPAMDL
10420 DOUBLE PRECISION PARMDL
10421 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
10422 C general process information
10423 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
10424 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
10425 C event weights and generated cross section
10426 INTEGER IPOWGC,ISWCUT,IVWGHT
10427 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
10428 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
10429 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
10431 DOUBLE PRECISION PRO,XPROB,SIGSDI,CALLS,SIGSUM,ECMSUM
10432 DIMENSION PRO(8,4),XPROB(8),SIGSDI(2)
10433 DIMENSION CALLS(4),SIGSUM(4),ECMSUM(4)
10436 DOUBLE PRECISION DT_RNDM
10437 DOUBLE PRECISION SIGDDI,SIGHD,SIGHR,SIGNDR,XI
10439 IF(IDEB(11).GE.15) WRITE(LO,'(/,1X,A,/5X,I3,2I6,1P4E11.3)')
10440 & 'PHO_SAMPRO: called with IP,IFP1/2,ECM,PVIR1/2,SPROB',
10441 & IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB
10443 IF(IPROC.GE.0) THEN
10445 C interpolate cross sections
10446 CALL PHO_CSINT(IP,IFP1,IFP2,-1,-1,ECM,PVIR1,PVIR2)
10449 IF((IP.EQ.1).and.((SPROB.gt.1.D0).or.(SPROB.lt.0.D0))) THEN
10450 WRITE(LO,'(/,1X,A,/5X,I12,I3,2I6,1P4E11.3)')
10451 & 'PHO_SAMPRO: inconsistent gap survival probability',
10452 & 'EVENT,IP,IFP1/2,ECM,PVIR1/2,SPROB:',
10453 & KEVENT,IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB
10456 C calculate cumulative probabilities
10457 IF(ISWMDL(1).EQ.3) THEN
10458 IF(ISWMDL(2).GE.1) THEN
10459 SIGSDI(1) = SIGLSD(1)+SIGHSD(1)
10460 SIGSDI(2) = SIGLSD(2)+SIGHSD(2)
10461 SIGDDI = SIGLDD+SIGHDD
10462 SIGNDR = SIGINE-SIGVM(0,0)-SIGCDF(0)-SIGDIR
10463 & - SIGSDI(1)-SIGSDI(2)-SIGDDI
10464 XPROB(1) = SIGNDR*SPROB*DBLE(IPRON(1,IP))
10465 XPROB(2) = XPROB(1)+SIGELA*SPROB*DBLE(IPRON(2,IP))
10466 XPROB(3) = XPROB(2)+SIGVM(0,0)*SPROB*DBLE(IPRON(3,IP))
10467 XPROB(4) = XPROB(3)+SIGCDF(0)*SPROB*DBLE(IPRON(4,IP))
10468 XPROB(5) = XPROB(4)+SIGSDI(1)*SPROB*DBLE(IPRON(5,IP))
10469 XPROB(6) = XPROB(5)+SIGSDI(2)*SPROB*DBLE(IPRON(6,IP))
10470 XPROB(7) = XPROB(6)+SIGDDI*SPROB*DBLE(IPRON(7,IP))
10471 XPROB(8) = XPROB(7)+SIGDIR*DBLE(IPRON(8,IP))
10474 IF(IPRON(1,IP).EQ.1) SIGHR = SIGHAR
10476 IF(IPRON(8,IP).EQ.1) SIGHD = SIGDIR
10477 XPROB(1) = SIGHR/(SIGHR+SIGHD)
10478 XPROB(2) = XPROB(1)
10479 XPROB(3) = XPROB(1)
10480 XPROB(4) = XPROB(1)
10481 XPROB(5) = XPROB(1)
10482 XPROB(6) = XPROB(1)
10483 XPROB(7) = XPROB(1)
10484 XPROB(8) = XPROB(1)+SIGHD/(SIGHR+SIGHD)
10487 IF(IDEB(11).GE.15) THEN
10488 WRITE(LO,'(1X,A,I3)')
10489 & 'PHO_SAMPRO: partial cross sections for IP',IP
10490 WRITE(LO,'(5X,I3,2X,1PE12.4)') 1,XPROB(1)
10492 WRITE(LO,'(5X,I3,2X,1PE12.4)') I,XPROB(I)-XPROB(I-1)
10497 WRITE(LO,'(/,1X,A,I4)') 'PHO_SAMPRO:ERROR: unsupported model',
10502 IF(XPROB(8).LT.1.D-20) THEN
10504 & WRITE(LO,'(1X,2A,/10X,A,1P3E11.3)') 'PHO_SAMPRO:ERROR: ',
10505 & 'activated processes have vanishing cross section sum',
10506 & 'IP,ECM,SIG_sum:',IP,ECM,XPROB(8)
10512 XI = DT_RNDM(XI)*XPROB(8)
10514 IF(XI.LE.XPROB(I)) GOTO 110
10519 CALLS(IP) = CALLS(IP)+1.D0
10520 PRO(IPROC,IP) = PRO(IPROC,IP)+1.D0
10521 ECMSUM(IP) = ECMSUM(IP)+ECM
10522 IF(ISWMDL(2).GE.1) THEN
10523 SIGSUM(IP) = SIGSUM(IP)+XPROB(8)
10525 SIGSUM(IP) = SIGSUM(IP)+SIGGEN(3)
10529 IF(IDEB(11).GE.5) WRITE(LO,'(1X,A,I3,I12,I4)')
10530 & 'PHO_SAMPRO: IP,CALL,PROC-ID',
10531 & IP,INT(CALLS(IP)+0.1D0),IPROC
10533 C statistics initialization
10534 ELSE IF(IPROC.EQ.-1) THEN
10544 C write out statistics
10545 ELSE IF(IPROC.EQ.-2) THEN
10547 IF(ISWMDL(2).EQ.0) KMAX=1
10549 IF(CALLS(K).GT.0.5D0) THEN
10550 SIGSUM(K) = SIGSUM(K)/CALLS(K)**2
10551 ECMSUM(K) = ECMSUM(K)/CALLS(K)
10552 IF(IDEB(11).GE.0) THEN
10553 WRITE(LO,'(/,1X,2A,I4,1PE12.3,/,1X,A)')
10554 & 'PHO_SAMPRO: internal process statistics ',
10555 & '(IP,<Ecm>)',K,ECMSUM(K),
10556 & '---------------------------------------'
10558 & ' process sampled cross section'
10559 IF(ISWMDL(2).GE.1) THEN
10560 WRITE(LO,'(9(/5X,A,0PF12.0,5X,1PE12.3))')
10561 & ' all processes',CALLS(K),CALLS(K)*SIGSUM(K),
10562 & ' nondif.inelastic',PRO(1,K),PRO(1,K)*SIGSUM(K),
10563 & ' elastic',PRO(2,K),PRO(2,K)*SIGSUM(K),
10564 & 'vmeson production',PRO(3,K),PRO(3,K)*SIGSUM(K),
10565 & ' double pomeron',PRO(4,K),PRO(4,K)*SIGSUM(K),
10566 & ' single diffr.(1)',PRO(5,K),PRO(5,K)*SIGSUM(K),
10567 & ' single diffr.(2)',PRO(6,K),PRO(6,K)*SIGSUM(K),
10568 & ' double diffract.',PRO(7,K),PRO(7,K)*SIGSUM(K),
10569 & ' direct processes',PRO(8,K),PRO(8,K)*SIGSUM(K)
10571 WRITE(LO,'(3(/5X,A,0PF12.0,5X,1PE12.3))')
10572 & ' all processes',CALLS(K),CALLS(K)*SIGSUM(K),
10573 & ' double resolved',PRO(1,K),PRO(1,K)*SIGSUM(K),
10574 & ' single res + dir',PRO(8,K),PRO(8,K)*SIGSUM(K)
10583 *$ CREATE PHO_SAMPRB.FOR
10585 CDECK ID>, PHO_SAMPRB
10586 SUBROUTINE PHO_SAMPRB(ECMI,IP,ISAM,JSAM,KSAM)
10587 C********************************************************************
10589 C routine to sample number of cut graphs of different kind
10591 C input: IP scattering particle combination
10593 C IP -1 initialization
10594 C -2 output of statistics
10595 C others sampling of cuts
10597 C output: ISAM number of soft Pomerons cut
10598 C JSAM number of soft Reggeons cut
10599 C KSAM number of hard Pomerons cut
10601 C PHO_PRBDIS has to be called before
10603 C********************************************************************
10604 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10607 C input/output channels
10609 COMMON /POINOU/ LI,LO
10610 C event debugging information
10612 PARAMETER (NMAXD=100)
10613 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
10614 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10615 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
10616 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10617 C model switches and parameters
10619 INTEGER ISWMDL,IPAMDL
10620 DOUBLE PRECISION PARMDL
10621 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
10622 C general process information
10623 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
10624 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
10625 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
10626 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
10627 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
10628 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
10629 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
10630 C obsolete cut-off information
10631 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
10632 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10633 C cut probability distribution
10634 INTEGER IEETA1,IIMAX,KKMAX
10635 PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
10636 INTEGER IEEMAX,IMAX,KMAX
10638 DOUBLE PRECISION EPTAB
10639 COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
10641 C global event kinematics and particle IDs
10642 INTEGER IFPAP,IFPAB
10643 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
10644 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
10646 INTEGER IPFIL,IFAFIL,IFBFIL
10647 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
10648 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
10649 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
10650 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
10651 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
10652 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
10653 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
10654 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
10655 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
10656 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
10657 & IPFIL,IFAFIL,IFBFIL
10658 C table of particle indices for recursive PHOJET calls
10660 PARAMETER ( MAXIPX = 100 )
10661 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
10662 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
10663 & IPOIX1,IPOIX2,IPOIX3
10665 DIMENSION ECMS1(4),ECMS2(4),AVERB(0:3,4),AVERC(0:3,4)
10667 C sample number of interactions
10673 IF((IPAMDL(13).GT.0).AND.(IPROCE.EQ.1).AND.(IPOIX3.EQ.0)) THEN
10674 IF(IPAMDL(16).EQ.0) ECMC = SECM
10678 C sample up to kinematic limits only
10679 IMAX1 = MIN(IMAX,INT(0.4D0*ECMC/PARMDL(161)))
10680 IF(IMAX1.LT.1) THEN
10681 IF(IPAMDL(2).EQ.1) THEN
10686 AVERB(3,IP) = AVERB(3,IP)+1.D0
10688 C only pomeron even at very low energies
10692 AVERB(1,IP) = AVERB(1,IP)+1.D0
10694 AVERB(0,IP) = AVERB(0,IP)+1.D0
10697 C find interpolation factors
10698 IF(ECMX.LE.EPTAB(IP,1)) THEN
10701 ELSE IF(ECMX.LT.EPTAB(IP,IEEMAX)) THEN
10703 IF(ECMX.LE.EPTAB(IP,I)) GOTO 200
10709 WRITE(LO,'(/1X,A,2E12.3)')
10710 & 'PHO_SAMPRB:too high energy',ECMX,EPTAB(IP,IEEMAX)
10711 CALL PHO_PREVNT(-1)
10717 & FAC2=LOG(ECMX/EPTAB(IP,I1))/LOG(EPTAB(IP,I2)/EPTAB(IP,I1))
10719 C reggeon probability
10720 PREG = -(PROB(IP,I1,0,0)*FAC1+PROB(IP,I2,0,0)*FAC2)
10721 C calculate soft suppression factor
10722 IF(IP.EQ.1) FSUPP = PARMDL(35)**2
10723 & /((PVIRT(1)+PARMDL(35))*(PVIRT(2)+PARMDL(35)))
10730 PRO = PROB(IP,I1,ISAM,KSAM)*FAC1
10731 & +PROB(IP,I2,ISAM,KSAM)*FAC2
10732 IF(PRO.GT.XI) GOTO 100
10735 ISAM = MIN(IMAX,ISAM)
10736 KSAM = MIN(KMAX,KSAM)
10740 IF(ITER.GT.100) THEN
10745 IF(IDEB(12).GE.3) WRITE(LO,'(1X,A,I10,E11.3,I6)')
10746 & 'PHO_SAMPRB: rejection (EV,ECM,ITER)',KEVENT,ECMX,ITER
10750 C reggeon contribution
10752 IF(IPAMDL(2).EQ.1) THEN
10754 IF(DT_RNDM(PRO).LT.PREG) JSAM = JSAM+1
10758 C statistics of bare cuts
10760 AVERB(0,IP) = AVERB(0,IP)+1.D0
10761 AVERB(1,IP) = AVERB(1,IP)+DBLE(ISAM)
10762 AVERB(2,IP) = AVERB(2,IP)+DBLE(KSAM)
10763 AVERB(3,IP) = AVERB(3,IP)+DBLE(JSAM)
10765 C limitation given by field dimensions
10766 IF((2*ISAM+JSAM+3*KSAM).GT.50) GOTO 10
10770 C reweight according to virtualities and PDF treatment
10771 IF(IPAMDL(115).GE.1) THEN
10773 IF(FSUP(1)*FSUP(2).LT.DT_RNDM(ECMI)) GOTO 10
10777 C reduce number of cuts according to photon virtualities
10778 IF(IPAMDL(114).GE.1) THEN
10782 IF(DT_RNDM(WGX).GT.WGX) THEN
10783 IF(ISAM+JSAM+KSAM.GT.1) THEN
10787 ELSE IF(ISAM.GT.0) THEN
10797 C phase space limitation
10799 XM = DBLE(2*ISAM+JSAM)*PARMDL(160+IP)
10800 & +DBLE(2*KSAM)*PTCUT(IP)
10801 PACC = EXP(PARMDL(9)*(PARMDL(160+IP)-XM)/ECMC)
10802 IF(DT_RNDM(XM).GT.PACC) THEN
10803 IF(ISAM+JSAM+KSAM.GT.1) THEN
10807 ELSE IF(ISAM.GT.0) THEN
10810 ELSE IF(KSAM.GT.KLIM) THEN
10821 C collect statistics
10823 ECMS1(IP) = ECMS1(IP)+ECMX
10824 ECMS2(IP) = ECMS2(IP)+ECMC
10826 AVERC(0,IP) = AVERC(0,IP)+1.D0
10827 AVERC(1,IP) = AVERC(1,IP)+DBLE(ISAM)
10828 AVERC(2,IP) = AVERC(2,IP)+DBLE(KSAM)
10829 AVERC(3,IP) = AVERC(3,IP)+DBLE(JSAM)
10831 IF(IDEB(12).GE.10) WRITE(LO,'(1X,A,2E11.4,3I4)')
10832 & 'PHO_SAMPRB: ECM,I,J,K',ECM,ECMX,ISAM,JSAM,KSAM
10834 C initialize statistics
10835 ELSE IF(IP.EQ.-1) THEN
10847 C write out statistics
10848 ELSE IF(IP.EQ.-2) THEN
10849 WRITE(LO,'(2(/1X,A))') 'PHO_SAMPRB: interaction statistics',
10850 & '----------------------------------'
10852 IF(AVERB(0,I).LT.2.D0) GOTO 75
10853 WRITE(LO,'(1X,A,I3,1P,2E13.3)')
10854 & 'statistics for IP,<Ecm_1>,<Ecm_2>',I,
10855 & ECMS1(I)/MAX(AVERB(0,I),1.D0),ECMS2(I)/MAX(AVERB(0,I),1.D0)
10857 & 'average number of s-pom,h-pom,reg cuts (bare)'
10858 WRITE(LO,'(5X,F12.0,1P3E12.4)') AVERB(0,I),
10859 & (AVERB(K,I)/AVERB(0,I),K=1,3)
10861 & 'average (with energy/virtuality corrections)'
10862 WRITE(LO,'(5X,F12.0,1P3E12.4)') AVERC(0,I),
10863 & (AVERC(K,I)/AVERC(0,I),K=1,3)
10871 *$ CREATE PHO_TRIREG.FOR
10873 CDECK ID>, PHO_TRIREG
10874 SUBROUTINE PHO_TRIREG(S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP,VIR2A,
10876 C**********************************************************************
10878 C calculation of triple-Pomeron total cross section
10879 C according to Gribov's Regge theory
10881 C input: S squared cms energy
10882 C GA coupling constant to diffractive line
10883 C AA slope related to GA (GeV**-2)
10884 C GB coupling constant to elastic line
10885 C BB slope related to GB (GeV**-2)
10886 C DELTA effective pomeron delta (intercept-1)
10887 C ALPHAP slope of pomeron trajectory (GeV**-2)
10888 C GPPP triple-Pomeron coupling
10889 C BPPP slope related to B0PPP (GeV**-2)
10890 C VIR2A virtuality of particle a (GeV**2)
10891 C note: units of all coupling constants are mb**1/2
10893 C output: SIGTR total triple-Pomeron cross section
10894 C BTR effective triple-Pomeron slope
10895 C (differs from diffractive slope!)
10897 C uses E_i (Exponential-Integral function)
10899 C**********************************************************************
10900 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10903 PARAMETER (EPS =0.0001D0)
10905 C input/output channels
10907 COMMON /POINOU/ LI,LO
10908 C event debugging information
10910 PARAMETER (NMAXD=100)
10911 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
10912 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10913 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
10914 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10916 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
10917 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
10918 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
10920 C integration cut-off Sigma_U ( see Nucl.Phys.B97(1975)493 )
10922 C integration cut-off Sigma_L (min. squared mass of diff. blob)
10925 IF(IDEB(50).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
10926 & 'PHO_TRIREG: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP ',
10927 & S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
10934 C change units of ALPHAP to mb
10935 ALSCA = ALPHAP*GEV2MB
10938 PART1=GA*GB**2*GPPP/(16.*PI*2.*ALSCA)*S**DELTA*
10939 & EXP(-(BB+BPPP)/(2.*ALPHAP)*DELTA)
10940 PART2=PHO_EXPINT(((BB+BPPP)/(2.*ALPHAP)+LOG(S/SIGL))*DELTA)
10941 PART3=PHO_EXPINT(((BB+BPPP)/(2.*ALPHAP)+LOG(SIGU))*DELTA)
10943 SIGTR=PART1*(PART2-PART3)
10946 PART1 = (BB+BPPP+2.*ALPHAP*LOG(S/SIGL))/
10947 & (BB+BPPP+2.*ALPHAP*LOG(SIGU))
10949 PART1 = 0.5D0*ALPHAP*LOG(1.D0+S/(SIGU*SIGL))/PART2
10950 BTR = (AA+BB/2.D0)/2.D0+BPPP+ALPHAP*LOG(S/4.D0)
10953 IF(SIGTR.LT.EPS) SIGTR = 0.D0
10954 IF(BTR.LT.BB) BTR = BB
10956 IF(IDEB(50).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
10957 & 'PHO_TRIREG: ENERGY,SIGTR,BTR ',SQRT(S),SIGTR,BTR
10960 *$ CREATE PHO_LOOREG.FOR
10962 CDECK ID>, PHO_LOOREG
10963 SUBROUTINE PHO_LOOREG(S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP,
10964 & VIR2A,VIR2B,SIGLO,BLO)
10965 C**********************************************************************
10967 C calculation of loop-Pomeron total cross section
10968 C according to Gribov's Regge theory
10970 C input: S squared cms energy
10971 C GA coupling constant to diffractive line
10972 C AA slope related to GA (GeV**-2)
10973 C GB coupling constant to elastic line
10974 C BB slope related to GB (GeV**-2)
10975 C DELTA effective pomeron delta (intercept-1)
10976 C ALPHAP slope of pomeron trajectory (GeV**-2)
10977 C GPPP triple-Pomeron coupling
10978 C BPPP slope related to B0PPP (GeV**-2)
10979 C VIR2A virtuality of particle a (GeV**2)
10980 C VIR2B virtuality of particle b (GeV**2)
10981 C note: units of all coupling constants are mb**1/2
10983 C output: SIGLO total loop-Pomeron cross section
10984 C BLO effective loop-Pomeron slope
10985 C (differs from double diffractive slope!)
10987 C uses E_i (Exponential-Integral function)
10989 C**********************************************************************
10990 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10993 PARAMETER (EPS =0.0001D0)
10995 C input/output channels
10997 COMMON /POINOU/ LI,LO
10998 C event debugging information
11000 PARAMETER (NMAXD=100)
11001 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11002 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11003 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11004 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11006 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
11007 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
11008 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
11010 C integration cut-off Sigma_U ( see Nucl.Phys.B97(1975)493 )
11012 C integration cut-off Sigma_L (min. squared mass of diff. blob)
11013 SIGL = 5.+VIR2A+VIR2B
11015 IF(IDEB(51).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
11016 & 'PHO_LOOREG: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP ',
11017 & S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
11026 C change units of ALPHAP to mb
11027 ALSCA = ALPHAP*GEV2MB
11030 PART1=GA*GB*GPPP**2/(16.*PI*2.*ALSCA)*S**DELTA*
11031 & EXP(-DELTA*BPPP/ALPHAP)
11032 PARTA=BPPP/ALPHAP+LOG(S/SIGL**2)
11033 PARTB=BPPP/ALPHAP+LOG(SIGU)
11034 SIGLO=PART1*(PARTA*(PHO_EXPINT(PARTA*DELTA)
11035 & -PHO_EXPINT(PARTB*DELTA))
11036 & +EXP(PARTA*DELTA)/DELTA-EXP(PARTB*DELTA)/DELTA
11040 PART1 = LOG(ABS(PARTA/PARTB))
11041 & *(PARTA-LOG(1.D0+S/(SIGL**2*SIGU)))
11042 PART1 = 0.25*ALPHAP*LOG(1.D0+S/(SIGU*SIGL))**2/PART1
11043 BLO = (AA+BB)/2.+2.*BPPP+ALPHAP*LOG(S/4.D0)
11046 IF(SIGLO.LT.EPS) SIGLO = 0.D0
11047 IF(BLO.LT.2.D0*BPPP) BLO = 2.D0*BPPP
11049 IF(IDEB(51).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
11050 & 'PHO_LOOREG: ENERGY,SIGLO,BLO',SQRT(S),SIGLO,BLO
11053 *$ CREATE PHO_TRXPOM.FOR
11055 CDECK ID>, PHO_TRXPOM
11056 SUBROUTINE PHO_TRXPOM(S,GA,AA,GB,BB,DELTA,ALPHAP,
11057 & GPPP,BPPP,SIGDP,BDP)
11058 C**********************************************************************
11060 C calculation of total cross section of two tripe-Pomeron
11061 C graphs in X configuration according to Gribov's Reggeon field
11064 C input: S squared cms energy
11065 C GA coupling constant to elastic line 1
11066 C AA slope related to GA (GeV**-2)
11067 C GB coupling constant to elastic line 2
11068 C BB slope related to GB (GeV**-2)
11069 C DELTA effective pomeron delta (intercept-1)
11070 C ALPHAP slope of pomeron trajectory (GeV**-2)
11071 C BPPP triple-Pomeron coupling
11072 C BTR slope related to B0PPP (GeV**-2)
11073 C note: units of all coupling constants are mb**1/2
11075 C output: SIGDP total cross section for double-Pomeron
11077 C BDP effective double-Pomeron slope
11079 C**********************************************************************
11080 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11083 PARAMETER (EPS =0.0001D0)
11085 C input/output channels
11087 COMMON /POINOU/ LI,LO
11088 C event debugging information
11090 PARAMETER (NMAXD=100)
11091 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11092 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11093 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11094 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11095 C model switches and parameters
11097 INTEGER ISWMDL,IPAMDL
11098 DOUBLE PRECISION PARMDL
11099 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11101 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
11102 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
11103 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
11105 DIMENSION XWGH1(96),XPOS1(96)
11107 C lower integration cut-off Sigma_L
11108 SIGL = PARMDL(71)**2
11109 C upper integration cut-off Sigma_U
11110 C = 1.D0-1.D0/PARMDL(70)**2
11111 C = MAX(PARMDL(72),C)
11112 SIGU = (1.D0-C)**2*S
11113 C integration precision
11117 IF(IDEB(52).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
11118 & 'PHO_TRXPOM: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP',
11119 & S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
11121 IF(SIGU.LE.SIGL) THEN
11132 FAC = (GPPP*GA*GB)**2/(256.D0*PI2)/ALPHAP/GEV2MB**2
11133 ALPHA2 = 2.D0*ALPHAP
11134 ALOC = LOG(1.D0/(1.D0-C))
11135 CALL PHO_GAUSET(XIL,XIU,NGAUS1,XPOS1,XWGH1)
11138 AMXSQ = EXP(XPOS1(I1))
11139 ALOSMX = LOG(S/AMXSQ)
11140 ALCSMX = LOG((1.D0-C)*S/AMXSQ)
11141 W = LOG((AA+BPPP+ALPHA2*ALCSMX)/(BB+BPPP+ALPHA2*ALOC))
11143 WN=(AA+BB+2.D0*BPPP+ALPHA2*ALOSMX)
11144 C supercritical part
11145 WSC = AMXSQ**DELTA*(S/AMXSQ)**(2.D0*DELTA)
11146 XSUM = XSUM + W*XWGH1(I1)/WN*WSC
11151 BDP = 0.5*(AA+BB+BPPP+ALPHAP*XI)
11153 IF(IDEB(52).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
11154 & 'PHO_TRXPOM: ENERGY,SIGDP,BDP',SQRT(S),SIGDP,BDP
11157 *$ CREATE PHO_CHAN2A.FOR
11159 CDECK ID>, PHO_CHAN2A
11160 SUBROUTINE PHO_CHAN2A(BB)
11161 C***********************************************************************
11163 C simple two channel model to realize low mass diffraction
11164 C (version A, iteration of triple- and loop-Pomeron)
11166 C input: BB impact parameter (mb**1/2)
11169 C AMPEL elastic amplitude
11170 C AMPVM(4,4) q-elastic VM production
11171 C AMLMSD(2) low mass single diffraction amplitude
11172 C AMHMSD(2) high mass single diffraction amplitude
11173 C AMLMDD low mass double diffraction amplitude
11174 C AMHMDD high mass double diffraction amplitude
11175 C AMPDP(4) central diffraction amplitude
11177 C***********************************************************************
11178 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11181 PARAMETER (DEPS = 1.D-5,
11184 C input/output channels
11186 COMMON /POINOU/ LI,LO
11187 C event debugging information
11189 PARAMETER (NMAXD=100)
11190 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11191 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11192 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11193 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11194 C model switches and parameters
11196 INTEGER ISWMDL,IPAMDL
11197 DOUBLE PRECISION PARMDL
11198 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11200 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
11201 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
11202 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
11203 C complex Born graph amplitudes used for unitarization
11204 COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
11206 COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
11207 & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
11208 C unitarized amplitudes for different diffraction channels
11209 DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
11210 & ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
11211 & ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
11213 COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
11214 & ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
11215 & ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
11216 & ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
11217 & ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
11218 & ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
11219 & ZXL(4,4),BXL(4,4)
11220 C Reggeon phenomenology parameters
11221 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
11222 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
11223 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
11224 & ALREG,ALREGP,GR(2),B0REG(2),
11225 & GPPP,GPPR,B0PPP,B0PPR,
11226 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
11227 C parameters of 2x2 channel model
11228 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
11229 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
11230 C global event kinematics and particle IDs
11231 INTEGER IFPAP,IFPAB
11232 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
11233 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
11236 DIMENSION AB(9,4),CHI(4),CHDS(4),CHDH(4),CHDA(4),CHDB(4),
11237 & CHDD(4),CHDPE(4),CHDPA(4),CHDPB(4),CHDPD(4),
11238 & AMPCHA(4),EX1CHI(4),EX2CHI(4),ABSUM(4),AMPELA(4,0:9)
11239 DIMENSION CHIFAC(4,4),EXPFAC(4,4),IELTAB(4,4)
11241 C combinatorical factors
11242 DATA CHIFAC / 1.D0, 1.D0,-1.D0,-1.D0,
11243 & 1.D0,-1.D0, 1.D0,-1.D0,
11244 & 1.D0,-1.D0,-1.D0, 1.D0,
11245 & 1.D0, 1.D0, 1.D0, 1.D0 /
11246 DATA EXPFAC / 1.D0, 1.D0, 1.D0, 1.D0,
11247 & 1.D0,-1.D0,-1.D0, 1.D0,
11248 & -1.D0, 1.D0,-1.D0, 1.D0,
11249 & -1.D0,-1.D0, 1.D0, 1.D0 /
11250 DATA IELTAB / 1, 2, 3, 4,
11255 IF(IDEB(86).GE.20) WRITE(LO,'(1X,A,E12.3)')
11256 & 'PHO_CHAN2A: impact parameter B',BB
11260 AB(1,I) = ZXP(1,I)*EXP(-B24/BXP(1,I))
11261 & +ZXR(1,I)*EXP(-B24/BXR(1,I))
11262 AB(2,I) = ZXH(1,I)*EXP(-B24/BXH(1,I))
11263 AB(3,I) =-ZXT1A(1,I)*EXP(-B24/BXT1A(1,I))
11264 AB(4,I) =-ZXT2A(1,I)*EXP(-B24/BXT2A(1,I))
11265 AB(5,I) =-ZXL(1,I)*EXP(-B24/BXL(1,I))
11266 & -ZXT1B(1,I)*EXP(-B24/BXT1B(1,I))
11267 & -ZXT2B(1,I)*EXP(-B24/BXT2B(1,I))
11268 AB(6,I) = ZXDPE(1,I)*EXP(-B24/BXDPE(1,I))
11269 AB(7,I) = ZXDPA(1,I)*EXP(-B24/BXDPA(1,I))
11270 AB(8,I) = ZXDPB(1,I)*EXP(-B24/BXDPB(1,I))
11271 AB(9,I) = ZXDPD(1,I)*EXP(-B24/BXDPD(1,I))
11277 ABSUM(I) = ABSUM(I) + AB(II,I)
11280 IF(IDEB(86).GE.20) WRITE(LO,'(1X,A,4E12.3)')
11281 & 'PHO_CHAN2A: ABSUM',ABSUM
11298 AMPELA(I,K+4) = 0.D0
11300 CHI(I) = CHI(I) + CHIFAC(K,I)*ABSUM(K)
11301 CHDS(I) = CHDS(I) + CHIFAC(K,I)*AB(1,K)
11302 CHDH(I) = CHDH(I) + CHIFAC(K,I)*AB(2,K)
11303 CHDA(I) = CHDA(I) + CHIFAC(K,I)*AB(3,K)
11304 CHDB(I) = CHDB(I) + CHIFAC(K,I)*AB(4,K)
11305 CHDD(I) = CHDD(I) + CHIFAC(K,I)*AB(5,K)
11306 CHDPE(I) = CHDPE(I) + CHIFAC(K,I)*AB(6,K)
11307 CHDPA(I) = CHDPA(I) + CHIFAC(K,I)*AB(7,K)
11308 CHDPB(I) = CHDPB(I) + CHIFAC(K,I)*AB(8,K)
11309 CHDPD(I) = CHDPD(I) + CHIFAC(K,I)*AB(9,K)
11311 IF(CHI(I).LT.-DEPS) THEN
11312 IF(IDEB(86).GE.0) THEN
11313 WRITE(LO,'(1X,A,I3,2E12.3)')
11314 & 'PHO_CHAN2A: neg.eigenvalue (I,B,CHI)',I,BB,CHI(I)
11315 WRITE(LO,'(5X,A,5E12.3)') 'E,CHIs:',ECM,(ABSUM(K),K=1,4)
11318 IF(ABS(CHI(I)).GT.200.D0) THEN
11324 EX2CHI(I) = TMP*TMP
11327 IF(IDEB(86).GE.20) THEN
11328 WRITE(LO,'(1X,A,4E12.3)') 'PHO_CHAN2A: EX1CHI',EX1CHI
11334 CFAC = 2.D0*EXPFAC(J,K)*EX2CHI(J)
11335 AMPELA(K,0) = AMPELA(K,0) - EXPFAC(J,K)*EX1CHI(J)
11336 AMPELA(K,1) = AMPELA(K,1) + CFAC*CHDS(J)
11337 AMPELA(K,2) = AMPELA(K,2) + CFAC*CHDH(J)
11338 AMPELA(K,3) = AMPELA(K,3) - CFAC*CHDA(J)
11339 AMPELA(K,4) = AMPELA(K,4) - CFAC*CHDB(J)
11340 AMPELA(K,5) = AMPELA(K,5) - CFAC*CHDD(J)
11341 AMPELA(K,6) = AMPELA(K,6) + CFAC*CHDPE(J)
11342 AMPELA(K,7) = AMPELA(K,7) + CFAC*CHDPA(J)
11343 AMPELA(K,8) = AMPELA(K,8) + CFAC*CHDPB(J)
11344 AMPELA(K,9) = AMPELA(K,9) + CFAC*CHDPD(J)
11348 IF(IDEB(86).GE.25) THEN
11350 WRITE(LO,'(1X,A,I3,4E10.3)') 'PHO_CHAN2A: AMPELA(1-4,I)',I,
11351 & (AMPELA(K,1),K=1,4)
11355 C VDM factors --> amplitudes
11356 C low mass excitations
11360 AMPCHA(I) = AMPCHA(I) + AMPFAC(K)*AMPELA(IELTAB(K,I),0)
11363 AMPVME = AMPCHA(1)/EIGHT
11364 AMLMSD(1) = AMPCHA(2)/EIGHT
11365 AMLMSD(2) = AMPCHA(3)/EIGHT
11366 AMLMDD = AMPCHA(4)/EIGHT
11367 C elastic part, high mass diffraction
11368 AMPEL = 0.5D0*ZXD(1,1)*EXP(-B24/BXD(1,1))
11379 AMPEL = AMPEL + ELAFAC(I)*AMPELA(I,0)/8.D0
11380 AMPSOF = AMPSOF + ELAFAC(I)*AMPELA(I,1)
11381 AMPHAR = AMPHAR + ELAFAC(I)*AMPELA(I,2)
11382 AMHMSD(1) = AMHMSD(1) + ELAFAC(I)*AMPELA(I,3)
11383 AMHMSD(2) = AMHMSD(2) + ELAFAC(I)*AMPELA(I,4)
11384 AMHMDD = AMHMDD + ELAFAC(I)*AMPELA(I,5)
11385 AMPDP(1) = AMPDP(1) + ELAFAC(I)*AMPELA(I,6)
11386 AMPDP(2) = AMPDP(2) + ELAFAC(I)*AMPELA(I,7)
11387 AMPDP(3) = AMPDP(3) + ELAFAC(I)*AMPELA(I,8)
11388 AMPDP(4) = AMPDP(4) + ELAFAC(I)*AMPELA(I,9)
11390 AMPSOF = AMPSOF/16.D0
11391 AMPHAR = AMPHAR/16.D0
11392 AMHMSD(1) = AMHMSD(1)/16.D0
11393 AMHMSD(2) = AMHMSD(2)/16.D0
11394 AMHMDD = AMHMDD/16.D0
11395 AMPDP(1) = AMPDP(1)/16.D0
11396 AMPDP(2) = AMPDP(2)/16.D0
11397 AMPDP(3) = AMPDP(3)/16.D0
11398 AMPDP(4) = AMPDP(4)/16.D0
11399 IF(DREAL(AMHMSD(1)).LE.0.D0) AMHMSD(1) = 0.D0
11400 IF(DREAL(AMHMSD(2)).LE.0.D0) AMHMSD(2) = 0.D0
11401 IF(DREAL(AMHMDD).LE.0.D0) AMHMDD = 0.D0
11402 IF(DREAL(AMPDP(1)).LE.0.D0) AMPDP(1) = 0.D0
11403 IF(DREAL(AMPDP(2)).LE.0.D0) AMPDP(2) = 0.D0
11404 IF(DREAL(AMPDP(3)).LE.0.D0) AMPDP(3) = 0.D0
11405 IF(DREAL(AMPDP(4)).LE.0.D0) AMPDP(4) = 0.D0
11407 C vector-meson production, weight factors
11408 IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22)) THEN
11409 IF(IFPAP(1).EQ.22) THEN
11410 IF(IFPAP(2).EQ.22) THEN
11413 AMPVM(I,J) = PARMDL(9+I)*PARMDL(9+J)*AMPVME
11417 AMPVM(1,1) = PARMDL(10)*AMPVME
11418 AMPVM(2,1) = PARMDL(11)*AMPVME
11419 AMPVM(3,1) = PARMDL(12)*AMPVME
11420 AMPVM(4,1) = PARMDL(13)*AMPVME
11422 ELSE IF(IFPAP(2).EQ.22) THEN
11423 AMPVM(1,1) = PARMDL(10)*AMPVME
11424 AMPVM(1,2) = PARMDL(11)*AMPVME
11425 AMPVM(1,3) = PARMDL(12)*AMPVME
11426 AMPVM(1,4) = PARMDL(13)*AMPVME
11430 IF(IDEB(86).GE.5) THEN
11431 WRITE(LO,'(/,1X,A)')
11432 & 'PHO_CHAN2A: impact parameter amplitudes'
11433 WRITE(LO,'(1X,A,1P,2E12.3)') ' AMPEL',AMPEL
11434 WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(1,1-4)',(AMPVM(1,K),K=1,4)
11435 WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(2,1-4)',(AMPVM(2,K),K=1,4)
11436 WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(3,1-4)',(AMPVM(3,K),K=1,4)
11437 WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(4,1-4)',(AMPVM(4,K),K=1,4)
11438 WRITE(LO,'(1X,A,1P,4E12.3)') ' AMPSOF/HAR',AMPSOF,AMPHAR
11439 WRITE(LO,'(1X,A,1P,4E12.3)') ' AMLMSD',AMLMSD
11440 WRITE(LO,'(1X,A,1P,4E12.3)') ' AMHMSD',AMHMSD
11441 WRITE(LO,'(1X,A,1P,2E12.3)') ' AMLMDD',AMLMDD
11442 WRITE(LO,'(1X,A,1P,2E12.3)') ' AMHMDD',AMHMDD
11443 WRITE(LO,'(1X,A,1P,8E10.3)') ' AMPDP(1-4)',AMPDP
11448 *$ CREATE PHO_EVENT.FOR
11450 CDECK ID>, PHO_EVENT
11451 SUBROUTINE PHO_EVENT(NEV,P1,P2,FAC,IREJ)
11452 C********************************************************************
11454 C main subroutine to manage simulation processes
11456 C input: NEV -1 initialization
11457 C 1 generation of events
11458 C 2 generation of events without rejection
11459 C due to energy dependent cross section
11460 C 3 generation of events without rejection
11461 C using initialization energy
11462 C -2 output of event generation statistics
11463 C P1(4) momentum of particle 1 (internal TARGET)
11464 C P2(4) momentum of particle 2 (internal PROJECTILE)
11465 C FAC used for initialization:
11466 C contains cross section the events corresponds to
11467 C during generation: current cross section
11469 C output: IREJ 0: event accepted
11470 C 1: event rejected
11472 C********************************************************************
11473 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11476 PARAMETER ( TINY = 1.D-10 )
11478 DIMENSION P1(4),P2(4)
11480 C input/output channels
11482 COMMON /POINOU/ LI,LO
11483 C event debugging information
11485 PARAMETER (NMAXD=100)
11486 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11487 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11488 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11489 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11490 C model switches and parameters
11492 INTEGER ISWMDL,IPAMDL
11493 DOUBLE PRECISION PARMDL
11494 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11495 C general process information
11496 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
11497 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
11498 C internal rejection counters
11500 PARAMETER (NMXJ=60)
11501 CHARACTER*10 REJTIT
11503 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
11504 C gamma-lepton or gamma-hadron vertex information
11505 INTEGER IGHEL,IDPSRC,IDBSRC
11506 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
11507 & RADSRC,AMSRC,GAMSRC
11508 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
11509 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
11510 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
11511 C global event kinematics and particle IDs
11512 INTEGER IFPAP,IFPAB
11513 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
11514 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
11516 INTEGER IPFIL,IFAFIL,IFBFIL
11517 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
11518 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
11519 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
11520 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
11521 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
11522 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
11523 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
11524 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
11525 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
11526 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
11527 & IPFIL,IFAFIL,IFBFIL
11528 C event weights and generated cross section
11529 INTEGER IPOWGC,ISWCUT,IVWGHT
11530 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
11531 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
11532 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
11533 C names of hard scattering processes
11535 PARAMETER ( Max_pro_1 = 16 )
11537 COMMON /POHPRO/ PROC(0:Max_pro_1)
11538 C hard cross sections and MC selection weights
11540 PARAMETER ( Max_pro_2 = 16 )
11541 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
11542 & MH_acc_1,MH_acc_2
11543 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
11544 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
11545 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
11546 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
11547 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
11548 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
11549 C table of particle indices for recursive PHOJET calls
11551 PARAMETER ( MAXIPX = 100 )
11552 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
11553 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
11554 & IPOIX1,IPOIX2,IPOIX3
11556 DIMENSION IPRSAM(10),IPRACC(10),IENACC(10),IDNS(4),IDNA(4)
11562 WRITE(LO,'(/3(/1X,A))')
11563 & '=======================================================',
11564 & ' ------- initialization of event generation --------',
11565 & '======================================================='
11566 CALL PHO_SETMDL(0,0,-2)
11567 C amplitude parameters
11570 CALL PHO_REJSTA(-1)
11571 C initialize MC package
11572 CALL PHO_EVEINI(1,P1,P2,JM1,JM2)
11574 CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
11576 CALL PHO_PARTON(-1,0,0,P1,P2,IREJ)
11611 ELSE IF(NEV.GT.0) THEN
11613 C -------------- begin event generation ---------------
11616 IF(NEV.EQ.3) IPAMDL(13) = 1
11619 CALL PHO_TRACE(0,0,0)
11620 IF(IDEB(68).GE.2) THEN
11621 IF((MOD(KEVENT,50).EQ.0).OR.(IDEB(68).GE.3))
11622 & WRITE(LO,'(1X,A,2I12)') 'call to PHO_EVENT no',KEVENT,KACCEP
11624 CALL PHO_EVEINI(0,P1,P2,JM1,JM2)
11625 C cross section calculation
11628 IF(IVWGHT(1).EQ.1) THEN
11629 WG = EVWGHT(1)*SIGGEN(3)/SIGGEN(4)
11631 WG = SIGGEN(3)/SIGGEN(4)
11633 IF(DT_RNDM(FAC).GT.WG) THEN
11635 IF(IDEB(68).GE.6) THEN
11636 WRITE(LO,'(1X,2A,/5X,2I10,6X,1P3E10.3)')
11637 & 'PHO_EVENT: rejection due to cross section',
11638 & ' (CALL/ACC/EVWGHT(1)/SIG/SIGMAX)',
11639 & KEVENT,KACCEP,EVWGHT(1),SIGGEN(3),SIGGEN(4)
11640 CALL PHO_PREVNT(-1)
11646 SIGGEN(1) = SIGGEN(4)*DBLE(KEVGEN)/DBLE(KEVENT)
11647 HSWGHT(0) = MAX(1.D0,WG)
11652 IF(ITRY1.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
11656 CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
11658 IF(IPROCE.EQ.0) THEN
11659 IF(IDEB(68).GE.4) WRITE(LO,'(1X,A)') 'PHO_EVENT: ',
11660 & 'rejection by PHO_SAMPRO (call,Ecm)',KEVENT,ECM
11664 C sampling statistics
11665 IPRSAM(IPROCE) = IPRSAM(IPROCE)+1
11670 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
11671 C sample number of cut graphs according to IPROCE and
11672 C generate parton configurations+strings
11673 CALL PHO_PARTON(IPROCE,JM1,JM2,P1,P2,IREJ)
11674 C collect statistics
11678 ISTS = ISTS+KSTRG+KHTRG
11679 ISLS = ISLS+KSLOO+KHLOO
11680 IDIS = IDIS+MIN(KHDIR,1)
11681 IDPS = IDPS+KHDPO+KSDPO
11682 IF((IDIFR1+IDIFR2+IDDPOM.EQ.0).AND.(KHDIR.GT.0))
11683 & IDNS(KHDIR) = IDNS(KHDIR)+1
11686 IF(IDEB(68).GE.4) THEN
11687 WRITE(LO,'(/1X,A,2I5)')
11688 & 'PHO_EVENT: rejection by PHO_PARTON',ITRY2,IREJ
11689 CALL PHO_PREVNT(-1)
11691 IF((IREJ.EQ.50).AND.(NEV.EQ.1)) THEN
11694 IFAIL(1) = IFAIL(1)+1
11695 IF(ITRY1.GT.5) RETURN
11697 IF(ISWMDL(2).EQ.0) RETURN
11700 IF(ITRY2.LT.5) GOTO 60
11703 C fragmentation of strings
11705 C FSR and string fragmentation is done separately by DPMJET routines
11706 C CALL PHO_STRFRA(IREJ)
11710 IFAIL(23) = IFAIL(23)+1
11711 IF(IDEB(68).GE.4) THEN
11712 WRITE(LO,'(/1X,A,2I5)')
11713 & 'PHO_EVENT: rejection by PHO_STRFRA',ITRY2,IREJ
11714 CALL PHO_PREVNT(-1)
11718 C check of conservation of quantum numbers
11719 IF(IDEB(68).GE.-5) THEN
11720 CALL PHO_CHECK(-1,IREJ)
11721 IF(IREJ.NE.0) GOTO 50
11723 C event now completely processed and accepted
11724 C acceptance statistics
11725 IPRACC(IPROCE) = IPRACC(IPROCE)+1
11729 ISTA = ISTA+(KSTRG+KHTRG)
11730 ISLA = ISLA+(KSLOO+KHLOO)
11731 IDIA = IDIA+MIN(KHDIR,1)
11732 IDPA = IDPA+KHDPO+KSDPO
11733 IF((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GT.0))
11734 & IDNA(KHDIR) = IDNA(KHDIR)+1
11736 IENACC(IPORES(I)) = IENACC(IPORES(I))+1
11740 C debug output (partial / full event listing)
11741 if((IDEB(68).eq.1).and.(MOD(KACCEP,50).EQ.0))
11742 & WRITE(LO,'(1X,A,2I12)') 'call to PHO_EVENT no',KEVENT,KACCEP
11743 IF(IDEB(67).GE.10) THEN
11744 IF(IDEB(67).LE.15) THEN
11745 CALL PHO_PREVNT(-1)
11746 ELSE IF(IDEB(67).LE.20) THEN
11748 ELSE IF(IDEB(67).LE.25) THEN
11757 IF(IPOWGC(I).GT.0) THEN
11758 HSWGHT(0) = HSWGHT(0)*HSWGHT(I)
11761 IF(IVWGHT(1).EQ.1) THEN
11763 IF(WG.GT.1.01D0) THEN
11764 IF(EVWGHT(1).LT.1.01D0) THEN
11765 WRITE(LO,'(1X,A,2I12,1PE12.3)')
11766 & 'PHO_EVENT: cross section weight > 1',
11768 WRITE(LO,'(5X,A,1P3E11.3)') 'SIGCUR,SIGMAX,EVWGHT(1):',
11769 & SIGGEN(3),SIGGEN(4),EVWGHT(1)
11771 EVWGHT(1) = HSWGHT(0)
11778 C effective cross section
11779 SIGGEN(2) = SIGGEN(4)*DBLE(KACCEP)/DBLE(KEVENT)
11780 ECMSUM = ECMSUM+ECM
11781 SIGGEN(3) = SIGGEN(3)*HSWGHT(0)
11782 ELSE IF(NEV.EQ.-2) THEN
11784 C ---------------- end of event generation ----------------------
11786 WRITE(LO,'(/3(/1X,A),//1X,A,3I12,/1X,A,F12.1)')
11787 & '====================================================',
11788 & ' --------- summary of event generation ----------',
11789 & '====================================================',
11790 & 'called,generated,accepted events:',KEVENT,KEVGEN,KACCEP,
11791 & 'average CMS energy:',ECMSUM/DBLE(MAX(1,KACCEP))
11793 C write out statistics
11794 IF(KACCEP.GT.0) THEN
11796 FAC1 = SIGGEN(4)/DBLE(KEVENT)
11797 FAC2 = FAC/DBLE(KACCEP)
11798 WRITE(LO,'(/1X,A,/1X,A)')
11799 & 'PHO_EVENT: generated and accepted events',
11800 & '----------------------------------------'
11802 & 'process, sampled, accepted, cross section (internal/external)'
11803 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'non.diff.',IPRSAM(1),
11804 & IPRACC(1),DBLE(IPRACC(1))*FAC1,DBLE(IPRACC(1))*FAC2
11805 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'elas sca.',IPRSAM(2),
11806 & IPRACC(2),DBLE(IPRACC(2))*FAC1,DBLE(IPRACC(2))*FAC2
11807 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'qela sca.',IPRSAM(3),
11808 & IPRACC(3),DBLE(IPRACC(3))*FAC1,DBLE(IPRACC(3))*FAC2
11809 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.pom.',IPRSAM(4),
11810 & IPRACC(4),DBLE(IPRACC(4))*FAC1,DBLE(IPRACC(4))*FAC2
11811 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'diff.par1',IPRSAM(5),
11812 & IPRACC(5),DBLE(IPRACC(5))*FAC1,DBLE(IPRACC(5))*FAC2
11813 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'diff.par2',IPRSAM(6),
11814 & IPRACC(6),DBLE(IPRACC(6))*FAC1,DBLE(IPRACC(6))*FAC2
11815 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.dif.',IPRSAM(7),
11816 & IPRACC(7),DBLE(IPRACC(7))*FAC1,DBLE(IPRACC(7))*FAC2
11817 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir all ',IPRSAM(8),
11818 & IPRACC(8),DBLE(IPRACC(8))*FAC1,DBLE(IPRACC(8))*FAC2
11819 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir X res',IDNS(1),IDNA(1),
11820 & DBLE(IDNA(1))*FAC1,DBLE(IDNA(1))*FAC2
11821 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'res X dir',IDNS(2),IDNA(2),
11822 & DBLE(IDNA(2))*FAC1,DBLE(IDNA(2))*FAC2
11823 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir X dir',IDNS(3),IDNA(3),
11824 & DBLE(IDNA(3))*FAC1,DBLE(IDNA(3))*FAC2
11825 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'soft pom.',ISPS,ISPA,
11826 & DBLE(ISPA)*FAC1,DBLE(ISPA)*FAC2
11827 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'hard pom.',IHPS,IHPA,
11828 & DBLE(IHPA)*FAC1,DBLE(IHPA)*FAC2
11829 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'soft reg.',ISRS,ISRA,
11830 & DBLE(ISRA)*FAC1,DBLE(ISRA)*FAC2
11831 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'enh. trg.',ISTS,ISTA,
11832 & DBLE(ISTA)*FAC1,DBLE(ISTA)*FAC2
11833 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'enh. log.',ISLS,ISLA,
11834 & DBLE(ISLA)*FAC1,DBLE(ISLA)*FAC2
11835 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.pom.',IDPS,IDPA,
11836 & DBLE(IDPA)*FAC1,DBLE(IDPA)*FAC2
11837 IF(ISWMDL(14).GT.0) THEN
11838 WRITE(LO,'(3X,A,I3)') 'recursive pomeron splitting:',
11840 WRITE(LO,'(5X,A,I12)') '1->2pom-cut :',IENACC(8)
11841 WRITE(LO,'(5X,A,I12)') '1->doub-pom :',IENACC(4)
11842 WRITE(LO,'(5X,A,I12)') '1->diff-dis1:',IENACC(5)
11843 WRITE(LO,'(5X,A,I12)') '1->diff-dis2:',IENACC(6)
11844 WRITE(LO,'(5X,A,I12)') '1->doub-diff:',IENACC(7)
11846 WRITE(LO,'(2(/1X,A,1PE12.3)/)') ' sampled cross section (mb)',
11847 & SIGGEN(1),'accepted cross section (mb)',SIGGEN(2)
11849 CALL PHO_REJSTA(-2)
11850 CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
11852 CALL PHO_PARTON(-2,0,0,P1,P2,IREJ)
11853 C statistics of hard scattering processes
11854 WRITE(LO,'(2(/1X,A))')
11855 & 'PHO_EVENT: statistics of hard scattering processes',
11856 & '--------------------------------------------------'
11858 IF(MH_tried(0,K).GT.0) THEN
11859 WRITE(LO,'(/5X,A,I3)')
11860 & 'process (accepted,x-section internal/external) for IP:',K
11861 DO 47 M=0,Max_pro_2
11862 WRITE(LO,'(1X,I3,1X,A,2X,2I12,1P2E13.3)') M,PROC(M),
11863 & MH_tried(M,K),MH_acc_1(M,K),DBLE(MH_acc_1(M,K))*FAC1,
11864 & DBLE(MH_acc_2(M,K))*FAC2
11870 WRITE(LO,'(/1X,A,I4,/)') 'no output of statistics',KEVENT
11872 WRITE(LO,'(/3(/1X,A)/)')
11873 & '======================================================',
11874 & ' ------- end of event generation summary --------',
11875 & '======================================================'
11877 WRITE(LO,'(/1X,A,I7)') 'PHO_EVENT:ERROR: unsupported NEV',NEV
11882 *$ CREATE PHO_PARTON.FOR
11884 CDECK ID>, PHO_PARTON
11885 SUBROUTINE PHO_PARTON(IPROC,JM1,JM2,P1,P2,IREJ)
11886 C********************************************************************
11888 C calculation of complete parton configuration
11890 C input: IPROC process ID 1 nondiffractive
11892 C 3 quasi-ela. rho,omega,phi prod.
11896 C 7 double diff diss.
11897 C 8 single-resolved / direct photon
11898 C JM1,2 index of mother particles in /POEVT1/
11901 C output: complete parton configuration in /POEVT1/
11904 C 50 rejection due to user cutoffs
11906 C********************************************************************
11907 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11910 DIMENSION P1(4),P2(4)
11912 PARAMETER ( TINY = 1.D-10 )
11914 C input/output channels
11916 COMMON /POINOU/ LI,LO
11917 C event debugging information
11919 PARAMETER (NMAXD=100)
11920 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11921 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11922 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11923 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11924 C model switches and parameters
11926 INTEGER ISWMDL,IPAMDL
11927 DOUBLE PRECISION PARMDL
11928 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11929 C table of particle indices for recursive PHOJET calls
11931 PARAMETER ( MAXIPX = 100 )
11932 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
11933 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
11934 & IPOIX1,IPOIX2,IPOIX3
11935 C general process information
11936 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
11937 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
11938 C global event kinematics and particle IDs
11939 INTEGER IFPAP,IFPAB
11940 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
11941 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
11943 INTEGER IPFIL,IFAFIL,IFBFIL
11944 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
11945 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
11946 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
11947 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
11948 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
11949 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
11950 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
11951 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
11952 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
11953 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
11954 & IPFIL,IFAFIL,IFBFIL
11955 C event weights and generated cross section
11956 INTEGER IPOWGC,ISWCUT,IVWGHT
11957 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
11958 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
11959 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
11960 C internal rejection counters
11962 PARAMETER (NMXJ=60)
11963 CHARACTER*10 REJTIT
11965 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
11968 C clear event statistics
11982 C-------------------------------------------------------------------
11983 C nondiffractive resolved processes
11985 IF(IPROC.EQ.1) THEN
11986 C sample number of interactions
11990 C generate only hard events
11991 IF(ISWMDL(2).EQ.0) THEN
11998 C minimum bias events
12001 CALL PHO_SAMPRB(ECM,IP,IINT,JINT,KINT)
12002 IPOWGC(1) = IPOWGC(1)+1
12008 C resolved soft processes: pomeron and reggeon
12011 C resolved hard process: hard pomeron
12013 C resolved absorptive corrections
12016 C restrictions given by user
12017 IF(MSPOM.LT.ISWCUT(1)) GOTO 10
12018 IF(MSREG.LT.ISWCUT(2)) GOTO 10
12019 IF(MHPOM.LT.ISWCUT(3)) GOTO 10
12020 HSWGHT(1) = 1.D0/DBLE(IPOWGC(1))
12021 C ----------------------------
12022 IF(ISWMDL(15).EQ.0) THEN
12024 IF(MSREG.GT.0) THEN
12031 ELSE IF(ISWMDL(15).EQ.1) THEN
12032 IF(MHPOM.GT.0) THEN
12036 ELSE IF(MSPOM.GT.0) THEN
12042 ELSE IF(ISWMDL(15).EQ.2) THEN
12043 MHPOM = MIN(1,MHPOM)
12044 ELSE IF(ISWMDL(15).EQ.3) THEN
12045 MSPOM = MIN(1,MSPOM)
12048 C ----------------------------
12057 IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,I7,6I4)')
12058 & 'PHO_PARTON: EV,SP,SR,HP,HD,ET,EL',
12059 & KEVENT,MSPOM,MSREG,MHPOM,MHDIR,MPTRI,MPLOO
12064 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12072 CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
12074 IF(IREJ.EQ.50) RETURN
12075 IF(IDEB(3).GE.2) THEN
12076 WRITE(LO,'(/1X,A,I5)')
12077 & 'PHO_PARTON: rejection by PHO_STDPAR ',ITRY2
12078 CALL PHO_PREVNT(-1)
12082 IF(MHPOM.GT.0) THEN
12084 ELSE IF(MSPOM.GT.0) THEN
12089 C check of quantum numbers of parton configurations
12090 IF(IDEB(3).GE.0) THEN
12091 CALL PHO_CHECK(1,IREJ)
12092 IF(IREJ.NE.0) GOTO 50
12094 C sample strings to prepare fragmentation
12095 CALL PHO_STRING(1,IREJ)
12097 IF(IREJ.EQ.50) RETURN
12098 IFAIL(30) = IFAIL(30)+1
12099 IF(IDEB(3).GE.2) THEN
12100 WRITE(LO,'(/1X,A,I5)')
12101 & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
12102 CALL PHO_PREVNT(-1)
12104 IF(ITRY2.LT.20) GOTO 50
12105 IF(IDEB(3).GE.1) THEN
12106 WRITE(LO,'(/1X,A,I5)')
12107 & 'PHO_PARTON: rejection',ITRY2
12108 CALL PHO_PREVNT(-1)
12120 C-------------------------------------------------------------------
12121 C elastic scattering / quasi-elastic rho/omega/phi production
12123 ELSE IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
12124 IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,I4)')
12125 & 'PHO_PARTON: ela./q-ela.sca:(EV,IPROC)',KEVENT,IPROC
12127 C DPMJET call with special projectile / target: transform into CMS
12128 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12129 & CALL PHO_DFWRAP(1,JM1,JM2)
12131 CALL PHO_QELAST(IPROC,JM1,JM2,IREJ)
12134 C DPMJET call with special projectile / target: clean up
12135 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12136 & CALL PHO_DFWRAP(-2,JM1,JM2)
12137 IF(IDEB(3).GE.2) THEN
12138 WRITE(LO,'(/1X,A,I5)')
12139 & 'PHO_PARTON: rejection by PHO_QELAST',IREJ
12140 CALL PHO_PREVNT(-1)
12145 C DPMJET call with special projectile / target: transform back
12146 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12147 & CALL PHO_DFWRAP(2,JM1,JM2)
12149 C prepare possible decays
12150 CALL PHO_STRING(1,IREJ)
12152 IF(IREJ.EQ.50) RETURN
12153 IFAIL(30) = IFAIL(30)+1
12157 C---------------------------------------------------------------------
12158 C double Pomeron scattering
12160 ELSE IF(IPROC.EQ.4) THEN
12163 IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10)')
12164 & 'PHO_PARTON: EV,double-pomeron scattering',KEVENT
12169 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12171 CALL PHO_CDIFF(JM1,JM2,MSOFT,MHARD,1,IREJ)
12173 IF(IDEB(3).GE.2) THEN
12174 WRITE(LO,'(/1X,A,I5)')
12175 & 'PHO_PARTON: rejection by PHO_CDIFF',IREJ
12176 CALL PHO_PREVNT(-1)
12180 C check of quantum numbers of parton configurations
12181 IF(IDEB(3).GE.0) THEN
12182 CALL PHO_CHECK(1,IREJ)
12183 IF(IREJ.NE.0) GOTO 60
12185 C sample strings to prepare fragmentation
12186 CALL PHO_STRING(1,IREJ)
12188 IF(IREJ.EQ.50) RETURN
12189 IFAIL(30) = IFAIL(30)+1
12190 IF(IDEB(3).GE.2) THEN
12191 WRITE(LO,'(/1X,A,I5)')
12192 & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
12193 CALL PHO_PREVNT(-1)
12195 IF(ITRY2.LT.10) GOTO 60
12196 WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
12197 CALL PHO_PREVNT(-1)
12202 C-----------------------------------------------------------------------
12203 C single / double diffraction dissociation
12205 ELSE IF((IPROC.GE.5).AND.(IPROC.LE.7)) THEN
12208 IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,2I4)')
12209 & 'PHO_PARTON: EV,diffraction',KEVENT,IPAR1,IPAR2
12210 IF(IPROC.EQ.5) ID1S = ID1S+1
12211 IF(IPROC.EQ.6) ID2S = ID2S+1
12212 IF(IPROC.EQ.7) ID3S = ID3S+1
12216 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12219 IF(IPROC.EQ.5) IPAR2 = 0
12220 IF(IPROC.EQ.6) IPAR1 = 0
12221 C calculate rapidity gap survival probability
12223 IF(ECM.GT.10.D0) THEN
12224 IF((IPAR1.GE.1).AND.(IPAR2.EQ.0)) THEN
12225 IF(SIGTR1(1).LT.1.D-10) THEN
12228 SPROB = SIGHSD(1)/(SIGTR1(1)-2.D0*(SIGDPO(1)+SIGDPO(2)))
12230 ELSE IF((IPAR1.EQ.0).AND.(IPAR2.GE.1)) THEN
12231 IF(SIGTR2(1).LT.1.D-10) THEN
12234 SPROB = SIGHSD(2)/(SIGTR2(1)-2.D0*(SIGDPO(1)+SIGDPO(3)))
12236 ELSE IF((IPAR1.GE.1).AND.(IPAR2.GE.1)) THEN
12237 IF(SIGLOO.LT.1.D-10) THEN
12240 SPROB = SIGHDD/SIGLOO
12246 * temporary patch, r.e. 8.6.99
12250 C DPMJET call with special projectile / target: transform into CMS
12251 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12252 & CALL PHO_DFWRAP(1,JM1,JM2)
12254 CALL PHO_DIFDIS(IPAR1,IPAR2,JM1,JM2,SPROB,0,MSOFT,MHARD,IREJ)
12257 C DPMJET call with special projectile / target: clean up
12258 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12259 & CALL PHO_DFWRAP(-2,JM1,JM2)
12260 IF(IDEB(3).GE.2) THEN
12261 WRITE(LO,'(/1X,A,I5)')
12262 & 'PHO_PARTON: rejection by PHO_DIFDIS',IREJ
12263 CALL PHO_PREVNT(-1)
12268 C DPMJET call with special projectile / target: transform back
12269 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12270 & CALL PHO_DFWRAP(2,JM1,JM2)
12272 C check of quantum numbers of parton configurations
12273 IF(IDEB(3).GE.0) THEN
12274 CALL PHO_CHECK(1,IREJ)
12275 IF(IREJ.NE.0) GOTO 70
12277 C sample strings to prepare fragmentation
12278 CALL PHO_STRING(1,IREJ)
12280 IF(IREJ.EQ.50) RETURN
12281 IFAIL(30) = IFAIL(30)+1
12282 IF(IDEB(3).GE.2) THEN
12283 WRITE(LO,'(/1X,A,I5)')
12284 & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
12285 CALL PHO_PREVNT(-1)
12287 IF(ITRY2.LT.10) GOTO 70
12288 WRITE(LO,'(/1X,A,I5)')
12289 & 'PHO_PARTON: rejection',ITRY2
12290 CALL PHO_PREVNT(-1)
12293 IF(IPROC.EQ.5) ID1A = ID1A+1
12294 IF(IPROC.EQ.6) ID2A = ID2A+1
12295 IF(IPROC.EQ.7) ID3A = ID3A+1
12297 C-----------------------------------------------------------------------
12298 C single / double direct processes
12300 ELSE IF(IPROC.EQ.8) THEN
12305 IF(IDEB(3).GE.5) THEN
12306 WRITE(LO,'(1X,A,I10)') 'PHO_PARTON: EV,direct proc',KEVENT
12312 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12318 CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
12320 IF(IREJ.EQ.50) RETURN
12321 IF(IDEB(3).GE.2) THEN
12322 WRITE(LO,'(/1X,A,I5)')
12323 & 'PHO_PARTON: rejection by PHO_STDPAR',ITRY2
12324 CALL PHO_PREVNT(-1)
12329 C check of quantum numbers of parton configurations
12330 IF(IDEB(3).GE.0) THEN
12331 CALL PHO_CHECK(1,IREJ)
12332 IF(IREJ.NE.0) GOTO 80
12334 C sample strings to prepare fragmentation
12335 CALL PHO_STRING(1,IREJ)
12337 IF(IREJ.EQ.50) RETURN
12338 IFAIL(30) = IFAIL(30)+1
12339 IF(IDEB(3).GE.2) THEN
12340 WRITE(LO,'(/1X,A,I5)')
12341 & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
12342 CALL PHO_PREVNT(-1)
12344 IF(ITRY2.LT.10) GOTO 80
12345 WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
12346 CALL PHO_PREVNT(-1)
12349 IF(IPROC.EQ.5) ID1A = ID1A+1
12350 IF(IPROC.EQ.6) ID2A = ID2A+1
12351 IF(IPROC.EQ.7) ID3A = ID3A+1
12354 C-----------------------------------------------------------------------
12355 C initialize control statistics
12357 ELSE IF(IPROC.EQ.-1) THEN
12358 CALL PHO_SAMPRB(ECM,-1,0,0,0)
12359 CALL PHO_STDPAR(-1,0,0,0,0,0,0,IREJ)
12360 CALL PHO_SEAFLA(-1,0,0,DUM)
12361 IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
12362 & CALL PHO_QELAST(-1,1,2,0)
12383 CALL PHO_STRING(-1,IREJ)
12384 CALL PHO_DIFDIS(0,0,0,0,0.D0,-1,0,0,IREJ)
12387 C-----------------------------------------------------------------------
12388 C produce statistics summary
12390 ELSE IF(IPROC.EQ.-2) THEN
12391 IF(ISWMDL(2).NE.0) CALL PHO_SAMPRB(ECM,-2,0,0,0)
12392 IF(IDEB(3).GE.0) THEN
12393 WRITE(LO,'(/1X,A,/1X,A)')
12394 & 'PHO_PARTON: internal statistics on parton configurations',
12395 & '--------------------------------------------------------'
12396 WRITE(LO,'(5X,A)') 'process sampled accepted'
12397 WRITE(LO,'(5X,A,2I12)') 'soft pom.',ISPS,ISPA
12398 WRITE(LO,'(5X,A,2I12)') 'hard pom.',IHPS,IHPA
12399 WRITE(LO,'(5X,A,2I12)') 'soft reg.',ISRS,ISRA
12400 WRITE(LO,'(5X,A,2I12)') 'enh. tri.',ISTS,ISTA
12401 WRITE(LO,'(5X,A,2I12)') 'enh. loo.',ISLS,ISLA
12402 WRITE(LO,'(5X,A,2I12)') 'diff.pa1.',ID1S,ID1A
12403 WRITE(LO,'(5X,A,2I12)') 'diff.pa2.',ID2S,ID2A
12404 WRITE(LO,'(5X,A,2I12)') 'doub.dif.',ID3S,ID3A
12405 WRITE(LO,'(5X,A,2I12)') 'doub.pom.',IDPS,IDPA
12406 WRITE(LO,'(5X,A,2I12/)') 'dir.phot.',IDIS,IDIA
12408 CALL PHO_STDPAR(-2,0,0,0,0,0,0,IREJ)
12409 IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
12410 & CALL PHO_QELAST(-2,1,2,0)
12411 CALL PHO_STRING(-2,IREJ)
12412 CALL PHO_DIFDIS(0,0,0,0,0.D0,-2,0,0,IREJ)
12413 CALL PHO_SEAFLA(-2,0,0,DUM)
12416 WRITE(LO,'(1X,A,I2)')
12417 & 'PARTON:ERROR: unknown process ID ',IPROC
12423 *$ CREATE PHO_MCINI.FOR
12425 CDECK ID>, PHO_MCINI
12426 SUBROUTINE PHO_MCINI
12427 C********************************************************************
12429 C initialization of MC event generation
12431 C********************************************************************
12432 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12435 PARAMETER ( PIMASS = 0.13D0,
12438 C input/output channels
12440 COMMON /POINOU/ LI,LO
12441 C event debugging information
12443 PARAMETER (NMAXD=100)
12444 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12445 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12446 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12447 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12448 C model switches and parameters
12450 INTEGER ISWMDL,IPAMDL
12451 DOUBLE PRECISION PARMDL
12452 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
12453 C general process information
12454 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
12455 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
12457 INTEGER IPFIL,IFAFIL,IFBFIL
12458 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
12459 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
12460 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
12461 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
12462 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
12463 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
12464 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
12465 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
12466 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
12467 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
12468 & IPFIL,IFAFIL,IFBFIL
12469 C hard cross sections and MC selection weights
12471 PARAMETER ( Max_pro_2 = 16 )
12472 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
12473 & MH_acc_1,MH_acc_2
12474 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
12475 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
12476 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
12477 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
12478 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
12479 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
12480 C interpolation tables for hard cross section and MC selection weights
12481 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
12482 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
12483 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
12484 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
12485 & HQ2a_tab,HQ2b_tab,HEcm_tab
12487 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12488 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12489 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12490 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12491 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
12492 & HEcm_tab(1:Max_tab_E,0:4),
12493 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
12494 C global event kinematics and particle IDs
12495 INTEGER IFPAP,IFPAB
12496 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
12497 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
12498 C obsolete cut-off information
12499 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
12500 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
12501 C event weights and generated cross section
12502 INTEGER IPOWGC,ISWCUT,IVWGHT
12503 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
12504 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
12505 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
12506 C cut probability distribution
12507 INTEGER IEETA1,IIMAX,KKMAX
12508 PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
12509 INTEGER IEEMAX,IMAX,KMAX
12511 DOUBLE PRECISION EPTAB
12512 COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
12514 C energy-interpolation table
12516 PARAMETER ( IEETA2 = 20 )
12518 DOUBLE PRECISION SIGTAB,SIGECM
12519 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
12521 CHARACTER*15 PHO_PNAME
12524 DATA XMPOM / 0.766D0 /
12526 C initialize fragmentation
12527 CALL PHO_FRAINI(ISWMDL(6))
12529 C reset interpolation tables
12533 SIGTAB(I,K,J) = 0.D0
12539 C max. number of allowed colors (large N expansion)
12542 CALL PHO_SELCOL(IC1,IC2,0,0,0,0,-1)
12544 C lower energy limit of initialization
12545 ETABLO = PARMDL(19)
12546 IF(ECM.LE.5.D0) ETABLO = MIN(2.5D0,ETABLO)
12548 WRITE(LO,'(/,1X,A,2F12.1)')
12549 & 'PHO_MCINI: selected energy range (SQRT(S))',ETABLO,ECM
12550 WRITE(LO,'(5X,A,A,F7.3,E15.4)')
12551 & 'particle 1 (name,mass,virtuality): ',PHO_PNAME(IFPAP(1),1),
12552 & PMASS(1),PVIRT(1)
12553 WRITE(LO,'(5X,A,A,F7.3,E15.4)')
12554 & 'particle 2 (name,mass,virtuality): ',PHO_PNAME(IFPAP(2),1),
12555 & PMASS(2),PVIRT(2)
12557 C cuts on probabilities of multiple interactions
12558 IMAX = MIN(IPAMDL(32),IIMAX)
12559 KMAX = MIN(IPAMDL(33),KKMAX)
12560 AH = 2.D0*PTCUT(1)/ECM
12561 IMAX = MAX(5,MIN(IMAX,INT(ECM/2.0D0)))
12562 KMAX = MIN(KMAX,1+INT(0.9*1.D0/AH))
12564 C hard interpolation table
12566 ECMF(2) = 0.9D0*ECMF(1)
12570 IH_Ecm_up(k) = MIN(IPAMDL(30),Max_tab_E)
12571 IF(ECMF(k).LT.100.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),15)
12572 IF(ECMF(k).LT.50.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),10)
12573 IF(ECMF(k).LT.10.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),5)
12576 C initialization of hard scattering for all channels and cutoffs
12577 IF(HSWCUT(5).GT.PARMDL(36)) CALL PHO_HARMCI(-1,ECMF(1))
12579 IF(ISWMDL(2).EQ.0) I0 = 1
12581 CALL PHO_HARMCI(I,ECMF(I))
12584 C dimension of interpolation table of cut probabilities
12585 IEEMAX = MIN(IPAMDL(31),IEETA1)
12586 IF(ECM.LT.100.D0) IEEMAX = MIN(IEEMAX,15)
12587 IF(ECM.LT.50.D0) IEEMAX = MIN(IEEMAX,10)
12588 IF(ECM.LT.10.D0) IEEMAX = MIN(IEEMAX,5)
12591 C calculate probability distribution
12599 IF(ISWMDL(2).EQ.0) I0 = 1
12601 ECMPRO = ECMF(IP)*1.001D0
12609 ELSE IF(IP.EQ.3) THEN
12616 ELSE IF(IP.EQ.2) THEN
12631 IF(IEEMAX.GT.1) THEN
12633 ELMIN = LOG(ETABLO)
12637 EDELTA = (LOG(ECMPRO)-ELMIN)/DBLE(MAX(1,IEEMAX-1))
12639 ECMPRO = EXP(ELMIN+DBLE(I-1)*EDELTA)
12640 CALL PHO_PRBDIS(IP,ECMPRO,I)
12643 CALL PHO_PRBDIS(IP,ECMPRO,1)
12646 C debug output of cross section tables
12647 IF(((IDEB(62).GE.0).AND.(IP.EQ.1)).OR.(IDEB(62).GE.3)) THEN
12648 IF((PVIRT(1)+PVIRT(2).GT.0.01D0).AND.(IDEB(62).EQ.0)) GOTO 201
12649 WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12650 &'Table of total cross sections (mb) for particle combination',IP,
12651 &' Ecm SIGtot SIGela SIGine SIGqel SIGsd1 SIGsd2 SIGdd',
12652 &'-------------------------------------------------------------'
12654 WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,1,I),
12655 & SIGTAB(IP,2,I),SIGTAB(IP,28,I),SIGTAB(IP,3,I),
12656 & SIGTAB(IP,30,I)+SIGTAB(IP,32,I),
12657 & SIGTAB(IP,31,I)+SIGTAB(IP,33,I),
12658 & SIGTAB(IP,34,I)+SIGTAB(IP,35,I)
12661 IF(IDEB(62).GE.2) THEN
12662 WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12663 &'Table of partial x-sections (mb) for particle combination',IP,
12664 &' Ecm SIGSD1L SIGSD1H SIGSD2L SIGSD2H SIGDDL SIGDDH SIGCDF',
12665 &'--------------------------------------------------------------'
12667 WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,30,I),
12668 & SIGTAB(IP,32,I),SIGTAB(IP,31,I),SIGTAB(IP,33,I),
12669 & SIGTAB(IP,34,I),SIGTAB(IP,35,I),SIGTAB(IP,36,I)
12672 IF(IDEB(62).GE.2) THEN
12673 WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12674 &'Table of born graph x-sections (mb) for particle combination',IP,
12675 &' Ecm SIGSVDM SIGHRES SIGHDIR SIGTR1 SIGTR2 SIGLOO SIGDPO',
12676 &'-------------------------------------------------------------'
12678 WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),
12679 & SIGTAB(IP,56,I)+SIGTAB(IP,57,I),SIGTAB(IP,58,I),
12680 & SIGTAB(IP,59,I),SIGTAB(IP,60,I)+SIGTAB(IP,61,I),
12681 & SIGTAB(IP,62,I)+SIGTAB(IP,63,I),SIGTAB(IP,64,I),
12682 & SIGTAB(IP,65,I)+SIGTAB(IP,66,I)+SIGTAB(IP,67,I)
12685 WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12686 &'Table of unitarized x-sections (mb) for particle combination',IP,
12687 &' Ecm SIGSVDM SIGHVDM SIGTR1 SIGTR2 SIGLOO SIGDPO SLOPE',
12688 &'-------------------------------------------------------------'
12690 WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,79,I),
12691 & SIGTAB(IP,80,I),SIGTAB(IP,32,I),SIGTAB(IP,33,I),
12692 & SIGTAB(IP,35,I),SIGTAB(IP,36,I),SIGTAB(IP,39,I)
12695 IF(IDEB(62).GE.1) THEN
12696 WRITE(LO,'(/1X,A,/1X,A,2I4,/1X,A,/1X,A)')
12697 &'Table of expected average number of cuts in non-diff events:',
12698 &' for max. number of cuts soft/hard:',IMAX,KMAX,
12699 &' Ecm PTCUT SIGNDF POM-S POM-H REG-S',
12700 &'---------------------------------------------'
12702 WRITE(LO,'(1X,1P,6E10.3)') SIGECM(IP,I),SIGTAB(IP,77,I),
12703 & SIGTAB(IP,78,I),SIGTAB(IP,74,I),SIGTAB(IP,75,I),
12707 WRITE(LO,'(/1X,A,/1X,A,/1X,A)')
12708 & 'Table of rapidity gap survival probability (high-mass diff.):',
12709 & ' Ecm Spro-sd1 Spro-sd2 Spro-dd Spro-cd',
12710 & '---------------------------------------------------'
12712 IF(SIGECM(IP,I).GT.10.D0) THEN
12713 SPRSD1 = SIGTAB(IP,32,I)/(SIGTAB(IP,60,I)
12714 & -2.D0*(SIGTAB(IP,65,I)+SIGTAB(IP,66,I)))
12715 SPRSD2 = SIGTAB(IP,33,I)/(SIGTAB(IP,62,I)
12716 & -2.D0*(SIGTAB(IP,65,I)+SIGTAB(IP,67,I)))
12717 SPRDD = SIGTAB(IP,35,I)/(SIGTAB(IP,64,I)+SIGTAB(IP,61,I)
12718 & +SIGTAB(IP,63,I)-2.D0*(SIGTAB(IP,66,I)
12719 & +SIGTAB(IP,67,I)+2.D0*SIGTAB(IP,68,I)))
12720 SPRCDF = SIGTAB(IP,36,I)/(SIGTAB(IP,65,I)+SIGTAB(IP,66,I)
12721 & +SIGTAB(IP,67,I)+SIGTAB(IP,68,I))
12722 WRITE(LO,'(1X,1P,5E10.3)') SIGECM(IP,I),
12723 & SPRSD1,SPRSD2,SPRDD,SPRCDF
12731 C simulate only hard scatterings
12732 IF(ISWMDL(2).EQ.0) THEN
12733 WRITE(LO,'(2(/1X,A))')
12734 & 'WARNING: generation of hard scatterings only!',
12735 & '============================================='
12747 IF(IPRON(1,1).EQ.1) SIGMAX = SIGTAB(1,58,I)
12748 IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGTAB(1,59,I)
12749 IF(SIGMAX.GT.SIGGEN(4)) THEN
12755 WRITE(LO,'(2(/1X,A))')
12756 & 'activated processes, cross section',
12757 & '----------------------------------'
12758 WRITE(LO,'(5X,A,I3,2X,3I3)')
12759 & ' nondiffr. resolved processes',(IPRON(1,K),K=1,4)
12760 WRITE(LO,'(5X,A,I3,2X,3I3)')
12761 & ' elastic scattering',(IPRON(2,K),K=1,4)
12762 WRITE(LO,'(5X,A,I3,2X,3I3)')
12763 & 'qelast. vectormeson production',(IPRON(3,K),K=1,4)
12764 WRITE(LO,'(5X,A,I3,2X,3I3)')
12765 & ' double pomeron processes',(IPRON(4,K),K=1,4)
12766 WRITE(LO,'(5X,A,I3,2X,3I3)')
12767 & ' single diffract. particle (1)',(IPRON(5,K),K=1,4)
12768 WRITE(LO,'(5X,A,I3,2X,3I3)')
12769 & ' single diffract. particle (2)',(IPRON(6,K),K=1,4)
12770 WRITE(LO,'(5X,A,I3,2X,3I3)')
12771 & ' double diffract. processes',(IPRON(7,K),K=1,4)
12772 WRITE(LO,'(5X,A,I3,2X,3I3)')
12773 & ' direct photon processes',(IPRON(8,K),K=1,4)
12775 C calculate effective cross section
12778 CALL PHO_CSINT(1,IFPAP(1),IFPAP(2),-1,-1,SIGECM(1,I),
12779 & PVIRT(1),PVIRT(2))
12781 if(iswmdl(2).ge.1) then
12782 IF(IPRON(1,1).EQ.1) SIGMAX = SIGTOT-SIGELA-SIGVM(0,0)
12783 & -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
12784 & -SIGLDD-SIGHDD-SIGDIR
12785 IF(IPRON(2,1).EQ.1) SIGMAX = SIGMAX+SIGELA
12786 IF(IPRON(3,1).EQ.1) SIGMAX = SIGMAX+SIGVM(0,0)
12787 IF(IPRON(4,1).EQ.1) SIGMAX = SIGMAX+SIGCDF(0)
12788 IF(IPRON(5,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(1)+SIGHSD(1)
12789 IF(IPRON(6,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(2)+SIGHSD(2)
12790 IF(IPRON(7,1).EQ.1) SIGMAX = SIGMAX+SIGLDD+SIGHDD
12791 IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
12793 IF(IPRON(1,1).EQ.1) SIGMAX = SIGHAR
12794 IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
12796 IF(SIGMAX.GT.SIGGEN(4)) THEN
12804 IF(SIGGEN(4).LT.1.D-20) THEN
12805 WRITE(LO,'(//1X,A)')
12806 & 'PHO_MCINI:ERROR: selected processes have vanishing x-section'
12809 WRITE(LO,'(3X,A,1P3E11.4)') 'maximum search (Elow/Eup/Epeak)',
12810 & SIGECM(1,1),SIGECM(1,IEEMAX),SIGECM(1,ISIGM)
12811 WRITE(LO,'(11X,A,1PE12.4,/)') 'max. cross section (mb)',SIGGEN(4)
12815 *$ CREATE PHO_REJSTA.FOR
12817 CDECK ID>, PHO_REJSTA
12818 SUBROUTINE PHO_REJSTA(IMODE)
12819 C********************************************************************
12821 C MC rejection counting
12823 C input IMODE -1 initialization
12824 C -2 output of statistics
12826 C********************************************************************
12832 C input/output channels
12834 COMMON /POINOU/ LI,LO
12835 C event debugging information
12837 PARAMETER (NMAXD=100)
12838 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12839 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12840 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12841 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12842 C internal rejection counters
12844 PARAMETER (NMXJ=60)
12845 CHARACTER*10 REJTIT
12847 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
12854 IF(IMODE.EQ.-1) THEN
12859 REJTIT(1) = 'PARTON ALL'
12860 REJTIT(2) = 'STDPAR ALL'
12861 REJTIT(3) = 'STDPAR DPO'
12862 REJTIT(4) = 'POMSCA ALL'
12863 REJTIT(5) = 'POMSCA INT'
12864 REJTIT(6) = 'POMSCA KIN'
12865 REJTIT(7) = 'DIFDIS ALL'
12866 REJTIT(8) = 'POSPOM ALL'
12867 REJTIT(9) = 'HRES.DIF.1'
12868 REJTIT(10) = 'HDIR.DIF.1'
12869 REJTIT(11) = 'HRES.DIF.2'
12870 REJTIT(12) = 'HDIR.DIF.2'
12871 REJTIT(13) = 'DIFDIS INT'
12872 REJTIT(14) = 'HADRON SP2'
12873 REJTIT(15) = 'HADRON SP3'
12874 REJTIT(16) = 'HARDIR ALL'
12875 REJTIT(17) = 'HARDIR INT'
12876 REJTIT(18) = 'HARDIR KIN'
12877 REJTIT(19) = 'MCHECK BAR'
12878 REJTIT(20) = 'MCHECK MES'
12879 REJTIT(21) = 'DIF.DISS.1'
12880 REJTIT(22) = 'DIF.DISS.2'
12881 REJTIT(23) = 'STRFRA ALL'
12882 REJTIT(24) = 'MSHELL CHA'
12883 REJTIT(25) = 'PARTPT SOF'
12884 REJTIT(26) = 'PARTPT HAR'
12885 REJTIT(27) = 'INTRINS KT'
12886 REJTIT(28) = 'HACHEK DIR'
12887 REJTIT(29) = 'HACHEK RES'
12888 REJTIT(30) = 'STRING ALL'
12889 REJTIT(31) = 'POMSCA INT'
12890 REJTIT(32) = 'DIFF SLOPE'
12891 REJTIT(33) = 'GLU2QU ALL'
12892 REJTIT(34) = 'MASCOR ALL'
12893 REJTIT(35) = 'PARCOR ALL'
12894 REJTIT(36) = 'MSHELL PAR'
12895 REJTIT(37) = 'MSHELL ALL'
12896 REJTIT(38) = 'POMCOR ALL'
12897 REJTIT(39) = 'DB-POM KIN'
12898 REJTIT(40) = 'DB-POM ALL'
12899 REJTIT(41) = 'SOFTXX ALL'
12900 REJTIT(42) = 'SOFTXX PSP'
12903 ELSE IF(IMODE.EQ.-2) THEN
12904 WRITE(LO,'(/,1X,A,/,1X,A)') 'PHO_REJSTA: rejection statistics',
12905 & '--------------------------------'
12908 & WRITE(LO,'(1X,I3,1X,A,5X,I15)') I,REJTIT(I),IFAIL(I)
12911 WRITE(LO,'(1X,A,I3)') 'PHO_REJSTA: invalid mode ',IMODE
12916 *$ CREATE PHO_POSPOM.FOR
12918 CDECK ID>, PHO_POSPOM
12919 SUBROUTINE PHO_POSPOM(IP,IND1,IND2,IGEN,IPOM,KCUT,ISWAP,IREJ)
12920 C***********************************************************************
12922 C registration of one cut pomeron (soft/semihard)
12924 C input: IP particle combination the pomeron belongs to
12925 C IND1,2 position of X values in /POSOFT/
12926 C 1 corresponds to a valence-pomeron
12927 C IGEN production process of mother particles
12928 C IPOM pomeron number
12929 C KCUT total number of cut pomerons and reggeons
12931 C output: ISWAP exchange of x values
12932 C IND1,2 increased by the number of partons belonging
12933 C to the generated pomeron cut
12934 C IREJ success/failure
12936 C**********************************************************************
12937 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12940 PARAMETER ( DEPS = 1.D-8 )
12942 C input/output channels
12944 COMMON /POINOU/ LI,LO
12945 C event debugging information
12947 PARAMETER (NMAXD=100)
12948 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12949 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12950 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12951 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12952 C internal rejection counters
12954 PARAMETER (NMXJ=60)
12955 CHARACTER*10 REJTIT
12957 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
12958 C model switches and parameters
12960 INTEGER ISWMDL,IPAMDL
12961 DOUBLE PRECISION PARMDL
12962 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
12963 C general process information
12964 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
12965 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
12966 C global event kinematics and particle IDs
12967 INTEGER IFPAP,IFPAB
12968 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
12969 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
12970 C data of c.m. system of Pomeron / Reggeon exchange
12971 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
12972 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
12973 & SIDP,CODP,SIFP,COFP
12974 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
12975 & SIDP,CODP,SIFP,COFP,NPOSP(2),
12976 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
12977 C obsolete cut-off information
12978 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
12979 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
12980 C energy-interpolation table
12982 PARAMETER ( IEETA2 = 20 )
12984 DOUBLE PRECISION SIGTAB,SIGECM
12985 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
12986 C light-cone x fractions and c.m. momenta of soft cut string ends
12988 PARAMETER ( MAXSOF = 50 )
12989 INTEGER IJSI2,IJSI1
12990 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
12991 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
12992 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
12993 & IJSI1(MAXSOF),IJSI2(MAXSOF)
12995 C standard particle data interface
12998 PARAMETER (NMXHEP=4000)
13000 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
13001 DOUBLE PRECISION PHEP,VHEP
13002 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
13003 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
13005 C extension to standard particle data interface (PHOJET specific)
13006 INTEGER IMPART,IPHIST,ICOLOR
13007 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
13009 C table of particle indices for recursive PHOJET calls
13011 PARAMETER ( MAXIPX = 100 )
13012 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
13013 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
13014 & IPOIX1,IPOIX2,IPOIX3
13016 DIMENSION P1(4),P2(4),WGXHSD(2),WGX(6)
13024 EA1 = XS1(IND1)*ECMP/2.D0
13025 EA2 = XS1(IND1+1)*ECMP/2.D0
13026 EB1 = XS2(IND2)*ECMP/2.D0
13027 EB2 = XS2(IND2+1)*ECMP/2.D0
13028 CMASS1 = MIN(EA1,EA2)
13029 CMASS2 = MIN(EB1,EB2)
13032 IF(IDEB(9).GE.20) THEN
13033 WRITE(LO,'(1X,2A,5I4)') 'PHO_POSPOM: ',
13034 & 'IP,IND1,IND2,KCUT,IPOIX1',IP,IND1,IND2,KCUT,IPOIX1
13035 WRITE(LO,'(1X,A,2I4,1P2E12.4)') 'MOTHER1/2,MASS1/2',JM1,JM2,
13041 CALL PHO_VALFLA(JM1,IFLA1,IFLA2,EA1,EA2)
13043 CALL PHO_SEAFLA(JM1,IFLA1,IFLA2,CMASS1)
13046 CALL PHO_VALFLA(JM2,IFLB1,IFLB2,EB1,EB2)
13048 CALL PHO_SEAFLA(JM2,IFLB1,IFLB2,CMASS2)
13051 P1(I) = PSOFT1(I,IND1)+PSOFT1(I,IND1+1)
13052 P2(I) = PSOFT2(I,IND2)+PSOFT2(I,IND2+1)
13055 C pomeron resolved?
13056 IF((ISWMDL(14).GT.0).AND.(IPOIX1.GT.0)) THEN
13057 C find energy for cross section calculation
13058 IF(IPAMDL(16).EQ.2) THEN
13060 ELSE IF(IPAMDL(16).EQ.3) THEN
13061 IF(IPROCE.EQ.1) THEN
13067 ESUB = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2
13068 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2)
13070 C load cross sections from interpolation table
13071 IF(ESUB.LE.SIGECM(IP,1)) THEN
13074 ELSE IF(ESUB.LT.SIGECM(IP,ISIMAX)) THEN
13076 IF(ESUB.LE.SIGECM(IP,I)) GOTO 200
13082 WRITE(LO,'(/1X,A,2E12.3)')
13083 & 'PHO_POSPOM: energy too high',ESUB,SIGECM(IP,ISIMAX)
13084 CALL PHO_PREVNT(-1)
13089 IF(I1.NE.I2) FAC2=LOG(ESUB/SIGECM(IP,I1))
13090 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
13092 C calculate weights
13093 * WGXHSD(1) = FAC2*SIGTAB(IP,32,I2)+FAC1*SIGTAB(IP,32,I1)
13094 * WGXHSD(2) = FAC2*SIGTAB(IP,33,I2)+FAC1*SIGTAB(IP,33,I1)
13095 * WGXHDD = FAC2*SIGTAB(IP,35,I2)+FAC1*SIGTAB(IP,35,I1)
13096 * WGXCDF = FAC2*SIGTAB(IP,36,I2)+FAC1*SIGTAB(IP,36,I1)
13097 * WGXPOM = FAC2*SIGTAB(IP,37,I2)+FAC1*SIGTAB(IP,37,I1)
13098 * WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
13100 WGXPOM = FAC2*(SIGTAB(IP,56,I2)+SIGTAB(IP,57,I2))
13101 & +FAC1*(SIGTAB(IP,56,I1)+SIGTAB(IP,57,I1))
13102 WGXHSD(1) = FAC2*SIGTAB(IP,60,I2)+FAC1*SIGTAB(IP,60,I1)
13103 WGXHSD(2) = FAC2*SIGTAB(IP,62,I2)+FAC1*SIGTAB(IP,62,I1)
13104 WGXHDD = FAC2*(SIGTAB(IP,61,I2)+SIGTAB(IP,63,I2)
13105 & +SIGTAB(IP,64,I2))
13106 & +FAC1*(SIGTAB(IP,61,I1)+SIGTAB(IP,63,I1)
13107 & +SIGTAB(IP,64,I1))
13108 WGXCDF = FAC2*(SIGTAB(IP,65,I2)+SIGTAB(IP,66,I2)
13109 & +SIGTAB(IP,67,I2)+SIGTAB(IP,68,I2))
13110 & +FAC1*(SIGTAB(IP,65,I1)+SIGTAB(IP,66,I1)
13111 & +SIGTAB(IP,67,I1)+SIGTAB(IP,68,I1))
13114 WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
13115 C central diff. cut
13117 C diff. diss. of particle 1
13119 C diff. diss. of particle 2
13121 C double diff. dissociation
13124 WGX(6) = 2.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)
13126 * IF((WGX(1).LT.0.D0).AND.((IP.EQ.1).OR.(IDEB(9).GE.1))) THEN
13127 * WRITE(LO,'(1X,A,/1X,A,I3,1P,2E11.3)') ' PHO_POSPOM: ',
13128 * & ' unitarity bound reached for ',IP,ESUB,WGX(1)
13129 * WRITE(LO,'(5X,A)') 'WGXHSD(1),WGXHSD(2),WGXHDD,WGXCDF,WGXPOM:'
13130 * WRITE(LO,'(5X,1P5E11.3)') WGXHSD,WGXHDD,WGXCDF,WGXPOM
13131 * WRITE(LO,'(5X,A,/,5X,1P,6E11.3)') 'weight factors WG(1-6)',WGX
13134 SUM = WGX(1)+WGX(2)+WGX(3)+WGX(4)+WGX(5)+WGX(6)
13138 XI = DT_RNDM(SUM)*SUM
13144 IF((XI.GT.SUM).AND.(I.LT.6)) GOTO 210
13145 C phase space correction
13148 IF(I.EQ.6) ISAM = 8
13149 PACC = EXP(-PARMDL(8)*DBLE(ISAM*PARMDL(160+IP))/ESUB)
13150 * IF(DT_RNDM(SUM).GT.PACC) I=1
13151 IF(DT_RNDM(SUM).GT.PACC) GOTO 205
13154 C do not generate diffraction for events with only one cut pomeron
13155 IF((KCUT.EQ.1).AND.(I.LT.6)) I = 1
13157 C do not generate recursive calls for remants with
13158 C diquark-anti-diquark flavour contents
13159 if((abs(IFLA1).gt.1000).and.(IFLA1+IFLA2.eq.0)) I = 1
13160 if((abs(IFLB1).gt.1000).and.(IFLB1+IFLB2.eq.0)) I = 1
13163 IF(IDEB(9).GE.20) WRITE(LO,'(1X,A,/1X,I2,1P7E11.3)')
13164 & 'PHO_POSPOM: IPRO,ESUB,WGX(1-6)',I,ESUB,WGX
13167 C second scattering needed
13168 CALL PHO_HACODE(IFLA1,IFLA2,IDHA1,IDUM)
13169 CALL PHO_HACODE(IFLB1,IFLB2,IDHA2,IDUM)
13170 IDPD1 = IPHO_ID2PDG(IDHA1)
13171 IDPD2 = IPHO_ID2PDG(IDHA2)
13173 if(INDX1.eq.1) then
13174 if((IPHIST(2,JM1).GE.0).and.(IDHEP(JM1).NE.990))
13179 CALL PHO_REGPAR(1,IDPD1,IDHA1,JM1,JM2,P1(1),P1(2),P1(3),P1(4),
13180 & IPOM,IGEN_had,0,0,IPOS1,1)
13182 if(INDX2.eq.1) then
13183 if((IPHIST(2,JM2).GE.0).and.(IDHEP(JM2).NE.990))
13188 CALL PHO_REGPAR(1,IDPD2,IDHA2,JM2,JM1,P2(1),P2(2),P2(3),P2(4),
13189 & IPOM,IGEN_had,0,0,IPOS1,1)
13196 IF(IPOIX2.GT.MAXIPX) THEN
13197 WRITE(LO,'(1X,2A,2I5)') 'PHO_POSPOM: no space left in ',
13198 & '/PORECU/ (IPOIX2,MAXIPX):',IPOIX2,MAXIPX
13203 IPORES(IPOIX2) = I+2
13204 IPOPOS(1,IPOIX2) = IPOS1-1
13205 IPOPOS(2,IPOIX2) = IPOS1
13211 IF(ISWMDL(12).EQ.0) THEN
13213 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
13214 CALL PHO_SELCOL(0,0,ICC1,ICC2,ICD1,ICD2,1)
13216 C purely gluonic pomeron or sea strings formed by gluons
13218 IF( ((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0))
13219 & .OR.((IPAMDL(19).EQ.1).AND.(IND1.NE.1))) THEN
13223 IF( ((IDHEP(JM2).EQ.990).AND.(IPAMDL(20).GT.0))
13224 & .OR.((IPAMDL(19).EQ.1).AND.(IND2.NE.1))) THEN
13230 IF(IFLA1.NE.21) THEN
13231 IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
13232 & .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
13233 & CALL PHO_SWAPI(ICA1,ICD1)
13235 IF(IFLB1.NE.21) THEN
13236 IF(((ABS(IFLB1).GT.6).AND.(IFLB1.LT.0))
13237 & .OR.((ABS(IFLB1).LE.6).AND.(IFLB1.GT.0)))
13238 & CALL PHO_SWAPI(ICB1,ICC1)
13241 IF(ICA1*ICB1.GT.0) THEN
13242 IF((IND1.NE.1).AND.(IND2.NE.1)) THEN
13243 IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
13244 CALL PHO_SWAPI(IFLA1,IFLA2)
13245 CALL PHO_SWAPI(ICA1,ICD1)
13247 CALL PHO_SWAPI(IFLB1,IFLB2)
13248 CALL PHO_SWAPI(ICB1,ICC1)
13250 ELSE IF(IND1.NE.1) THEN
13251 CALL PHO_SWAPI(IFLA1,IFLA2)
13252 CALL PHO_SWAPI(ICA1,ICD1)
13253 ELSE IF(IND2.NE.1) THEN
13254 CALL PHO_SWAPI(IFLB1,IFLB2)
13255 CALL PHO_SWAPI(ICB1,ICC1)
13256 ELSE IF((IFLA1.EQ.-IFLA2).AND.(IFLB1.EQ.-IFLB2)) THEN
13257 IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
13258 CALL PHO_SWAPI(IFLA1,IFLA2)
13259 CALL PHO_SWAPI(ICA1,ICD1)
13261 CALL PHO_SWAPI(IFLB1,IFLB2)
13262 CALL PHO_SWAPI(ICB1,ICC1)
13264 ELSE IF(IFLA1.EQ.-IFLA2) THEN
13265 CALL PHO_SWAPI(IFLA1,IFLA2)
13266 CALL PHO_SWAPI(ICA1,ICD1)
13267 ELSE IF(IFLB1.EQ.-IFLB2) THEN
13268 CALL PHO_SWAPI(IFLB1,IFLB2)
13269 CALL PHO_SWAPI(ICB1,ICC1)
13272 IF(IDEB(9).GE.5) THEN
13273 WRITE(LO,'(1X,A,I12)')
13274 & 'PHO_POSPOM: string end swap (KEVENT)',KEVENT
13275 WRITE(LO,'(5X,A,4I7)')
13276 & 'flavors:',IFLA1,IFLA2,IFLB1,IFLB2
13277 WRITE(LO,'(5X,A,4I7)') 'colors :',ICA1,ICD1,ICB1,ICC1
13284 C purely gluonic pomeron or sea strings formed by gluons
13285 IF(IFLA1.EQ.21) THEN
13286 CALL PHO_REGPAR(-1,21,0,JM1,JM2,P1(1),P1(2),P1(3),P1(4),
13287 & IPOM,IGEN,ICA1,ICD1,IPOS1,1)
13290 C strings formed by quarks
13292 C valence quark labels
13293 IF((INDX1.EQ.1).and.(IPHIST(2,JM1).GE.0)
13294 & .and.(IDHEP(JM1).NE.990)) THEN
13299 CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
13300 & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICA1,
13303 CALL PHO_REGPAR(-1,IFLA2,0,JM1,JM2,PSOFT1(1,IND1),
13304 & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICD1,
13310 C purely gluonic pomeron or sea strings formed by gluons
13311 IF(IFLB1.EQ.21) THEN
13312 CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,P2(1),P2(2),P2(3),P2(4),
13313 & IPOM,IGEN,ICB1,ICC1,IPOS2,1)
13316 C strings formed by quarks
13318 C valence quark labels
13319 IF((INDX2.EQ.1).and.(IPHIST(2,JM2).GE.0)
13320 & .and.(IDHEP(JM2).NE.990)) THEN
13325 CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
13326 & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICB1,
13329 CALL PHO_REGPAR(-1,IFLB2,0,JM2,JM1,PSOFT2(1,IND2),
13330 & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICC1,
13336 C soft pt assignment
13337 IF(ISWMDL(18).EQ.0) THEN
13338 CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(IP),IREJ)
13340 IFAIL(25) = IFAIL(25)+1
13345 * CALL PHO_BFKL(P1,P2,IPART,IREJ)
13346 * IF(IREJ.NE.0) RETURN
13351 *$ CREATE PHO_HADSP2.FOR
13353 CDECK ID>, PHO_HADSP2
13354 SUBROUTINE PHO_HADSP2(IFLB,XS1,XMAX,XSOFT1,IREJ)
13355 C***********************************************************************
13357 C split hadron momentum XMAX into two partons using
13358 C lower cut-off: AS
13360 C input: IFLB compressed particle code of particle to split
13361 C XS1 sum of x values already selected
13362 C XMAX maximal x possible
13364 C output: XS1 new sum of x values (without first one)
13365 C XSOFT1 field of selected x values
13367 C**********************************************************************
13368 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13371 PARAMETER ( DEPS = 1.D-8 )
13373 DIMENSION XSOFT1(50)
13375 C input/output channels
13377 COMMON /POINOU/ LI,LO
13378 C event debugging information
13380 PARAMETER (NMAXD=100)
13381 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13382 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13383 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13384 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13385 C internal rejection counters
13387 PARAMETER (NMXJ=60)
13388 CHARACTER*10 REJTIT
13390 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13391 C data on most recent hard scattering
13392 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13393 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13394 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13395 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13396 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13397 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13398 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13399 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13400 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13403 DATA PVMES1 /-0.5D0/
13404 DATA PVMES2 /-0.5D0/
13405 DATA PVBAR1 / 1.5D0/
13406 DATA PVBAR2 /-0.5D0/
13412 IF(ipho_bar3(IFLB,0).EQ.0) THEN
13413 XPOT1 = PVMES1+1.D0
13414 XPOT2 = PVMES2+1.D0
13415 C baryonic particle
13417 XPOT1 = PVBAR1+1.D0
13418 XPOT2 = PVBAR2+1.D0
13425 IF(ITER.GE.ITMAX) THEN
13426 IF(IDEB(39).GE.3) THEN
13427 WRITE(LO,'(1X,A,I8)')
13428 & 'PHO_HADSP2: REJECTION (ITER)',ITER
13429 WRITE(LO,'(5X,A,3E12.3)') 'XS1,XMAX,AS:',XS1,XMAX,AS
13431 IFAIL(14) = IFAIL(14)+1
13435 ZZ = XREST*PHO_RNDBET(XPOT2,XPOT1)
13436 IF((ZZ.GT.XMAX).OR.(ZZ.LT.AS)) GOTO 100
13438 IF((1.D0-XSS1).LT.AS) GOTO 100
13441 XSOFT1(1) = 1.D0-XSS1
13444 IF(IDEB(39).GE.10) THEN
13445 WRITE(LO,'(1X,A,2I8)') 'PHO_HADSP2: ITMAX,ITER',ITMAX,ITER
13446 WRITE(LO,'(5X,A,3E10.3,5X,2E11.4)') 'XS1,XMAX,AS X1,X2:',
13447 & XS1,XMAX,AS,XSOFT1(1),XSOFT1(2)
13451 *$ CREATE PHO_HADSP3.FOR
13453 CDECK ID>, PHO_HADSP3
13454 SUBROUTINE PHO_HADSP3(IFLB,XS1,XMAX,XSOFT1,IREJ)
13455 C***********************************************************************
13457 C split hadron momentum XMAX into diquark & quark pair
13458 C using lower cut-off: AS
13460 C input: IFLB compressed particle code of particle to split
13461 C XS1 sum of x values already selected
13462 C XMAX maximal x possible
13464 C output: XS1 new sum of x values
13465 C XSOFT1 field of selected x values
13468 C**********************************************************************
13469 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13471 PARAMETER ( DEPS = 1.D-8 )
13473 DIMENSION XSOFT1(50),XSOFT2(50)
13475 C input/output channels
13477 COMMON /POINOU/ LI,LO
13478 C event debugging information
13480 PARAMETER (NMAXD=100)
13481 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13482 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13483 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13484 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13485 C internal rejection counters
13487 PARAMETER (NMXJ=60)
13488 CHARACTER*10 REJTIT
13490 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13491 C data of c.m. system of Pomeron / Reggeon exchange
13492 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
13493 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
13494 & SIDP,CODP,SIFP,COFP
13495 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
13496 & SIDP,CODP,SIFP,COFP,NPOSP(2),
13497 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
13499 DIMENSION XPOT1(3),XPOT2(3),XMIN(2,3)
13502 DATA PVMES1 /-0.5D0/
13503 DATA PVMES2 /-0.5D0/
13504 DATA PSMES /-0.99D0/
13505 DATA PVBAR1 / 1.5D0/
13506 DATA PVBAR2 /-0.5D0/
13507 DATA PSBAR /-0.99D0/
13511 C determine exponents
13517 IF(ipho_bar3(IFLB,0).EQ.0) THEN
13524 C baryonic particle
13544 CALL PHO_SELSXS(3,3,XPOT1,XPOT2,XMIN,XS1,XDUM1,XMAX,XDUM2,
13545 & XSOFT1,XSOFT2,IREJ)
13548 IF(IDEB(74).GE.3) WRITE(LO,'(1X,A,I6,2E12.4)')
13549 & 'PHO_HADSP3: rejection (IFLB,XS1,XMAX)',IFLB,XS1,XMAX
13550 IFAIL(15) = IFAIL(15)+1
13555 IF(IDEB(74).GE.10) THEN
13556 WRITE(LO,'(1X,A,I6,2E12.4)')
13557 & 'PHO_HADSP3: IFLB,XS1,XMAX',IFLB,XS1,XMAX
13559 WRITE(LO,'(10X,I4,2E12.4)') I,XSOFT1(I),XSOFT2(I)
13565 *$ CREATE PHO_SOFTXX.FOR
13567 CDECK ID>, PHO_SOFTXX
13568 SUBROUTINE PHO_SOFTXX(JM1,JM2,MSPAR1,MSPAR2,IVAL1,IVAL2,MSM1,MSM2,
13569 & XSUM1,XSUM2,XMAX1,XMAX2,XS1,XS2,IREJ)
13570 C***********************************************************************
13572 C select soft x values
13574 C input: JM1,JM2 mother particle index in POEVT1
13575 C (0 flavour not known before)
13576 C MSPAR1,2 number of x values to select
13577 C IVAL1,2 number valence quarks involved in hard
13578 C scattering (0,1,2)
13579 C MSM1,2 minimum number of soft x to get sampled
13580 C XSUM1,2 sum of all x values samples up this call
13581 C XMAX1,2 max. x value
13583 C output XSUM1,2 new sum of x-values sampled
13584 C XS1,2 field containing sampled x values
13586 C x values of valence partons are first given
13588 C***********************************************************************
13589 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13592 C input/output channels
13594 COMMON /POINOU/ LI,LO
13595 C event debugging information
13597 PARAMETER (NMAXD=100)
13598 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13599 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13600 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13601 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13602 C internal rejection counters
13604 PARAMETER (NMXJ=60)
13605 CHARACTER*10 REJTIT
13607 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13608 C model switches and parameters
13610 INTEGER ISWMDL,IPAMDL
13611 DOUBLE PRECISION PARMDL
13612 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
13613 C data of c.m. system of Pomeron / Reggeon exchange
13614 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
13615 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
13616 & SIDP,CODP,SIFP,COFP
13617 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
13618 & SIDP,CODP,SIFP,COFP,NPOSP(2),
13619 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
13621 C standard particle data interface
13624 PARAMETER (NMXHEP=4000)
13626 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
13627 DOUBLE PRECISION PHEP,VHEP
13628 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
13629 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
13631 C extension to standard particle data interface (PHOJET specific)
13632 INTEGER IMPART,IPHIST,ICOLOR
13633 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
13635 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
13636 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
13637 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
13638 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
13639 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
13640 C obsolete cut-off information
13641 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
13642 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
13643 C data on most recent hard scattering
13644 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13645 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13646 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13647 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13648 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13649 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13650 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13651 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13652 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13654 DIMENSION XS1(*),XS2(*)
13657 PARAMETER ( MAXPOT = 50 )
13658 DIMENSION XPOT1(MAXPOT),XPOT2(MAXPOT),XMIN(2,MAXPOT)
13662 MSMAX = MAX(MSPAR1,MSPAR2)
13663 MSMIN = MAX(MSM1,MSM2)
13665 IF(MSMAX.GT.MAXPOT) THEN
13666 WRITE(LO,'(1X,2A,2I4)') 'PHO_SOFTXX: no space left in ',
13667 & 'local fields XPOT1/2 (MSMAX,MAXPOT):',MSMAX,MAXPOT
13672 C determine exponents
13673 IBAR1 = ipho_bar3(JM1,2)
13674 IBAR2 = ipho_bar3(JM2,2)
13676 IF((IBAR1*IBAR2).LT.0) ISWAP = 1
13677 C meson-baryon scattering (asymmetric sea)
13678 IF((ABS(IBAR1)+ABS(IBAR2)).EQ.1) THEN
13686 C lower limits for x sampling
13687 XMMINA = 2.D0*PARMDL(157)/ECMP
13688 XBMINA = 2.D0*PARMDL(158)/ECMP
13689 XSMINA = 2.D0*PARMDL(159)/ECMP
13690 XMIN1 = MAX(XSOMIN,AS/XMAX2)
13691 XMIN2 = MAX(XSOMIN,AS/XMAX1)
13692 XMAXP1 = MIN(1.D0-XMIN1*MSMAX,XMAX1)
13693 XMAXP2 = MIN(1.D0-XMIN2*MSMAX,XMAX2)
13694 XMIN1 = MAX(AS/XMAX2,XMIN1)
13695 XMIN2 = MAX(AS/XMAX1,XMIN2)
13698 XMMIN1 = MAX(XMIN1,XMMINA)
13699 XBMIN1 = MAX(XMIN1,XBMINA)
13700 XSMIN1 = MAX(XMIN1,XSMINA)
13702 IF(IBAR1.EQ.0) THEN
13703 IF(IHFLS(1).EQ.0) THEN
13704 XPOT1(1) = PARMDL(62)
13706 XPOT1(2) = PARMDL(63)
13709 XPOT1(1) = PARMDL(54)
13711 XPOT1(2) = PARMDL(55)
13714 DO 100 I=3-IVAL1,MSMAX
13718 C baryonic particle
13720 IF(IHFLS(1).EQ.0) THEN
13721 XPOT1(1) = PARMDL(62)
13723 XPOT1(2) = PARMDL(63)
13726 XPOT1(1) = PARMDL(50)
13728 XPOT1(2) = PARMDL(51)
13731 DO 200 I=3-IVAL1,MSMAX
13738 XMMIN2 = MAX(XMIN2,XMMINA)
13739 XBMIN2 = MAX(XMIN2,XBMINA)
13740 XSMIN2 = MAX(XMIN2,XSMINA)
13742 IF(IBAR2.EQ.0) THEN
13743 IF(IHFLS(2).EQ.0) THEN
13744 XPOT2(1) = PARMDL(62)
13746 XPOT2(2) = PARMDL(63)
13749 XPOT2(1) = PARMDL(54)
13751 XPOT2(2) = PARMDL(55)
13754 DO 300 I=3-IVAL2,MSMAX
13758 C baryonic particle
13760 IF(IHFLS(2).EQ.0) THEN
13761 XPOT2(1) = PARMDL(62)
13763 XPOT2(2) = PARMDL(63)
13766 XPOT2(1) = PARMDL(50)
13768 XPOT2(2) = PARMDL(51)
13771 DO 400 I=3-IVAL2,MSMAX
13781 C check limits (important for valences)
13782 IF((XMIN(1,1).GE.XMAXP1).OR.(XMIN(1,2).GE.XMAXP1)) GOTO 1000
13783 IF((XMIN(2,1).GE.XMAXP2).OR.(XMIN(2,2).GE.XMAXP2)) GOTO 1000
13786 IF(IHFLS(1).NE.0) XMINS1 = XMINS1+(PARMDL(166)/ECMP)**2
13788 IF(IHFLS(2).NE.0) XMINS2 = XMINS2+(PARMDL(166)/ECMP)**2
13790 XMINS1 = XMINS1+XMIN(1,I)
13791 XMINS2 = XMINS2+XMIN(2,I)
13793 IF((XMINS1.GE.1.D0).OR.(XMINS2.GE.1.D0)) GOTO 1000
13795 C try to sample x values
13796 IF(IPAMDL(14).EQ.0) THEN
13797 IF(MSOFT.EQ.2) THEN
13798 CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13800 ELSE IF(MSOFT.LT.5) THEN
13801 CALL PHO_SELSXR(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13802 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13804 CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13805 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13807 ELSE IF(IPAMDL(14).EQ.1) THEN
13808 IF(MSOFT.EQ.2) THEN
13809 CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13812 CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13813 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13815 ELSE IF(IPAMDL(14).EQ.2) THEN
13816 CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13817 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13818 ELSE IF(IPAMDL(14).EQ.3) THEN
13819 IF(MSOFT.EQ.2) THEN
13820 CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13822 ELSE IF(IVAL1+IVAL2.EQ.0) THEN
13823 CALL PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13824 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13826 CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13827 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13830 WRITE(LO,'(/,1X,A,I3)')
13831 & 'PHO_SOFTXX:ERROR: unsupported IPAMDL(14)',IPAMDL(14)
13835 IFAIL(41) = IFAIL(41)+1
13836 IF(IDEB(60).GE.2) THEN
13837 WRITE(LO,'(1X,A,I12,4I3)')
13838 & 'PHO_SOFTXX: rejection: EVE,MSP1/2,MSM1/2',
13839 & KEVENT,MSPAR1,MSPAR2,MSM1,MSM2
13840 WRITE(LO,'(1X,A,1P4E11.3)') 'XSUM1/2,XMAX1/2',
13841 & XSUM1,XSUM2,XMAX1,XMAX2
13845 IF(MSOFT.NE.MSMAX) THEN
13846 MSDIFF = MSMAX-MSOFT
13847 MSPAR1 = MSPAR1-MSDIFF
13848 MSPAR2 = MSPAR2-MSDIFF
13851 C correct for different MSPAR numbers
13852 IF(MSOFT.NE.MSPAR1) THEN
13853 IF(MSPAR1.GT.1) THEN
13855 DO 500 I=MSPAR1+1,MSOFT
13858 XFAC = (1.D0-XSUM1)/(1.D0-XDEL-XSUM1)
13860 XS1(I) = XS1(I)*XFAC
13862 XSS1 = (XSS1-XDEL-XSUM1)*XFAC+XSUM1
13867 IF(MSOFT.NE.MSPAR2) THEN
13868 IF(MSPAR2.GT.1) THEN
13870 DO 600 I=MSPAR2+1,MSOFT
13873 XFAC = (1.D0-XSUM2)/(1.D0-XDEL-XSUM2)
13875 XS2(I) = XS2(I)*XFAC
13877 XSS2 = (XSS2-XDEL-XSUM2)*XFAC+XSUM2
13884 XS1(1) = 1.D0 - XSS1
13885 XS2(1) = 1.D0 - XSS2
13890 IF(IDEB(60).GE.10) THEN
13891 WRITE(LO,'(1X,A,I8,2I4,2E12.4)')
13892 & 'PHO_SOFTXX: EVE,MSPAR1/2,XSUM1/2:',
13893 & KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
13894 WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I XS1/2 XPOT1/2 XMIN1/2'
13896 WRITE(LO,'(5X,I3,6E12.4)') I,XS1(I),XS2(I),XPOT1(I),XPOT2(I),
13897 & XMIN(1,I),XMIN(2,I)
13903 C not enough phase space
13906 IFAIL(42) = IFAIL(42)+1
13910 IF(IDEB(60).GE.1) THEN
13911 WRITE (6,'(1X,A,1P,2E11.3,/1X,A,/5X,6E11.3)')
13912 & 'PHO_SOFTXX: Xmin>Xmax or sum(Xmin)>1 (ECM,AS)',
13913 & ECMP,AS,'PHO_SOFTXX: Xmin1/2,Xmaxp1/2,sum(Xmin1/2)',
13914 & XMIN1,XMIN2,XMAXP1,XMAXP2,XMINS1,XMINS2
13915 WRITE(LO,'(1X,A,1P,3E11.3)')
13916 & 'PHO_SOFTXX: Xmmina,Xbmina,Xsmina:',XMMINA,XBMINA,XSMINA
13917 WRITE(LO,'(1X,A,1P,3E11.3)')
13918 & 'PHO_SOFTXX: Xmmin1,Xbmin1,Xsmin1:',XMMIN1,XBMIN1,XSMIN1
13919 WRITE(LO,'(1X,A,1P,3E11.3)')
13920 & 'PHO_SOFTXX: Xmmin2,Xbmin2,Xsmin2:',XMMIN2,XBMIN2,XSMIN2
13922 & 'PHO_SOFTXX: Table of lower x limits (I,Xmin(1,I),Xmin(2,I))'
13924 WRITE(LO,'(5X,I3,1P,2E11.3)') I,XMIN(1,I),XMIN(2,I)
13926 WRITE(LO,'(1X,A,I10,2I4,2E11.3)')
13927 & 'PHO_SOFTXX: KEVENT,MSPAR1/2,XSUM1/2:',
13928 & KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
13929 WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I XPOT1/2 XMIN1/2'
13931 WRITE(LO,'(5X,I3,4E12.4)') I,XPOT1(I),XPOT2(I),
13932 & XMIN(1,I),XMIN(2,I)
13938 *$ CREATE PHO_SELSXR.FOR
13940 CDECK ID>, PHO_SELSXR
13941 SUBROUTINE PHO_SELSXR(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
13942 & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
13943 C***********************************************************************
13945 C select x values of soft string ends (rejection method)
13947 C***********************************************************************
13948 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13951 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
13953 C input/output channels
13955 COMMON /POINOU/ LI,LO
13956 C event debugging information
13958 PARAMETER (NMAXD=100)
13959 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13960 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13961 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13962 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13963 C model switches and parameters
13965 INTEGER ISWMDL,IPAMDL
13966 DOUBLE PRECISION PARMDL
13967 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
13968 C data on most recent hard scattering
13969 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13970 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13971 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13972 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13973 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13974 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13975 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13976 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13977 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13978 C global event kinematics and particle IDs
13979 INTEGER IFPAP,IFPAB
13980 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
13981 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
13982 C obsolete cut-off information
13983 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
13984 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
13986 DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
13988 IF(IDEB(13).GE.10) THEN
13989 WRITE(LO,'(1X,A)') 'PHO_SELSXR:'
13990 WRITE(LO,'(5X,A,I4,5E11.3)') 'MSOFT,XS1,XS2,XMAX1,2',
13991 & MSOFT,XS1,XS2,XMAX1,XMAX2
13993 WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
13999 XMINK = MAX(PSOMIN/ECM*2.D0,XSOMIN)
14000 XMIN1 = MAX(AS/XMAX1,XMINK)
14001 XMIN2 = MAX(AS/XMAX2,XMINK)
14003 IF(MSOFT.EQ.1) THEN
14008 XWMAX = MAX(XMAX1**XPOT1(1),XMIN1**XPOT1(1))
14009 & *MAX(XMAX2**XPOT2(1),XMIN2**XPOT2(1))
14014 POT(1,I) = XPOT1(I)+1.D0
14015 POT(2,I) = XPOT2(I)+1.D0
14016 REVP(1,I) = 1.D0/POT(1,I)
14017 REVP(2,I) = 1.D0/POT(2,I)
14018 XLMIN(1,I) = XMIN(1,I)**POT(1,I)
14019 XLMAX = XMAX1**POT(1,I)
14020 XLDIF(1,I) = XLMAX-XLMIN(1,I)
14021 XLMIN(2,I) = XMIN(2,I)**POT(2,I)
14022 XLMAX = XMAX2**POT(2,I)
14023 XLDIF(2,I) = XLMAX-XLMIN(2,I)
14029 IF(ITRY0.GE.IPAMDL(181)) THEN
14030 IF(MSOFT-MSMIN.GE.2) THEN
14042 Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
14043 Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
14044 XSOFT1(I) = Z1**REVP(1,I)
14045 XSOFT2(I) = Z2**REVP(2,I)
14047 IF(ITRY1.GE.50) GOTO 1000
14048 IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
14050 XREST1 = XREST1-XSOFT1(I)
14051 IF(XREST1.LT.XMIN1) GOTO 5
14052 IF(XREST1.LT.XMIN(1,1)) GOTO 5
14053 XREST2 = XREST2-XSOFT2(I)
14054 IF(XREST2.LT.XMIN2) GOTO 5
14055 IF(XREST2.LT.XMIN(2,1)) GOTO 5
14056 IF(XREST1*XREST2.LT.AS) GOTO 5
14064 * XX = XX*XSOFT1(I)**XPOT1(I)*XSOFT2(I)**XPOT2(I)
14066 XX = XSOFT1(1)**XPOT1(1)*XSOFT2(1)**XPOT2(1)
14067 IF((XX-DT_RNDM(XX)*XWMAX).LT.0.D0) GOTO 5
14075 IF(IDEB(13).GE.2) THEN
14076 WRITE(LO,'(1X,A,2I4)')
14077 & 'PHO_SELSXR: REJECTION(ITRY0/1)',ITRY0,ITRY1
14078 WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
14083 *$ CREATE PHO_SELSX2.FOR
14085 CDECK ID>, PHO_SELSX2
14086 SUBROUTINE PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
14088 C***********************************************************************
14090 C select x values of soft string ends using PHO_RNDBET
14092 C***********************************************************************
14093 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14096 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XS1(*),XS2(*)
14098 C input/output channels
14100 COMMON /POINOU/ LI,LO
14101 C event debugging information
14103 PARAMETER (NMAXD=100)
14104 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14105 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14106 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14107 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14108 C model switches and parameters
14110 INTEGER ISWMDL,IPAMDL
14111 DOUBLE PRECISION PARMDL
14112 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14113 C data on most recent hard scattering
14114 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14115 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14116 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14117 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14118 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14119 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14120 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14121 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14122 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14123 C obsolete cut-off information
14124 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14125 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14129 IF(IDEB(32).GE.10) THEN
14130 WRITE(LO,'(1X,A)') 'PHO_SELSX2:'
14131 WRITE(LO,'(5X,A,5E11.3)') 'AS,XSUM1,2,XMAX1,2',
14132 & AS,XSUM1,XSUM2,XMAX1,XMAX2
14134 WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
14141 GAM1 = XPOT1(1)+1.D0
14142 GAM2 = XPOT2(1)+1.D0
14143 BET1 = XPOT1(2)+1.D0
14144 BET2 = XPOT2(2)+1.D0
14147 DO 100 I=1,IPAMDL(182)
14151 X1 = PHO_RNDBET(GAM1,BET1)
14153 IF(ITRY1.GE.50) GOTO 1000
14154 IF((X1.LE.XMIN(1,1)).OR.((1.D0-X1).LE.XMIN(1,2))) GOTO 10
14158 X2 = PHO_RNDBET(GAM2,BET2)
14160 IF(ITRY2.GE.50) GOTO 1000
14161 IF((X2.LE.XMIN(2,1)).OR.((1.D0-X2).LE.XMIN(2,2))) GOTO 11
14165 IF(X1*X2*FAC.GT.AS) THEN
14166 IF(X3*X4*FAC.GT.AS) THEN
14171 IF(XS1(1).GT.XMIN(1,1)) THEN
14172 IF(XS2(1).GT.XMIN(2,1)) THEN
14173 IF(XS1(2).GT.XMIN(1,2)) THEN
14174 IF(XS2(2).GT.XMIN(2,2)) THEN
14175 XSUM1 = XSUM1+XS1(2)
14176 XSUM2 = XSUM2+XS2(2)
14190 IF(IDEB(32).GE.2) THEN
14191 WRITE(LO,'(1X,A,3I4)')
14192 & 'PHO_SELSX2: REJECTION(ITRY0/1/2)',ITRY0,ITRY1,ITRY2
14193 WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
14200 *$ CREATE PHO_SELSXS.FOR
14202 CDECK ID>, PHO_SELSXS
14203 SUBROUTINE PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
14204 & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
14205 C***********************************************************************
14207 C select x values of soft string ends (rescaling method)
14209 C***********************************************************************
14210 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14213 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
14215 C input/output channels
14217 COMMON /POINOU/ LI,LO
14218 C event debugging information
14220 PARAMETER (NMAXD=100)
14221 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14222 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14223 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14224 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14225 C model switches and parameters
14227 INTEGER ISWMDL,IPAMDL
14228 DOUBLE PRECISION PARMDL
14229 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14230 C data on most recent hard scattering
14231 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14232 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14233 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14234 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14235 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14236 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14237 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14238 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14239 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14240 C obsolete cut-off information
14241 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14242 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14244 DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
14250 IF(MSOFT.EQ.1) THEN
14251 XSOFT1(1) = 1.D0-XS1
14253 XSOFT2(1) = 1.D0-XS2
14259 POT(1,I) = XPOT1(I)+1.D0
14260 POT(2,I) = XPOT2(I)+1.D0
14261 REVP(1,I) = 1.D0/POT(1,I)
14262 REVP(2,I) = 1.D0/POT(2,I)
14263 XLMIN(1,I) = XMIN(1,I)**POT(1,I)
14264 XLMAX = XMAX1**POT(1,I)
14265 XLDIF(1,I) = XLMAX-XLMIN(1,I)
14266 XLMIN(2,I) = XMIN(2,I)**POT(2,I)
14267 XLMAX = XMAX2**POT(2,I)
14268 XLDIF(2,I) = XLMAX-XLMIN(2,I)
14274 IF(ITRY0.GE.IPAMDL(180)) THEN
14275 IF(MSOFT-MSMIN.GE.2) THEN
14286 Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
14287 Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
14288 XSOFT1(I) = Z1**REVP(1,I)
14289 XSOFT2(I) = Z2**REVP(2,I)
14291 IF(ITRY1.GE.50) GOTO 1000
14292 IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
14293 XSUM1 = XSUM1+XSOFT1(I)
14294 XSUM2 = XSUM2+XSOFT2(I)
14296 FAC1 = (1.D0-XS1)/XSUM1
14297 FAC2 = (1.D0-XS2)/XSUM2
14299 XSOFT1(I) = XSOFT1(I)*FAC1
14300 XSOFT2(I) = XSOFT2(I)*FAC2
14301 IF(XSOFT1(I).LT.XMIN(1,I)) GOTO 5
14302 IF(XSOFT2(I).LT.XMIN(2,I)) GOTO 5
14303 IF(XSOFT1(I)*XSOFT2(I).LT.AS) GOTO 5
14306 XS1 = 1.D0-XSOFT1(1)
14307 XS2 = 1.D0-XSOFT2(1)
14312 IF(IDEB(14).GE.2) THEN
14313 WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXS: ',
14314 & 'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
14316 WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
14322 *$ CREATE PHO_SELSXI.FOR
14324 CDECK ID>, PHO_SELSXI
14325 SUBROUTINE PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
14326 & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
14327 C***********************************************************************
14329 C select x values of soft string ends (sea independent from valence)
14331 C***********************************************************************
14332 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14335 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
14337 C input/output channels
14339 COMMON /POINOU/ LI,LO
14340 C event debugging information
14342 PARAMETER (NMAXD=100)
14343 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14344 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14345 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14346 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14347 C model switches and parameters
14349 INTEGER ISWMDL,IPAMDL
14350 DOUBLE PRECISION PARMDL
14351 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14352 C data on most recent hard scattering
14353 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14354 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14355 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14356 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14357 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14358 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14359 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14360 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14361 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14362 C obsolete cut-off information
14363 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14364 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14366 DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
14373 POT(1,I) = XPOT1(I)+1.D0
14374 POT(2,I) = XPOT2(I)+1.D0
14375 REVP(1,I) = 1.D0/POT(1,I)
14376 REVP(2,I) = 1.D0/POT(2,I)
14377 XLMIN(1,I) = XMIN(1,I)**POT(1,I)
14378 XLMAX = XMAX1**POT(1,I)
14379 XLDIF(1,I) = XLMAX-XLMIN(1,I)
14380 XLMIN(2,I) = XMIN(2,I)**POT(2,I)
14381 XLMAX = XMAX2**POT(2,I)
14382 XLDIF(2,I) = XLMAX-XLMIN(2,I)
14390 IF(ITRY0.GE.IPAMDL(183)) THEN
14391 IF(MSOFT-MSMIN.GE.2) THEN
14402 Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
14403 Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
14404 XSOFT1(I) = Z1**REVP(1,I)
14405 XSOFT2(I) = Z2**REVP(2,I)
14407 IF(ITRY1.GE.50) GOTO 1000
14408 IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
14409 XSUM1 = XSUM1+XSOFT1(I)
14410 XSUM2 = XSUM2+XSOFT2(I)
14413 IF(XSUM1.GT.1.D0-XMIN(1,1)-XMIN(1,2)) GOTO 5
14414 IF(XSUM2.GT.1.D0-XMIN(2,1)-XMIN(2,2)) GOTO 5
14416 C selection of valence
14417 CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
14418 & XSOFT1,XSOFT2,IREJ)
14420 IF(MSOFT-MSMIN.GE.2) THEN
14424 IF(IDEB(31).GE.2) WRITE(LO,'(1X,A,1P,4E11.4)')
14425 & 'PHO_SELSXI: rejection by PHO_SELSX2 (XSUM1/2,XMAX1/2)',
14426 & XSUM1,XSUM2,XMAX1,XMAX2
14430 XS1 = 1.D0-XSOFT1(1)
14431 XS2 = 1.D0-XSOFT2(1)
14436 IF(IDEB(14).GE.2) THEN
14437 WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXI: ',
14438 & 'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
14440 WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
14446 *$ CREATE PHO_SELCOL.FOR
14448 CDECK ID>, PHO_SELCOL
14449 SUBROUTINE PHO_SELCOL(ICO1,ICO2,ICOA1,ICOA2,ICOB1,ICOB2,IMODE)
14450 C********************************************************************
14452 C color combinatorics
14454 C input: ICO1,2 colors of incoming particle
14455 C IMODE -2 output of initialization status
14456 C -1 initialization
14457 C ICINP(1) selection mode
14459 C 1 large N_c expansion
14460 C ICINP(2) max. allowed color
14461 C 0 clear internal color counter
14462 C 1 hadron into two colored objects
14463 C 2 quark into quark gluon
14464 C 3 gluon into gluon gluon
14465 C 4 gluon into quark antiquark
14467 C output: ICOA1,2 colors of first outgoing particle
14468 C ICOB1,2 colors of second outgoing particle
14470 C********************************************************************
14471 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14474 C input/output channels
14476 COMMON /POINOU/ LI,LO
14477 C event debugging information
14479 PARAMETER (NMAXD=100)
14480 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14481 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14482 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14483 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14485 DATA METHOD /0/, II /0/
14489 IF(METHOD.EQ.0) THEN
14491 IF(IMODE.EQ.1) THEN
14494 & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14499 ELSE IF(IMODE.EQ.2) THEN
14502 & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14513 ELSE IF(IMODE.EQ.3) THEN
14516 & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14517 IF(DT_RNDM(DUM).GT.0.5D0) THEN
14528 ELSE IF(IMODE.EQ.4) THEN
14533 ELSE IF(IMODE.EQ.0) THEN
14535 ELSE IF(IMODE.EQ.-1) THEN
14538 ELSE IF(IMODE.EQ.-2) THEN
14539 WRITE(LO,'(1X,A,2I5)') 'PHO_SELCOL: METHOD,MAXCOL',
14542 WRITE(LO,'(1X,A,I5)')
14543 & 'PHO_SELCOL:ERROR: unsupported mode',IMODE
14548 WRITE(LO,'(1X,A,I5)')
14549 & 'PHO_SELCOL:ERROR:unsupported method selected',METHOD
14554 IF(IDEB(75).GE.10) THEN
14555 WRITE(LO,'(1X,A,I5,I12,I5)') 'PHO_SELCOL: IMODE,MAXCOL,II',
14557 WRITE(LO,'(10X,A,2I5)') 'input colors',ICI1,ICI2
14558 WRITE(LO,'(10X,A,4I5)') 'output colors',ICOA1,ICOA2,ICOB1,ICOB2
14563 *$ CREATE ipho_diqu.FOR
14565 CDECK ID>, ipho_diqu
14566 INTEGER FUNCTION ipho_diqu(iq1,iq2)
14567 C***********************************************************************
14569 C selection of diquark number (PDG convention)
14571 C***********************************************************************
14579 C input/output channels
14581 COMMON /POINOU/ LI,LO
14582 C event debugging information
14584 PARAMETER (NMAXD=100)
14585 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14586 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14587 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14588 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14589 C model switches and parameters
14591 INTEGER ISWMDL,IPAMDL
14592 DOUBLE PRECISION PARMDL
14593 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14595 C external functions
14596 double precision DT_RNDM
14600 double precision dum
14608 i0 = max(i1,i2)*1000+min(i1,i2)*100
14609 if(DT_RNDM(dum).gt.PARMDL(135)) then
14616 ipho_diqu = sign(i0,iq1)
14620 *$ CREATE PHO_PARREM.FOR
14622 CDECK ID>, PHO_PARREM
14623 SUBROUTINE PHO_PARREM(INDX,IOUT,IREM,IREJ)
14624 C**********************************************************************
14626 C selection of particle remnant flavour(s) (quark or diquark)
14628 C input: INDX index of particle in /POEVT1/
14629 C IOUT parton which was taken out
14631 C output: IREM remnant according to valence flavours
14632 C IREJ 0 flavour combination possible
14633 C 1 flavour combination impossible
14635 C all particle ID are given according to PDG conventions
14637 C**********************************************************************
14643 integer INDX,IOUT,IREM,IREJ
14645 C input/output channels
14647 COMMON /POINOU/ LI,LO
14648 C event debugging information
14650 PARAMETER (NMAXD=100)
14651 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14652 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14653 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14654 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14656 C standard particle data interface
14659 PARAMETER (NMXHEP=4000)
14661 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14662 DOUBLE PRECISION PHEP,VHEP
14663 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14664 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14666 C extension to standard particle data interface (PHOJET specific)
14667 INTEGER IMPART,IPHIST,ICOLOR
14668 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14670 C general particle data
14671 double precision xm_list,tau_list,gam_list,
14672 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
14673 & xm_bb82_list,xm_bb102_list
14674 integer ich3_list,iba3_list,iq_list,
14675 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
14676 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
14677 & xm_psm2_list(6,6),xm_vem2_list(6,6),
14678 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
14679 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
14680 & ich3_list(300),iba3_list(300),iq_list(3,300),
14681 & id_psm_list(6,6),id_vem_list(6,6),
14682 & id_b8_list(6,6,6),id_b10_list(6,6,6)
14684 C external functions
14688 integer ID,IS,ID1,ID2,i,k,K1,K2,IQUA,IDQ
14689 dimension IQUA(3),IDQ(2)
14696 WRITE(LO,'(1X,A,I6)') 'PHO_PARREM: no CPC ID available for',INDX
14700 C particle with flavour mixing
14705 else if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
14706 C pi0, rho0, and omega
14707 IF(ABS(IOUT).LE.2) THEN
14713 else if((abs(ID1).eq.311).or.(ID1.eq.310).or.(ID1.eq.130)) then
14714 C neutral kaons (K0,K0-bar)
14715 if(abs(IOUT).eq.1) then
14716 IREM = sign(3,-IOUT)
14718 else if(abs(IOUT).eq.3) then
14719 IREM = sign(1,-IOUT)
14724 else if((ID1.eq.990).or.(ID1.eq.110)) then
14725 C pomeron and reggeon
14733 IQUA(1) = iq_list(1,ID)*IS
14734 IQUA(2) = iq_list(2,ID)*IS
14735 IQUA(3) = iq_list(3,ID)*IS
14737 C compare to flavour content
14738 IF(ABS(IOUT).LT.1000) THEN
14739 C single quark requested
14740 IF(IQUA(1).EQ.IOUT) THEN
14743 ELSE IF(IQUA(2).EQ.IOUT) THEN
14746 ELSE IF(IQUA(3).EQ.IOUT) THEN
14752 IF(IQUA(3).EQ.0) THEN
14755 IREM = ipho_diqu(IQUA(K1),IQUA(K2))
14757 ELSE IF(IQUA(3).NE.0) THEN
14758 C diquark requested from baryon
14760 IDQ(2) = (IOUT-IDQ(1)*1000)/100
14763 if(IDQ(i).eq.IQUA(k)) then
14771 IREM = IQUA(1)+IQUA(2)+IQUA(3)
14776 IF(IDEB(72).GE.10) WRITE(LO,'(1X,A,5I6)')
14777 & 'PHO_PARREM: INDX,ID-PDG,ID-BAM,IOUT,IREM',
14778 & INDX,ID1,ID2,IOUT,IREM
14784 IF(IDEB(72).GE.2) WRITE(LO,'(1X,A,5I7)')
14785 & 'PHO_PARREM: rejection IDPDG,Q1-3,IOUT',IDHEP(INDX),IQUA,IOUT
14789 *$ CREATE PHO_VALFLA.FOR
14791 CDECK ID>, PHO_VALFLA
14792 SUBROUTINE PHO_VALFLA(IPAR,IFL1,IFL2,E1,E2)
14793 C***********************************************************************
14795 C selection of valence flavour decomposition of particle IPAR
14797 C input: IPAR particle index in /POEVT1/
14798 C -1 initialization
14799 C -2 output of statistics
14800 C XMASS mass of particle
14801 C (important for pomeron:
14802 C mass dependent flavour sampling)
14804 C output: IFL1,IFL2
14805 C baryon: IFL1 diquark flavour
14806 C (valence flavours according to PDG conventions)
14808 C***********************************************************************
14809 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14812 PARAMETER ( EPS = 0.1D0,
14815 C input/output channels
14817 COMMON /POINOU/ LI,LO
14818 C event debugging information
14820 PARAMETER (NMAXD=100)
14821 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14822 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14823 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14824 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14825 C model switches and parameters
14827 INTEGER ISWMDL,IPAMDL
14828 DOUBLE PRECISION PARMDL
14829 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14831 C standard particle data interface
14834 PARAMETER (NMXHEP=4000)
14836 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14837 DOUBLE PRECISION PHEP,VHEP
14838 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14839 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14841 C extension to standard particle data interface (PHOJET specific)
14842 INTEGER IMPART,IPHIST,ICOLOR
14843 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14845 C general particle data
14846 double precision xm_list,tau_list,gam_list,
14847 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
14848 & xm_bb82_list,xm_bb102_list
14849 integer ich3_list,iba3_list,iq_list,
14850 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
14851 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
14852 & xm_psm2_list(6,6),xm_vem2_list(6,6),
14853 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
14854 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
14855 & ich3_list(300),iba3_list(300),iq_list(3,300),
14856 & id_psm_list(6,6),id_vem_list(6,6),
14857 & id_b8_list(6,6,6),id_b10_list(6,6,6)
14863 C select particle code
14865 ID = abs(IMPART(K))
14866 IBAR = IPHO_BAR3(K,2)
14874 if(ITER.GT.ITMX) then
14875 WRITE(LO,'(1x,2a,i10,1p,2e11.3)') 'PHO_VALFLA: ',
14876 & 'no valences found for (IPAR,E1,E2)',IPAR,E1,E2
14885 C charge dependent flavour sampling
14887 K = INT(DT_RNDM(E1)*6.D0)+1
14891 ELSE IF(K.EQ.5) THEN
14898 C optional strangeness suppression
14899 IF((IFL1.EQ.3).AND.(DT_RNDM(E2).GT.PARMDL(160))) GOTO 15
14900 IF(DT_RNDM(DUM).LT.0.5D0) THEN
14907 ELSE IF((ID1.EQ.990).or.(ID1.eq.110)) THEN
14908 IF(ISWMDL(19).EQ.0) THEN
14909 C SU(3) symmetric valences
14910 K = INT(DT_RNDM(E1)*3.D0)+1
14911 IF(DT_RNDM(DUM).LT.0.5D0) THEN
14917 ELSE IF(ISWMDL(19).EQ.1) THEN
14918 C mass dependent flavour sampling
14920 CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
14922 WRITE(LO,'(/1X,2A,I5)') 'PHO_VALFLA: ',
14923 & 'invalid flavour selection mode ISWMDL(19)',ISWMDL(19)
14927 C meson with flavour mixing
14928 ELSE if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
14929 K = INT(2.D0*DT_RNDM(E1))+1
14934 K = INT(2.D0*DT_RNDM(E1))+1
14935 IFL1 = iq_list(K,ID)
14937 IFL2 = iq_list(K,ID)
14940 CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
14946 K = INT(2.999999D0*DT_RNDM(E2))+1
14949 IFL1 = ipho_diqu(iq_list(K1,ID),iq_list(K2,ID))
14950 IFL2 = iq_list(K,ID)
14953 C change sign for antiparticles
14959 ************************************************************************
14960 C check kinematic constraints
14961 * IF((PHO_PMASS(IFL1,3).GT.E1)
14962 * & .OR.(PHO_PMASS(IFL2,3).GT.E2)) GOTO 10
14963 ************************************************************************
14966 IF(IDEB(46).GE.10) WRITE(LO,'(1X,A,I5,2E12.4,2I7)')
14967 & 'PHO_VALFLA: IPAR,MASS1/2,FL1/2',IPAR,E1,E2,IFL1,IFL2
14969 ELSE IF(IPAR.EQ.-1) THEN
14972 ELSE IF(IPAR.EQ.-2) THEN
14973 C output of final statistics
14976 WRITE(LO,'(1X,A,I10)')
14977 & 'PHO_VALFLA:ERROR: invalid input particle (IPAR)',IPAR
14983 *$ CREATE PHO_REGFLA.FOR
14985 CDECK ID>, PHO_REGFLA
14986 SUBROUTINE PHO_REGFLA(JM1,JM2,IFLR1,IFLR2,IREJ)
14987 C**********************************************************************
14989 C selection of reggeon flavours
14991 C input: JM1,JM2 position index of mother hadrons
14993 C output: IFLR1,IFLR2 valence flavours according to
14994 C PDG conventions and JM1,JM2
14995 C IREJ 0 reggeon possible
14996 C 1 reggeon impossible
14998 C**********************************************************************
14999 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15002 PARAMETER ( EPS = 0.1D0,
15005 C input/output channels
15007 COMMON /POINOU/ LI,LO
15008 C event debugging information
15010 PARAMETER (NMAXD=100)
15011 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15012 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15013 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15014 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15015 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
15016 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
15017 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
15018 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
15019 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
15021 C standard particle data interface
15024 PARAMETER (NMXHEP=4000)
15026 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15027 DOUBLE PRECISION PHEP,VHEP
15028 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15029 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15031 C extension to standard particle data interface (PHOJET specific)
15032 INTEGER IMPART,IPHIST,ICOLOR
15033 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15039 E1 = SQRT((PHEP(4,JM1)+PHEP(4,JM2))**2
15040 & -(PHEP(1,JM1)+PHEP(1,JM2))**2
15041 & -(PHEP(2,JM1)+PHEP(2,JM2))**2
15042 & -(PHEP(3,JM1)+PHEP(3,JM2))**2)/2.D0
15045 IF(ITER.GT.50) THEN
15048 IF(IDEB(41).GE.2) WRITE(LO,'(/1X,A,2I7,1P,E12.4)')
15049 & 'PHO_REGFLA: rejection, no reggeon found for',
15050 & IDHEP(JM1),IDHEP(JM2),E1
15054 CALL PHO_VALFLA(JM1,IFLA1,IFLA2,E1,E1)
15055 CALL PHO_VALFLA(JM2,IFLB1,IFLB2,E1,E1)
15056 IF(IFLA1.EQ.-IFLB1) THEN
15059 ELSE IF(IFLA1.EQ.-IFLB2) THEN
15062 ELSE IF(IFLA2.EQ.-IFLB1) THEN
15065 ELSE IF(IFLA2.EQ.-IFLB2) THEN
15070 IF(IDEB(41).GE.25) WRITE(LO,'(/1X,A,3I4)')
15071 & 'PHO_REGFLA: int.rejection JM1,JM2,ITRY',JM1,JM2,ITER
15075 IF(IDEB(41).GE.10) WRITE(LO,'(1X,A,/5X,2I4,2I6,2I5,1PE10.3)')
15076 & 'PHO_REGFLA: JM1/2,PDG-ID1/2,IFLR1/2,MASS',
15077 & JM1,JM2,IDHEP(JM1),IDHEP(JM2),IFLR1,IFLR2,E1
15078 ELSE IF(JM1.EQ.-1) THEN
15080 ELSE IF(JM1.EQ.-2) THEN
15081 C output of statistics
15083 WRITE(LO,'(1X,A,I10)')
15084 & 'PHO_REGFLA: invalid mother particle (JM1)',JM1
15090 *$ CREATE PHO_SEAFLA.FOR
15092 CDECK ID>, PHO_SEAFLA
15093 SUBROUTINE PHO_SEAFLA(IPAR,IFL1,IFL2,CHMASS)
15094 C**********************************************************************
15096 C selection of sea flavour content of particle IPAR
15098 C input: IPAR particle index in /POEVT1/
15099 C CHMASS available invariant string mass
15100 C positive mass --> use BAMJET method
15101 C negative mass --> SU(3) symmetric sea according
15102 C to values given in PARMDL(1-6)
15103 C IPAR -1 initialization
15104 C -2 output of statistics
15106 C output: sea flavours according to PDG conventions
15108 C**********************************************************************
15109 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15112 PARAMETER ( EPS = 0.1D0,
15115 C input/output channels
15117 COMMON /POINOU/ LI,LO
15118 C event debugging information
15120 PARAMETER (NMAXD=100)
15121 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15122 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15123 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15124 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15125 C model switches and parameters
15127 INTEGER ISWMDL,IPAMDL
15128 DOUBLE PRECISION PARMDL
15129 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15130 C some hadron information, will be deleted in future versions
15132 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
15133 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
15136 IF((ISWMDL(20).EQ.1).OR.(CHMASS.LT.0.D0)) THEN
15137 C constant weights for sea
15141 SUM = SUM + PARMDL(K)
15143 XI = DT_RNDM(SUM)*SUM
15146 SUM = SUM + PARMDL(K)
15147 IF(XI.LE.SUM) GOTO 55
15150 IF(K.GT.NFSEA) GOTO 15
15152 C mass dependent flavour sampling
15154 CALL PHO_FLAUX(CHMASS,K)
15155 IF(K.GT.NFSEA) GOTO 10
15157 IF(DT_RNDM(CHMASS).GT.0.5D0) K = -K
15160 IF(IDEB(46).GE.10) THEN
15161 WRITE(LO,'(1X,A,3I5,E12.4)') 'PHO_SEAFLA:IPAR,IFL1,IFL2,MASS',
15162 & IPAR,IFL1,IFL2,CHMASS
15164 ELSE IF(IPAR.EQ.-1) THEN
15167 ELSE IF(IPAR.EQ.-2) THEN
15168 C output of statistics
15170 WRITE(LO,'(1X,A,I10)') 'PHO_SEAFLA:ERROR:INVALID IPAR',IPAR
15176 *$ CREATE PHO_FLAUX.FOR
15178 CDECK ID>, PHO_FLAUX
15179 SUBROUTINE PHO_FLAUX(EQUARK,K)
15180 C***********************************************************************
15182 C auxiliary subroutine to select flavours
15184 C********************************************************************
15185 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15188 PARAMETER ( DEPS = 1.D-14 )
15190 C input/output channels
15192 COMMON /POINOU/ LI,LO
15193 C event debugging information
15195 PARAMETER (NMAXD=100)
15196 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15197 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15198 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15199 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15200 C some hadron information, will be deleted in future versions
15202 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
15203 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
15207 C calculate weights for given energy
15208 IF(EQUARK.LT.QMASS(1)) THEN
15210 & WRITE(LO,'(1X,A,E12.3)') 'PHO_FLAUX: VERY SMALL MASS',
15220 IF(EQUARK.GT.QMASS(K)) THEN
15221 WGHT(K) = PHO_BETAF(EQUARK,QMASS(K),BET)
15225 SUM = SUM + WGHT(K)
15229 XI = SUM*(DT_RNDM(SUM)-DEPS)
15234 SUM = SUM + WGHT(K)
15235 IF(XI.GT.SUM) GOTO 400
15237 IF(IDEB(16).GE.20) THEN
15238 WRITE(LO,'(1X,A,I5)') 'PHO_FLAUX: selected flavour',K
15242 *$ CREATE PHO_BETAF.FOR
15244 CDECK ID>, PHO_BETAF
15245 DOUBLE PRECISION FUNCTION PHO_BETAF(X1,X2,BET)
15246 C********************************************************************
15248 C weights of different quark flavours
15250 C********************************************************************
15251 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15256 IF(BETX1.LT.70.D0) AX=-1.D0/BET**2*(BETX1+1.D0)*EXP(-BETX1)
15257 AY=1.D0/BET**2*(BET*X2+1.D0)*EXP(-BET*X2)
15263 *$ CREATE PHO_MCHECK.FOR
15265 CDECK ID>, PHO_MCHECK
15266 SUBROUTINE PHO_MCHECK(J1,IREJ)
15267 C********************************************************************
15269 C check parton momenta for fragmentation
15271 C input: J1 first string number
15277 C IREJ 0 successful
15280 C in case of very small string mass:
15281 C NNCH mass label of string
15283 C -1 octett baryon / pseudo scalar meson
15284 C 1 decuplett baryon / vector meson
15285 C IBHAD hadron number according to CPC,
15286 C string will be treated as resonance
15287 C (sometimes far off mass shell)
15289 C constant WIDTH ( 0.01GeV ) determines range of acceptance
15291 C********************************************************************
15292 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15295 PARAMETER ( WIDTH = 0.01D0,
15298 C input/output channels
15300 COMMON /POINOU/ LI,LO
15301 C event debugging information
15303 PARAMETER (NMAXD=100)
15304 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15305 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15306 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15307 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15308 C model switches and parameters
15310 INTEGER ISWMDL,IPAMDL
15311 DOUBLE PRECISION PARMDL
15312 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15314 C standard particle data interface
15317 PARAMETER (NMXHEP=4000)
15319 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15320 DOUBLE PRECISION PHEP,VHEP
15321 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15322 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15324 C extension to standard particle data interface (PHOJET specific)
15325 INTEGER IMPART,IPHIST,ICOLOR
15326 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15328 C color string configurations including collapsed strings and hadrons
15330 PARAMETER (MSTR=500)
15331 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15332 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15333 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15334 & NNCH(MSTR),IBHAD(MSTR),ISTR
15335 C internal rejection counters
15337 PARAMETER (NMXJ=60)
15338 CHARACTER*10 REJTIT
15340 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
15343 C quark antiquark jet
15344 STRM = PHEP(5,NPOS(1,J1))
15345 IF(NCODE(J1).EQ.3) THEN
15346 CALL PHO_MEMASS(IPAR1(J1),IPAR2(J1),
15347 & AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
15349 & WRITE(LO,'(1X,A,/3X,I3,5E12.3)')
15350 & 'PHO_MCHECK:1.STRING NO, CHMASS,AMPS,AMPS2,AMVE,AMVE2 ',
15351 & J1,STRM,AMPS,AMPS2,AMVE,AMVE2
15352 IF(STRM.LT.AMPS) THEN
15354 IFAIL(20) = IFAIL(20) + 1
15356 ELSE IF(STRM.LT.AMPS2) THEN
15357 IF(STRM.LT.(AMVE-WIDTH)) THEN
15368 C quark diquark or v.s. jet
15369 ELSE IF((NCODE(J1).EQ.4).OR.(NCODE(J1).EQ.6)) THEN
15370 CALL PHO_BAMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),
15371 & AM8,AM82,AM10,AM102,I8,I10)
15373 & WRITE(LO,'(1X,A,/5X,I3,5E12.3)')
15374 & 'PHO_MCHECK:1.STRING NO, CHMASS,AM8,AM82,AM10,AM102 ',
15375 & J1,STRM,AM8,AM82,AM10,AM102
15376 IF(STRM.LT.AM8) THEN
15378 IFAIL(19) = IFAIL(19) + 1
15380 ELSE IF(STRM.LT.AM82) THEN
15381 IF(STRM.LT.(AM10-WIDTH)) THEN
15392 C diquark a-diquark string
15393 ELSE IF(NCODE(J1).EQ.5) THEN
15394 CALL PHO_DQMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),IPAR4(J1),
15397 & WRITE(LO,'(1X,A,/5X,I3,3E12.3)')
15398 & 'PHO_MCHECK:1.STRING NO, CHMASS,AM82,AM102 ',
15399 & J1,STRM,AM82,AM102
15400 IF(STRM.LT.AM82) THEN
15402 IFAIL(19) = IFAIL(19) + 1
15408 ELSE IF(NCODE(J1).LT.0) THEN
15411 WRITE(LO,'(/,1X,2A,2I8)') 'PHO_MCHECK: ',
15412 & 'inconsistent flavours for string (NO,NCODE)',J1,NCODE(J1)
15417 *$ CREATE PHO_POMCOR.FOR
15419 CDECK ID>, PHO_POMCOR
15420 SUBROUTINE PHO_POMCOR(IREJ)
15421 C********************************************************************
15423 C join quarks to gluons in case of too small masses
15427 C IREJ -1 initialization
15428 C -2 output of statistics
15432 C IREJ 0 successful
15436 C********************************************************************
15437 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15440 PARAMETER ( EPS = 1.D-10 )
15442 C input/output channels
15444 COMMON /POINOU/ LI,LO
15445 C event debugging information
15447 PARAMETER (NMAXD=100)
15448 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15449 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15450 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15451 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15452 C model switches and parameters
15454 INTEGER ISWMDL,IPAMDL
15455 DOUBLE PRECISION PARMDL
15456 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15458 C standard particle data interface
15461 PARAMETER (NMXHEP=4000)
15463 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15464 DOUBLE PRECISION PHEP,VHEP
15465 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15466 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15468 C extension to standard particle data interface (PHOJET specific)
15469 INTEGER IMPART,IPHIST,ICOLOR
15470 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15472 C color string configurations including collapsed strings and hadrons
15474 PARAMETER (MSTR=500)
15475 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15476 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15477 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15478 & NNCH(MSTR),IBHAD(MSTR),ISTR
15482 IF(IREJ.EQ.-1) THEN
15486 ELSE IF(IREJ.EQ.-2) THEN
15487 WRITE(LO,'(/1X,A,2I8)')
15488 & 'PHO_POMCOR: total/joined strings',ICTOT,ICCOR
15497 IF(ISWMDL(25).LE.0) RETURN
15498 C debug string entries
15499 IF(IDEB(83).GE.25) CALL PHO_PRSTRG
15503 IF(ITER.GE.NITER) THEN
15505 IF(IDEB(83).GE.2) THEN
15506 WRITE(LO,'(1X,A,2I5)') 'PHO_POMCOR: rejection',ITER,NITER
15507 IF(IDEB(83).GE.10) CALL PHO_PREVNT(0)
15512 C check mass limits
15515 IF(NCODE(I).LT.0) GOTO 99
15517 NRPOM = IPHIST(2,J1)
15518 IF(NRPOM.GE.100) GOTO 99
15519 CMASS0 = PHEP(5,J1)
15521 IF(NCODE(I).EQ.3) THEN
15522 CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
15523 ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
15524 CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
15525 & AM1,AM2,AM3,AM4,IP1,IP2)
15526 ELSE IF(NCODE(I).EQ.5) THEN
15527 CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
15533 ELSE IF(NCODE(I).EQ.7) THEN
15535 ELSE IF(NCODE(I).LT.0) THEN
15538 WRITE(LO,'(/,1X,A,2I5)') 'ERROR:PHO_POMCOR:STRING NO,NCODE ',
15543 & WRITE(LO,'(1X,A,/3X,2I4,5E11.3,2I5)')
15544 & 'PHO_POMCOR: STRING,POM,CHMASS,AM1,AM2,AM3,AM4,IP1,IP2',
15545 & I,NRPOM,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
15546 C select masses to correct
15547 IF(CMASS0.LT.MAX(AM2,AM4)) THEN
15549 IF((K.NE.I).AND.(NCODE(K).GE.0)) THEN
15551 C join quarks to gluon
15552 IF(NRPOM.EQ.IPHIST(2,J2)) THEN
15560 IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
15561 CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
15562 & -(PHEP(1,KK1)+PHEP(1,KK2))**2
15563 & -(PHEP(2,KK1)+PHEP(2,KK2))**2
15564 & -(PHEP(2,KK1)+PHEP(2,KK2))**2
15565 IFL1 = ABS(IDHEP(KK1))
15567 PROB1 = 0.1D0/MAX(CMASS,EPS)
15569 PROB1 = 0.9D0/MAX(CMASS,EPS)
15572 KK1 = ABS(NPOS(3,I))
15573 KK2 = ABS(NPOS(3,K))
15574 IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
15575 CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
15576 & -(PHEP(1,KK1)+PHEP(1,KK2))**2
15577 & -(PHEP(2,KK1)+PHEP(2,KK2))**2
15578 & -(PHEP(2,KK1)+PHEP(2,KK2))**2
15579 IFL2 = ABS(IDHEP(KK1))
15581 PROB2 = 0.1D0/MAX(CMASS,EPS)
15583 PROB2 = 0.9D0/MAX(CMASS,EPS)
15586 IF(IFL1+IFL2.EQ.0) GOTO 99
15589 IF((DT_RNDM(CMASS)*(PROB1+PROB2)).LT.PROB1) THEN
15596 KK1 = ABS(NPOS(JJ,I))
15597 KK2 = ABS(NPOS(JJ,K))
15598 I1 = ABS(NPOS(JE,I))
15603 K2 = ABS(NPOS(JE,K))
15607 C copy mother partons of string I
15609 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
15610 & PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
15611 & ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
15615 PJ(II) = PHEP(II,KK1)+PHEP(II,KK2)
15617 CALL PHO_REGPAR(-1,21,0,J1,J2,PJ(1),PJ(2),PJ(3),PJ(4),
15618 & I,IPHIST(2,KK2),ICOLOR(1,KK1),ICOLOR(1,KK2),IPOS,1)
15619 C copy mother partons of string K
15621 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
15622 & PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
15623 & ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
15625 C create new string entry
15627 PJ(II) = PHEP(II,J1)+PHEP(II,J2)
15630 CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PJ(1),PJ(2),PJ(3),
15631 & PJ(4),I,IPHIST(2,J1),ICOLOR(1,J1)+ICOLOR(1,J2),
15632 & ICOLOR(2,J1)+ICOLOR(2,J2),IPOS,1)
15633 C delete string K in /POSTRG/
15635 C update string I in /POSTRG/
15639 C calculate new CPC string codes
15640 CALL PHO_ID2STR(IDHEP(IP1),IDHEP(IP2),NCODE(I),IPAR1(I),
15641 & IPAR2(I),IPAR3(I),IPAR4(I))
15649 IF(IDEB(83).GE.20) THEN
15650 WRITE(LO,'(1X,A)') 'PHO_POMCOR: after string recombination'
15651 IF(IDEB(83).GE.22) THEN
15659 *$ CREATE PHO_MASCOR.FOR
15661 CDECK ID>, PHO_MASCOR
15662 SUBROUTINE PHO_MASCOR(IREJ)
15663 C********************************************************************
15665 C check and adjust parton momenta for fragmentation
15669 C IREJ -1 initialization
15670 C -2 output of statistics
15674 C IREJ 0 successful
15677 C in case of very small string mass:
15678 C - direct manipulation of /POEVT1/ and /POEVT2/
15679 C - string will be deleted from /POSTRG/ (label -99)
15681 C********************************************************************
15682 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15685 PARAMETER ( EPS = 1.D-10,
15689 C input/output channels
15691 COMMON /POINOU/ LI,LO
15692 C event debugging information
15694 PARAMETER (NMAXD=100)
15695 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15696 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15697 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15698 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15699 C internal rejection counters
15701 PARAMETER (NMXJ=60)
15702 CHARACTER*10 REJTIT
15704 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
15705 C model switches and parameters
15707 INTEGER ISWMDL,IPAMDL
15708 DOUBLE PRECISION PARMDL
15709 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15711 C standard particle data interface
15714 PARAMETER (NMXHEP=4000)
15716 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15717 DOUBLE PRECISION PHEP,VHEP
15718 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15719 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15721 C extension to standard particle data interface (PHOJET specific)
15722 INTEGER IMPART,IPHIST,ICOLOR
15723 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15725 C color string configurations including collapsed strings and hadrons
15727 PARAMETER (MSTR=500)
15728 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15729 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15730 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15731 & NNCH(MSTR),IBHAD(MSTR),ISTR
15733 DIMENSION PC1(4),PC2(4),P1(4),PTR(4),GAM(3),GAMB(3)
15735 IF(IREJ.EQ.-1) THEN
15739 ELSE IF(IREJ.EQ.-2) THEN
15740 WRITE(LO,'(/1X,A,2I8/)')
15741 & 'PHO_MASCOR: total/converted strings',ICTOT,ICCOR
15749 IF(ISWMDL(7).EQ.-1) RETURN
15751 IF(IDEB(42).GE.25) CALL PHO_PRSTRG
15756 IF(ITER.GE.NITER) THEN
15758 IF(IDEB(42).GE.2) THEN
15759 WRITE(LO,'(1X,A,2I5)') 'PHO_MASCOR: rejection',ITER,NITER
15760 IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
15765 C check mass limits
15766 IF(DT_RNDM(CMASS0).LT.0.5D0) THEN
15775 DO 100 I=IM1,IM2,IST
15777 CMASS0 = PHEP(5,J1)
15779 IF(NCODE(I).EQ.3) THEN
15780 CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
15781 ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
15782 CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
15783 & AM1,AM2,AM3,AM4,IP1,IP2)
15784 ELSE IF(NCODE(I).EQ.5) THEN
15785 CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
15791 ELSE IF(NCODE(I).EQ.7) THEN
15796 *??????????????????????????????????
15799 *??????????????????????????????????
15800 ELSE IF(NCODE(I).LT.0) THEN
15803 WRITE(LO,'(/,1X,A,2I5)') 'PHO_MASCOR:ERROR: string no,NCODE ',
15807 IF(IDEB(42).GE.20) WRITE(LO,'(1X,A,/3X,I3,5E11.3,2I5)')
15808 & 'PHO_MASCOR: string no CHMASS,AM1,AM2,AM3,AM4,IP1,IP2:',
15809 & I,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
15810 C select masses to correct
15813 C correction needed?
15814 C no resonances for diquark-antidiquark and gluon-gluon strings
15815 IF(NCODE(I).EQ.5) THEN
15816 IF(CMASS0.LT.1.3D0*AM1) THEN
15817 IF(ISWMDL(7).LE.2) THEN
15828 C resonances possible
15829 IF(ISWMDL(7).EQ.0) THEN
15830 IF(CMASS0.LT.AM1*0.99D0) THEN
15835 ELSE IF(CMASS0.LT.MIN(AM2,AM4)*1.2D0) THEN
15836 DELM1 = 1.D0/((CMASS0-AM1)**2+EPS)
15837 DELM2 = 1.D0/((CMASS0-AM3)**2+EPS)
15838 IF(DT_RNDM(DELM1).LT.DELM1/(DELM1+DELM2)) THEN
15848 ELSE IF((ISWMDL(7).EQ.1).OR.(ISWMDL(7).EQ.2)) THEN
15849 IF(CMASS0.LT.AM1*0.99) THEN
15855 ELSE IF(ISWMDL(7).EQ.3) THEN
15856 IF(CMASS0.LT.AM1) THEN
15861 WRITE(LO,'(/1X,A,I5)')
15862 & 'PHO_MASCOR:ERROR:UNSUPPORTED ISWMDL(7)',ISWMDL(7)
15867 C correction necessary?
15868 IF(IBHAD(I).NE.0) THEN
15869 C find largest invar. mass
15872 DO 200 J2=NHEP,3,-1
15874 IF(ABS(ISTHEP(J2)).EQ.1) THEN
15875 IF((IPHIST(1,J2).LE.0).OR.(IPHIST(1,J2).GT.ISTR)) THEN
15876 WRITE(LO,'(1X,2A,I7,I12)') 'PHO_MASCOR: ',
15877 & 'inconsistent IPHIST(1,J2) entry (J2,KEV):',J2,KEVENT
15879 ELSE IF(NCODE(IPHIST(1,J2)).GT.0) THEN
15880 CMASS2= (PHEP(4,J1)+PHEP(4,J2))**2
15881 & -(PHEP(1,J1)+PHEP(1,J2))**2
15882 & -(PHEP(2,J1)+PHEP(2,J2))**2
15883 & -(PHEP(3,J1)+PHEP(3,J2))**2
15884 IF(CMASS2.GT.CMASS1) THEN
15893 IF((J1.EQ.J2).OR.(CMASS1.LE.EMIN)) THEN
15894 IF(INEED.EQ.1) THEN
15905 CMASS1 = SQRT(CMASS1)
15906 CMASS2 = PHEP(5,J2)
15907 IF(CMASS1.LT.(CMASS2+CHMASS)) CMASS2 = CMASS1-1.1D0*CHMASS
15909 IF(CMASS2.GT.0.D0) CALL PHO_MSHELL(PHEP(1,J1),PHEP(1,J2),
15910 & CHMASS,CMASS2,PC1,PC2,IREJ)
15912 IFAIL(24) = IFAIL(24)+1
15913 IF(IDEB(42).GE.2) THEN
15914 WRITE(LO,'(1X,A,2I4)')
15915 & 'PHO_MASCOR: rejection by PHO_MSHELL (J1,J2):',J1,J2
15916 IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
15921 C momentum transfer
15923 PTR(II) = PHEP(II,J2)-PC2(II)
15925 IF(IDEB(42).GE.10) WRITE(LO,'(1X,A,/5X,2I3,4E12.3)')
15926 & 'PHO_MASCOR: J1,J2,transfer',J1,J2,PTR
15927 C copy parents of strings
15928 C register partons belonging to first string
15929 IF(IDHEP(J1).EQ.90) THEN
15931 K2 = MAX(JMOHEP(1,J1),-JMOHEP(2,J1))
15934 ESUM = ESUM+PHEP(4,II)
15936 IF(JMOHEP(2,J1).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J1))
15938 FAC = PHEP(4,II)/ESUM
15940 P1(K) = PHEP(K,II)+FAC*PTR(K)
15942 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15943 & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15944 & ICOLOR(2,II),IPOS,1)
15947 IF(JMOHEP(2,J1).GT.0) THEN
15949 FAC = PHEP(4,II)/ESUM
15951 P1(K) = PHEP(K,II)+FAC*PTR(K)
15953 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15954 & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15955 & ICOLOR(2,II),IPOS,1)
15962 C register partons belonging to second string
15963 IF(IDHEP(J2).EQ.90) THEN
15964 CALL PHO_GETLTR(PHEP(1,J2),PC2,GAM,GAMB,DELE,IREJL)
15966 K2 = MAX(JMOHEP(1,J2),-JMOHEP(2,J2))
15969 ESUM = ESUM+PHEP(4,II)
15971 IF(JMOHEP(2,J2).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J2))
15973 **sr 28.12.2006 fix adopted from FLUKA
15974 C FAC = PHEP(4,II)/ESUM
15975 IF (ABS(ESUM).GT.0.D0) THEN
15976 FAC = PHEP(4,II)/ESUM
15981 IF(IREJL.EQ.0) THEN
15982 CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
15983 P1(4) = P1(4)+FAC*DELE
15986 P1(K) = PHEP(K,II)-FAC*PTR(K)
15989 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15990 & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15991 & ICOLOR(2,II),IPOS,1)
15994 IF(JMOHEP(2,J2).GT.0) THEN
15996 FAC = PHEP(4,II)/ESUM
15997 IF(IREJL.EQ.0) THEN
15998 CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
15999 P1(4) = P1(4)+FAC*DELE
16002 P1(K) = PHEP(K,II)-FAC*PTR(K)
16005 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
16006 & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
16007 & ICOLOR(2,II),IPOS,1)
16014 C register first string/collapsed to hadron
16015 IF((ISWMDL(7).EQ.0).OR.(ISWMDL(7).EQ.1)) THEN
16016 IF(NCODE(I).NE.5) THEN
16017 CALL PHO_REGPAR(1,0,IBHAD(I),K1A,K2A,PC1(1),PC1(2),PC1(3),
16018 & PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
16019 C label string as collapsed to hadron/resonance
16023 CALL PHO_REGPAR(-1,90,0,K1A,K2A,PC1(1),PC1(2),PC1(3),
16024 & PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
16031 CALL PHO_REGPAR(ISTA,IDHEP(J1),IMPART(J1),K1A,K2A,PC1(1),
16032 & PC1(2),PC1(3),PC1(4),IPHIST(1,J1),IPHIST(2,J1),
16033 & ICOLOR(1,J1),ICOLOR(2,J1),IPOS,1)
16034 IF(IDHEP(J1).EQ.90) THEN
16035 NPOS(1,IPHIST(1,J1)) = IPOS
16036 NPOS(2,IPHIST(1,J1)) = K1A
16037 NPOS(3,IPHIST(1,J1)) = K2A
16038 C label string as collapsed to resonance-string
16040 ELSE IF((IPHIST(1,J1).GE.1).AND.(IPHIST(1,J1).LE.ISTR)) THEN
16041 IF(NPOS(1,IPHIST(1,J1)).EQ.J1) NPOS(1,IPHIST(1,J1))=IPOS
16044 C register second string/hadron/parton
16045 CALL PHO_REGPAR(ISTB,IDHEP(J2),IMPART(J2),K1B,K2B,PC2(1),
16046 & PC2(2),PC2(3),PC2(4),IPHIST(1,J2),IPHIST(2,J2),ICOLOR(1,J2),
16047 & ICOLOR(2,J2),IPOS,1)
16048 IF(IDHEP(J2).EQ.90) THEN
16049 NPOS(1,IPHIST(1,J2))=IPOS
16050 NPOS(2,IPHIST(1,J2))=K1B
16051 NPOS(3,IPHIST(1,J2))=K2B
16052 C label string touched by momentum transfer
16054 ELSE IF((IPHIST(1,J2).GE.1).AND.(IPHIST(1,J2).LE.ISTR)) THEN
16055 IF(NPOS(1,IPHIST(1,J2)).EQ.J2) NPOS(1,IPHIST(1,J2))=IPOS
16059 C consistency checks
16060 IF(IDEB(42).GE.5) THEN
16061 CALL PHO_CHECK(-1,IDEV)
16062 IF(IDEB(42).GE.25) CALL PHO_PREVNT(0)
16064 C jump to next iteration
16070 IF(IDEB(42).GE.15) THEN
16071 IF((ITOUCH.GT.0).OR.(IDEB(42).GE.25)) THEN
16072 WRITE(LO,'(1X,A,I5)') 'PHO_MASCOR: iterations:',ITER
16078 *$ CREATE PHO_PARCOR.FOR
16080 CDECK ID>, PHO_PARCOR
16081 SUBROUTINE PHO_PARCOR(MODE,IREJ)
16082 C********************************************************************
16084 C conversion of string partons (using JETSET masses)
16086 C input: MODE >0 position index of corresponding string
16087 C -1 initialization
16088 C -2 output of statistics
16091 C IREJ 1 combination of strings impossible
16092 C 0 successful combination
16094 C********************************************************************
16095 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16098 PARAMETER ( DELM = 0.005D0,
16102 C input/output channels
16104 COMMON /POINOU/ LI,LO
16105 C event debugging information
16107 PARAMETER (NMAXD=100)
16108 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16109 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16110 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16111 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16112 C internal rejection counters
16114 PARAMETER (NMXJ=60)
16115 CHARACTER*10 REJTIT
16117 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
16118 C model switches and parameters
16120 INTEGER ISWMDL,IPAMDL
16121 DOUBLE PRECISION PARMDL
16122 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16124 C standard particle data interface
16127 PARAMETER (NMXHEP=4000)
16129 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16130 DOUBLE PRECISION PHEP,VHEP
16131 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16132 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16134 C extension to standard particle data interface (PHOJET specific)
16135 INTEGER IMPART,IPHIST,ICOLOR
16136 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16138 C color string configurations including collapsed strings and hadrons
16140 PARAMETER (MSTR=500)
16141 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16142 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16143 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16144 & NNCH(MSTR),IBHAD(MSTR),ISTR
16146 DIMENSION PP1(4),PP2(4),PB1(4),PB2(4),GAM(3),GAMB(3),
16147 & PL(4,100),XMP(100),XML(100)
16149 DOUBLE PRECISION PYMASS
16154 IF(IMODE.GT.0) THEN
16156 I1 = JMOHEP(1,IMODE)
16157 I2 = ABS(JMOHEP(2,IMODE))
16158 C copy to local field
16163 PL(K,L) = PHEP(K,I)
16167 XML(L) = PYMASS(IDHEP(I))
16171 XMC = PHEP(5,IMODE)
16172 IF(IDEB(82).GE.20) THEN
16173 WRITE(LO,'(1X,A,I7,2I4)')
16174 & 'PHO_PARCOR: ini.momenta,masses(C/L),EV,ICH,L',
16177 WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16182 C two parton configurations
16183 C -----------------------------------------
16187 IF((XM1+XM2).GE.XMC) THEN
16188 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,/,5X,I3,3E12.4)')
16189 & 'PHO_PARCOR: REJECTION I,XM1,XM2,XMC',
16190 & IMODE,XM1,XM2,XMC
16193 C conversion possible
16194 CALL PHO_MSHELL(PL(1,1),PL(1,2),XM1,XM2,PP1,PP2,IREJ)
16196 IFAIL(36) = IFAIL(36)+1
16197 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,I4,E12.4)')
16198 & 'PHO_PARCOR: rejection by PHO_MSHELL EV,STRING,MASS',
16210 C multi parton configurations
16211 C ---------------------------------
16214 C random selection of string side to start with
16215 IF(DT_RNDM(XMC).LT.0.5D0) THEN
16237 IF(ITER.GT.2) GOTO 230
16239 C conversion according to color flow method
16241 DO 210 II=K1,K2-KS,KS
16242 DO 215 IK=II+KS,K2,KS
16245 * IF(IDEB(82).GE.10) WRITE(LO,'(1X,A,2I3,4E12.4)')
16246 * & 'PHO_PARCOR:I,K,XM(1-4)',II,IK,XM1,XMP(II),XM2,XMP(IK)
16247 IF((ABS(XM1-XMP(II)).GT.DELM)
16248 & .OR.(ABS(XM2-XMP(IK)).GT.DELM)) THEN
16249 CALL PHO_MSHELL(PL(1,II),PL(1,IK),XM1,XM2,PP1,PP2,IREJ)
16251 IFAIL(36) = IFAIL(36)+1
16252 IF(IDEB(82).GE.6) WRITE(LO,'(1X,2A,I8,3I4)')
16254 & 'int.rej. by PHO_MSHELL EV,IC,I1,I2',
16255 & KEVENT,IMODE,II,IK
16260 PL(KK,II) = PP1(KK)
16261 PL(KK,IK) = PP2(KK)
16274 IF(IFAI.NE.0) GOTO 300
16279 C conversion according to remainder method
16282 IF(ABS(XM1-XMP(I)).GT.DELM) THEN
16285 C conversion necessary
16288 PB2(K) = PHEP(K,IMODE)-PB1(K)
16290 XM2 = PB2(4)**2-PB2(1)**2-PB2(2)**2-PB2(3)**2
16291 IF(XM2.LT.0.D0) THEN
16292 IF(IDEB(82).GE.10) WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
16294 & 'int.rej. I,IPA,ICH,XML,XMP,XM2**2,MCHAIN',
16295 & I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
16299 IF((XM1+XM2).GE.XMC) THEN
16300 IF(IDEB(82).GE.10) WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
16302 & 'int.rej. I,IPA,ICH,XML,XMP,XM2,XMC',
16303 & I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
16306 C conversion possible
16307 CALL PHO_MSHELL(PB1,PB2,XM1,XM2,PP1,PP2,IREJ)
16309 IFAIL(36) = IFAIL(36)+1
16310 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,3I4)')
16311 & 'PHO_PARCOR: PHO_MSHELL rej. ITER,STRING,PARTON',
16315 C calculate Lorentz transformation
16316 CALL PHO_GETLTR(PB2,PP2,GAM,GAMB,DELE,IREJ)
16318 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,3I4)')
16319 & 'PHO_PARCOR: PHO_GETLTR rej. ITER,STRING,PARTON',
16324 C transform remaining partons
16327 CALL PHO_MKSLTR(PL(1,L),PP2,GAM,GAMB)
16342 C register transformed partons
16350 CALL PHO_REGPAR(-1,IDHEP(I),0,IMODE,0,PL(1,L),PL(2,L),
16351 & PL(3,L),PL(4,L),IPHIST(1,I),IPHIST(2,I),ICOLOR(1,I),
16352 & ICOLOR(2,I),IPOS,1)
16356 CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PHEP(1,IMODE),
16357 & PHEP(2,IMODE),PHEP(3,IMODE),PHEP(4,IMODE),IPHIST(1,IMODE),
16358 & IPHIST(2,IMODE),ICOLOR(1,IMODE),ICOLOR(2,IMODE),IPOS,1)
16360 I = IPHIST(1,IMODE)
16366 IF(IDEB(82).GE.20) THEN
16367 WRITE(LO,'(1X,A,I7,2I4)')
16368 & 'PHO_PARCOR: fin.momenta,masses(C/L),(EV,ICH,L)',
16371 WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16374 WRITE(LO,'(1X,A,2I5)')
16375 & 'PHO_PARCOR: conversion done (old/new ICH)',IMODE,IPOS
16381 IF(IDEB(82).GE.3) THEN
16382 WRITE(LO,'(/1X,A,/,5X,3I5,E12.4)')
16383 & 'PHO_PARCOR: rejection I,IPAR,ICHAIN,MCHAIN',
16384 & IFAI,IPAR,IMODE,XMC
16385 IF(IDEB(82).GE.5) THEN
16386 WRITE(LO,'(1X,A,I7,2I4)')
16387 & 'PHO_PARCOR: momenta,masses(C/L),(EV,ICH,L)',
16388 & KEVENT,IMODE,IPAR
16390 WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16397 ELSE IF(IMODE.EQ.-1) THEN
16401 ELSE IF(IMODE.EQ.-2) THEN
16407 *$ CREATE PHO_STRING.FOR
16409 CDECK ID>, PHO_STRING
16410 SUBROUTINE PHO_STRING(IMODE,IREJ)
16411 C********************************************************************
16413 C calculation of string combinatorics, Lorentz boosts and
16416 C - splitting of gluons
16417 C - strings will be built up from pairs of partons
16418 C according to their color labels
16419 C with IDHEP(..) = -1
16420 C - there can be other particles between to string partons
16421 C (these will be unchanged by string construction)
16422 C - string mass fine correction
16424 C input: IMODE 1 complete string processing
16425 C -1 initialization
16426 C -2 output of statistics
16429 C IREJ 1 combination of strings impossible
16430 C 0 successful combination
16431 C 50 rejection due to user cutoffs
16433 C********************************************************************
16434 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16437 PARAMETER ( DEPS = 1.D-15,
16440 C input/output channels
16442 COMMON /POINOU/ LI,LO
16443 C event debugging information
16445 PARAMETER (NMAXD=100)
16446 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16447 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16448 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16449 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16450 C general process information
16451 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
16452 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
16453 C internal rejection counters
16455 PARAMETER (NMXJ=60)
16456 CHARACTER*10 REJTIT
16458 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
16459 C model switches and parameters
16461 INTEGER ISWMDL,IPAMDL
16462 DOUBLE PRECISION PARMDL
16463 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16464 C hard cross sections and MC selection weights
16466 PARAMETER ( Max_pro_2 = 16 )
16467 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
16468 & MH_acc_1,MH_acc_2
16469 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
16470 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
16471 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
16472 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
16473 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
16474 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
16476 C standard particle data interface
16479 PARAMETER (NMXHEP=4000)
16481 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16482 DOUBLE PRECISION PHEP,VHEP
16483 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16484 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16486 C extension to standard particle data interface (PHOJET specific)
16487 INTEGER IMPART,IPHIST,ICOLOR
16488 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16490 C color string configurations including collapsed strings and hadrons
16492 PARAMETER (MSTR=500)
16493 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16494 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16495 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16496 & NNCH(MSTR),IBHAD(MSTR),ISTR
16497 C table of particle indices for recursive PHOJET calls
16499 PARAMETER ( MAXIPX = 100 )
16500 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
16501 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
16502 & IPOIX1,IPOIX2,IPOIX3
16504 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
16505 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
16506 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
16509 IF(IMODE.EQ.-1) THEN
16510 CALL PHO_POMCOR(-1)
16511 CALL PHO_MASCOR(-1)
16512 CALL PHO_PARCOR(-1,IREJ)
16515 ELSE IF(IMODE.EQ.-2) THEN
16516 CALL PHO_POMCOR(-2)
16517 CALL PHO_MASCOR(-2)
16518 CALL PHO_PARCOR(-2,IREJ)
16523 C generate enhanced graphs
16524 IF(IPOIX2.GT.0) THEN
16528 IF(ISWMDL(14).EQ.1) IPOIX1 = 0
16542 IF(IPORES(I).EQ.8) THEN
16548 IGEN = abs(IPHIST(2,IPOPOS(1,I)))
16549 CALL PHO_STDPAR(IPOPOS(1,I),IPOPOS(2,I),IGEN,
16550 & LSPOM,LSREG,LHPOM,LHDIR,IREJ)
16552 IF(IDEB(4).GE.2) THEN
16553 WRITE(LO,'(/1X,A,I5)')
16554 & 'PHO_STRING: sec.rejection by PHO_STDPAR',IREJ
16555 CALL PHO_PREVNT(-1)
16559 KSPOM = KSPOMS+LSPOM
16560 KSREG = KSREGS+LSREG
16561 KHPOM = KHPOMS+LHPOM
16562 KHDIR = KHDIRS+LHDIR
16563 ELSE IF(IPORES(I).EQ.4) THEN
16566 CALL PHO_CDIFF(IPOPOS(1,I),IPOPOS(2,I),MSOFT,MHARD,1,IREJ)
16569 IF(IDEB(4).GE.2) THEN
16570 WRITE(LO,'(/1X,A,I5)')
16571 & 'PHO_STRING: sec.rejection by PHO_CDIFF',IREJ
16572 CALL PHO_PREVNT(-1)
16577 KSPOM = KSPOMS+KSPOM
16578 KSREG = KSREGS+KSREG
16579 KHPOM = KHPOMS+KHPOM
16580 KHDIR = KHDIRS+KHDIR
16584 IF(IPORES(I).EQ.5) THEN
16587 ELSE IF(IPORES(I).EQ.6) THEN
16596 CALL PHO_DIFDIS(IDIF1,IDIF2,IPOPOS(1,I),IPOPOS(2,I),SPROB,
16597 & 0,MSOFT,MHARD,IREJ)
16600 IF(IDEB(4).GE.2) THEN
16601 WRITE(LO,'(/1X,A,I5)')
16602 & 'PHO_STRING: sec.rejection by PHO_DIFDIS',IREJ
16603 CALL PHO_PREVNT(-1)
16607 KSPOM = KSPOMS+KSPOM
16608 KSREG = KSREGS+KSREG
16609 KHPOM = KHPOMS+KHPOM
16610 KHDIR = KHDIRS+KHDIR
16616 IF(IPOIX2.GT.I2) THEN
16622 C optional: split gluons to q-qbar pairs
16623 IF(ISWMDL(9).GT.0) THEN
16626 IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).EQ.21)) THEN
16632 IF(ICOLOR(1,K).EQ.-ICG1) THEN
16634 IF(IQ1*IQ2.NE.0) GOTO 45
16635 ELSE IF(ICOLOR(1,K).EQ.-ICG2) THEN
16637 IF(IQ1*IQ2.NE.0) GOTO 45
16640 WRITE(LO,'(/1X,2A,3I6)') 'PHO_STRING:ERROR:(1) ',
16641 & 'no matching color found (IG,ICG1,ICG2)',I,ICG1,ICG2
16644 CALL PHO_GLU2QU(I,IQ1,IQ2,IREJ)
16646 IF(IDEB(19).GE.5) THEN
16647 WRITE(LO,'(/,1X,A)')
16648 & 'PHO_STRING: no gluon splitting possible'
16657 C construct strings and write entries sorted by strings
16663 IF(ISTR.GT.MSTR) THEN
16664 WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
16665 & 'event has too many strings (ISTR,MSTR):',ISTR,MSTR
16671 IF(ISTHEP(I).EQ.1) THEN
16672 C hadrons / resonances / clusters
16676 NPOS(4,ISTR) = abs(IPHIST(2,I))
16680 ELSE IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).NE.21)) THEN
16681 C quark /diquark terminated strings
16682 ICOL1 = -ICOLOR(1,I)
16687 ICH1 = IPHO_CHR3(I,2)
16688 IBA1 = IPHO_BAR3(I,2)
16689 CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
16690 & P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
16691 & ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
16697 IF(ISTHEP(K).EQ.-1)THEN
16698 IF(IDHEP(K).EQ.21) THEN
16699 IF(ICOLOR(1,K).EQ.ICOL1) THEN
16700 ICOL1 = -ICOLOR(2,K)
16702 ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
16703 ICOL1 = -ICOLOR(1,K)
16706 ELSE IF(ICOLOR(1,K).EQ.ICOL1) THEN
16712 WRITE(LO,'(/1X,A,I5)')
16713 & 'PHO_STRING:ERROR:(2) no matching color found for',-ICOL1
16720 NRPOM = MAX(NRPOM,IPHIST(1,K))
16721 ICH1 = ICH1+IPHO_CHR3(K,2)
16722 IBA1 = IBA1+IPHO_BAR3(K,2)
16723 CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
16724 & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
16725 & IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
16726 C further parton involved?
16727 IF(ICOL1.NE.0) GOTO 65
16731 CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
16732 & ISTR,IGEN,ICH1,IBA1,IPOS,1)
16733 C store additional string information
16734 NPOS(1,ISTR) = IPOS
16736 NPOS(3,ISTR) = -JM2
16737 NPOS(4,ISTR) = abs(IPHIST(2,K))
16738 C calculate CPC string codes
16739 CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
16740 & IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
16747 IF(ISTR.GT.MSTR) THEN
16748 WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
16749 & 'event has too many strings (ISTR,MSTR):',ISTR,MSTR
16755 IF(ISTHEP(I).EQ.-1) THEN
16756 C gluon loop-strings
16757 ICOL1 = -ICOLOR(1,I)
16764 CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
16765 & P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
16766 & ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
16771 IF(ICOLOR(2,I).EQ.ICOL1) GOTO 170
16773 IF(ISTHEP(K).EQ.-1)THEN
16774 IF(ICOLOR(1,K).EQ.ICOL1) THEN
16775 ICOL1 = -ICOLOR(2,K)
16777 ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
16778 ICOL1 = -ICOLOR(1,K)
16783 WRITE(LO,'(/1X,A,I5)')
16784 & 'PHO_STRING:ERROR:(3) no matching color found for',-ICOL1
16791 NRPOM = MAX(NRPOM,IPHIST(1,K))
16792 CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
16793 & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
16794 & IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
16795 C further parton involved?
16796 IF(ICOL1.NE.0) GOTO 165
16801 CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
16802 & ISTR,IGEN,ICH1,IBA1,IPOS,1)
16803 C store additional string information
16804 NPOS(1,ISTR) = IPOS
16806 NPOS(3,ISTR) = -JM2
16807 NPOS(4,ISTR) = abs(IPHIST(2,K))
16808 C calculate CPC string codes
16809 CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
16810 & IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
16817 IF(IDEB(19).GE.17) THEN
16818 WRITE(LO,'(1X,A)') 'PHO_STRING: after string construction'
16822 C pomeron corrections
16823 CALL PHO_POMCOR(IREJ)
16825 IFAIL(38) = IFAIL(38)+1
16826 IF(IDEB(19).GE.3) THEN
16827 WRITE(LO,'(1X,A,I6)')
16828 & 'PHO_STRING: rejection by PHO_POMCOR (IREJ)',IREJ
16829 CALL PHO_PREVNT(-1)
16834 C string mass corrections
16835 CALL PHO_MASCOR(IREJ)
16837 IFAIL(34) = IFAIL(34)+1
16838 IF(IDEB(19).GE.3) THEN
16839 WRITE(LO,'(1X,A,I6)')
16840 & 'PHO_STRING: rejection by PHO_MASCOR (IREJ)',IREJ
16841 CALL PHO_PREVNT(-1)
16846 C parton mass corrections
16848 IF(NCODE(I).GE.0) THEN
16849 CALL PHO_PARCOR(NPOS(1,I),IREJ)
16851 IFAIL(35) = IFAIL(35)+1
16852 IF(IDEB(19).GE.3) THEN
16853 WRITE(LO,'(1X,A,I6)')
16854 & 'PHO_STRING: rejection by PHO_PARCOR (IREJ)',IREJ
16855 CALL PHO_PREVNT(-1)
16862 C statistics of hard processes
16864 IF(ISTHEP(I).EQ.25) THEN
16867 MH_acc_2(K,II) = MH_acc_2(K,II)+1
16871 C debug: write out strings
16872 IF(IDEB(19).GE.5) THEN
16874 & CALL PHO_CHECK(1,IDEV)
16875 IF(IDEB(19).GE.15) THEN
16884 *$ CREATE PHO_STRFRA.FOR
16886 CDECK ID>, PHO_STRFRA
16887 SUBROUTINE PHO_STRFRA(IREJ)
16888 C********************************************************************
16890 C do all fragmentation of strings
16892 C output: IREJ 0 successful
16894 C 50 rejection due to user cutoffs
16896 C********************************************************************
16902 C input/output channels
16904 COMMON /POINOU/ LI,LO
16906 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
16907 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
16908 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
16909 C event debugging information
16911 PARAMETER (NMAXD=100)
16912 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16913 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16914 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16915 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16916 C general process information
16917 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
16918 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
16919 C model switches and parameters
16921 INTEGER ISWMDL,IPAMDL
16922 DOUBLE PRECISION PARMDL
16923 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16924 C global event kinematics and particle IDs
16925 INTEGER IFPAP,IFPAB
16926 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
16927 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
16929 C standard particle data interface
16932 PARAMETER (NMXHEP=4000)
16934 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16935 DOUBLE PRECISION PHEP,VHEP
16936 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16937 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16939 C extension to standard particle data interface (PHOJET specific)
16940 INTEGER IMPART,IPHIST,ICOLOR
16941 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16943 C color string configurations including collapsed strings and hadrons
16945 PARAMETER (MSTR=500)
16946 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16947 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16948 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16949 & NNCH(MSTR),IBHAD(MSTR),ISTR
16953 DOUBLE PRECISION PX,PY,PZ,HE,XMB,PT1,PT2,DUM
16955 INTEGER I,II,IJ,IFOUND,IP,IP_old,IPMOTH,IPOS,IBAM,IJOIN,
16956 & IGEN,IS,ISH,ISTR,J,K1,K2,NHEP1,NLINES
16958 integer indx(500),indx_max
16960 DOUBLE PRECISION DT_RNDM
16961 INTEGER ipho_pdg2id
16962 EXTERNAL DT_RNDM,ipho_pdg2id
16964 DOUBLE PRECISION PYP,RQLUN
16968 DOUBLE PRECISION PARU,PARJ
16969 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16972 DOUBLE PRECISION P,V
16973 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16975 DIMENSION IJOIN(100)
16978 IF(ABS(ISWMDL(6)).GT.3) THEN
16979 WRITE(LO,'(/1X,2A,I3)') 'PHO_STRFRA:ERROR: ',
16980 & 'invalid value of ISWMDL(6)',ISWMDL(6)
16984 C popcorn suppression
16985 IF(PARMDL(134).GT.0.D0) THEN
16986 IF(DT_RNDM(DUM).LT.PARMDL(134)) THEN
16993 C copy partons to fragmentation code JETSET
16999 C select partons with common production process
17001 if(IGEN.lt.0) goto 299
17005 if((IGEN.eq.NPOS(4,I)).or.(IPAMDL(17).eq.0)) then
17007 C write final particles/resonances to JETSET
17008 IF(NCODE(I).EQ.-99) THEN
17011 P(IP,1) = PHEP(1,II)
17012 P(IP,2) = PHEP(2,II)
17013 P(IP,3) = PHEP(3,II)
17014 P(IP,4) = PHEP(4,II)
17015 P(IP,5) = PHEP(5,II)
17017 K(IP,2) = IDHEP(II)
17023 if(indx_max.eq.500) then
17024 WRITE(LO,'(1x,2a,i8,I12)') 'PHO_STRFRA: ',
17025 & 'no space left in index vector (indx,Kevent)',
17031 indx_max = indx_max+1
17032 indx(indx_max) = II
17033 C write partons to JETSET
17034 ELSE IF(NCODE(I).GE.0) THEN
17035 K1 = JMOHEP(1,NPOS(1,I))
17036 K2 = MAX(JMOHEP(1,NPOS(1,I)),-JMOHEP(2,NPOS(1,I)))
17040 P(IP,1) = PHEP(1,II)
17041 P(IP,2) = PHEP(2,II)
17042 P(IP,3) = PHEP(3,II)
17043 P(IP,4) = PHEP(4,II)
17044 P(IP,5) = PHEP(5,II)
17046 K(IP,2) = IDHEP(II)
17053 indx_max = indx_max+1
17054 indx(indx_max) = II
17057 II = JMOHEP(2,NPOS(1,I))
17058 IF((II.GT.0).AND.(II.NE.K1)) THEN
17060 P(IP,1) = PHEP(1,II)
17061 P(IP,2) = PHEP(2,II)
17062 P(IP,3) = PHEP(3,II)
17063 P(IP,4) = PHEP(4,II)
17064 P(IP,5) = PHEP(5,II)
17066 K(IP,2) = IDHEP(II)
17073 indx_max = indx_max+1
17074 indx(indx_max) = II
17078 C connect partons to strings
17080 CALL PYJOIN(IJ,IJOIN)
17084 NPOS(4,I) = -NPOS(4,I)
17090 if(IP.eq.0) goto 299
17092 C hard final state evolution
17093 IF((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
17095 do 125 k1=1,indx_max
17097 IF(IPHIST(1,I).LE.-100) THEN
17104 IF(IJOIN(K1).EQ.0) GOTO 130
17106 IF((IPAMDL(102).EQ.1)
17107 & .AND.(IPHIST(1,I).NE.-100)) GOTO 130
17109 IF(IJOIN(K2).EQ.0) GOTO 135
17111 IF(IPHIST(1,I).EQ.IPHIST(1,II)) THEN
17112 PT1 = SQRT(PHEP(1,II)**2+PHEP(2,II)**2)
17113 PT2 = SQRT(PHEP(1,I)**2+PHEP(2,I)**2)
17114 RQLUN = MIN(PT1,PT2)
17116 IF(IDEB(22).GE.10) WRITE(LO,'(1X,A,2I5,E12.4)')
17117 & 'PHO_STRFRA: PYSHOW called',I,II,RQLUN
17118 CALL PYSHOW(IPHIST(2,I),IPHIST(2,II),RQLUN)
17129 C fragment parton / hadron configuration (hadronization & decay)
17131 IF(ISWMDL(6).NE.0) THEN
17139 if(MSTU(28).ne.0) then
17140 IF(IDEB(22).GE.10) THEN
17141 WRITE(LO,'(1X,A,I12,I3)')
17142 & 'PHO_STRFRA:(1) Lund code warning (EV/code)',
17148 IF(MSTU(24).NE.0) THEN
17149 IF(IDEB(22).GE.2) THEN
17150 WRITE(LO,'(1X,A,I12,I3)')
17151 & 'PHO_STRFRA:(1) rejection by Lund code (EV/code)',
17161 C change particle status in JETSET to avoid internal adjustments
17163 K(k1,1) = K(k1,1)+1000
17170 C restore original JETSET particle status codes
17172 K(i,1) = K(i,1)-1000
17175 * IF(IDEB(22).GE.25) THEN
17176 * WRITE(LO,'(//1X,2A)') 'PHO_STRFRA: ',
17177 * & 'particle/string system before fragmentation'
17178 * CALL PHO_PREVNT(2)
17181 C copy hadrons back to POEVT1 / POEVT2
17188 C copy hadrons back with full history information
17189 IF(IPAMDL(178).EQ.1) THEN
17191 IF(NCODE(II).GE.0) THEN
17192 K1 = IPHIST(2,NPOS(2,II))
17193 K2 = IPHIST(2,-NPOS(3,II))
17194 ELSE IF(NCODE(II).EQ.-99) THEN
17195 K1 = IPHIST(2,NPOS(1,II))
17203 IF(PYK(J,7).EQ.1) THEN
17206 IF((IPMOTH.GE.K1).AND.(IPMOTH.LE.K2)) THEN
17208 IBAM = ipho_pdg2id(PYK(J,8))
17210 IF((IBAM.EQ.0).AND.(ISWMDL(6).NE.0)) THEN
17211 IF(IDEB(22).GE.2) THEN
17212 WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
17213 & 'LUND interface (1) rejection'
17227 C register parton/hadron
17230 IF(ISWMDL(6).EQ.0) THEN
17233 IF(IDEB(22).GE.2) THEN
17234 WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
17235 & 'LUND interface (2) rejection'
17243 CALL PHO_REGPAR(IS,PYK(J,8),IBAM,NPOS(1,II),0,
17244 & PX,PY,PZ,HE,J,0,0,0,IPOS,1)
17250 IF(IFOUND.EQ.0) THEN
17251 IF(IDEB(2).GE.2) THEN
17252 WRITE(LO,'(2A,I12,I3)') 'PHO_STRFRA: ',
17253 & 'no particles found for string (EVE,ISTR):',KEVENT,II
17255 ISTHEP(NPOS(1,II)) = 2
17260 C copy hadrons back without history information
17261 JDAHEP(1,1) = NHEP1
17262 JDAHEP(1,2) = NHEP1
17265 IF(PYK(J,7).EQ.1) THEN
17266 IBAM = ipho_pdg2id(PYK(J,8))
17268 IF((IBAM.EQ.99999).AND.(ISWMDL(6).NE.0)) THEN
17269 IF(IDEB(22).GE.2) THEN
17270 WRITE(LO,'(/1X,A)')
17271 & 'PHO_STRFRA: LUND interface (3) rejection'
17284 C register parton/hadron
17287 IF(ISWMDL(6).EQ.0) THEN
17290 IF(IDEB(22).GE.2) THEN
17291 WRITE(LO,'(/1X,A)')
17292 & 'PHO_STRFRA: LUND interface (4) rejection'
17300 CALL PHO_REGPAR(IS,PYK(J,8),IBAM,1,2,PX,PY,PZ,
17301 & HE,J,0,0,0,IPOS,1)
17307 IF((NCODE(II).GE.0).OR.(NCODE(II).EQ.-99))
17308 & ISTHEP(NPOS(1,II)) = 2
17313 C debug event status
17314 IF(IDEB(22).GE.15) THEN
17315 WRITE(LO,'(//1X,A)')
17316 & 'PHO_STRFRA: particle system after fragmentation'
17322 *$ CREATE PHO_EVEINI.FOR
17324 CDECK ID>, PHO_EVEINI
17325 SUBROUTINE PHO_EVEINI(IMODE,P1,P2,IP1,IP2)
17326 C********************************************************************
17328 C prepare /POEVT1/ for new event
17330 C first subroutine called for each event
17332 C input: P1(4) particle 1
17334 C IMODE 0 general initialization
17335 C 1 initialization of particles and kinematics
17336 C 2 initialization after internal rejection
17338 C output: IP1,IP2 index of interacting particles
17340 C********************************************************************
17341 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17344 DIMENSION P1(4),P2(4)
17346 PARAMETER ( EPS = 1.D-5,
17349 C input/output channels
17351 COMMON /POINOU/ LI,LO
17352 C event debugging information
17354 PARAMETER (NMAXD=100)
17355 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17356 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17357 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17358 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17359 C model switches and parameters
17361 INTEGER ISWMDL,IPAMDL
17362 DOUBLE PRECISION PARMDL
17363 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17364 C general process information
17365 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
17366 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
17367 C gamma-lepton or gamma-hadron vertex information
17368 INTEGER IGHEL,IDPSRC,IDBSRC
17369 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
17370 & RADSRC,AMSRC,GAMSRC
17371 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
17372 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
17373 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
17374 C global event kinematics and particle IDs
17375 INTEGER IFPAP,IFPAB
17376 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
17377 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
17378 C energy-interpolation table
17380 PARAMETER ( IEETA2 = 20 )
17382 DOUBLE PRECISION SIGTAB,SIGECM
17383 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
17385 INTEGER IPFIL,IFAFIL,IFBFIL
17386 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
17387 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
17388 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
17389 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
17390 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
17391 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
17392 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
17393 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
17394 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
17395 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
17396 & IPFIL,IFAFIL,IFBFIL
17397 C color string configurations including collapsed strings and hadrons
17399 PARAMETER (MSTR=500)
17400 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
17401 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
17402 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
17403 & NNCH(MSTR),IBHAD(MSTR),ISTR
17405 C standard particle data interface
17408 PARAMETER (NMXHEP=4000)
17410 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
17411 DOUBLE PRECISION PHEP,VHEP
17412 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
17413 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
17415 C extension to standard particle data interface (PHOJET specific)
17416 INTEGER IMPART,IPHIST,ICOLOR
17417 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
17419 C table of particle indices for recursive PHOJET calls
17421 PARAMETER ( MAXIPX = 100 )
17422 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
17423 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
17424 & IPOIX1,IPOIX2,IPOIX3
17425 C event weights and generated cross section
17426 INTEGER IPOWGC,ISWCUT,IVWGHT
17427 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
17428 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
17429 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
17433 C reset debug variables
17452 IF(ISWMDL(14).GT.0) IPOIX1 = 1
17455 C reset /POEVT1/ and /POEVT2/
17456 CALL PHO_REGPAR(0,0,0,0,0,0.D0,0.D0,0.D0,0.D0,
17458 CALL PHO_SELCOL(0,0,0,0,0,0,0)
17463 C initialization of particle kinematics
17465 C lepton-photon/hadron-photon vertex and initial particles
17468 IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
17469 CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),0,0,PINI(1,1),PINI(2,1),
17470 & PINI(3,1),PINI(4,1),0,0,0,0,IM(1),1)
17472 CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
17473 & P1(4),0,0,0,0,IP1,1)
17475 IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
17476 CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),0,0,PINI(1,2),PINI(2,2),
17477 & PINI(3,2),PINI(4,2),0,0,0,0,IM(2),1)
17479 CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
17480 & P2(4),0,0,0,0,IP2,1)
17482 IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
17483 CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),IM(1),0,PFIN(1,1),
17484 & PFIN(2,1),PFIN(3,1),PFIN(4,1),0,10,0,0,IPOS,1)
17485 CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
17486 & P1(4),0,0,0,0,IP1,1)
17488 IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
17489 CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),IM(2),0,PFIN(1,2),
17490 & PFIN(2,2),PFIN(3,2),PFIN(4,2),0,10,0,0,IPOS,1)
17491 CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
17492 & P2(4),0,0,0,0,IP2,1)
17496 IF(IMODE.LE.1) THEN
17498 ECM = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
17499 & -(P1(3)+P2(3))**2)
17500 * CALL PHO_PECMS(1,PMASS(1),PMASS(2),ECM,PCM,EE)
17501 PMASS(1) = PHEP(5,IP1)
17503 IF(IFPAP(1).EQ.22) PVIRT(1) = PMASS(1)**2
17504 PMASS(2) = PHEP(5,IP2)
17506 IF(IFPAP(2).EQ.22) PVIRT(2) = PMASS(2)**2
17509 C cross section calculations
17511 IF(IMODE.NE.1) THEN
17513 CALL PHO_CSINT(IP,IFPAP(1),IFPAP(2),IGHEL(1),IGHEL(2),
17514 & ECM,PVIRT(1),PVIRT(2))
17517 IF(IMODE.LE.0) THEN
17518 C effective cross section
17520 IF(ISWMDL(2).ge.1) THEN
17521 IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGTOT-SIGELA-SIGVM(0,0)
17522 & -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)-SIGLDD
17524 IF(IPRON(2,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGELA
17525 IF(IPRON(3,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGVM(0,0)
17526 IF(IPRON(4,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGCDF(0)
17527 IF(IPRON(5,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(1)+SIGHSD(1)
17528 IF(IPRON(6,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(2)+SIGHSD(2)
17529 IF(IPRON(7,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLDD+SIGHDD
17530 IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
17531 C simulate only hard scatterings
17533 IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGHAR
17534 IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
17539 C reset of mother/daughter relations only (IMODE = 2)
17542 IF(IDEB(63).GE.15) THEN
17543 WRITE(LO,'(/1X,2A,I12,I3)') 'PHO_EVEINI: ',
17544 & '/POEVT1/ initialized (event/mode)',KEVENT,IMODE
17545 IF(IMODE.LE.0) THEN
17546 WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)') 'PHO_EVEINI: ',
17547 & 'current suppression factors total-1/2 hard-1/2 diff-1/2:',
17551 IDEB(57) = MAX(5,ITMP)
17552 CALL PHO_XSECT(1,0,ONEM)
17560 *$ CREATE PHO_CSINT.FOR
17562 CDECK ID>, PHO_CSINT
17563 SUBROUTINE PHO_CSINT(IP,IFPA,IFPB,IHLA,IHLB,ECM,PVIR2A,PVIR2B)
17564 C********************************************************************
17566 C calculate cross sections by interpolation
17568 C input: IP particle combination
17569 C IFPA/B particle PDG number
17570 C IHLA/B particle helicity (photons only)
17571 C ECM c.m. energy (GeV)
17572 C PVIR2A virtuality of particle A (GeV**2, positive)
17573 C PVIR2B virtuality of particle B (GeV**2, positive)
17575 C output: cross sections stored in /POCSEC/
17577 C********************************************************************
17578 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17581 PARAMETER ( EPS = 1.D-5,
17584 C input/output channels
17586 COMMON /POINOU/ LI,LO
17588 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
17589 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
17590 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
17591 C event debugging information
17593 PARAMETER (NMAXD=100)
17594 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17595 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17596 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17597 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17598 C model switches and parameters
17600 INTEGER ISWMDL,IPAMDL
17601 DOUBLE PRECISION PARMDL
17602 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17603 C energy-interpolation table
17605 PARAMETER ( IEETA2 = 20 )
17607 DOUBLE PRECISION SIGTAB,SIGECM
17608 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
17610 INTEGER IPFIL,IFAFIL,IFBFIL
17611 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
17612 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
17613 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
17614 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
17615 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
17616 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
17617 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
17618 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
17619 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
17620 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
17621 & IPFIL,IFAFIL,IFBFIL
17622 C hard cross sections and MC selection weights
17624 PARAMETER ( Max_pro_2 = 16 )
17625 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
17626 & MH_acc_1,MH_acc_2
17627 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
17628 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
17629 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
17630 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
17631 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
17632 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
17634 DIMENSION PVIRT(2),SIGSRH(2),FSUT(2),FSUL(2),IFPAP(2),IHEL(2)
17636 dimension PD(-6:6),FH_T(2),FH_L(2)
17639 IF(IDEB(15).GE.10) WRITE(LO,'(1X,A,/10X,I3,2I6,1P3E12.4)')
17640 & 'PHO_CSINT: called with IP, IFP1, IFP2, ECM, PVIR1, PVIR2',
17641 & IP,IFPA,IFPB,ECM,PVIR2A,PVIR2B
17643 C check currently stored cross sections
17644 IF((IP.EQ.IPFIL).AND.(ECM.EQ.ECMFIL)
17645 & .AND.(PVIR2A.EQ.P2AFIL).AND.(PVIR2B.EQ.P2BFIL)
17646 & .AND.(IFPA.EQ.IFAFIL).AND.(IFPB.EQ.IFBFIL)) THEN
17647 C nothing to calculate
17649 & WRITE(LO,'(1X,A)') 'PHO_CSINT: nothing done'
17653 C copy to local fields
17661 C load cross sections from interpolation table
17662 IF(ECM.LE.SIGECM(IP,1)) THEN
17665 ELSE IF(ECM.LE.SIGECM(IP,ISIMAX)) THEN
17667 IF(ECM.LE.SIGECM(IP,I)) GOTO 200
17673 WRITE(LO,'(/1X,A,2E12.3)')
17674 & 'PHO_CSINT: too high energy',ECM,SIGECM(IP,ISIMAX)
17675 CALL PHO_PREVNT(-1)
17680 IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
17681 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
17684 C cross section dependence on photon virtualities
17689 IF(IFPAP(K).EQ.22) THEN
17690 IF(ISWMDL(10).GE.1) THEN
17695 C GVDM factors for transverse/longitudinal photons
17697 FSUT(K) = FSUT(K)+PARMDL(26+I)
17698 & /(1.D0+PVIRT(K)/PARMDL(30+I))**2
17700 & +PARMDL(26+I)*PVIRT(K)/(4.D0*PARMDL(30+I))
17701 & /(1.D0+PVIRT(K)/PARMDL(30+I))**2
17703 FSUT(K) = FSUT(K)+PARMDL(30)/(1.D0+PVIRT(K)/PARMDL(34))
17705 IF((ABS(IHEL(K)).EQ.1).OR.(ISWMDL(10).EQ.1)) THEN
17707 FSUH(K) = FSUT(K)/(FSUT(K)+FSUL(K))
17708 C diffraction of trans. photons corresponds mainly to leading twist
17711 C longitudinal (scalar) part
17712 IF((IHEL(K).LE.0).OR.(ISWMDL(10).EQ.1)) THEN
17713 FSUP(K) = FSUP(K)+FSUL(K)
17714 FSUH(K) = FSUH(K)+FSUL(K)/(FSUT(K)+FSUL(K))
17715 C diffraction of long. photons corresponds mainly to higher twist
17716 FSUD(K) = 0.5D0*LOG(((ECM*PARMDL(45))**2+PVIRT(K))
17717 & /((0.765D0+PARMDL(46))**2+PVIRT(K)))
17718 & /LOG(ECM*PARMDL(45)/(0.765D0+PARMDL(46)))
17721 if(ideb(15).ge.10) then
17722 WRITE(LO,'(1x,2a,2i3,/,5x,1p5e12.4)') 'PHO_CSINT: ',
17723 & 'side,helicity,F_tran,F_long,F_eff,F_hard,F_diff',
17724 & K,IHEL(K),FSUT(K),FSUL(K),FSUP(K),FSUH(K),FSUD(K)
17730 FACP = FSUP(1)*FSUP(2)
17731 FACH = FSUH(1)*FSUH(2)
17732 FACD = FSUD(1)*FSUD(2)
17734 C matching of model cross section to F2(x,Q2,P2) in limit of Q2 >> P2
17736 if((IFPAP(1).eq.22).and.(IFPAP(2).eq.22)
17737 & .and.(IPAMDL(117).gt.0)) then
17738 C check kinematic limit
17739 Q2_max = max(PVIRT(1),PVIRT(2))
17740 Q2_min = min(PVIRT(1),PVIRT(2))
17741 if((Q2_max.gt.1.D0).and.(Q2_min.lt.1.D0)) then
17743 C calculate F2 from current parton density
17744 if(PVIRT(1).gt.PVIRT(2)) then
17751 X = Q2/(ECM**2+Q2+P2)
17752 call pho_actpdf(IFPAP(K),K)
17753 call pho_pdf(K,X,Q2,P2,PD)
17754 C light quark contribution
17757 F2_light = F2_light+Q_ch2(j)*(PD(j)+PD(-j))
17759 C heavy quark contribution
17760 call pho_qpmpdf(4,X,Q2,0.D0,P2,xpdf_c)
17761 F2_c = 2.D0*4.D0/9.D0*xpdf_c
17762 F2 = (F2_light+F2_c)
17764 C calculate model prediction
17765 SIGTOT = FAC2*SIGTAB(IP,1,I2)+FAC1*SIGTAB(IP,1,I1)
17766 SIGINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
17767 CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17769 if(ISWMDL(10).ge.2) then
17771 C calculate all helicity combinations
17772 if(IPAMDL(115).eq.0) then
17774 SIGSRH(1) = HSig(10)+HSig(11)
17775 SIGSRH(2) = HSig(12)+HSig(13)
17776 SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
17777 C photon helicity factors
17778 FH_T(1) = FSUT(1)/(FSUT(1)+FSUL(1))
17779 FH_L(1) = 1.D0-FH_T(1)
17780 FH_T(2) = FSUT(2)/(FSUT(2)+FSUL(2))
17781 FH_L(2) = 1.D0-FH_T(2)
17782 SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
17783 & + SIGDIH*FH_T(1)*FH_T(2)
17784 & + SIGSRH(1)*FH_T(1)*FSUT(2)
17785 & + SIGSRH(2)*FSUT(1)*FH_T(2)
17786 SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
17787 & + SIGDIH*FH_T(1)*FH_L(2)
17788 & + SIGSRH(1)*FH_T(1)*FSUL(2)
17789 & + SIGSRH(2)*FSUT(1)*FH_L(2)
17790 SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
17791 & + SIGDIH*FH_L(1)*FH_T(2)
17792 & + SIGSRH(1)*FH_L(1)*FSUT(2)
17793 & + SIGSRH(2)*FSUL(1)*FH_T(2)
17794 SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
17795 & + SIGDIH*FH_L(1)*FH_L(2)
17796 & + SIGSRH(1)*FH_L(1)*FSUL(2)
17797 & + SIGSRH(2)*FSUL(1)*FH_L(2)
17799 C use explicit PDF virtuality dependence (pre-tabulated)
17801 SIGSRH(1) = HSig(10)+HSig(11)
17802 SIGSRH(2) = HSig(12)+HSig(13)
17803 SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
17804 write(LO,*) ' PHO_CSINT: invalid option for F2 matching'
17806 * CALL PHO_HARINT(IP,ECM,PVIRT(1),PVIRT(2),0,
17807 * & Max_pro_2,3,4,1)
17808 * SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
17809 * & + HSig(10)+HSig(12)+HSig(14)+HSig(16)+HSig(18)
17810 * SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
17811 * & + HSig(10)+HSig(12)+HSig(14)+HSig(16)+HSig(19)
17812 * SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
17813 * & + HSig(11)+HSig(13)+HSig(15)+HSig(17)+HSig(20)
17814 * SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
17815 * & + HSig(11)+HSig(13)+HSig(15)+HSig(17)+HSig(21)
17817 Xnu = Ecm*Ecm+Q2+P2
17818 F2_fac = Q2*Xnu/sqrt(Xnu*Xnu-Q2*P2)/(4.D0*Pi*Pi)
17821 F2m = F2_fac*(SIG_TT+SIG_LT-0.5D0*SIG_TL-0.5D0*SIG_LL)
17822 F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUL(1)*FSUT(2)
17823 & -0.5D0*FSUT(1)*FSUL(2)-0.5D0*FSUL(1)*FSUL(2))
17825 F2m = F2_fac*(SIG_TT+SIG_TL-0.5D0*SIG_LT-0.5D0*SIG_LL)
17826 F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUT(1)*FSUL(2)
17827 & -0.5D0*FSUL(1)*FSUT(2)-0.5D0*FSUL(1)*FSUL(2))
17832 C assume sig_eff = sigtot
17834 SIGSRH(1) = HSig(10)+HSig(11)
17835 SIGSRH(2) = HSig(12)+HSig(13)
17836 SIGtmp = SIGTOT-SIGSRH(1)-SIGSRH(2)-SIGDIH
17837 SIGeff = SIGtmp*FSUP(1)*FSUP(2)
17838 & +SIGSRH(1)*FSUP(2)+SIGSRH(2)*FSUP(1)+SIGDIH
17839 Xnu = Ecm*Ecm+Q2+P2
17840 F2_fac = Q2*Xnu/sqrt(Xnu*Xnu-Q2*P2)/(4.D0*Pi*Pi)
17842 F2m = F2_fac*SIGeff
17843 F2s = F2_fac*SIGtmp*FSUP(1)*FSUP(2)
17845 * write(LO,*) ' PHO_CSINT: Q2_1,Q2_2,W ',PVIRT(1),PVIRT(2),Ecm
17846 * write(LO,*) ' PHO_CSINT: F2_mod,F2_pdf,mod/pdf ',F2m,F2,F2m/F2
17848 C global factor to re-scale suppression of soft contributions
17849 Fcorr = (F2-F2m+F2s)/F2s
17850 * write(LO,*) ' PHO_CSINT: re-scaling factor: ',Fcorr,FACP*Fcorr
17856 SIGTOT = (FAC2*SIGTAB(IP,1,I2)+FAC1*SIGTAB(IP,1,I1))*FACP
17857 SIGINE = (FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1))*FACP
17858 SIGELA = (FAC2*SIGTAB(IP,2,I2)+FAC1*SIGTAB(IP,2,I1))*FACP
17863 SIGVM(I,K) = (FAC2*SIGTAB(IP,J,I2)+FAC1*SIGTAB(IP,J,I1))
17868 SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
17869 SIGHAR = FAC2*SIGTAB(IP,58,I2)+FAC1*SIGTAB(IP,58,I1)
17870 C suppression of multi-pomeron graphs (diffraction)
17871 SIGLSD(1) = (FAC2*SIGTAB(IP,30,I2)+FAC1*SIGTAB(IP,30,I1))
17872 & *FACP*FSUP(2)*FSUD(1)
17873 SIGLSD(2) = (FAC2*SIGTAB(IP,31,I2)+FAC1*SIGTAB(IP,31,I1))
17874 & *FACP*FSUP(1)*FSUD(2)
17875 SIGHSD(1) = (FAC2*SIGTAB(IP,32,I2)+FAC1*SIGTAB(IP,32,I1))
17876 & *FACP*FSUP(2)*FSUD(1)
17877 SIGHSD(2) = (FAC2*SIGTAB(IP,33,I2)+FAC1*SIGTAB(IP,33,I1))
17878 & *FACP*FSUP(1)*FSUD(2)
17879 SIGLDD = (FAC2*SIGTAB(IP,34,I2)+FAC1*SIGTAB(IP,34,I1))
17881 SIGHDD = (FAC2*SIGTAB(IP,35,I2)+FAC1*SIGTAB(IP,35,I1))*FACP
17882 SIGCDF(0) = (FAC2*SIGTAB(IP,36,I2)+FAC1*SIGTAB(IP,36,I1))
17884 SIGTR1(1) = (FAC2*SIGTAB(IP,60,I2)+FAC1*SIGTAB(IP,60,I1))
17885 & *FACP*FSUP(2)*FSUD(1)
17886 SIGTR1(2) = (FAC2*SIGTAB(IP,61,I2)+FAC1*SIGTAB(IP,61,I1))
17887 & *FACP*FSUP(2)*FSUD(1)
17888 SIGTR2(1) = (FAC2*SIGTAB(IP,62,I2)+FAC1*SIGTAB(IP,62,I1))
17889 & *FACP*FSUP(1)*FSUD(2)
17890 SIGTR2(2) = (FAC2*SIGTAB(IP,63,I2)+FAC1*SIGTAB(IP,63,I1))
17891 & *FACP*FSUP(1)*FSUD(2)
17892 SIGLOO = (FAC2*SIGTAB(IP,64,I2)+FAC1*SIGTAB(IP,64,I1))*FACP
17893 SIGDPO(1) = (FAC2*SIGTAB(IP,65,I2)+FAC1*SIGTAB(IP,65,I1))
17895 SIGDPO(2) = (FAC2*SIGTAB(IP,66,I2)+FAC1*SIGTAB(IP,66,I1))
17897 SIGDPO(3) = (FAC2*SIGTAB(IP,67,I2)+FAC1*SIGTAB(IP,67,I1))
17899 SIGDPO(4) = (FAC2*SIGTAB(IP,68,I2)+FAC1*SIGTAB(IP,68,I1))
17902 C corrections due to photon virtuality dependence of PDFs
17903 if(iswmdl(2).eq.1) then
17904 CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17905 C minimum bias event generation
17906 IF(IPAMDL(115).GE.1) THEN
17907 C all the virtuality dependence is given by PDF parametrization
17908 SIGHIN = FAC2*SIGTAB(IP,80,I2)+FAC1*SIGTAB(IP,80,I1)
17909 IF(IPAMDL(116).GE.2) THEN
17910 C direct interaction according to full QPM calculation
17912 SIGSRH(1) = HSig(10)+HSig(11)
17913 SIGSRH(2) = HSig(12)+HSig(13)
17915 C direct interaction suppressed according to helicity factor
17916 SIGDIH = HSig(14)*FACH
17917 SIGSRH(1) = (HSig(10)+HSig(11))*FSUH(1)
17918 SIGSRH(2) = (HSig(12)+HSig(13))*FSUH(2)
17920 write(LO,*) ' PHO_CSINT: option not supported yet'
17923 C rescale relevant hard processes
17925 SIGSRH(1) = HSig(10)+HSig(11)
17926 SIGSRH(2) = HSig(12)+HSig(13)
17927 SIGtmp = SIGINE-(SIGDIH+SIGSRH(1)+SIGSRH(2))*FACP
17928 SIGDIR = HSig(14)*FACH+SIGSRH(1)*FSUH(1)*FSUP(2)
17929 & +SIGSRH(2)*FSUP(1)*FSUH(2)
17930 SIGINE = SIGtmp+SIGDIR
17931 SIGTOT = SIGINE+SIGELA
17934 C only hard interactions
17935 CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17936 SIGSRH(1) = (HSig(10)+HSig(11))*FSUH(1)
17937 SIGSRH(2) = (HSig(12)+HSig(13))*FSUH(2)
17938 SIGDIR = HSig(14)+SIGSRH(1)+SIGSRH(2)
17939 SIGHAR = HSig(9)*FACH
17942 SIG1SO = (FAC2*SIGTAB(IP,37,I2)+FAC1*SIGTAB(IP,37,I1))*FACP
17943 SIG1HA = (FAC2*SIGTAB(IP,38,I2)+FAC1*SIGTAB(IP,38,I1))*FACH
17944 SLOEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
17949 SLOVM(I,K) = FAC2*SIGTAB(IP,J,I2)+FAC1*SIGTAB(IP,J,I1)
17952 SIGPOM = (FAC2*SIGTAB(IP,56,I2)+FAC1*SIGTAB(IP,56,I1))*FACP
17953 SIGREG = (FAC2*SIGTAB(IP,57,I2)+FAC1*SIGTAB(IP,57,I1))*FACP
17963 & WRITE(LO,'(1X,A)') 'PHO_CSINT: cross sections calculated'
17969 *$ CREATE PHO_PRIMKT.FOR
17971 CDECK ID>, PHO_PRIMKT
17972 SUBROUTINE PHO_PRIMKT(IMODE,IF,IL,PTCUT,IREJ)
17973 C***********************************************************************
17975 C give primordial kt to partons entering hard scatterings and
17976 C remants connected to hard parton-parton interactions by color flow
17978 C input: IMODE -2 output of statistics
17979 C -1 initialization
17980 C 1 sampling of primordial kt
17981 C IF first entry in /POEVT1/ to check
17982 C IL last entry in /POEVT1/ to check
17983 C PTCUT current value of PTCUT to distinguish
17984 C between soft and hard
17986 C output: IREJ 0 success
17989 C***********************************************************************
17995 DOUBLE PRECISION DEPS
17996 PARAMETER ( DEPS = 1.D-15 )
17998 INTEGER IMODE,IF,IL,IREJ
17999 DOUBLE PRECISION PTCUT
18001 C input/output channels
18003 COMMON /POINOU/ LI,LO
18004 C event debugging information
18006 PARAMETER (NMAXD=100)
18007 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18008 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18009 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18010 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18011 C model switches and parameters
18013 INTEGER ISWMDL,IPAMDL
18014 DOUBLE PRECISION PARMDL
18015 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18017 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
18018 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
18019 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
18020 C data of c.m. system of Pomeron / Reggeon exchange
18021 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18022 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18023 & SIDP,CODP,SIFP,COFP
18024 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18025 & SIDP,CODP,SIFP,COFP,NPOSP(2),
18026 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
18027 C hard scattering data
18029 PARAMETER ( MSCAHD = 50 )
18030 INTEGER LSCAHD,LSC1HD,LSIDX,
18031 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
18032 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
18033 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
18034 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
18035 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
18036 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
18037 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
18038 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
18039 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
18041 C standard particle data interface
18044 PARAMETER (NMXHEP=4000)
18046 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
18047 DOUBLE PRECISION PHEP,VHEP
18048 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
18049 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
18051 C extension to standard particle data interface (PHOJET specific)
18052 INTEGER IMPART,IPHIST,ICOLOR
18053 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
18055 DOUBLE PRECISION PTS,XP,XP2,POLD,PNEW,GA,PP
18056 DIMENSION PTS(0:2,5),XP(5),
18057 & XP2(5,2),POLD(2,2),PNEW(4,2),GA(4),PP(4)
18059 INTEGER IROTT,IBALT,IBAL,IV,IV2,IRMAX
18061 PARAMETER (IRMAX=200)
18062 DIMENSION IROTT(IRMAX),IBALT(5,2),IBAL(2),IV(5),IV2(5,2)
18064 DOUBLE PRECISION SI,EI,SF,EF,PTOT,EE,XX,YY,ZZ,ANORF,FAC,DEL,PT2,
18065 & DEL2,GAE,GAZ,SID,COD,SIF,COF,ESUM
18066 INTEGER IROT,I,J,K,NHD,ISTART,INEXT,ICOM
18069 IF(IDEB(10).GE.10) WRITE(LO,'(1X,A,3I4,1P,E11.3)')
18070 & 'PHO_PRIMKT: called with IMODE,IF,IL,PTCUT',
18071 & IMODE,IF,IL,PTCUT
18073 C give primordial kt to partons engaged in a hard scattering
18075 IF(IMODE.EQ.1) THEN
18087 IF(ISTHEP(I).EQ.25) THEN
18088 C hard scattering number
18089 NHD = IPHIST(1,I+1)
18092 C calculate momenta of incoming partons
18093 POLD(1,1) = XHD(K,1)*ECMP/2.D0
18094 POLD(2,1) = POLD(1,1)
18095 POLD(1,2) = -XHD(K,2)*ECMP/2.D0
18096 POLD(2,2) = -POLD(1,2)
18105 C search for partons involved in hard interaction
18109 IF(ABS(ISTHEP(I)).EQ.1) THEN
18110 C hard scatterd partons (including ISR)
18111 IF((IPHIST(1,I).EQ.-NHD)
18112 & .OR.(IPHIST(1,I).EQ.NHD+1)
18113 & .OR.(IPHIST(1,I).EQ.NHD+2)) THEN
18116 IF(IROT.GT.IRMAX) THEN
18117 WRITE(LO,'(1X,/,2A,2I5)') 'PHO_PRIMKT: ',
18118 & 'no memory left in IROTT, event rejected (max/IROT)',
18127 ELSE IF(IPHIST(1,I).EQ.NHD) THEN
18128 IF(PHEP(3,I).GT.0.D0) THEN
18133 IBAL(J) = IBAL(J)+1
18134 IBALT(IBAL(J),J) = I
18135 XP2(IBAL(J),J) = PHEP(3,I)/ECMP
18136 IF(ISWMDL(24).EQ.0) THEN
18138 IF(IDHEP(I).NE.21) IV2(IBAL(J),J) = ICOLOR(2,I)
18139 ELSE IF(ISWMDL(24).EQ.1) THEN
18140 IV2(IBAL(J),J) = -1
18145 C possibly further hard scattering
18146 ELSE IF(ISTHEP(I).EQ.25) THEN
18155 if(IDEB(10).ge.15) then
18156 WRITE(LO,'(1X,2A,I4)') 'PHO_PRIMKT: ',
18157 & 'hard scattering number: ',NHD/100
18158 WRITE(LO,'(1X,2A,I5)') 'PHO_PRIMKT: ',
18159 & 'number of entries to rotate: ',IROT
18161 WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
18162 & 'entries to rotate: ',I,IROTT(I)
18164 WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
18165 & 'number of entries to balance: ',IBAL
18168 WRITE(LO,'(1X,2A,I2,2I5)')
18169 & 'PHO_PRIMKT: entries to balance (side,no,line)',
18175 C incoming partons (comment lines), skip direct interacting particles
18177 IF((IDHEP(ICOM+K).NE.22).AND.(IDHEP(ICOM+K).NE.990)) THEN
18178 IF(PHEP(3,ICOM+K).GT.0.D0) THEN
18183 IBAL(J) = IBAL(J)+1
18184 IBALT(IBAL(J),J) = -ICOM-K
18185 XP2(IBAL(J),J) = POLD(1,J)/ECMP
18186 IV2(IBAL(J),J) = -1
18190 C check consistency
18191 IF((IBAL(1).GT.4).OR.(IBAL(2).GT.4)) THEN
18192 WRITE(LO,'(1X,2A,I10)') 'PHO_PRIMKT: ',
18193 & 'inconsistent hard scattering remnant for event: ',KEVENT
18194 WRITE(LO,'(1X,A,3I4,1P,E11.3)')
18195 & 'PHO_PRIMKT called with IMODE,IF,IL,PTCUT',
18196 & IMODE,IF,IL,PTCUT
18197 WRITE(LO,'(1X,A,I4)') 'hard scattering number: ',NHD/100
18199 WRITE(LO,'(1X,A,2I5)') 'entries to rotate',I,IROTT(I)
18203 WRITE(LO,'(1X,A,I2,2I5)')
18204 & 'entries to balance (side,no,line)',J,I,IBALT(I,J)
18207 IF(IBAL(1)+IBAL(2).GT.0) CALL PHO_PREVNT(0)
18210 C calculate primordial kt
18213 IF((IBAL(1).GT.1).OR.(IBAL(2).GT.1)) THEN
18215 C add transverse momentum (overwrite /POEVT1/ entries)
18217 IF(IBAL(J).GT.1) THEN
18218 C sample from truncated distribution
18225 CALL PHO_SOFTPT(K,PTCUT,PTCUT,XP,IV,PTS)
18226 IF(PTS(0,K).GE.PARMDL(100)) GOTO 190
18227 C transform incoming partons of hard scattering
18228 DEL = ABS(POLD(1,J))+POLD(2,J)
18231 PNEW(1,J) = PTS(1,K)
18232 PNEW(2,J) = PTS(2,K)
18233 PNEW(3,J) = (-1)**J*(PT2 - DEL2)/(2.D0*DEL)
18234 PNEW(4,J) = (DEL2 + PT2)/(2.D0*DEL)
18235 C spectator partons
18237 DO 220 I=1,IBAL(J)-1
18239 PHEP(1,K) = PHEP(1,K)+PTS(1,I)
18240 PHEP(2,K) = PHEP(2,K)+PTS(2,I)
18241 ESUM = ESUM+PHEP(4,K)
18243 C long. momentum transfer
18244 PP(3) = PNEW(3,J) - POLD(1,J)
18245 PP(4) = PNEW(4,J) - POLD(2,J)
18246 DO 230 I=1,IBAL(J)-1
18248 FAC = PHEP(4,K)/ESUM
18249 PHEP(3,K) = PHEP(3,K) - FAC*PP(3)
18250 PHEP(4,K) = PHEP(4,K) - FAC*PP(4)
18254 IF(IDEB(10).GE.15) THEN
18255 WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
18256 & 'old incoming:',J,0.D0,0.D0,(POLD(I,J),I=1,2)
18257 WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
18258 & 'new incoming:',J,(PNEW(I,J),I=1,4)
18264 PNEW(3,J) = POLD(1,J)
18265 PNEW(4,J) = POLD(2,J)
18269 C transformation of hard scattering final states (including ISR)
18271 C old parton c.m. energy
18272 SI = (POLD(2,1)+POLD(2,2))**2-(POLD(1,1)+POLD(1,2))**2
18274 C new parton c.m. energy
18275 SF = (PNEW(4,1)+PNEW(4,2))**2-(PNEW(1,1)+PNEW(1,2))**2
18276 & -(PNEW(2,1)+PNEW(2,2))**2-(PNEW(3,1)+PNEW(3,2))**2
18280 IF(IDEB(10).GE.25) WRITE(LO,'(1X,A,1P,E12.4)')
18281 & 'PHO_PRIMKT: scaling factor (E-final/E-initial): ',FAC
18283 C calculate Lorentz transformation
18284 GAZ = -(POLD(1,1)+POLD(1,2))/EI
18285 GAE = (POLD(2,1)+POLD(2,2))/EI
18287 GA(I) = (PNEW(I,1)+PNEW(I,2))/EF
18289 CALL PHO_ALTRA(GA(4),-GA(1),-GA(2),-GA(3),PNEW(1,1),PNEW(2,1),
18290 & PNEW(3,1),PNEW(4,1),PTOT,PP(1),PP(2),PP(3),PP(4))
18291 PTOT = MAX(DEPS,PTOT)
18293 SID= SQRT(PP(1)**2+PP(2)**2)/PTOT
18296 IF(PTOT*SID.GT.1.D-5) THEN
18297 COF=PP(1)/(SID*PTOT)
18298 SIF=PP(2)/(SID*PTOT)
18299 ANORF=SQRT(COF*COF+SIF*SIF)
18305 C check consistency initial/final configuration before rotation
18306 IF(IDEB(10).GE.25) THEN
18307 WRITE(LO,'(1X,A,1P,4E11.3)') 'PHO_PRIMKT: ini. momentum (1):',
18308 & 0.D0,0.D0,(POLD(I,1)+POLD(I,2),I=1,2)
18315 PP(J) = PP(J)+PHEP(J,K)
18318 WRITE(LO,'(1X,A,1P,4E11.3)')
18319 & 'PHO_PRIMKT: fin. momentum (1):',PP
18322 C apply rotation/boost to scattered particles
18326 PP(J) = FAC*PHEP(J,K)
18328 CALL PHO_ALTRA(GAE,0.D0,0.D0,GAZ,PP(1),PP(2),PP(3),
18329 & PP(4),PTOT,PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
18330 CALL PHO_TRANS(PHEP(1,K),PHEP(2,K),PHEP(3,K),
18331 & COD,SID,COF,SIF,XX,YY,ZZ)
18333 CALL PHO_ALTRA(GA(4),GA(1),GA(2),GA(3),XX,YY,ZZ,EE,PTOT,
18334 & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
18338 C check consistency initial/final configuration after rotation
18339 IF(IDEB(10).GE.25) THEN
18341 PP(I) = PNEW(I,1)+PNEW(I,2)
18343 WRITE(LO,'(1X,A,1P,4E11.3)')
18344 & 'PHO_PRIMKT: ini. momentum (2):',PP
18351 PP(J) = PP(J)+PHEP(J,K)
18354 WRITE(LO,'(1X,A,1P,4E11.3)')
18355 & 'PHO_PRIMKT: fin. momentum (2):',PP
18360 IF(INEXT.EQ.1) GOTO 100
18364 ELSE IF(IMODE.EQ.-1) THEN
18366 C output of statistics etc.
18368 ELSE IF(IMODE.EQ.-2) THEN
18373 WRITE(LO,'(/1X,A,I4)')
18374 & 'PHO_PRIMKT:ERROR: invalid value of IMODE:',IMODE
18380 *$ CREATE PHO_PARTPT.FOR
18382 CDECK ID>, PHO_PARTPT
18383 SUBROUTINE PHO_PARTPT(IMODE,IF,IL,PTCUT,IREJ)
18384 C********************************************************************
18386 C assign to soft partons
18388 C input: IMODE -2 output of statistics
18389 C -1 initialization
18390 C 0 sampling of pt for soft partons belonging to
18392 C 1 sampling of pt for soft partons belonging to
18394 C IF first entry in /POEVT1/ to check
18395 C IL last entry in /POEVT1/ to check
18396 C PTCUT current value of PTCUT to distinguish
18397 C between soft and hard
18399 C output: IREJ 0 success
18402 C (soft pt is sampled by call to PHO_SOFTPT)
18404 C********************************************************************
18405 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18408 PARAMETER ( DEPS = 1.D-15 )
18410 INTEGER IMODE,IF,IL,IREJ
18411 DOUBLE PRECISION PTCUT
18413 C input/output channels
18415 COMMON /POINOU/ LI,LO
18416 C event debugging information
18418 PARAMETER (NMAXD=100)
18419 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18420 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18421 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18422 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18423 C model switches and parameters
18425 INTEGER ISWMDL,IPAMDL
18426 DOUBLE PRECISION PARMDL
18427 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18429 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
18430 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
18431 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
18432 C data of c.m. system of Pomeron / Reggeon exchange
18433 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18434 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18435 & SIDP,CODP,SIFP,COFP
18436 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18437 & SIDP,CODP,SIFP,COFP,NPOSP(2),
18438 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
18440 C standard particle data interface
18443 PARAMETER (NMXHEP=4000)
18445 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
18446 DOUBLE PRECISION PHEP,VHEP
18447 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
18448 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
18450 C extension to standard particle data interface (PHOJET specific)
18451 INTEGER IMPART,IPHIST,ICOLOR
18452 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
18454 DOUBLE PRECISION PTS,PB,XP,XPB,PC
18455 DIMENSION PTS(0:2,50),PB(0:2,2),XP(50),XPB(2),PC(4)
18457 INTEGER MODIFY,IV,IVB
18458 DIMENSION MODIFY(50),IV(50),IVB(2)
18461 IF(IDEB(6).GE.10) WRITE(LO,'(1X,A,3I4,1P,E11.3)')
18462 & 'PHO_PARTPT: called with IMODE,IF,IL,PTCUT',
18463 & IMODE,IF,IL,PTCUT
18465 IF(IMODE.LT.0) GOTO 1000
18468 IF((ISWMDL(3).EQ.10).AND.(ISWMDL(4).EQ.10)) RETURN
18470 C count entries to modify
18479 IF(IMODE.EQ.0) THEN
18481 IF((ISTHEP(I).EQ.-1).AND.(ABS(IPHIST(1,I)).LT.100)) THEN
18484 XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
18486 IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
18487 IF(PHEP(4,I).LT.EMIN) THEN
18494 C hard Pomeron associated remnants (IPHIST(1,)=100,200,...)
18496 ELSE IF(IMODE.EQ.1) THEN
18499 IF((ISTHEP(I).EQ.-1).AND.(IPHIST(1,I).GE.100)) THEN
18500 IF(MOD(IPHIST(1,I),100).EQ.0) THEN
18503 XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
18504 IF(ISWMDL(24).EQ.0) THEN
18506 IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
18507 ELSE IF(ISWMDL(24).EQ.1) THEN
18512 IF(PHEP(4,I).LT.EMIN) THEN
18523 WRITE(LO,'(/1X,A,I5)') 'PHO_PARTPT:ERROR: invalid mode',IMODE
18528 IF(IDEB(6).GE.5) THEN
18529 WRITE(LO,'(1X,2A,3I4)') 'PHO_PARTPT: ',
18530 & 'number of partons, IPEAK,MODE',IENTRY,IPEAK,IMODE
18531 IF(IDEB(6).GE.20) CALL PHO_PREVNT(0)
18535 IF(IENTRY.LE.1) RETURN
18537 C sample pt of soft partons
18539 IF(ISWMDL(5).LE.1) THEN
18541 IPEAK = DT_RNDM(DUM)*IENTRY+1
18542 CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
18543 CALL PHO_SWAPD(XP(IPEAK),XP(1))
18544 CALL PHO_SWAPI(IV(IPEAK),IV(1))
18546 C energy limited sampling
18550 IF(ITER.GE.1000) THEN
18551 IF(IDEB(6).GE.3) THEN
18552 WRITE(LO,'(1X,A,3I5)')
18553 & 'PHO_PARTPT: rejection for MODE,ENTRY,ITER',
18554 & IMODE,IENTRY,ITER
18555 WRITE(LO,'(8X,A,I5)') 'I II IV XP EP',
18559 WRITE(LO,'(5X,3I5,1P,2E13.4)')
18560 & I,II,IV(I),XP(I),PHEP(4,II)
18562 IF(IDEB(6).GE.5) CALL PHO_PREVNT(0)
18569 PTMX = MIN(PHEP(4,II),PTCUT)
18572 IF(ISWMDL(5).EQ.0) THEN
18573 CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
18575 CALL PHO_SOFTPT(1,PTMX,PTMX,XPB,IVB,PB)
18580 PSUMX = PSUMX+PB(1,1)
18581 PSUMY = PSUMY+PB(2,1)
18583 PTREM = SQRT(PSUMX**2+PSUMY**2)
18584 IF(PTREM.GT.MIN(PHEP(4,MODIFY(1)),PTCUT)) GOTO 400
18587 ELSE IF((ISWMDL(5).EQ.2)
18588 & .OR.((IMODE.EQ.1).AND.(ISWMDL(5).EQ.3))) THEN
18589 C unlimited sampling
18590 IPEAK = DT_RNDM(PSUMX)*IENTRY+1
18591 CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
18592 CALL PHO_SWAPD(XP(IPEAK),XP(1))
18593 CALL PHO_SWAPI(IV(IPEAK),IV(1))
18594 CALL PHO_SOFTPT(IENTRY,PTCUT,PTCUT,XP,IV,PTS)
18595 ELSE IF(ISWMDL(5).EQ.3) THEN
18596 C each string has balanced pt
18598 IF(IV(K).LE.-90) GOTO 499
18600 IC1 = -ICOLOR(1,I1)
18601 DO 510 L=K+1,IENTRY
18602 IF(ICOLOR(1,MODIFY(L)).EQ.IC1) GOTO 511
18604 WRITE(LO,'(//1X,A,I5)')
18605 & 'PHO_PARTPT:ERROR: no color found for (line,color)',I1,-IC1
18609 AMSQR = (PHEP(4,I1)+PHEP(4,I2))**2-(PHEP(1,I1)+PHEP(1,I2))**2
18610 & -(PHEP(2,I1)+PHEP(2,I2))**2-(PHEP(3,I1)+PHEP(3,I2))**2
18613 IVB(1) = MAX(IV(K),IV(L))
18615 CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
18618 PTS(1,L) = -PB(1,1)
18619 PTS(2,L) = -PB(2,1)
18620 GAM = (PHEP(4,I1)+PHEP(4,I2))/AM
18621 GAMBEZ = (PHEP(3,I1)+PHEP(3,I2))/AM
18624 PLONG = SQRT(PTMX**2-PB(0,1)**2+1.D-12)
18625 PC(3) = SIGN(PLONG,PHEP(3,I1))
18627 CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
18628 & PTOT,PHEP(1,I1),PHEP(2,I1),PHEP(3,I1),PHEP(4,I1))
18632 CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
18633 & PTOT,PHEP(1,I2),PHEP(2,I2),PHEP(3,I2),PHEP(4,I2))
18639 WRITE(LO,'(/1X,A,I4)')
18640 & 'PHO_PARTPT:ERROR: invalid value of ISWMDL(5):',ISWMDL(5)
18644 C change partons in /POEVT1/
18646 IF(IV(II).GT.-90) THEN
18648 PHEP(1,I) = PHEP(1,I)+PTS(1,II)
18649 PHEP(2,I) = PHEP(2,I)+PTS(2,II)
18650 AMSQR = PHEP(4,I)**2
18651 & -PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
18652 PHEP(5,I) = SIGN(SQRT(ABS(AMSQR)),AMSQR)
18657 IF(IDEB(6).GE.15) THEN
18658 WRITE(LO,'(1X,A,/,8X,A,I5)') 'PHO_PARTPT: table of momenta',
18659 & 'I II IV XP EP PTS PTX PTY',IPEAK
18662 WRITE(LO,'(2X,3I5,1P,5E12.4)')
18663 & I,II,IV(I),XP(I),PHEP(4,II),PTS(0,I),PTS(1,I),PTS(2,I)
18669 C initialization / output of statistics
18671 CALL PHO_SOFTPT(IMODE,PTM,PTM,XP,IV,PTS)
18675 *$ CREATE PHO_SOFTPT.FOR
18677 CDECK ID>, PHO_SOFTPT
18678 SUBROUTINE PHO_SOFTPT(ISOFT,PTCUT,PTMAX,XV,IV,PTSOF)
18679 C***********************************************************************
18681 C select pt of soft string ends
18683 C input: ISOFT number of soft partons
18684 C -1 initialization
18685 C >=0 sampling of p_t
18686 C -2 output of statistics
18687 C PTCUT cutoff for soft strings
18688 C PTMAX maximal allowed PT
18689 C XV field of x values
18693 C output: /POINT3/ containing parameters AAS,BETAS
18694 C PTSOF filed with soft pt values
18696 C note: ISWMDL(3/4) = 0 dNs/dP_t = P_t ASS * exp(-BETA*P_t**2)
18697 C ISWMDL(3/4) = 1 dNs/dP_t = P_t ASS * exp(-BETA*P_t)
18698 C ISWMDL(3/4) = 2 photon wave function
18699 C ISWMDL(3/4) = 10 no soft P_t assignment
18701 C***********************************************************************
18702 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18705 PARAMETER ( DEPS = 1.D-15)
18707 DIMENSION PTSOF(0:2,*),XV(*)
18710 C input/output channels
18712 COMMON /POINOU/ LI,LO
18713 C event debugging information
18715 PARAMETER (NMAXD=100)
18716 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18717 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18718 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18719 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18720 C model switches and parameters
18722 INTEGER ISWMDL,IPAMDL
18723 DOUBLE PRECISION PARMDL
18724 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18725 C data of c.m. system of Pomeron / Reggeon exchange
18726 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18727 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18728 & SIDP,CODP,SIFP,COFP
18729 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18730 & SIDP,CODP,SIFP,COFP,NPOSP(2),
18731 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
18732 C data on most recent hard scattering
18733 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
18734 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
18735 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
18736 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
18737 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
18738 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
18739 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
18740 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
18741 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
18742 C data needed for soft-pt calculation
18743 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18744 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18746 DIMENSION BETAB(100)
18749 IF(ISOFT.GE.0) THEN
18750 CALLS = CALLS + 1.D0
18751 C sample according to model ISWMDL(3-6)
18752 IF(ISOFT.GT.1) THEN
18759 IF(IV(I).EQ.1) THEN
18761 C photon/pomeron valence part
18762 IF(IPAMDL(5).EQ.1) THEN
18763 IF(XV(I).GE.0.D0) THEN
18764 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
18769 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
18774 ELSE IF(IPAMDL(5).EQ.2) THEN
18776 ELSE IF(IPAMDL(5).EQ.3) THEN
18780 ELSE IF(IV(I).EQ.0) THEN
18782 C hard scattering remnant
18784 IF(IPAMDL(6).EQ.0) THEN
18786 ELSE IF(IPAMDL(6).EQ.1) THEN
18792 BETA = MAX(BETA,0.01D0)
18793 CALL PHO_SELPT(XV(I),0.D0,PTCUT,PTS,BETA,IMODE)
18794 PTS = MIN(PTMAX,PTS)
18795 CALL PHO_SFECFE(SIG,COG)
18797 PTSOF(1,I) = COG*PTS
18798 PTSOF(2,I) = SIG*PTS
18799 PTXS = PTXS+PTSOF(1,I)
18800 PTYS = PTYS+PTSOF(2,I)
18803 C balancing of momenta
18804 PTS = SQRT(PTXS**2+PTYS**2)
18805 IF(PTS.GE.PTMAX) GOTO 210
18813 C single parton only
18817 IF(IV(1).EQ.1) THEN
18819 C photon/Pomeron valence part
18820 IF(IPAMDL(5).EQ.1) THEN
18821 IF(XV(1).GE.0.D0) THEN
18822 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
18827 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
18832 ELSE IF(IPAMDL(5).EQ.2) THEN
18834 ELSE IF(IPAMDL(5).EQ.3) THEN
18838 ELSE IF(IV(1).EQ.0) THEN
18840 C hard scattering remnant
18842 IF(IPAMDL(6).EQ.1) THEN
18848 BETA = MAX(BETA,0.01D0)
18849 CALL PHO_SELPT(XV(1),0.D0,PTCUT,PTS,BETA,IMODE)
18850 PTS = MIN(PTMAX,PTS)
18851 CALL PHO_SFECFE(SIG,COG)
18853 PTSOF(1,1) = COG*PTS
18854 PTSOF(2,1) = SIG*PTS
18859 IF(IDEB(29).GE.10) THEN
18860 WRITE(LO,'(1X,A,I4)') 'PHO_SOFTPT: ISOFT',ISOFT
18861 WRITE(LO,'(6X,A)') 'TABLE OF I, IV, XV, PT, PT-X, PT-Y, BETA'
18863 WRITE(LO,'(10X,2I3,1P,5E12.3)') I,IV(I),XV(I),PTSOF(0,I),
18864 & PTSOF(1,I),PTSOF(2,I),BETAB(I)
18868 C initialization of statistics and parameters
18870 ELSE IF(ISOFT.EQ.-1) THEN
18874 IMODE = -100+ISWMDL(3)
18875 CALL PHO_SELPT(ECMP,PTSMIN,PTSMAX,PTS,BETAS(3),IMODE)
18877 C output of statistics
18879 ELSE IF(ISOFT.EQ.-2) THEN
18882 WRITE(LO,'(1X,2A,I2)') 'PHO_SOFTPT:ERROR: ',
18883 & 'unsupported ISOFT ',ISOFT
18888 *$ CREATE PHO_SELPT.FOR
18890 CDECK ID>, PHO_SELPT
18891 SUBROUTINE PHO_SELPT(EE,PTLOW,PTHIGH,PTS,BETA,IMODE)
18892 C***********************************************************************
18894 C select pt from different distributions
18896 C input: EE energy (for initialization only)
18897 C otherwise x value of corresponding parton
18898 C PTLOW lower pt limit
18899 C PTHIGH upper pt limit
18900 C (PTHIGH > 20 will cause DEXP underflows)
18902 C IMODE = 0 dNs/dP_t = P_t * ASS * exp(-BETA*P_t**2)
18903 C IMODE = 1 dNs/dP_t = P_t * ASS * exp(-BETA*P_t)
18904 C IMODE = 2 dNs/dP_t according photon wave function
18905 C IMODE = 10 no sampling
18907 C IMODE = -100+IMODE initialization according to
18908 C given limitations
18910 C output: PTS sampled pt value
18912 C BETA soft pt slope in central region
18914 C***********************************************************************
18915 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18918 PARAMETER ( PI2 = 6.28318530718D0,
18923 C input/output channels
18925 COMMON /POINOU/ LI,LO
18926 C event debugging information
18928 PARAMETER (NMAXD=100)
18929 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18930 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18931 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18932 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18933 C model switches and parameters
18935 INTEGER ISWMDL,IPAMDL
18936 DOUBLE PRECISION PARMDL
18937 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18938 C data of c.m. system of Pomeron / Reggeon exchange
18939 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18940 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18941 & SIDP,CODP,SIFP,COFP
18942 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18943 & SIDP,CODP,SIFP,COFP,NPOSP(2),
18944 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
18945 C average number of cut soft and hard ladders (obsolete)
18946 DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
18947 COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
18948 C data needed for soft-pt calculation
18949 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18950 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18952 DOUBLE PRECISION PHO_CONN0,PHO_CONN1
18953 EXTERNAL PHO_CONN0,PHO_CONN1
18957 IF(IMODE.LT.0) GOTO 100
18964 IF(PX.LT.AMIN) RETURN
18966 IF((PX-PTLOW).LT.0.01) THEN
18967 IF(IDEB(5).GE.3) WRITE(LO,'(1X,A,2E12.3,I3)')
18968 & 'PHO_SELPT: PTLOW,PTHIGH,IMODE ',PTLOW,PTHIGH,IMODE
18972 C sampling of pt values according to IMODE
18974 IF(IMODE.EQ.0) THEN
18976 FAC1 = EXP(-BETA*PX**2)
18979 XI1 = DT_RNDM(PX)*FAC2 + FAC1
18980 PTS = SQRT(-1.D0/BETA*LOG(XI1))
18981 IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 25
18983 ELSE IF(IMODE.EQ.1) THEN
18985 XIMIN = EXP(-BETA*PTHIGH)
18988 PTS = -LOG((XIDEL*DT_RNDM(XIDEL)+XIMIN)
18989 & *(XIDEL*DT_RNDM(XIMIN)+XIMIN)+DEPS)/BETA
18990 IF(PTS.LT.XMT) GOTO 50
18991 PTS = SQRT(PTS**2-XMT2)
18992 IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 50
18994 ELSE IF(IMODE.EQ.2) THEN
18996 IF(EE.GE.0.D0) THEN
19002 AA = (1.D0-XV)*XV*P2+PARMDL(25)
19004 PTS = SQRT(AA/(DT_RNDM(PX)+EPS)-AA)
19005 IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 75
19009 ELSE IF(IMODE.NE.10) THEN
19010 WRITE(LO,'(/1X,A,I4)') 'PHO_SELPT:ERROR: invalid IMODE',IMODE
19015 IF(IDEB(5).GE.20) THEN
19016 WRITE(LO,'(1X,A,I3,4E10.3)')
19017 & 'PHO_SELPT: MODE,BET,PTMI,PTMA,PT',
19018 & IMODE,BETA,PTLOW,PTHIGH,PTS
19027 C calculation of parameters
19031 C initialization for model 0 (gaussian pt distribution)
19034 BETAS(1) = PARMDL(23)+0.15D0*LOG(EE)*(PARMDL(24)-PARMDL(23))
19037 XTOL = PHO_CONN0(BETLO)*PHO_CONN0(BETUP)
19038 IF(XTOL.LT.0.D0) THEN
19043 BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN0,METHOD)
19044 * IF(BETA.LT.-1.D+10) THEN
19045 * WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
19046 * & '(model 0: Ecm,PTcut)',EE,PTCON
19047 * WRITE(LO,'(1X,A,1P,3E10.3)')
19048 * & 'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
19049 * CALL PHO_PREVNT(-1)
19052 AAS = DSIGHP/PTCON*EXP(-BETA*PTCON**2)
19059 C initialization for model 1 (exponential pt distribution)
19061 ELSE IF(INIT.EQ.1) THEN
19064 BETAS(1) = PARMDL(21)+0.15D0*LOG(EE)*(PARMDL(22)-PARMDL(21))
19067 XTOL = PHO_CONN1(BETLO)*PHO_CONN1(BETUP)
19068 IF(XTOL.LT.0.D0) THEN
19073 BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN1,METHOD)
19074 * IF(BETA.LT.-1.D+10) THEN
19075 * WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
19076 * & '(model 1: Ecm,PTcut)',EE,PTCON
19077 * WRITE(LO,'(1X,A,1P,3E10.3)')
19078 * & 'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
19079 * CALL PHO_PREVNT(-1)
19082 AAS = DSIGHP/PTCON*EXP(-BETA*PTCON)
19088 ELSE IF(INIT.EQ.10) THEN
19090 & WRITE(LO,'(/1X,A)') 'PHO_SELPT: no soft pt sampling'
19093 WRITE(LO,'(1X,A,I4)') 'PHO_SELPT:ERROR: invalid distribution',
19097 BETA = MIN(BETA,BETAS(1))
19099 C hard cross section is too big: neg. beta parameter
19100 IF(BETA.LE.0.D0) THEN
19101 WRITE(LO,'(1X,A,1P,2E12.3)')
19102 & 'PHO_SELPT: parameter BETA negative (BETA,AAS)',BETA,AAS
19103 WRITE(LO,'(1X,A,1P,4E11.3)') 'SIGS,DSIGHP,SIGH,PTCON:',
19104 & SIGS,DSIGHP,SIGH,PTCON
19105 CALL PHO_PREVNT(-1)
19108 C output of initialization parameters
19109 IF(IDEB(5).GE.10) THEN
19110 WRITE(LO,'(1X,A,I3)') 'PHO_SELPT: initialization for model',
19112 WRITE(LO,'(5X,A,1P,2E13.3)')
19113 & 'BETA,AAS ',BETA,AAS
19114 WRITE(LO,'(5X,A,1P,3E13.3)')
19115 & 'ECM,PTMIN,PTMAX ',EE,PTSMIN,PTSMAX
19116 WRITE(LO,'(5X,A,1P,3E13.3)')
19117 & 'SIGS,DSIGHP,SIGH',SIGS,DSIGHP,SIGH
19122 *$ CREATE PHO_CONN0.FOR
19124 CDECK ID>, PHO_CONN0
19125 DOUBLE PRECISION FUNCTION PHO_CONN0(BETA)
19126 C***********************************************************************
19128 C auxiliary function to determine parameters of soft
19129 C pt distribution dNs/dP_t = P_t * AAS * EXP(-BETA*P_t**2)
19131 C internal factors: FS number of soft partons in soft Pomeron
19132 C FH number of soft partons in hard Pomeron
19134 C***********************************************************************
19140 C input/output channels
19142 COMMON /POINOU/ LI,LO
19143 C average number of cut soft and hard ladders (obsolete)
19144 DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
19145 COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
19146 C data needed for soft-pt calculation
19147 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
19148 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
19150 DOUBLE PRECISION BETA,XX,FF
19153 IF(ABS(XX).LT.1.D-3) THEN
19154 FF = FS*SIGS+FH*SIGH
19155 & - DSIGHP*(PTCON/2.D0+PTCON**3*BETA/4.D0)
19157 FF = FS*SIGS+FH*SIGH
19158 & - DSIGHP/(2.D0*PTCON*BETA)*(EXP(XX)-1.D0)
19162 * WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:BETA,AAS,FF',BETA,AAS,FF
19163 * WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP
19167 *$ CREATE PHO_CONN1.FOR
19169 CDECK ID>, PHO_CONN1
19170 DOUBLE PRECISION FUNCTION PHO_CONN1(BETA)
19171 C***********************************************************************
19173 C auxiliary function to determine parameters of soft
19174 C pt distribution dNs/dP_t = P_t * AAS * EXP(-BETA*P_t)
19176 C internal factors: FS number of soft partons in soft Pomeron
19177 C FH number of soft partons in hard Pomeron
19179 C***********************************************************************
19185 C input/output channels
19187 COMMON /POINOU/ LI,LO
19188 C average number of cut soft and hard ladders (obsolete)
19189 DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
19190 COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
19191 C data needed for soft-pt calculation
19192 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
19193 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
19195 DOUBLE PRECISION BETA,XX,FF
19198 IF(ABS(XX).LT.1.D-3) THEN
19199 FF = FS*SIGS+FH*SIGH
19200 & - DSIGHP*(PTCON/2.D0+PTCON**2*BETA/6.D0)
19202 FF = FS*SIGS+FH*SIGH
19203 & - DSIGHP/(PTCON*BETA**2)*(EXP(XX)-1.D0-BETA*PTCON)
19207 * WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:BETA,AAS,FF',BETA,AAS,FF
19208 * WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP
19212 *$ CREATE PHO_MSHELL.FOR
19214 CDECK ID>, PHO_MSHELL
19215 SUBROUTINE PHO_MSHELL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
19216 C********************************************************************
19218 C rescaling of momenta of two partons to put both
19221 C input: PA1,PA2 input momentum vectors
19222 C XM1,2 desired masses of particles afterwards
19223 C P1,P2 changed momentum vectors
19225 C********************************************************************
19226 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19229 PARAMETER ( DEPS = 1.D-20 )
19231 DIMENSION PA1(*),PA2(*),P1(*),P2(*)
19233 C input/output channels
19235 COMMON /POINOU/ LI,LO
19236 C event debugging information
19238 PARAMETER (NMAXD=100)
19239 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19240 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19241 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19242 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19243 C internal rejection counters
19245 PARAMETER (NMXJ=60)
19246 CHARACTER*10 REJTIT
19248 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19253 IF(IDEB(40).GE.10) THEN
19254 WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
19255 WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
19256 WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
19257 WRITE(LO,'(5X,A,2E12.3)') 'new masses:',XM1,XM2
19260 C Lorentz transformation into system CMS
19265 XMS = EE**2-PX**2-PY**2-PZ**2
19266 IF(XMS.LT.(XM1+XM2)**2) THEN
19268 IFAIL(37) = IFAIL(37)+1
19270 if((xm1.gt.1.D4).or.(xm2.gt.1.D4)) irej = irej/idev
19272 IF(IDEB(40).GE.3) THEN
19273 WRITE(LO,'(/1X,A,I12)')
19274 & 'PHO_MSHELL:reject: too small string mass (KEVENT)',KEVENT
19275 WRITE(LO,'(5X,A,3E12.4)') 'two-part.mass, part.masses:',
19276 & SIGN(SQRT(ABS(XMS)),XMS),XM1,XM2
19277 WRITE(LO,'(5X,A,4E11.4)') 'PX,PY,PZ,EE:',PX,PY,PZ,EE
19279 IF(IDEB(40).GE.3) GOTO 55
19288 CALL PHO_ALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
19289 & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
19291 PTOT1 = MAX(DEPS,PTOT1)
19293 SID = SQRT(P1(1)**2+P1(2)**2)/PTOT1
19296 IF(PTOT1*SID.GT.1.D-5) THEN
19297 COF = P1(1)/(SID*PTOT1)
19298 SIF = P1(2)/(SID*PTOT1)
19299 ANORF = SQRT(COF*COF+SIF*SIF)
19304 C new CM momentum and energies (for masses XM1,XM2)
19308 PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*XMS)
19309 EE1 = SQRT(XM12+PCMP**2)
19312 CALL PHO_TRANS(0.D0,0.D0,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
19313 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
19314 & PTOT1,P1(1),P1(2),P1(3),P1(4))
19315 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
19316 & PTOT2,P2(1),P2(2),P2(3),P2(4))
19318 C check consistency
19320 IF(ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
19322 ELSE IF(ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
19324 ELSE IF(ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
19326 ELSE IF(ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
19332 WRITE(LO,'(1X,A,I3)')
19333 & 'PHO_MSHELL: inconsistent transformation (IDEV)',IDEV
19334 WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
19335 WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
19336 WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
19337 WRITE(LO,'(5X,A,3E12.3)') 'ava.mass,masses:',XMS,XM1,XM2
19338 WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
19339 WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
19340 WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
19341 ELSE IF(IDEB(40).GE.10) THEN
19342 WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
19343 WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
19344 WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
19348 *$ CREATE PHO_GLU2QU.FOR
19350 CDECK ID>, PHO_GLU2QU
19351 SUBROUTINE PHO_GLU2QU(IG,IQ1,IQ2,IREJ)
19352 C********************************************************************
19354 C split gluon with index I in POEVT1
19355 C (massless gluon assumed)
19359 C IQ1 first quark index
19360 C IQ2 second quark index
19362 C output: new quarks in /POEVT1/
19363 C IREJ 1 splitting impossible
19364 C 0 splitting successful
19366 C********************************************************************
19367 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19370 PARAMETER ( DEPS = 1.D-15,
19373 C input/output channels
19375 COMMON /POINOU/ LI,LO
19376 C event debugging information
19378 PARAMETER (NMAXD=100)
19379 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19380 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19381 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19382 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19383 C model switches and parameters
19385 INTEGER ISWMDL,IPAMDL
19386 DOUBLE PRECISION PARMDL
19387 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
19389 C standard particle data interface
19392 PARAMETER (NMXHEP=4000)
19394 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
19395 DOUBLE PRECISION PHEP,VHEP
19396 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
19397 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
19399 C extension to standard particle data interface (PHOJET specific)
19400 INTEGER IMPART,IPHIST,ICOLOR
19401 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
19403 C internal rejection counters
19405 PARAMETER (NMXJ=60)
19406 CHARACTER*10 REJTIT
19408 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19410 DIMENSION P1(4),P2(4)
19415 C calculate string masses max possible
19416 IF(ISWMDL(9).EQ.1) THEN
19417 CMASS1=2.D0*(PHEP(4,IG)*PHEP(4,IQ1)-PHEP(1,IG)*PHEP(1,IQ1)
19418 & -PHEP(2,IG)*PHEP(2,IQ1)-PHEP(3,IG)*PHEP(3,IQ1))
19419 IF(CMASS1.LT.CUTM) THEN
19420 IF(IDEB(73).GE.5) THEN
19421 WRITE(LO,'(1X,A,3I4,4E10.3)')
19422 & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS1',IG,IQ1,IQ2,CMASS1
19424 IFAIL(33) = IFAIL(33) + 1
19428 CMASS2=2.D0*(PHEP(4,IG)*PHEP(4,IQ2)-PHEP(1,IG)*PHEP(1,IQ2)
19429 & -PHEP(2,IG)*PHEP(2,IQ2)-PHEP(3,IG)*PHEP(3,IQ2))
19430 IF(CMASS2.LT.CUTM) THEN
19431 IF(IDEB(73).GE.5) THEN
19432 WRITE(LO,'(1X,A,3I4,4E10.3)')
19433 & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS2',IG,IQ1,IQ2,CMASS2
19435 IFAIL(33) = IFAIL(33) + 1
19440 C calculate minimal z
19441 ZMIN1 = (CUTM-SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))/CMASS1+EPS
19442 ZMIN2 = (CUTM-SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))/CMASS2+EPS
19443 ZMIN = MIN(ZMIN1,ZMIN2)
19444 IF(MAX(ZMIN1,ZMIN2).GE.0.45D0) THEN
19445 IF(IDEB(73).GE.5) THEN
19446 WRITE(LO,'(1X,A,3I3,4E10.3)')
19447 & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,ZMIN1,ZMIN2,P1*PG,P2*PG',
19448 & IG,IQ1,IQ2,ZMIN1,ZMIN2,CMASS1,CMASS2
19450 IFAIL(33) = IFAIL(33) + 1
19455 ZMIN = MIN(0.1D0,0.5D0/PHEP(4,IG))
19458 ZFRAC = PHO_GLUSPL(ZMIN)
19459 IF((ZFRAC.LT.ZMIN1).OR.((1.D0-ZFRAC).LT.ZMIN2)) THEN
19463 P1(I) = PHEP(I,IG)*ZFRAC
19464 P2(I) = PHEP(I,IG)*(1.D0-ZFRAC)
19467 CMASS1 = SQRT(ZFRAC*CMASS1+SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))
19468 CMASS2 = SQRT((1.D0-ZFRAC)*CMASS2
19469 & +SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))
19470 CALL PHO_SEAFLA(IG,K,I,MIN(CMASS1,CMASS2))
19472 IF(ABS(IDHEP(IQ1)).GT.6) THEN
19473 K = SIGN(ABS(K),IDHEP(IQ1))
19475 K = -SIGN(ABS(K),IDHEP(IQ1))
19479 IC1 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
19480 IC2 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
19482 IC1 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
19483 IC2 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
19485 C register new partons
19486 CALL PHO_REGPAR(-1,K,0,IG,0,P1(1),P1(2),P1(3),P1(4),
19487 & IPHIST(1,IG),0,IC1,0,IPOS,1)
19488 CALL PHO_REGPAR(-1,-K,0,IG,0,P2(1),P2(2),P2(3),P2(4),
19489 & IPHIST(1,IG),0,IC2,0,IPOS,1)
19491 IF(IDEB(73).GE.20) THEN
19492 WRITE(LO,'(1X,A,/1X,A,3I3,5E10.3)')
19493 & 'PHO_GLU2QU:',' IG,IQ1,IQ2,ZMIN1,2,Z,P1*PG,P2*PG',
19494 & IG,IQ1,IQ2,ZMIN1,ZMIN2,ZFRAC,CMASS1,CMASS2
19495 WRITE(LO,'(1X,A,4I5)') ' flavours, colors ',
19500 *$ CREATE PHO_GLUSPL.FOR
19502 CDECK ID>, PHO_GLUSPL
19503 DOUBLE PRECISION FUNCTION PHO_GLUSPL(ZMIN)
19504 C*********************************************************************
19506 C calculate quark - antiquark light cone momentum fractions
19507 C according to Altarelli-Parisi g->q aq splitting function
19508 C (symmetric z interval assumed)
19510 C input: ZMIN minimal Z value allowed,
19511 C 1-ZMIN maximal Z value allowed
19513 C********************************************************************
19514 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19517 PARAMETER ( ALEXP= 0.3333333333D0,
19520 C input/output channels
19522 COMMON /POINOU/ LI,LO
19523 C event debugging information
19525 PARAMETER (NMAXD=100)
19526 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19527 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19528 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19529 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19531 IF(ZMIN.GE.0.5D0) THEN
19532 IF(IDEB(69).GT.2) THEN
19533 WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN>=0.5',ZMIN
19537 ELSE IF(ZMIN.LE.0.D0) THEN
19538 IF(IDEB(69).GT.2) THEN
19539 WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN<=0',ZMIN
19548 ZZ = ((1.D0-XI)*ZMINL**3+XI*ZMAX**3)**ALEXP
19549 IF(DT_RNDM(ZZ).LT.0.5D0) ZZ = 1.D0-ZZ
19552 IF(IDEB(69).GE.10) THEN
19553 WRITE(LO,'(1X,A,2E12.4)') 'PHO_GLUSPL: ZMIN,Z ',ZMIN,ZZ
19558 *$ CREATE PHO_STDPAR.FOR
19560 CDECK ID>, PHO_STDPAR
19561 SUBROUTINE PHO_STDPAR(IJM1,IJM2,IGEN,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
19562 C***********************************************************************
19564 C select the initial parton x-fractions and flavors and
19565 C the final parton momenta and flavours
19566 C for standard Pomeron/Reggeon cuts
19568 C input: IJM1 index of mother particle 1 in /POEVT1/
19569 C IJM2 index of mother particle 2 in /POEVT1/
19570 C IGEN production process of mother particles
19571 C MSPOM soft cut Pomerons
19572 C MHPOM hard or semihard cut Pomerons
19573 C MSREG soft cut Reggeons
19574 C MHDIR direct hard processes
19576 C IJM1 -1 initialization of statistics
19577 C -2 output of statistics
19579 C output: partons are directly written to /POEVT1/,/POEVT2/
19581 C structure of /POSOFT/
19582 C XS1(I),XS2(I): x-values of initial partons
19583 C IJSI1(I),IJSI2(I): flavor of initial parton
19586 C negative antiquarks
19587 C IJSF1(I),IJSF2(I): flavor of final state partons
19588 C PSOFT1(I,J),PSOFT2(I,J): final part. momentum and energy
19594 C***********************************************************************
19595 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19598 PARAMETER (RHOMAS = 0.766D0,
19602 C input/output channels
19604 COMMON /POINOU/ LI,LO
19605 C event debugging information
19607 PARAMETER (NMAXD=100)
19608 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19609 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19610 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19611 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19612 C model switches and parameters
19614 INTEGER ISWMDL,IPAMDL
19615 DOUBLE PRECISION PARMDL
19616 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
19618 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
19619 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
19620 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
19621 C general process information
19622 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
19623 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
19624 C global event kinematics and particle IDs
19625 INTEGER IFPAP,IFPAB
19626 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
19627 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
19628 C data of c.m. system of Pomeron / Reggeon exchange
19629 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
19630 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
19631 & SIDP,CODP,SIFP,COFP
19632 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
19633 & SIDP,CODP,SIFP,COFP,NPOSP(2),
19634 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
19635 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
19636 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
19637 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
19638 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
19639 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
19640 C obsolete cut-off information
19641 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
19642 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
19643 C currently activated parton density parametrizations
19645 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
19646 DOUBLE PRECISION PDFLAM,PDFQ2M
19647 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
19648 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
19649 C hard scattering parameters used for most recent hard interaction
19651 DOUBLE PRECISION ALQCD2,BQCD
19652 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
19653 C particles created by initial state evolution
19654 INTEGER MXISR1,MXISR2
19655 PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
19656 INTEGER IFLISR,IPOISR,IMXISR
19657 DOUBLE PRECISION PHISR
19658 COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
19659 & IPOISR(2,2,MXISR2),IMXISR(2)
19660 C light-cone x fractions and c.m. momenta of soft cut string ends
19662 PARAMETER ( MAXSOF = 50 )
19663 INTEGER IJSI2,IJSI1
19664 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
19665 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
19666 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
19667 & IJSI1(MAXSOF),IJSI2(MAXSOF)
19668 C table of particle indices for recursive PHOJET calls
19670 PARAMETER ( MAXIPX = 100 )
19671 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
19672 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
19673 & IPOIX1,IPOIX2,IPOIX3
19674 C hard scattering data
19676 PARAMETER ( MSCAHD = 50 )
19677 INTEGER LSCAHD,LSC1HD,LSIDX,
19678 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
19679 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
19680 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
19681 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
19682 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
19683 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
19684 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
19685 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
19686 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
19688 C standard particle data interface
19691 PARAMETER (NMXHEP=4000)
19693 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
19694 DOUBLE PRECISION PHEP,VHEP
19695 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
19696 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
19698 C extension to standard particle data interface (PHOJET specific)
19699 INTEGER IMPART,IPHIST,ICOLOR
19700 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
19702 C internal rejection counters
19704 PARAMETER (NMXJ=60)
19705 CHARACTER*10 REJTIT
19707 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19708 C internal cross check information on hard scattering limits
19709 DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
19710 COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)
19711 C hard cross sections and MC selection weights
19713 PARAMETER ( Max_pro_2 = 16 )
19714 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
19715 & MH_acc_1,MH_acc_2
19716 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
19717 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
19718 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
19719 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
19720 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
19721 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
19723 double precision pho_alphas
19725 DIMENSION PC(4),IFLA(2),ICI(2,2)
19727 IF(IJM1.EQ.-1) THEN
19730 ETAMA(1,I) = -1.D10
19732 ETAMA(2,I) = -1.D10
19738 CALL PHO_HARSCA(IJM1,1)
19739 CALL PHO_HARCOL(IJM1,0.D0,0,0,0,0,0,0,0,0,0,0,0,0)
19743 ELSE IF(IJM1.EQ.-2) THEN
19745 C output internal statistics
19746 IF(IDEB(23).GE.1) THEN
19747 WRITE(LO,'(/1X,A)')
19748 & 'kinematic limits particle c (ETAMIN,ETAMAX,XMIN,XMAX)'
19750 WRITE(LO,'(5X,I3,4E13.5)')
19751 & I,ETAMI(1,I),ETAMA(1,I),XXMI(1,I),XXMA(1,I)
19754 & 'kinematic limits particle d (ETAMIN,ETAMAX,XMIN,XMAX)'
19756 WRITE(LO,'(5X,I3,4E13.5)')
19757 & I,ETAMI(2,I),ETAMA(2,I),XXMI(2,I),XXMA(2,I)
19760 CALL PHO_HARSCA(IJM1,1)
19761 CALL PHO_HARCOL(IJM1,0.D0,0,0,0,0,0,0,0,0,0,0,0,0)
19768 IF(IDEB(23).GT.5) WRITE(LO,221) IJM1,IJM2,MSPOM,MHPOM,MSREG,MHDIR
19769 221 FORMAT (' PHO_STDPAR: JM1/2,MSPOM,MHPOM,MSREG,MHDIR ',6I5)
19771 C get mother data (exchange if first particle is a pomeron)
19772 IF((IDHEP(IJM1).EQ.990).AND.(IFPAP(1).NE.990)) THEN
19782 IDPDG1 = IDHEP(JM1)
19783 IDBAM1 = IMPART(JM1)
19784 IDPDG2 = IDHEP(JM2)
19785 IDBAM2 = IMPART(JM2)
19787 C store current status of /POEVT1/
19796 C get nominal masses (photons: VDM assumption)
19798 IF(IDHEP(JM1).EQ.22) THEN
19799 PMASSP(1) = RHOMAS+DELMAS
19800 PVIRTP(1) = PHEP(5,JM1)**2
19802 PMASSP(1) = PHO_PMASS(IDBAM1,0)+DELMAS
19805 IF(IDHEP(JM2).EQ.22) THEN
19806 PMASSP(2) = RHOMAS+DELMAS
19807 PVIRTP(2) = PHEP(5,JM2)**2
19809 PMASSP(2) = PHO_PMASS(IDBAM2,0)+DELMAS
19813 C calculate c.m. energy and check kinematics
19814 PC(1) = PHEP(1,JM1)+PHEP(1,JM2)
19815 PC(2) = PHEP(2,JM1)+PHEP(2,JM2)
19816 PC(3) = PHEP(3,JM1)+PHEP(3,JM2)
19817 PC(4) = PHEP(4,JM1)+PHEP(4,JM2)
19818 SS = (PC(4)+PC(3))*(PC(4)-PC(3))-PC(1)**2-PC(2)**2
19820 IF(SS.LE.(PMASSP(1)+PMASSP(2)+DEPS)**2) THEN
19821 WRITE(LO,'(/,1X,2A)') 'PHO_STDPAR: ',
19822 & 'energy smaller than two-particle threshold (event rejected)'
19829 IF(IDEB(23).GE.5) THEN
19830 WRITE(LO,'(1X,2A,2I7,E12.4)') 'PHO_STDPAR: ',
19831 & 'particles, available energy:',IDHEP(JM1),IDHEP(JM2),ECMP
19832 IF(IDEB(23).GE.25) CALL PHO_PREVNT(0)
19835 C Lorentz transformation into c.m. system
19837 GAMBEP(I) = PC(I)/ECMP
19839 CALL PHO_ALTRA(GAMBEP(4),-GAMBEP(1),-GAMBEP(2),-GAMBEP(3),
19840 & PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
19841 & PHEP(4,JM1),PTOT1,PC(1),PC(2),PC(3),PC(4))
19842 C rotation angle: particle 1 moves along +z
19844 SIDP = SQRT(PC(1)**2+PC(2)**2)/PTOT1
19847 IF(PTOT1*SIDP.GT.1.D-5) THEN
19848 COFP = PC(1)/(SIDP*PTOT1)
19849 SIFP = PC(2)/(SIDP*PTOT1)
19850 ANORF = SQRT(COFP*COFP+SIFP*SIFP)
19855 XM12 = PMASSP(1)**2
19856 XM22 = PMASSP(2)**2
19857 PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*ECMP)
19859 C find particle combination
19861 IF(IDPDG2.EQ.IFPAP(2)) THEN
19862 IF(IDPDG1.EQ.IFPAP(1)) II = 1
19863 ELSE IF(IDPDG2.EQ.990) THEN
19864 IF(IDPDG1.EQ.IFPAP(1)) THEN
19866 ELSE IF(IDPDG1.EQ.IFPAP(2)) THEN
19868 ELSE IF(IDPDG1.EQ.990) THEN
19873 IF(ISWMDL(14).GT.0) THEN
19876 WRITE(LO,'(/1X,2A,2I8)') 'PHO_STDPAR:ERROR: ',
19877 & 'invalid particle combination:',IDPDG1,IDPDG2
19882 C select parton distribution functions from tables
19883 IF((MHPOM+MHDIR).GT.0) THEN
19884 CALL PHO_ACTPDF(IDPDG1,1)
19885 CALL PHO_ACTPDF(IDPDG2,2)
19886 C initialize alpha_s calculation
19887 DUMMY = PHO_ALPHAS(0.D0,-4)
19890 C interpolate hard cross sections and rejection weights
19891 CALL PHO_HARINT(II,ECMP,PVIRTP(1),PVIRTP(2),
19892 & -1,Max_pro_2,1,4,MSPOM+MHPOM+MHDIR)
19896 C position of first particle added to /POEVT2/
19899 C ---------------- direct processes -----------------
19901 IF(MHDIR.EQ.1) THEN
19902 CALL PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
19903 IF(IREJ.EQ.50) RETURN
19904 IF(IREJ.NE.0) GOTO 150
19905 C write comments to /POEVT1/
19906 CALL PHO_REGPAR(25,II,NPROHD(1),IDPDG1,IDPDG2,X0HD(1,1),
19907 & X0HD(1,2),PTHD(1),VHD(1),N0INHD(1,1),N0INHD(1,2),
19908 & IPHO_CNV1(NOUTHD(1,1)),IPHO_CNV1(NOUTHD(1,2)),IPOS,1)
19909 CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,1)),IPDF1,JM1,JM2,
19910 & PPH(1,1),PPH(2,1),PPH(3,1),Q2SCA(1,1),100,NBRAHD(1,1),
19911 & ICA1,ICA2,IPOS,1)
19912 CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,2)),IPDF2,JM2,JM1,
19913 & PPH(1,2),PPH(2,2),PPH(3,2),Q2SCA(1,2),100,NBRAHD(1,2),
19914 & ICA1,ICA2,IPOS,1)
19915 CALL PHO_REGPAR(21,NOUTHD(1,1),IPDF1,JM1,JM2,PPH(5,1),
19916 & PPH(6,1),PPH(7,1),PPH(8,1),100,NBRAHD(1,1),ICA1,ICA2,
19918 CALL PHO_REGPAR(21,NOUTHD(1,2),IPDF2,JM2,JM1,PPH(5,2),
19919 & PPH(6,2),PPH(7,2),PPH(8,2),100,NBRAHD(1,2),ICA1,ICA2,
19922 C soft spectator partons
19930 C single resolved: QCD compton scattering
19931 C ------------------------------
19932 IF(NPROHD(1).EQ.10) THEN
19933 C register hadron remnant
19934 CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
19935 IPDF2 = 1000*IGRP(2)+ISET(2)
19936 ELSE IF(NPROHD(1).EQ.12) THEN
19937 C register hadron remnant
19938 CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
19939 IPDF1 = 1000*IGRP(1)+ISET(1)
19941 C single resolved: photon gluon fusion
19942 C ---------------------------
19943 ELSE IF(NPROHD(1).EQ.11) THEN
19944 C register hadron remnant
19945 CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
19946 IPDF2 = 1000*IGRP(2)+ISET(2)
19947 ELSE IF(NPROHD(1).EQ.13) THEN
19948 C register hadron remnant
19949 CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
19950 IPDF1 = 1000*IGRP(1)+ISET(1)
19952 C direct process (no remnant)
19953 C ----------------------------
19954 ELSE IF(NPROHD(1).EQ.14) THEN
19958 C write final high-pt partons to POEVT1
19959 IF((ISWMDL(8).GE.2).AND.(NPROHD(1).NE.14)) THEN
19965 IFLA(1) = NINHD(I,1)
19966 IFLA(2) = NINHD(I,2)
19967 C initial state radiation
19969 DO 135 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
19972 IFLB = IFLISR(K,IPA)
19973 IF(ABS(IFLB).LE.6) THEN
19975 IF(ICI(K,1)*ICI(K,2).NE.0) THEN
19977 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19978 & ICI(K,1),ICI(K,2),3)
19979 ELSE IF(IFLB.GT.0) THEN
19980 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19981 & ICI(K,1),ICI(K,2),4)
19983 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
19987 IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
19988 IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
19989 CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
19995 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
19998 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19999 & ICI(K,1),ICI(K,2),2)
20002 IIFL = IPHO_CNV1(IFLB)
20004 IFLA(K) = IFLA(K)-IFLB
20013 CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
20014 & PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),I*100+K,
20015 & IGEN,IC1,IC2,IPOS,1)
20018 ICOLOR(1,IPOS1-2) = ICI(1,1)
20019 ICOLOR(2,IPOS1-2) = ICI(1,2)
20020 ICOLOR(1,IPOS1-1) = ICI(2,1)
20021 ICOLOR(2,IPOS1-1) = ICI(2,2)
20022 CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
20023 & IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
20024 & NOUTHD(I,2),ICI(2,1),ICI(2,2))
20025 ICOLOR(1,IPOS1) = ICI(1,1)
20026 ICOLOR(2,IPOS1) = ICI(1,2)
20027 ICOLOR(1,IPOS2) = ICI(2,1)
20028 ICOLOR(2,IPOS2) = ICI(2,2)
20030 IPA = IPOISR(K,1,I)
20031 CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
20032 & PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
20033 & PHISR(K,4,IPA),-I*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
20036 ICOLOR(1,IPOS1-2) = ICA1
20037 ICOLOR(2,IPOS1-2) = ICA2
20038 ICOLOR(1,IPOS1-1) = ICB1
20039 ICOLOR(2,IPOS1-1) = ICB2
20040 CALL PHO_HARCOL(NPROHD(1),VHD(1),NINHD(1,1),ICA1,ICA2,
20041 & NINHD(1,2),ICB1,ICB2,NOUTHD(1,1),ICA1,ICA2,
20042 & NOUTHD(1,2),ICB1,ICB2)
20043 ICOLOR(1,IPOS1) = ICA1
20044 ICOLOR(2,IPOS1) = ICA2
20045 ICOLOR(1,IPOS2) = ICB1
20046 ICOLOR(2,IPOS2) = ICB2
20048 IF(ABS(NOUTHD(1,1)).GT.12) I = 1
20049 CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,1)),0,JM1,JM2,PPH(5,1),
20050 & PPH(6,1),PPH(7,1),PPH(8,1),-100,IGEN,ICA1,ICA2,IPOS,1)
20051 CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,2)),0,JM1,JM2,PPH(5,2),
20052 & PPH(6,2),PPH(7,2),PPH(8,2),-100,IGEN,ICB1,ICB2,IPOS,1)
20055 C assign soft pt to spectators
20056 IF(ISWMDL(18).EQ.0) THEN
20058 CALL PHO_PARTPT(0,NLOR1,IPOS2,PTCUT(II),IREJ)
20060 IFAIL(26) = IFAIL(26) + 1
20066 C ----------------- resolved processes -------------------
20068 C single Reggeon exchange
20069 C ----------------------------
20070 ELSE IF((MSREG.EQ.1).AND.(MHPOM+MSPOM.EQ.0)) THEN
20072 CALL PHO_REGFLA(JM1,JM2,IFL1,IFL2,IREJ)
20074 IFAIL(24) = IFAIL(24)+1
20079 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
20080 IF(((ABS(IFL1).GT.6).AND.(IFL1.GT.0))
20081 & .OR.((ABS(IFL1).LE.6).AND.(IFL1.LT.0))) THEN
20082 CALL PHO_SWAPI(ICA1,ICB1)
20088 C DPMJET call with special projectile / target
20089 **sr leading tab removed
20090 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
20092 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH*XPSUB,
20093 & ECMH*XPSUB,-1,IGEN,ICA1,0,IPOS1,1)
20094 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH*XTSUB,
20095 & ECMH*XTSUB,-1,IGEN,ICB1,0,IPOS2,1)
20096 C default treatment
20098 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH,ECMH,
20099 & -1,IGEN,ICA1,0,IPOS1,1)
20100 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH,ECMH,
20101 & -1,IGEN,ICB1,0,IPOS2,1)
20104 C soft pt assignment
20105 IF(ISWMDL(18).EQ.0) THEN
20106 CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
20108 IFAIL(25) = IFAIL(25) + 1
20113 C multi Reggeon / Pomeron exchange
20114 C----------------------------------------
20116 C parton configuration
20118 CALL PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,MSPAR1,MSPAR2,
20119 & MHPAR1,MHPAR2,IREJ)
20121 IF(IREJ.EQ.50) RETURN
20122 IF(IREJ.NE.0) GOTO 150
20124 C register particles
20125 IF(IDEB(23).GE.15) WRITE(LO,'(1X,A,/15X,7I5)')
20126 & 'PHO_STDPAR: MSPOM,MHPOM,MSREG,MSPAR1/2,IVAL1/2',
20127 & MSPOM,MHPOM,MSREG,MSPAR1,MSPAR2,IVAL1,IVAL2
20129 C register soft partons
20130 IF(IVAL1.NE.0) THEN
20131 IF(IVAL1.LT.0) THEN
20137 ELSE IF(MSPOM.EQ.0) THEN
20142 IF(IVAL2.NE.0) THEN
20143 IF(IVAL2.LT.0) THEN
20149 ELSE IF(MSPOM.EQ.0) THEN
20155 IF(IDEB(23).GE.20) WRITE(LO,'(1X,A,2I3,2X,2I3)')
20156 & 'PHO_STDPAR: IND1/2,IVAL1/2',IND1,IND2,IVAL1,IVAL2
20158 C soft Pomeron final states
20159 C -----------------------------------
20160 K = MSPOM+MHPOM+MSREG
20163 CALL PHO_POSPOM(II,IND1,IND2,IGEN,I,K,ISWAP,IREJ)
20165 IFAIL(8) = IFAIL(8) + 1
20171 C soft Reggeon final states
20172 C -----------------------------------------
20175 CMASS1 = MIN(PSOFT1(4,IND1),PSOFT2(4,IND2))
20176 IF(DT_RNDM(CMASS1).LT.0.5D0) THEN
20177 CALL PHO_SEAFLA(JM1,IFLA1,IFLB1,CMASS1)
20179 CALL PHO_SEAFLA(JM2,IFLA1,IFLB1,CMASS1)
20183 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
20184 IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
20185 & .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
20186 & CALL PHO_SWAPI(ICA1,ICB1)
20188 CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
20189 & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),
20190 & I,IGEN,ICA1,ICA2,IPOS1,1)
20192 CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
20193 & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),
20194 & I,IGEN,ICB1,ICB2,IPOS2,1)
20197 IF(IDEB(23).GE.20) WRITE(LO,'(1X,A,/15X,6I4)')
20198 & 'PHO_STDPAR: reg.cut: IND1,IND2,IFLA,IFLB,IPOS1,IPOS2',
20199 & IND1-1,IND2-1,IFLA1,IFLB1,IPOS1,IPOS2
20201 C soft pt assignment
20202 IF(ISWMDL(18).EQ.0) THEN
20203 CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
20205 IFAIL(25) = IFAIL(25) + 1
20212 C hard Pomeron final states
20213 C ------------------------------------
20220 IFLI1 = IPHO_CNV1(N0INHD(I,1))
20221 IFLI2 = IPHO_CNV1(N0INHD(I,2))
20222 IFLO1 = IPHO_CNV1(NOUTHD(I,1))
20223 IFLO2 = IPHO_CNV1(NOUTHD(I,2))
20225 C write comments to /POEVT1/
20226 CALL PHO_REGPAR(25,II,NPROHD(I),IDPDG1,IDPDG2,X0HD(I,1),
20227 & X0HD(I,2),PTHD(I),VHD(I),N0INHD(I,1),N0INHD(I,2),
20228 & IFLO1,IFLO2,IPOS,1)
20230 IPDF = 1000*IGRP(1)+ISET(1)
20231 CALL PHO_REGPAR(20,IFLI1,IPDF,JM1,JM2,PPH(I1,1),
20232 & PPH(I1+1,1),PPH(I1+2,1),Q2SCA(I,1),L*100,NBRAHD(I,1),
20233 & ICA1,ICA2,IPOS,1)
20234 IPDF = 1000*IGRP(2)+ISET(2)
20235 CALL PHO_REGPAR(20,IFLI2,IPDF,JM2,JM1,PPH(I1,2),
20236 & PPH(I1+1,2),PPH(I1+2,2),Q2SCA(I,2),L*100,NBRAHD(I,2),
20237 & ICB1,ICB2,IPOS,1)
20239 IPDF = 1000*IGRP(1)+ISET(1)
20240 CALL PHO_REGPAR(21,IFLO1,IPDF,JM1,JM2,PPH(I1,1),
20241 & PPH(I1+1,1),PPH(I1+2,1),PPH(I,1),L*100,NBRAHD(I,1),
20242 & ICA1,ICA2,IPOS1,1)
20243 IPDF = 1000*IGRP(2)+ISET(2)
20244 CALL PHO_REGPAR(21,IFLO2,IPDF,JM2,JM1,PPH(I1,2),
20245 & PPH(I1+1,2),PPH(I1+2,2),PPH(I,2),L*100,NBRAHD(I,2),
20246 & ICB1,ICB2,IPOS2,1)
20248 C spectator partons belonging to hard interaction
20249 IF(IVAL1.EQ.I) THEN
20252 ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL1.EQ.0)) THEN
20259 CALL PHO_HARREM(JM1,JM2,IGEN,L,IVQ,IND,ICA1,ICA2,IUSED,IREJ)
20260 IF(IVQ.LT.0) IND1 = IND1-IUSED
20261 IF(IVAL2.EQ.I) THEN
20264 ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL2.EQ.0)) THEN
20271 CALL PHO_HARREM(JM2,JM1,IGEN,-L,IVQ,IND,ICB1,ICB2,IUSED,IREJ)
20272 IF(IVQ.LT.0) IND2 = IND2-IUSED
20274 C register hard scattered partons
20275 IF((ISWMDL(8).GE.2)
20276 & .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
20281 IFLA(1) = NINHD(I,1)
20282 IFLA(2) = NINHD(I,2)
20283 C initial state radiation
20285 DO 235 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
20288 IFLB = IFLISR(K,IPA)
20289 IF(ABS(IFLB).LE.6) THEN
20291 IF(ICI(K,1)*ICI(K,2).NE.0) THEN
20293 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20294 & ICI(K,1),ICI(K,2),3)
20295 ELSE IF(IFLB.GT.0) THEN
20296 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20297 & ICI(K,1),ICI(K,2),4)
20299 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
20300 & ICI(K,2),IC1,IC2,4)
20303 IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
20304 IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
20305 CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
20311 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
20312 & ICI(K,2),IC1,IC2,2)
20314 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20315 & ICI(K,1),ICI(K,2),2)
20318 IIFL = IPHO_CNV1(IFLB)
20320 IFLA(K) = IFLA(K)-IFLB
20329 CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
20330 & PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),
20331 & L*100+K,IGEN,IC1,IC2,IPOS,1)
20334 ICOLOR(1,IPOS1-2) = ICI(1,1)
20335 ICOLOR(2,IPOS1-2) = ICI(1,2)
20336 ICOLOR(1,IPOS1-1) = ICI(2,1)
20337 ICOLOR(2,IPOS1-1) = ICI(2,2)
20338 CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
20339 & IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
20340 & NOUTHD(I,2),ICI(2,1),ICI(2,2))
20341 ICOLOR(1,IPOS1) = ICI(1,1)
20342 ICOLOR(2,IPOS1) = ICI(1,2)
20343 ICOLOR(1,IPOS2) = ICI(2,1)
20344 ICOLOR(2,IPOS2) = ICI(2,2)
20346 IPA = IPOISR(K,1,I)
20347 CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
20348 & PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
20349 & PHISR(K,4,IPA),-L*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
20352 ICOLOR(1,IPOS1-2) = ICA1
20353 ICOLOR(2,IPOS1-2) = ICA2
20354 ICOLOR(1,IPOS1-1) = ICB1
20355 ICOLOR(2,IPOS1-1) = ICB2
20356 CALL PHO_HARCOL(NPROHD(I),VHD(I),NINHD(I,1),ICA1,ICA2,
20357 & NINHD(I,2),ICB1,ICB2,NOUTHD(I,1),ICA1,ICA2,
20358 & NOUTHD(I,2),ICB1,ICB2)
20359 ICOLOR(1,IPOS1) = ICA1
20360 ICOLOR(2,IPOS1) = ICA2
20361 ICOLOR(1,IPOS2) = ICB1
20362 ICOLOR(2,IPOS2) = ICB2
20364 CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,1)),0,JM1,JM2,
20365 & PPH(I1,1),PPH(I1+1,1),PPH(I1+2,1),PPH(I1+3,1),-L*100,IGEN,
20366 & ICA1,ICA2,IPOS,1)
20367 CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,2)),0,JM1,JM2,
20368 & PPH(I1,2),PPH(I1+1,2),PPH(I1+2,2),PPH(I1+3,2),-L*100,IGEN,
20369 & ICB1,ICB2,IPOS,1)
20372 C end of resolved parton registration
20375 IF(MHDIR+MHPOM.GT.0) THEN
20377 IF(ISWMDL(29).GE.1) THEN
20378 C primordial kt of hard scattering
20379 CALL PHO_PRIMKT(1,NLOR1,NHEP,PTCUT(II),IREJ)
20381 IFAIL(27) = IFAIL(27)+1
20384 ELSE IF(ISWMDL(24).GE.0) THEN
20385 C give "soft" pt only to soft (spectator) partons in hard processes
20386 CALL PHO_PARTPT(1,NLOR1,NHEP,PTCUT(II),IREJ)
20388 IFAIL(26) = IFAIL(26)+1
20395 C give "soft" pt to partons in soft Pomerons
20396 IF((MHDIR.EQ.0).AND.(ISWMDL(18).EQ.1)) THEN
20397 CALL PHO_PARTPT(0,NLOR1,NHEP,PTCUT(II),IREJ)
20399 IFAIL(25) = IFAIL(25) + 1
20404 C boost back to lab frame
20405 CALL PHO_LTRHEP(NLOR1,NHEP,CODP,SIDP,COFP,SIFP,GAMBEP(4),
20406 & GAMBEP(1),GAMBEP(2),GAMBEP(3))
20409 C rejection treatment
20411 IFAIL(2) = IFAIL(2)+1
20417 C reset mother-daugther relations
20428 IF(IDEB(23).GT.2) WRITE(LO,'(/1X,A,4I6)')
20429 & 'PHO_STDPAR: rejection (MSPOM,MHPOM,MSREG,MHDIR)',
20430 & MSPOM,MHPOM,MSREG,MHDIR
20435 *$ CREATE PHO_HARCOL.FOR
20437 CDECK ID>, PHO_HARCOL
20438 SUBROUTINE PHO_HARCOL(MSPR,V,IP1,ICA1,ICA2,IP2,ICB1,ICB2,
20439 & IP3,ICC1,ICC2,IP4,ICD1,ICD2)
20440 C*********************************************************************
20442 C calculate color flow for hard resolved process
20444 C input: IP1..4 flavour of partons (PDG convention)
20445 C V parton subprocess Mandelstam variable V = t/s
20446 C (lightcone momenta assumed)
20447 C ICA,ICB color labels
20448 C MSPR process number
20449 C -1 initialization of statistics
20450 C -2 output of statistics
20452 C output: ICC,ICD color label of final partons
20454 C (it is possible to use the same variables for in and output)
20456 C**********************************************************************
20457 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20460 C input/output channels
20462 COMMON /POINOU/ LI,LO
20463 C event debugging information
20465 PARAMETER (NMAXD=100)
20466 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
20467 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20468 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
20469 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20470 C model switches and parameters
20472 INTEGER ISWMDL,IPAMDL
20473 DOUBLE PRECISION PARMDL
20474 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
20475 C names of hard scattering processes
20477 PARAMETER ( Max_pro_1 = 16 )
20479 COMMON /POHPRO/ PROC(0:Max_pro_1)
20481 DIMENSION PC(3),ICONF(8,5),IRECN(8,2)
20484 IF(MSPR.EQ.-1) THEN
20493 C output of statistics
20494 ELSE IF(MSPR.EQ.-2) THEN
20495 IF(IDEB(26).LT.1) RETURN
20496 WRITE(LO,'(/1X,A,/1X,A)')
20497 & 'PHO_HARCOL: sampled color configurations',
20498 & '----------------------------------------'
20499 WRITE(LO,'(6X,A,15X,A)')
20500 & 'diagram color configurations (1-4)','sum'
20503 ICONF(I,5) = ICONF(I,5) + ICONF(I,K)
20505 WRITE(LO,'(2X,A,4I11,I12)') PROC(I),(ICONF(I,K),K=1,5)
20507 IF(ISWMDL(11).GE.2) THEN
20508 WRITE(LO,'(/6X,A)')
20509 & 'diagram with / without color re-connection'
20511 WRITE(LO,'(2X,A,2I11)') PROC(I),IRECN(I,1),IRECN(I,2)
20517 C gluons: first color positive, quarks second color zero
20540 & WRITE(LO,'(1X,A,I4,/,5X,A,3I5,2X,3I5)')
20541 & 'PHO_HARCOL: process',MSPR,
20542 & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
20545 IF(IPAMDL(21).EQ.1) THEN
20547 C soft color re-connection option
20550 C hard g g final state, only g g --> g g
20551 IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
20552 IF(DT_RNDM(V).LT.PARMDL(140)) THEN
20557 IRECN(MSPR,1) = IRECN(MSPR,1)+1
20562 ELSE IF(MSPR.EQ.3) THEN
20563 C hard q g final state
20564 IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
20565 IF(DT_RNDM(V).LT.PARMDL(141)) THEN
20570 IRECN(MSPR,1) = IRECN(MSPR,1)+1
20575 ELSE IF((MSPR.EQ.5).OR.(MSPR.EQ.7).OR.(MSPR.EQ.8)) THEN
20576 C hard q q final state
20577 IF(ICA1.NE.-ICB1) THEN
20578 IF(DT_RNDM(V).LT.PARMDL(142)) THEN
20583 IRECN(MSPR,1) = IRECN(MSPR,1)+1
20589 IRECN(MSPR,2) = IRECN(MSPR,2)+1
20592 IF((ISWMDL(11).EQ.1).AND.(MSPR.LT.10)) THEN
20594 C large Nc limit of all graphs
20598 IF(DT_RNDM(V).GT.0.5D0) THEN
20603 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20609 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20611 ELSE IF(MSPR.EQ.2) THEN
20613 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20619 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20625 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20627 ELSE IF(MSPR.EQ.3) THEN
20629 IF(DT_RNDM(V).LT.0.5D0) THEN
20630 IF(IP1+IP2.GT.0) THEN
20635 ELSE IF(IP1.LT.0) THEN
20644 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20647 CALL PHO_HARCOR(-ICA1,ICB2)
20651 ELSE IF(IP2.GT.0) THEN
20652 CALL PHO_HARCOR(-ICB1,ICA2)
20656 ELSE IF(IP1.LT.0) THEN
20657 CALL PHO_HARCOR(-ICA1,ICB1)
20661 ELSE IF(IP2.LT.0) THEN
20662 CALL PHO_HARCOR(-ICB1,ICA1)
20667 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20669 ELSE IF(MSPR.EQ.4) THEN
20673 CALL PHO_HARCOR(-ICB1,ICA2)
20674 IF(ICB2.EQ.-ICB1) IC3 = ICA2
20675 IF(IP3*IC1.LT.0) THEN
20680 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20681 ELSE IF(MSPR.EQ.5) THEN
20683 IF(DT_RNDM(V).LT.0.5D0) THEN
20684 IF(ICA1*IP3.LT.0) THEN
20691 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20693 IF(ICA1*IP3.LT.0) THEN
20700 CALL PHO_HARCOR(-ICA1,ICB1)
20701 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20703 ELSE IF(MSPR.EQ.6) THEN
20705 IF(ICA1*IP3.LT.0) THEN
20708 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20712 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20714 ELSE IF(MSPR.EQ.7) THEN
20716 IF(DT_RNDM(V).LT.0.5D0) THEN
20719 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20723 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20725 ELSE IF(MSPR.EQ.8) THEN
20727 IF(IP1*IP2.GT.0) THEN
20728 IF(IP3.EQ.IP1) THEN
20735 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20737 IF(ICA1*IP3.LT.0) THEN
20744 CALL PHO_HARCOR(-ICA1,ICB1)
20745 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20749 WRITE(LO,'(/1X,A,I3)')
20750 & 'PHO_HARCOL:ERROR:invalid process number (MSPR)',MSPR
20756 C color flow according to QCD leading order matrix element
20761 PC(1) = 1/V**2 +2.D0/V +3.D0 +2.D0*V +V**2
20762 PC(2) = 1/U**2 +2.D0/U +3.D0 +2.D0*U +U**2
20763 PC(3) = (V/U)**2+2.D0*(V/U)+3.D0 +2.D0*(U/V)+(U/V)**2
20764 XI = (PC(1)+PC(2)+PC(3))*DT_RNDM(U)
20768 IF(XI.LT.PCS) GOTO 120
20772 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20773 IF(DT_RNDM(V).GT.0.5D0) THEN
20778 CALL PHO_HARCOR(-ICB2,ICA1)
20779 IF(ICB1.EQ.-ICB2) IC3 = ICA1
20785 CALL PHO_HARCOR(-ICB1,ICA2)
20786 IF(ICB2.EQ.-ICB1) IC4 = ICA2
20788 ELSE IF(I.EQ.2) THEN
20789 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20790 IF(DT_RNDM(U).GT.0.5D0) THEN
20795 CALL PHO_HARCOR(-ICB2,ICA1)
20796 IF(ICB1.EQ.-ICB2) IC1 = ICA1
20802 CALL PHO_HARCOR(-ICB1,ICA2)
20803 IF(ICB2.EQ.-ICB1) IC2 = ICA2
20806 IF(DT_RNDM(V).GT.0.5D0) THEN
20818 ICONF(MSPR,I) = ICONF(MSPR,I)+1
20819 ELSE IF(MSPR.EQ.2) THEN
20821 PC(1) = U/V-2.D0*U**2
20822 PC(2) = V/U-2.D0*V**2
20823 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20824 XI = (PC(1)+PC(2))*DT_RNDM(U)
20825 IF(XI.LT.PC(1)) THEN
20831 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20837 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20845 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20851 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20854 ELSE IF(MSPR.EQ.3) THEN
20856 PC(1) = 2.D0*(U/V)**2-U
20857 PC(2) = 2.D0/V**2-1.D0/U
20858 XI = (PC(1)+PC(2))*DT_RNDM(V)
20859 IF(XI.LT.PC(1)) THEN
20860 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20865 CALL PHO_HARCOR(-ICA1,ICB2)
20866 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20867 ELSE IF(IP1.LT.0) THEN
20871 CALL PHO_HARCOR(-ICA1,ICB1)
20872 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20873 ELSE IF(IP2.GT.0) THEN
20877 CALL PHO_HARCOR(-ICB1,ICA2)
20878 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20883 CALL PHO_HARCOR(-ICB1,ICA1)
20884 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20891 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20892 ELSE IF(IP1.LT.0) THEN
20896 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20897 ELSE IF(IP2.GT.0) THEN
20901 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20906 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20909 ELSE IF(MSPR.EQ.4) THEN
20911 PC(1) = U/V-2.D0*U**2
20912 PC(2) = V/U-2.D0*V**2
20913 XI = (PC(1)+PC(2))*DT_RNDM(U)
20914 IF(XI.LT.PC(1)) THEN
20918 CALL PHO_HARCOR(-ICB1,ICA2)
20919 IF(ICB2.EQ.-ICB1) IC3 = ICA2
20920 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20924 CALL PHO_HARCOR(-ICB2,ICA1)
20925 IF(ICB1.EQ.-ICB2) IC3 = ICA1
20926 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20932 CALL PHO_HARCOR(-ICB2,ICA1)
20933 IF(ICB1.EQ.-ICB2) IC1 = ICA1
20934 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20938 CALL PHO_HARCOR(-ICB1,ICA2)
20939 IF(ICB2.EQ.-ICB1) IC1 = ICA2
20940 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20943 ELSE IF(MSPR.EQ.5) THEN
20945 PC(1) = (1.D0+U**2)/V**2
20946 PC(2) = (V**2+U**2)
20947 XI = (PC(1)+PC(2))*DT_RNDM(V)
20948 IF(XI.LT.PC(1)) THEN
20949 CALL PHO_HARCOR(-ICB1,ICA1)
20950 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20954 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20958 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20962 IC1 = MAX(ICA1,ICB1)
20963 IC3 = MIN(ICA1,ICB1)
20964 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20966 IC1 = MIN(ICA1,ICB1)
20967 IC3 = MAX(ICA1,ICB1)
20968 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20971 ELSE IF(MSPR.EQ.6) THEN
20974 IC1 = MAX(ICA1,ICB1)
20975 IC3 = MIN(ICA1,ICB1)
20976 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20978 IC1 = MIN(ICA1,ICB1)
20979 IC3 = MAX(ICA1,ICB1)
20980 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20982 ELSE IF(MSPR.EQ.7) THEN
20984 PC(1) = (1.D0+U**2)/V**2
20985 PC(2) = (1.D0+V**2)/U**2
20986 XI = (PC(1)+PC(2))*DT_RNDM(U)
20987 IF(XI.LT.PC(1)) THEN
20990 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20994 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20996 ELSE IF(MSPR.EQ.8) THEN
20998 IF(IP1*IP2.LT.0) THEN
20999 CALL PHO_HARCOR(-ICB1,ICA1)
21000 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
21004 ICONF(MSPR,1) = ICONF(MSPR,1)+1
21008 ICONF(MSPR,2) = ICONF(MSPR,2)+1
21013 ICONF(MSPR,3) = ICONF(MSPR,3)+1
21016 ELSE IF(MSPR.EQ.10) THEN
21018 CALL PHO_SELCOL(ICB1,ICB2,IC1,IC2,IC3,IC4,2)
21020 CALL PHO_SWAPI(IC1,IC3)
21021 CALL PHO_SWAPI(IC2,IC4)
21023 ELSE IF(MSPR.EQ.11) THEN
21027 IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
21028 ELSE IF(MSPR.EQ.12) THEN
21030 CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,2)
21032 CALL PHO_SWAPI(IC1,IC3)
21033 CALL PHO_SWAPI(IC2,IC4)
21035 ELSE IF(MSPR.EQ.13) THEN
21039 IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
21040 ELSE IF(MSPR.EQ.14) THEN
21041 IF(ABS(IP3).GT.12) THEN
21045 CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,1)
21046 IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
21050 WRITE(LO,'(/1X,A,I3)')
21051 & 'PHO_HARCOL:ERROR:invalid process number',MSPR
21058 IF(IDEB(26).GE.10) WRITE(LO,'(5X,A,3I5,2X,3I5)')
21059 & 'final partons and colors',IP3,IC1,IC2,IP4,IC3,IC4
21060 C color connection?
21061 * IF(((IC1.NE.-IC3).AND.(IC1.NE.-IC4)).AND.
21062 * & (((IC2.NE.0).AND.(IC2.NE.-IC3).AND.(IC2.NE.-IC4))
21063 * & .OR.(IC2.EQ.0))) THEN
21065 * IF(((IP1.EQ.IP3).AND.(ICA1.EQ.IC1).AND.(ICA2.EQ.IC2))
21066 * & .OR.((IP1.EQ.IP4).AND.(ICA1.EQ.IC3).AND.(ICA2.EQ.IC4))) THEN
21067 * IF(IRC.NE.1) THEN
21068 * WRITE(LO,'(1X,A,I10,I3)')
21069 * & 'PHO_HARCOL:unexp. re-connection (event/MSPR):',KEVENT,MSPR
21070 * WRITE(LO,'(5X,A,3I5,2X,3I5)')
21071 * & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
21072 * WRITE(LO,'(5X,A,3I5,2X,3I5)')
21073 * & 'final partons and colors ',IP3,IC1,IC2,IP4,IC3,IC4
21078 * IF(IRC.EQ.1) THEN
21079 * WRITE(LO,'(1X,A,I10,I3)')
21080 * & 'PHO_HARCOL:re-conn. failed (event/MSPR):',KEVENT,MSPR
21081 * WRITE(LO,'(5X,A,3I5,2X,3I5)')
21082 * & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
21083 * WRITE(LO,'(5X,A,3I5,2X,3I5)')
21084 * & 'final partons and colors ',IP3,IC1,IC2,IP4,IC3,IC4
21094 *$ CREATE PHO_HARCOR.FOR
21096 CDECK ID>, PHO_HARCOR
21097 SUBROUTINE PHO_HARCOR(ICOLD,ICNEW)
21098 C***********************************************************************
21100 C substituite color in /POEVT2/
21102 C input: ICOLD old color
21105 C***********************************************************************
21106 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21109 C input/output channels
21111 COMMON /POINOU/ LI,LO
21113 C standard particle data interface
21116 PARAMETER (NMXHEP=4000)
21118 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
21119 DOUBLE PRECISION PHEP,VHEP
21120 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
21121 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
21123 C extension to standard particle data interface (PHOJET specific)
21124 INTEGER IMPART,IPHIST,ICOLOR
21125 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
21128 IF(ISTHEP(I).EQ.-1) THEN
21129 IF(ICOLOR(1,I).EQ.ICOLD) THEN
21130 ICOLOR(1,I) = ICNEW
21132 ELSE IF(IDHEP(I).EQ.21) THEN
21133 IF(ICOLOR(2,I).EQ.ICOLD) THEN
21134 ICOLOR(2,I) = ICNEW
21138 * ELSE IF(ISTHEP(I).EQ.20) THEN
21139 * IF(ICOLOR(1,I).EQ.-ICOLD) THEN
21140 * write(LO,*) ' PHO_HARCOR(3): line, old, new:',I,ICOLD,ICNEW
21141 * ICOLOR(1,I) = -ICNEW
21143 * ELSE IF(IDHEP(I).EQ.21) THEN
21144 * IF(ICOLOR(2,I).EQ.-ICOLD) THEN
21145 * write(LO,*) ' PHO_HARCOR(4): line, old, new:',I,ICOLD,ICNEW
21146 * ICOLOR(2,I) = -ICNEW
21154 *$ CREATE PHO_HARREM.FOR
21156 CDECK ID>, PHO_HARREM
21157 SUBROUTINE PHO_HARREM(JM1,JM2,IGEN,IHPOS,IVAL,INDXS,IC1,IC2,
21159 C***********************************************************************
21161 C sample color structure for initial quark/gluon of hard scattering
21162 C and write hadron remnant to /POEVT1/
21164 C input: JM1,2 index of mother particle in POEVT1
21165 C IGEN mother particle production process
21166 C IHPOS hard pomeron number
21167 C INDXH index of hard parton
21168 C positive for labels 1
21169 C negative for labels 2
21170 C IVAL 1 hard valence parton
21171 C 0 hard sea parton connected by color flow with
21173 C -1 hard sea parton independent off valence
21175 C INDXS index of soft partons needed
21177 C output: IC1,IC2 color label of initial parton
21178 C IUSED number of soft X values used
21179 C IREJ rejection flag
21181 C**********************************************************************
21182 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21185 PARAMETER ( TINY = 1.D-10 )
21187 C input/output channels
21189 COMMON /POINOU/ LI,LO
21190 C event debugging information
21192 PARAMETER (NMAXD=100)
21193 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
21194 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21195 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
21196 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21197 C model switches and parameters
21199 INTEGER ISWMDL,IPAMDL
21200 DOUBLE PRECISION PARMDL
21201 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21202 C data of c.m. system of Pomeron / Reggeon exchange
21203 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
21204 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
21205 & SIDP,CODP,SIFP,COFP
21206 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
21207 & SIDP,CODP,SIFP,COFP,NPOSP(2),
21208 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
21209 C obsolete cut-off information
21210 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
21211 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
21212 C light-cone x fractions and c.m. momenta of soft cut string ends
21214 PARAMETER ( MAXSOF = 50 )
21215 INTEGER IJSI2,IJSI1
21216 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
21217 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
21218 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
21219 & IJSI1(MAXSOF),IJSI2(MAXSOF)
21220 C hard scattering data
21222 PARAMETER ( MSCAHD = 50 )
21223 INTEGER LSCAHD,LSC1HD,LSIDX,
21224 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
21225 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
21226 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
21227 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
21228 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
21229 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
21230 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
21231 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
21232 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
21234 C standard particle data interface
21237 PARAMETER (NMXHEP=4000)
21239 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
21240 DOUBLE PRECISION PHEP,VHEP
21241 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
21242 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
21244 C extension to standard particle data interface (PHOJET specific)
21245 INTEGER IMPART,IPHIST,ICOLOR
21246 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
21248 C internal rejection counters
21250 PARAMETER (NMXJ=60)
21251 CHARACTER*10 REJTIT
21253 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
21257 INDXH = SIGN(LSIDX(ABS(IHPOS)),IHPOS)
21259 IF(INDXH.GT.0) THEN
21260 IJH = IPHO_CNV1(NINHD(INDXH,1))
21262 IJH = IPHO_CNV1(NINHD(-INDXH,2))
21264 C direct process (photon or pomeron)
21268 IF((IJH.EQ.22).OR.(IJH.EQ.990)) RETURN
21270 IHP = 100*ABS(IHPOS)
21272 ***************************************
21273 * IF((IDHEP(JM1).EQ.22).OR.(IDHEP(JM1).EQ.990)) IVSW = 0
21274 ***************************************
21276 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,2I3,1X,5I4)')
21277 & 'PHO_HARREM: JM1,JM2,IHPOS,INDXH,IFLH,IVAL,INDXS:',
21278 & JM1,JM2,IHPOS,INDXH,IJH,IVAL,INDXS
21281 C****************************************************************
21285 C valence quark engaged in hard scattering
21287 CALL PHO_PARREM(JM1,IJH,IREM,IREJ)
21289 WRITE(LO,'(/1X,2A,2I6)') 'PHO_HARREM: ',
21290 & 'invalid valence flavour requested JM,IFLA',JM1,IJH
21293 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21294 IF(((ABS(IREM).GT.6).AND.(IREM.GT.0))
21295 & .OR.((ABS(IREM).LE.6).AND.(IREM.LT.0))) THEN
21300 C remnant of hadron
21301 IF(INDXH.GT.0) THEN
21302 P1 = PSOFT1(1,INDXS)
21303 P2 = PSOFT1(2,INDXS)
21304 P3 = PSOFT1(3,INDXS)
21305 P4 = PSOFT1(4,INDXS)
21306 IJSI1(INDXS) = IREM
21308 P1 = PSOFT2(1,INDXS)
21309 P2 = PSOFT2(2,INDXS)
21310 P3 = PSOFT2(3,INDXS)
21311 P4 = PSOFT2(4,INDXS)
21312 IJSI2(INDXS) = IREM
21315 CALL PHO_REGPAR(-1,IREM,0,JM1,JM2,P1,P2,P3,P4,
21316 & IHP,IGEN,ICA1,IVSW,IPOS,1)
21317 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21318 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21319 & IREM,IPOS,SIGN(INDXS,INDXH)
21323 C sea quark engaged in hard scattering, valence quarks treated
21324 ELSE IF(IVAL.EQ.0) THEN
21325 IF(INDXH.GT.0) THEN
21326 E1 = PSOFT1(4,INDXS)
21327 E2 = PSOFT1(4,INDXS+1)
21329 E1 = PSOFT2(4,INDXS)
21330 E2 = PSOFT2(4,INDXS+1)
21332 CALL PHO_VALFLA(JM1,IVFL1,IVFL2,E1,E2)
21333 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21334 IF(DT_RNDM(P1).LT.0.5D0) THEN
21335 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21337 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21339 IF(((ABS(IVFL1).GT.6).AND.(IVFL1.GT.0))
21340 & .OR.((ABS(IVFL1).LE.6).AND.(IVFL1.LT.0))) THEN
21345 IF(INDXH.GT.0) THEN
21346 P1 = PSOFT1(1,INDXS)
21347 P2 = PSOFT1(2,INDXS)
21348 P3 = PSOFT1(3,INDXS)
21349 P4 = PSOFT1(4,INDXS)
21350 IJSI1(INDXS) = IVFL1
21352 P1 = PSOFT2(1,INDXS)
21353 P2 = PSOFT2(2,INDXS)
21354 P3 = PSOFT2(3,INDXS)
21355 P4 = PSOFT2(4,INDXS)
21356 IJSI2(INDXS) = IVFL1
21359 CALL PHO_REGPAR(-1,IVFL1,0,JM1,JM2,P1,P2,P3,P4,
21360 & IHP,IGEN,ICA1,IVSW,IPOS,1)
21361 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21362 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21363 & IVFL1,IPOS,SIGN(INDXS,INDXH)
21366 IF(INDXH.GT.0) THEN
21367 P1 = PSOFT1(1,INDXS+1)
21368 P2 = PSOFT1(2,INDXS+1)
21369 P3 = PSOFT1(3,INDXS+1)
21370 P4 = PSOFT1(4,INDXS+1)
21371 IJSI1(INDXS+1) = IVFL2
21373 P1 = PSOFT2(1,INDXS+1)
21374 P2 = PSOFT2(2,INDXS+1)
21375 P3 = PSOFT2(3,INDXS+1)
21376 P4 = PSOFT2(4,INDXS+1)
21377 IJSI2(INDXS+1) = IVFL2
21380 CALL PHO_REGPAR(-1,IVFL2,0,JM1,JM2,P1,P2,P3,P4,
21381 & IHP,IGEN,ICB1,IVSW,IPOS,1)
21382 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21383 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21384 & IVFL2,IPOS,SIGN(INDXS+1,INDXH)
21394 IF(INDXH.GT.0) THEN
21395 P1 = PSOFT1(1,INDXS+2)
21396 P2 = PSOFT1(2,INDXS+2)
21397 P3 = PSOFT1(3,INDXS+2)
21398 P4 = PSOFT1(4,INDXS+2)
21399 IJSI1(INDXS+2) = -IJH
21401 P1 = PSOFT2(1,INDXS+2)
21402 P2 = PSOFT2(2,INDXS+2)
21403 P3 = PSOFT2(3,INDXS+2)
21404 P4 = PSOFT2(4,INDXS+2)
21405 IJSI2(INDXS+2) = -IJH
21408 CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
21409 & IHP,IGEN,ICA1,0,IPOS,1)
21410 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21411 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21412 & -IJH,IPOS,SIGN(INDXS+2,INDXH)
21415 C sea quark engaged in hard scattering, valences treated separately
21416 ELSE IF(IVAL.EQ.-1) THEN
21417 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21423 IF(INDXH.GT.0) THEN
21424 P1 = PSOFT1(1,INDXS)
21425 P2 = PSOFT1(2,INDXS)
21426 P3 = PSOFT1(3,INDXS)
21427 P4 = PSOFT1(4,INDXS)
21428 IJSI1(INDXS) = -IJH
21430 P1 = PSOFT2(1,INDXS)
21431 P2 = PSOFT2(2,INDXS)
21432 P3 = PSOFT2(3,INDXS)
21433 P4 = PSOFT2(4,INDXS)
21434 IJSI2(INDXS) = -IJH
21437 CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
21438 & IHP,IGEN,ICA1,0,IPOS,1)
21439 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21440 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21441 & -IJH,IPOS,SIGN(INDXS,INDXH)
21445 WRITE(LO,'(1X,A,2I5)')
21446 & 'PHO_HARREM:ERROR:unsupported combination of IVAL,IJH',
21455 C****************************************************************
21457 C gluon from valence quarks
21460 C purely gluonic pomeron remnant
21461 IF((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0)) THEN
21462 IF(INDXH.GT.0) THEN
21463 P1 = PSOFT1(1,INDXS) + PSOFT1(1,INDXS+1)
21464 P2 = PSOFT1(2,INDXS) + PSOFT1(2,INDXS+1)
21465 P3 = PSOFT1(3,INDXS) + PSOFT1(3,INDXS+1)
21466 P4 = PSOFT1(4,INDXS) + PSOFT1(4,INDXS+1)
21469 P1 = PSOFT2(1,INDXS) + PSOFT2(1,INDXS+1)
21470 P2 = PSOFT2(2,INDXS) + PSOFT2(2,INDXS+1)
21471 P3 = PSOFT2(3,INDXS) + PSOFT2(3,INDXS+1)
21472 P4 = PSOFT2(4,INDXS) + PSOFT2(4,INDXS+1)
21476 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21477 IF(DT_RNDM(P2).LT.0.5D0) THEN
21478 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21480 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21483 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21484 & IHP,IGEN,ICA1,ICB1,IPOS,1)
21485 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21486 & 'PHO_HARREM: val.gluon:(IFL,IPOS,INDXS)',
21487 & IFL1,IPOS,SIGN(INDXS,INDXH)
21490 C valence quark remnant
21492 IF(INDXH.GT.0) THEN
21493 E1 = PSOFT1(4,INDXS)
21494 E2 = PSOFT1(4,INDXS+1)
21496 E1 = PSOFT2(4,INDXS)
21497 E2 = PSOFT2(4,INDXS+1)
21499 CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
21500 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21501 IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21502 & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21507 IF(DT_RNDM(P2).LT.0.5D0) THEN
21508 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21510 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21512 C remnant of hadron
21513 IF(INDXH.GT.0) THEN
21514 P1 = PSOFT1(1,INDXS)
21515 P2 = PSOFT1(2,INDXS)
21516 P3 = PSOFT1(3,INDXS)
21517 P4 = PSOFT1(4,INDXS)
21518 IJSI1(INDXS) = IFL1
21520 P1 = PSOFT2(1,INDXS)
21521 P2 = PSOFT2(2,INDXS)
21522 P3 = PSOFT2(3,INDXS)
21523 P4 = PSOFT2(4,INDXS)
21524 IJSI2(INDXS) = IFL1
21527 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21528 & IHP,IGEN,ICA1,IVSW,IPOS,1)
21529 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21530 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21531 & IFL1,IPOS,SIGN(INDXS,INDXH)
21534 IF(INDXH.GT.0) THEN
21535 P1 = PSOFT1(1,INDXS+1)
21536 P2 = PSOFT1(2,INDXS+1)
21537 P3 = PSOFT1(3,INDXS+1)
21538 P4 = PSOFT1(4,INDXS+1)
21539 IJSI1(INDXS+1) = IFL2
21541 P1 = PSOFT2(1,INDXS+1)
21542 P2 = PSOFT2(2,INDXS+1)
21543 P3 = PSOFT2(3,INDXS+1)
21544 P4 = PSOFT2(4,INDXS+1)
21545 IJSI2(INDXS+1) = IFL2
21548 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21549 & IHP,IGEN,ICB1,IVSW,IPOS,1)
21550 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21551 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21552 & IFL2,IPOS,SIGN(INDXS+1,INDXH)
21557 C gluon from sea quarks connected with valence quarks
21558 ELSE IF(IVAL.EQ.0) THEN
21559 IF(INDXH.GT.0) THEN
21560 E1 = PSOFT1(4,INDXS)
21561 E2 = PSOFT1(4,INDXS+1)
21563 E1 = PSOFT2(4,INDXS)
21564 E2 = PSOFT2(4,INDXS+1)
21566 CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
21567 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21568 IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21569 & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21574 IF(DT_RNDM(P3).LT.0.5D0) THEN
21575 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21577 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21579 C remnant of hadron
21580 IF(INDXH.GT.0) THEN
21581 P1 = PSOFT1(1,INDXS)
21582 P2 = PSOFT1(2,INDXS)
21583 P3 = PSOFT1(3,INDXS)
21584 P4 = PSOFT1(4,INDXS)
21585 IJSI1(INDXS) = IFL1
21587 P1 = PSOFT2(1,INDXS)
21588 P2 = PSOFT2(2,INDXS)
21589 P3 = PSOFT2(3,INDXS)
21590 P4 = PSOFT2(4,INDXS)
21591 IJSI2(INDXS) = IFL1
21594 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21595 & IHP,IGEN,ICA1,IVSW,IPOS,1)
21596 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21597 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21598 & IFL1,IPOS,SIGN(INDXS,INDXH)
21601 IF(INDXH.GT.0) THEN
21602 P1 = PSOFT1(1,INDXS+1)
21603 P2 = PSOFT1(2,INDXS+1)
21604 P3 = PSOFT1(3,INDXS+1)
21605 P4 = PSOFT1(4,INDXS+1)
21606 IJSI1(INDXS+1) = IFL2
21608 P1 = PSOFT2(1,INDXS+1)
21609 P2 = PSOFT2(2,INDXS+1)
21610 P3 = PSOFT2(3,INDXS+1)
21611 P4 = PSOFT2(4,INDXS+1)
21612 IJSI2(INDXS+1) = IFL2
21615 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21616 & IHP,IGEN,ICB1,IVSW,IPOS,1)
21617 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21618 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21619 & IFL2,IPOS,SIGN(INDXS+1,INDXH)
21621 IF(IPAMDL(18).EQ.0) THEN
21623 CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
21631 IF(DT_RNDM(P4).LT.0.5D0) THEN
21633 CALL PHO_SELCOL(ICC1,0,ICA1,ICA2,ICC1,ICC2,2)
21636 CALL PHO_SELCOL(ICC2,0,ICB1,ICB2,ICC1,ICC2,2)
21638 IF(INDXH.GT.0) THEN
21639 P1 = PSOFT1(1,INDXS+2)
21640 P2 = PSOFT1(2,INDXS+2)
21641 P3 = PSOFT1(3,INDXS+2)
21642 P4 = PSOFT1(4,INDXS+2)
21643 IJSI1(INDXS+2) = IFL1
21645 P1 = PSOFT2(1,INDXS+2)
21646 P2 = PSOFT2(2,INDXS+2)
21647 P3 = PSOFT2(3,INDXS+2)
21648 P4 = PSOFT2(4,INDXS+2)
21649 IJSI2(INDXS+2) = IFL1
21652 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21653 & IHP,IGEN,ICA1,0,IPOS,1)
21654 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21655 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21656 & IFL1,IPOS,SIGN(INDXS+2,INDXH)
21659 IF(INDXH.GT.0) THEN
21660 P1 = PSOFT1(1,INDXS+3)
21661 P2 = PSOFT1(2,INDXS+3)
21662 P3 = PSOFT1(3,INDXS+3)
21663 P4 = PSOFT1(4,INDXS+3)
21664 IJSI1(INDXS+3) = IFL2
21666 P1 = PSOFT2(1,INDXS+3)
21667 P2 = PSOFT2(2,INDXS+3)
21668 P3 = PSOFT2(3,INDXS+3)
21669 P4 = PSOFT2(4,INDXS+3)
21670 IJSI2(INDXS+3) = IFL2
21673 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21674 & IHP,IGEN,ICB1,0,IPOS,1)
21675 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21676 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21677 & IFL2,IPOS,SIGN(INDXS+3,INDXH)
21684 C gluon from independent sea quarks
21685 ELSE IF(IVAL.EQ.-1) THEN
21686 IF(IPAMDL(18).EQ.0) THEN
21687 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21688 CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
21689 IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21690 & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21695 IF(DT_RNDM(P1).LT.0.5D0) THEN
21696 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21698 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21700 C remainder of hadron
21701 IF(INDXH.GT.0) THEN
21702 P1 = PSOFT1(1,INDXS)
21703 P2 = PSOFT1(2,INDXS)
21704 P3 = PSOFT1(3,INDXS)
21705 P4 = PSOFT1(4,INDXS)
21706 IJSI1(INDXS) = IFL1
21708 P1 = PSOFT2(1,INDXS)
21709 P2 = PSOFT2(2,INDXS)
21710 P3 = PSOFT2(3,INDXS)
21711 P4 = PSOFT2(4,INDXS)
21712 IJSI2(INDXS) = IFL1
21715 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21716 & IHP,IGEN,ICA1,ICA2,IPOS,1)
21717 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21718 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21719 & IFL1,IPOS,SIGN(INDXS,INDXH)
21722 IF(INDXH.GT.0) THEN
21723 P1 = PSOFT1(1,INDXS-1)
21724 P2 = PSOFT1(2,INDXS-1)
21725 P3 = PSOFT1(3,INDXS-1)
21726 P4 = PSOFT1(4,INDXS-1)
21727 IJSI1(INDXS-1) = IFL2
21729 P1 = PSOFT2(1,INDXS-1)
21730 P2 = PSOFT2(2,INDXS-1)
21731 P3 = PSOFT2(3,INDXS-1)
21732 P4 = PSOFT2(4,INDXS-1)
21733 IJSI2(INDXS-1) = IFL2
21736 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21737 & IHP,IGEN,ICB1,ICB2,IPOS,1)
21738 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21739 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21740 & IFL2,IPOS,SIGN(INDXS-1,INDXH)
21744 CALL PHO_SELCOL(0,0,ICC1,ICA2,ICC2,ICB2,1)
21745 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,I5)')
21746 & 'PHO_HARREM: no spectator added:(INDXS)',
21747 & SIGN(INDXS,INDXH)
21752 WRITE(LO,'(1X,A,2I5)')
21753 & 'PHO_HARREM:ERROR: unsupported combination of IVAL,IJH',
21762 *$ CREATE PHO_HARDIR.FOR
21764 CDECK ID>, PHO_HARDIR
21765 SUBROUTINE PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,
21767 C**********************************************************************
21769 C parton orientated formulation of direct scattering processes
21773 C output: II particle combination (1..4)
21774 C IVAL1,2 0 no valence quarks engaged
21775 C 1 valence quarks engaged
21776 C MSPAR1,2 number of realized soft partons
21777 C MHPAR1,2 number of realized hard partons
21781 C**********************************************************************
21782 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21785 C input/output channels
21787 COMMON /POINOU/ LI,LO
21788 C event debugging information
21790 PARAMETER (NMAXD=100)
21791 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
21792 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21793 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
21794 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21795 C model switches and parameters
21797 INTEGER ISWMDL,IPAMDL
21798 DOUBLE PRECISION PARMDL
21799 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21800 C hard scattering parameters used for most recent hard interaction
21802 DOUBLE PRECISION ALQCD2,BQCD
21803 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
21804 C data of c.m. system of Pomeron / Reggeon exchange
21805 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
21806 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
21807 & SIDP,CODP,SIFP,COFP
21808 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
21809 & SIDP,CODP,SIFP,COFP,NPOSP(2),
21810 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
21811 C obsolete cut-off information
21812 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
21813 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
21814 C hard cross sections and MC selection weights
21816 PARAMETER ( Max_pro_2 = 16 )
21817 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
21818 & MH_acc_1,MH_acc_2
21819 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
21820 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
21821 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
21822 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
21823 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
21824 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
21825 C data on most recent hard scattering
21826 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
21827 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
21828 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
21829 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
21830 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
21831 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
21832 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
21833 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
21834 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
21835 C light-cone x fractions and c.m. momenta of soft cut string ends
21837 PARAMETER ( MAXSOF = 50 )
21838 INTEGER IJSI2,IJSI1
21839 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
21840 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
21841 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
21842 & IJSI1(MAXSOF),IJSI2(MAXSOF)
21843 C hard scattering data
21845 PARAMETER ( MSCAHD = 50 )
21846 INTEGER LSCAHD,LSC1HD,LSIDX,
21847 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
21848 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
21849 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
21850 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
21851 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
21852 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
21853 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
21854 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
21855 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
21856 C internal rejection counters
21858 PARAMETER (NMXJ=60)
21859 CHARACTER*10 REJTIT
21861 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
21863 DIMENSION P1(4),P2(4),PD1(-6:6)
21865 PARAMETER ( TINY = 1.D-10 )
21872 C check phase space
21873 IF(ECMP.LT.(2.D0*PTWANT+0.1D0)) THEN
21874 IFAIL(18) = IFAIL(18)+1
21879 AS = (PARMDL(160+II)/ECMP)**2
21880 AH = (2.D0*PTWANT/ECMP)**2
21885 XMAX = MAX(TINY,1.D0-AS)
21889 C main loop to select hard and soft parton kinematics
21890 C -----------------------------------------------------
21896 IFAIL(17) = IFAIL(17)+1
21897 IF(ITRY.GE.NTRY) THEN
21910 CALL PHO_HARSCA(1,II)
21914 IF(IDEB(25).GE.20) THEN
21915 WRITE(LO,'(1X,A,2E12.4,2I5)')
21916 & 'PHO_HARDIR: AS,XMAX,process ID,ITRY',
21917 & AS,XMAX,MSPR,ITRY
21918 WRITE(LO,'(1X,A,4E12.4)') 'HARD X1,2 SUM X1,2',
21922 IF(MSPR.LE.11) THEN
21923 IF((XSS2.GT.XMAX).OR.((1.D0-XSS2).LT.AS)) GOTO 120
21924 ELSE IF(MSPR.LE.13) THEN
21925 IF((XSS1.GT.XMAX).OR.((1.D0-XSS1).LT.AS)) GOTO 120
21942 NBRAHD(1,1)= IDPDG1
21943 NBRAHD(1,2)= IDPDG2
21947 PPH(4+I,1) = PHO1(I)
21948 PPH(4+I,2) = PHO2(I)
21956 IF(MSPR.LE.11) THEN
21957 NINHD(1,1) = IDPDG1
21959 PDFVA(1,2) = PDF2(IB)
21961 ELSE IF(MSPR.LE.13) THEN
21963 PDFVA(1,1) = PDF1(IA)
21964 NINHD(1,2) = IDPDG2
21967 NINHD(1,1) = IDPDG1
21968 NINHD(1,2) = IDPDG2
21971 N0INHD(1,1) = NINHD(1,1)
21972 N0INHD(1,2) = NINHD(1,2)
21973 N0IVAL(1,1) = IVAL1
21974 N0IVAL(1,2) = IVAL2
21978 C reweight according to photon virtuality
21979 IF(MSPR.NE.14) THEN
21980 IF(IPAMDL(115).GE.1) THEN
21982 IF(((MSPR.EQ.10).OR.(MSPR.EQ.11)).AND.(IDPDG2.EQ.22)) THEN
21984 IF(IPAMDL(115).EQ.1) THEN
21985 IF(QQPD.LT.(PVIRTP(2)+PARMDL(144))) THEN
21988 WGX = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
21989 & /LOG(QQPD/PARMDL(144))
21991 IF(NINHD(1,2).EQ.0) WGX = WGX*WGX
21992 ELSE IF(IPAMDL(115).EQ.2) THEN
21993 CALL PHO_PDF(2,X2,QQPD,PVIRTP(2),PD1)
21994 WGX = PD1(IB)/PDFVA(1,2)
21996 ELSE IF(((MSPR.EQ.12).OR.(MSPR.EQ.13))
21997 & .AND.(IDPDG1.EQ.22)) THEN
21999 IF(IPAMDL(115).EQ.1) THEN
22000 IF(QQPD.LT.(PVIRTP(1)+PARMDL(144))) THEN
22003 WGX = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
22004 & /LOG(QQPD/PARMDL(144))
22006 IF(NINHD(1,1).EQ.0) WGX = WGX*WGX
22007 ELSE IF(IPAMDL(115).EQ.2) THEN
22008 CALL PHO_PDF(1,X1,QQPD,PVIRTP(1),PD1)
22009 WGX = PD1(IA)/PDFVA(1,1)
22014 & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
22015 & 're-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
22016 & KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX
22018 IF(WGX.LT.DT_RNDM(WGX)) THEN
22024 & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
22025 & 're-weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
22026 & KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX
22032 IF((MSPR.NE.14).AND.(ISWMDL(8).GE.2)) THEN
22033 IF(IPAMDL(109).EQ.1) THEN
22034 Q2H = PARMDL(93)*PT**2
22036 Q2H = -PARMDL(93)*VHD(1)*XHD(1,1)*XHD(1,2)*ECMP*ECMP
22038 XHMAX1 = 1.D0 - XSS1 - AS + XHD(1,1)
22039 XHMAX2 = 1.D0 - XSS2 - AS + XHD(1,2)
22044 CALL PHO_HARISR(-1,P1,P2,NOUTHD(1,1),NOUTHD(1,2),N0INHD(1,1),
22045 & N0INHD(1,2),N0IVAL(1,1),N0IVAL(1,2),Q2H,X0HD(1,1),X0HD(1,2),
22046 & XHMAX1,XHMAX2,IFL1,IFL2,IVAL1,IVAL2,XISR1,XISR2,IREJ)
22047 XSS1 = XSS1+XISR1-XHD(1,1)
22048 XSS2 = XSS2+XISR2-XHD(1,2)
22060 C add photon/hadron remnant
22064 XMAXX = 1.D0 - XSS2 - AS
22065 XMAXH = MIN(XMAXX,PARMDL(44))
22066 CALL PHO_HADSP2(IDBAM2,XSS2,XMAXH,XS2,IREJ)
22072 ELSE IF(IFL1.EQ.0) THEN
22073 XMAXX = 1.D0 - XSS1 - AS
22074 XMAXH = MIN(XMAXX,PARMDL(44))
22075 CALL PHO_HADSP2(IDBAM1,XSS1,XMAXH,XS1,IREJ)
22083 ELSE IF(ABS(IFL2).LE.12) THEN
22084 IF(IVAL2.EQ.1) THEN
22085 XS2(1) = 1.D0 - XSS2
22091 XMAXX = 1.D0 - XSS2 - AS
22092 XMAXH = MIN(XMAXX,PARMDL(44))
22093 CALL PHO_HADSP3(IDBAM2,XSS2,XMAXH,XS2,IREJ)
22099 ELSE IF(ABS(IFL1).LE.12) THEN
22100 IF(IVAL1.EQ.1) THEN
22101 XS1(1) = 1.D0 - XSS1
22107 XMAXX = 1.D0 - XSS1 - AS
22108 XMAXH = MIN(XMAXX,PARMDL(44))
22109 CALL PHO_HADSP3(IDBAM1,XSS1,XMAXH,XS1,IREJ)
22116 C double direct process
22117 ELSE IF(MSPR.EQ.14) THEN
22125 WRITE(LO,'(/1X,A,I3/)')
22126 & 'PHO_HARDIR:ERROR: unsupported hard process (MSPR)',MSPR
22131 IF(IDEB(25).GE.3) WRITE(LO,'(1X,A,3I5)')
22132 & 'PHO_HARDIR: int. rejection (MSPR,ITRY,NTRY)',MSPR,ITRY,NTRY
22136 C soft particle momenta
22137 IF(MSPAR1.GT.0) THEN
22141 PSOFT1(3,I) = XS1(I)*ECMP/2.D0
22142 PSOFT1(4,I) = XS1(I)*ECMP/2.D0
22145 IF(MSPAR2.GT.0) THEN
22149 PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
22150 PSOFT2(4,I) = XS2(I)*ECMP/2.D0
22154 MH_acc_1(MSPR,II) = MH_acc_1(MSPR,II)+1
22155 KSOFT = MAX(MSPAR1,MSPAR2)
22156 KHARD = MAX(MHPAR1,MHPAR2)
22158 IF(IDEB(25).GE.10) THEN
22159 WRITE(LO,'(/1X,A,2I3,3I5)')
22160 & 'PHO_HARDIR: accepted IVAL1,IVAL2,MSPR,ITRY,NTRY',
22161 & IVAL1,IVAL2,MSPR,ITRY,NTRY
22162 IF(MSPAR1.GT.0) THEN
22163 WRITE(LO,'(5X,A,I4)') 'soft x particle 1:',MSPAR1
22165 WRITE(LO,'(10X,I3,E12.3)') I,XS1(I)
22168 IF(MSPAR2.GT.0) THEN
22169 WRITE(LO,'(5X,A,I4)') 'soft x particle 2:',MSPAR2
22171 WRITE(LO,'(10X,I3,E12.3)') I,XS2(I)
22174 WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavor particle 1:',MHPAR1
22175 WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,1),NINHD(1,1)
22176 WRITE(LO,'(5X,A,I4)') 'fin.hard momenta particle 1:',MHPAR1
22177 WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,1),K=5,8),NOUTHD(1,1)
22178 WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavour particle 2:',MHPAR2
22179 WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,2),NINHD(1,2)
22180 WRITE(LO,'(5X,A,I4)') 'fin.hard momenta particle 2:',MHPAR2
22181 WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,2),K=5,8),NOUTHD(1,2)
22186 IFAIL(16) = IFAIL(16)+1
22187 IF(IDEB(25).GE.2) THEN
22188 WRITE(LO,'(1X,A,3I5)')
22189 & 'PHO_HARDIR: rejection (ITRY,NTRY,IREJ)',ITRY,NTRY,IREJ
22190 WRITE(LO,'(5X,A,E12.4)') 'available energy:',ECMP
22191 IF(IDEB(25).GE.5) THEN
22194 CALL PHO_PREVNT(-1)
22200 *$ CREATE PHO_POMSCA.FOR
22202 CDECK ID>, PHO_POMSCA
22203 SUBROUTINE PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,
22204 & MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
22205 C**********************************************************************
22207 C parton orientated formulation of soft and hard inelastic events
22210 C input: II particle combiantion (1..4)
22211 C MSPOM number of soft pomerons
22212 C MHPOM number of semihard pomerons
22213 C MSREG number of soft reggeons
22215 C output: IVAL1,2 0 no valence quark engaged
22216 C otherwise: position of valence quark engaged
22217 C neg.number: gluon connected to valence quark
22219 C MSPAR1,2 number of realized soft partons
22220 C MHPAR1,2 number of realized hard partons
22224 C**********************************************************************
22225 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22228 PARAMETER (TINY = 1.D-30 )
22230 C input/output channels
22232 COMMON /POINOU/ LI,LO
22233 C event debugging information
22235 PARAMETER (NMAXD=100)
22236 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
22237 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22238 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
22239 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22240 C model switches and parameters
22242 INTEGER ISWMDL,IPAMDL
22243 DOUBLE PRECISION PARMDL
22244 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
22245 C general process information
22246 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
22247 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
22248 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
22249 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
22250 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
22251 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
22252 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
22253 C event weights and generated cross section
22254 INTEGER IPOWGC,ISWCUT,IVWGHT
22255 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
22256 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
22257 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
22258 C hard cross sections and MC selection weights
22260 PARAMETER ( Max_pro_2 = 16 )
22261 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
22262 & MH_acc_1,MH_acc_2
22263 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
22264 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
22265 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
22266 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
22267 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
22268 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
22269 C hard scattering parameters used for most recent hard interaction
22271 DOUBLE PRECISION ALQCD2,BQCD
22272 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
22273 C data of c.m. system of Pomeron / Reggeon exchange
22274 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
22275 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
22276 & SIDP,CODP,SIFP,COFP
22277 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
22278 & SIDP,CODP,SIFP,COFP,NPOSP(2),
22279 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
22280 C obsolete cut-off information
22281 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
22282 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
22283 C some hadron information, will be deleted in future versions
22285 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
22286 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
22287 C data on most recent hard scattering
22288 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22289 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22290 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22291 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22292 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22293 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22294 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22295 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22296 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22297 C light-cone x fractions and c.m. momenta of soft cut string ends
22299 PARAMETER ( MAXSOF = 50 )
22300 INTEGER IJSI2,IJSI1
22301 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
22302 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
22303 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
22304 & IJSI1(MAXSOF),IJSI2(MAXSOF)
22305 C hard scattering data
22307 PARAMETER ( MSCAHD = 50 )
22308 INTEGER LSCAHD,LSC1HD,LSIDX,
22309 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
22310 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
22311 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
22312 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
22313 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
22314 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
22315 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
22316 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
22317 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
22318 C table of particle indices for recursive PHOJET calls
22320 PARAMETER ( MAXIPX = 100 )
22321 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
22322 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
22323 & IPOIX1,IPOIX2,IPOIX3
22324 C internal rejection counters
22326 PARAMETER (NMXJ=60)
22327 CHARACTER*10 REJTIT
22329 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
22331 DIMENSION P1(4),P2(4),PD1(-6:6)
22333 IF(IDEB(24).GT.20) WRITE(LO,'(1X,A,3I5)')
22334 & 'PHO_POMSCA: MSPOM,MHPOM,MSREG',MSPOM,MHPOM,MSREG
22342 C phase space limitation (single hard valence-valence quark scattering)
22343 IF(MHPOM.GT.0) THEN
22344 Emin = 2.D0*PTWANT + 0.2D0
22345 IF(ECMP.LT.Emin) THEN
22346 IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P,3E10.3)') 'PHO_POMSCA: ',
22347 & 'kin. rejection (1) (Ecm,Ptcut,Emin)',ECMP,PTWANT,Emin
22349 IFAIL(6) = IFAIL(6) + 1
22354 SAS = PARMDL(160+II)/ECMP
22355 SAH = 2.D0*PTWANT/ECMP
22359 C save energy for leading particle effect
22361 if(IHFLS(1).ne.0) XMAXP1 = 1.D0-PARMDL(165)*XPSUB
22363 if(IHFLS(2).ne.0) XMAXP2 = 1.D0-PARMDL(165)*XTSUB
22366 C main loop to select hard and soft parton kinematics
22367 C -----------------------------------------------------
22368 IFAIL(31) = IFAIL(31)+MHARD
22374 IF(ITRY.GT.1) IFAIL(5) = IFAIL(5)+1
22375 IF(ITRY.GE.NTRY) THEN
22381 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
22382 XSS1 = MAX(0.D0,1.D0-XPSUB)
22383 XSS2 = MAX(0.D0,1.D0-XTSUB)
22390 C partons needed to construct soft/hard interactions
22391 MSPAR1 = 2*MSPOM+MSREG+MHPOM
22396 C number of strings
22397 MSCHA = 2*MSPOM+MSREG
22403 C check actual phase space limit
22404 XX = SAS*DBLE(MSCHA)+SAH*DBLE(MHCHA)/2.D0
22405 IF(XX.GE.1.D0) THEN
22406 IF(IDEB(24).GE.3) WRITE(LO,'(1X,2A,/1X,4I3,1P4E12.4)')
22407 & 'PHO_POMSCA: internal kin. rejection ',
22408 & '(MSpom,MHpom,MSchain,MHchain,Ecm,AS,AH,XX):',
22409 & MSPOM,MHPOM,MSCHA,MHCHA,ECMP,AS,AH,XX
22410 if(MSPOM+MSREG+MHPOM.gt.1) then
22411 if(MSREG.gt.0) then
22413 else if(MSPOM.gt.0) THEN
22415 else if(MHPOM.gt.1) then
22420 IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P2E10.3)')
22421 & 'PHO_POMSCA: kin. rejection (2) (Ecm,Ptcut)',ECMP,PTWANT
22423 IFAIL(6) = IFAIL(6) + 1
22427 XMAXX1 = MAX(TINY,1.D0-MIN(MSPAR1,1)*AS-MIN(MHPAR1,1)*AH)
22428 XMAXX2 = MAX(TINY,1.D0-MIN(MSPAR2,1)*AS-MIN(MHPAR2,1)*AH)
22430 C very low energy phase space restriction
22431 if(MHARD.gt.0) then
22432 if((XMAXX1*XMAXX2.le.AH)) then
22433 IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P2E10.3)')
22434 & 'PHO_POMSCA: kin. rejection (3) (Ecm,Ptcut)',ECMP,PTWANT
22436 IFAIL(6) = IFAIL(6) + 1
22441 AS = MAX(AS,PSOMIN/PCMP)
22444 Z1MAX = LOG(XMAXX1)
22445 Z2MAX = LOG(XMAXX2)
22446 Z1DIF = Z1MAX+Z2MAX-ALNH
22450 C select hard parton momenta
22451 C ------------------- begin of inner loop -------------------
22452 IF(IPOIX3.EQ.0) IPOWGC(4+II) = 0
22454 IF(MHARD.GT.MSCAHD) THEN
22455 WRITE(LO,'(1X,2A,2I3)') 'PHO_POMSCA: ',
22456 & 'no space left in /POHSLT/ (MHARD,MSCAHD):',MHARD,MSCAHD
22463 C generate one resolved hard scattering
22466 IF((NN.EQ.1).AND.(II.EQ.1).AND.(HSWCUT(4+II).GT.PTWANT)) THEN
22467 CALL PHO_HARINT(-1,ECMP,PVIRTP(1),PVIRTP(2),
22468 & -1,Max_pro_2,1,4,MSPOM+MHPOM)
22474 AH = (2.D0*PTWANT/ECMP)**2
22476 Z1DIF = Z1MAX+Z2MAX-ALNH
22478 IF((Z1DIF.LE.0.01D0).OR.(Z2DIF.LE.0.01D0)) THEN
22479 IF(IDEB(24).GE.1) WRITE(LO,'(1X,2A,/1X,1P4E12.3)')
22480 & 'PHO_POMSCA: kin.rejection, high-pt option ',
22481 & '(Z1/2max,ALNH,Z1dif):',Z1MAX,Z2MAX,ALNH,Z1DIF
22485 CALL PHO_HARSCA(2,II)
22486 CALL PHO_HARINT(1,ECMP,PVIRTP(1),PVIRTP(2),
22487 & -1,Max_pro_2,1,4,MSPOM+MHPOM)
22492 IPOWGC(4+II) = IPOWGC(4+II)+1
22493 HSWGHT(4+II) = XSCUT/HSig(9)*DBLE(MHARD)
22494 C minimum bias option
22496 CALL PHO_HARSCA(2,II)
22513 PDFVA(NN,1) = PDF1(IA)
22514 PDFVA(NN,2) = PDF2(IB)
22525 NBRAHD(NN,1) = IDPDG1
22526 NBRAHD(NN,2) = IDPDG2
22530 PPH(I3+I,1) = PHI1(I)
22531 PPH(I3+I,2) = PHI2(I)
22532 PPH(I4+I,1) = PHO1(I)
22533 PPH(I4+I,2) = PHO2(I)
22538 C sort according to pt-hat
22540 PTMX = PTHD(LSIDX(NN))
22543 IF(PTHD(LSIDX(I)).GT.PTMX) THEN
22545 PTMX = PTHD(LSIDX(I))
22548 IF(IPTM.NE.NN) CALL PHO_SWAPI(LSIDX(NN),LSIDX(IPTM))
22552 C copy partons, generate ISR
22555 XSSS1 = XSS1+XHD(NN,1)
22556 XSSS2 = XSS2+XHD(NN,2)
22558 IF(IDEB(24).GE.10) WRITE(LO,'(1X,A,3I4,1P,3E11.3)')
22559 & 'PHO_POMSCA: NR,LSIDX,MSPR,X1,X2,PT',
22560 & L,NN,NPROHD(NN),XHD(NN,1),XHD(NN,2),PTHD(NN)
22561 C check phase space
22562 IF( (XSSS1.GT.XMAXX1)
22563 & .OR.(XSSS2.GT.XMAXX2)
22564 & .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
22565 IF(IHARD.EQ.0) THEN
22566 IF(ISWMDL(2).NE.1) GOTO 20
22574 C reweight according to photon virtuality
22575 IF(IPAMDL(115).GE.1) THEN
22578 IF(IDPDG1.EQ.22) THEN
22579 IF(IPAMDL(115).EQ.1) THEN
22580 IF(QQPD.LT.PVIRTP(1)+PARMDL(144)) THEN
22583 WG1 = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
22584 & /LOG(QQPD/PARMDL(144))
22586 IF(NINHD(NN,1).EQ.0) WG1 = WG1*WG1
22587 ELSE IF(IPAMDL(115).EQ.2) THEN
22588 CALL PHO_PDF(1,X0HD(NN,1),QQPD,PVIRTP(1),PD1)
22589 WG1 = PD1(NINHD(NN,1))/PDFVA(NN,1)
22594 IF(IDPDG2.EQ.22) THEN
22595 IF(IPAMDL(115).EQ.1) THEN
22596 IF(QQPD.LT.PVIRTP(2)+PARMDL(144)) THEN
22599 WG1 = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
22600 & /LOG(QQPD/PARMDL(144))
22602 IF(NINHD(NN,2).EQ.0) WG1 = WG1*WG1
22603 ELSE IF(IPAMDL(115).EQ.2) THEN
22604 CALL PHO_PDF(2,X0HD(NN,2),QQPD,PVIRTP(2),PD1)
22605 WG1 = PD1(NINHD(NN,2))/PDFVA(NN,2)
22611 & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_POMSCA: ',
22612 & ' re-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
22613 & KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX
22615 IF(WGX.LT.DT_RNDM(WGX)) THEN
22624 IF(WGX.GT.1.D0) WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)')
22626 & 'weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
22627 & KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX
22632 IF((ISWMDL(8).GE.2)
22633 & .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
22634 IF(IPAMDL(109).EQ.1) THEN
22635 Q2H = PARMDL(93)*PTHD(NN)**2
22637 Q2H = -PARMDL(93)*VHD(NN)
22638 & *XHD(NN,1)*XHD(NN,2)*ECMP*ECMP
22640 XHMAX1 = 1.D0 - XSSS1 - MSCHA*AS + XHD(NN,1)
22641 XHMAX2 = 1.D0 - XSSS2 - MSCHA*AS + XHD(NN,2)
22644 P1(J) = PPH(I3+J,1)
22645 P2(J) = PPH(I3+J,2)
22648 & WRITE(LO,'(1X,A,/5X,2I3,1P,3E12.4)')
22649 & 'PHO_POMSCA: generate ISR for (L,NN,X1,X2,Q2H)',
22650 & L,NN,XHD(NN,1),XHD(NN,2),Q2H
22653 CALL PHO_HARISR(J,P1,P2,NOUTHD(NN,1),NOUTHD(NN,2),
22654 & N0INHD(NN,1),N0INHD(NN,2),N0IVAL(NN,1),N0IVAL(NN,2),Q2H,
22655 & X0HD(NN,1),X0HD(NN,2),XHMAX1,XHMAX2,IFL1,IFL2,
22656 & NIVAL(NN,1),NIVAL(NN,2),XISR1,XISR2,IREJ)
22657 XSSS1 = XSSS1+XISR1-XHD(NN,1)
22658 XSSS2 = XSSS2+XISR2-XHD(NN,2)
22665 C check phase space
22666 IF( (XSSS1.GT.XMAXX1)
22667 & .OR.(XSSS2.GT.XMAXX2)
22668 & .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
22669 IF(IHARD.EQ.0) THEN
22670 IF(ISWMDL(2).NE.1) GOTO 20
22678 C leave energy for leading particle effect
22679 IF((IHARD.GT.0).AND.
22680 & ((XSSS1.GT.XMAXP1).OR.(XSSS2.GT.XMAXP2))) then
22684 C hard scattering accepted
22688 IFAIL(31) = IFAIL(31)-1
22692 C ------------------- end of inner (hard) loop -------------------
22699 C count valences involved in hard scattering
22704 IF((NIVAL(NN,1).NE.0).AND.(IVAL1.EQ.0)) IVAL1 = NN
22705 IF((NIVAL(NN,2).NE.0).AND.(IVAL2.EQ.0)) IVAL2 = NN
22715 C photon, pomeron valences
22716 IF((IVAL1.EQ.0).AND.(NINHD(NN,1).NE.0)) THEN
22717 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
22722 IF((IVAL2.EQ.0).AND.(NINHD(NN,2).NE.0)) THEN
22723 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
22729 C total number of quarks
22730 IF(NINHD(NN,1).NE.0) THEN
22732 ELSE IF(IVGLU1.EQ.0) THEN
22735 IF(NINHD(NN,2).NE.0) THEN
22737 ELSE IF(IVGLU2.EQ.0) THEN
22742 C gluons emitted by valence quarks
22744 IF(II.EQ.1) VALPRO = VALPRG(1)
22747 IVAL1 = MAX(IVAL1,0)
22748 IF(IVAL1.EQ.0) THEN
22750 IF((IVGLU1.NE.0).AND.(DT_RNDM(XSS1).LT.VALPRO)) THEN
22756 IF(II.EQ.1) VALPRO = VALPRG(2)
22759 IVAL2 = MAX(IVAL2,0)
22760 IF(IVAL2.EQ.0) THEN
22762 IF((IVGLU2.NE.0).AND.(DT_RNDM(XSS2).LT.VALPRO)) THEN
22767 MSPOM = MAX(0,MSPOM-IQUA1-IQUA2)
22769 IF(IDEB(24).GE.5) WRITE(LO,'(1X,A,6I4)')
22770 & 'PHO_POMSCA: IVAL1/2,IQUA1/2,IVGLU1/2',
22771 & IVAL1,IVAL2,IQUA1,IQUA2,IVGLU1,IVGLU2
22773 C select soft X values
22775 C number of soft/remnant quarks
22776 IF(MSPOM.EQ.0) THEN
22777 IF(IPAMDL(18).EQ.0) THEN
22778 MSPAR1 = 2+2*MHPOM+MSREG-IQUA1-2*IVQ1-2*IVG1
22779 MSPAR2 = 2+2*MHPOM+MSREG-IQUA2-2*IVQ2-2*IVG2
22781 MSPAR1 = 2+MSREG+IQUA1-2*IVQ1
22782 MSPAR2 = 2+MSREG+IQUA2-2*IVQ2
22785 IF(IPAMDL(18).EQ.0) THEN
22786 MSPAR1 = 2*MSPOM+MSREG+2*MHPOM-IQUA1
22787 MSPAR2 = 2*MSPOM+MSREG+2*MHPOM-IQUA2
22789 MSPAR1 = 2*MSPOM+MSREG+IQUA1+2*IVG1
22790 MSPAR2 = 2*MSPOM+MSREG+IQUA2+2*IVG2
22794 IF(IDEB(24).GE.15) WRITE(LO,'(1X,A,9I3)')
22795 & 'PHO_POMSCA: MSP,MSR,MHP,IVQ1/2,IVG1/2,MSPAR1/2',
22796 & MSPOM,MSREG,MHPOM,IVQ1,IVQ2,IVG1,IVG2,MSPAR1,MSPAR2
22798 XMAX1 = 1.D0 - MAX(MSPAR1-1,0)*AS - XSS1
22799 XMAX2 = 1.D0 - MAX(MSPAR2-1,0)*AS - XSS2
22802 IF(IVAL1.LE.0) I1 = 0
22803 IF(IVAL2.LE.0) I2 = 0
22804 IF((IVQ1+IVG1)*(IVQ2+IVG2).NE.0) THEN
22807 MSDIFF = 2*MAX(0,MSPOM-1)
22811 MSM1 = MSPAR1-MSDIFF
22812 MSM2 = MSPAR2-MSDIFF
22813 XMAXH1 = MIN(XMAX1,PARMDL(44))
22814 XMAXH2 = MIN(XMAX2,PARMDL(44))
22815 CALL PHO_SOFTXX(NPOSP(1),NPOSP(2),MSG1,MSG2,I1,I2,MSM1,MSM2,
22816 & XSS1,XSS2,XMAXH1,XMAXH2,XS1,XS2,IREJ)
22818 C correct for proper simulation of high pt tail
22820 IF(IDEB(48).GE.2) WRITE(LO,'(1X,A,4I4)')
22821 & 'PHO_STDPAR: rejection (PHO_SOFTXX): MSPOM,MHPOM,I1,I2',
22822 & MSPOM,MHPOM,I1,I2
22823 IF(MSPOM*MHPOM.GT.0) THEN
22826 ELSE IF(MSPOM.GT.1) THEN
22829 ELSE IF(MHPOM.GT.1) THEN
22831 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0)
22832 & .AND.(IPROCE.EQ.1)) THEN
22833 XSS1 = MAX(0.D0,1.D0-XPSUB)
22834 XSS2 = MAX(0.D0,1.D0-XTSUB)
22841 XSS1 = XSS1+ XHD(I,1)
22842 XSS2 = XSS2+ XHD(I,2)
22850 MSPOM = MSPOM-(MSPAR1-MSG1)/2
22853 C ------------ kinematics sampled ---------------
22855 IF(IDEB(24).GE.10) THEN
22856 WRITE(LO,'(1X,A,I3)')
22857 & 'PHO_POMSCA: soft x values, ITRY',ITRY
22858 DO 104 I=2,MAX(MSPAR1,MSPAR2)
22859 WRITE(LO,'(10X,I3,2E12.3)') I,XS1(I),XS2(I)
22862 IF((1.D0-XSS1)*(1.D0-XSS2).LT.AS) GOTO 20
22865 XS1(1) = 1.D0 - XSS1
22866 XS2(1) = 1.D0 - XSS2
22870 MH_acc_1(NPROHD(N),II) = MH_acc_1(NPROHD(N),II)+1
22873 C soft particle momenta
22875 IF(MAX(MSPAR1,MSPAR2).GT.MAXSOF) THEN
22876 WRITE(LO,'(1X,2A,3I4)') 'PHO_POMSCA: no space left in ',
22877 & '/POSOFT/ (MSPAR1/2,MAXSOF):',MSPAR1,MSPAR2,MAXSOF
22885 PSOFT1(3,I) = XS1(I)*ECMP/2.D0
22886 PSOFT1(4,I) = XS1(I)*ECMP/2.D0
22891 PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
22892 PSOFT2(4,I) = XS2(I)*ECMP/2.D0
22895 KSOFT = MAX(MSPAR1,MSPAR2)
22896 KHARD = MAX(MHPAR1,MHPAR2)
22902 IF(IDEB(24).GE.10) THEN
22903 WRITE(LO,'(/1X,A,2I3,2I5)')
22904 & 'PHO_POMSCA: accepted IVAL1,IVAL2,ITRY,NTRY',
22905 & IVAL1,IVAL2,ITRY,NTRY
22906 IF(MSPAR1+MSPAR2.GT.0) THEN
22907 WRITE(LO,'(5X,A)') 'soft x particle1 particle2:'
22910 DO 105 I=1,MAX(MSPAR1,MSPAR2)
22911 IF(I.LE.MIN(MSPAR1,MSPAR2)) THEN
22912 WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),XS2(I)
22913 XTMP1 = XTMP1+XS1(I)
22914 XTMP2 = XTMP2+XS2(I)
22915 ELSE IF(I.LE.MSPAR1) THEN
22916 WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),0.D0
22917 XTMP1 = XTMP1+XS1(I)
22918 ELSE IF(I.LE.MSPAR2) THEN
22919 WRITE(LO,'(10X,I3,2E13.4)') I,0.D0,XS2(I)
22920 XTMP2 = XTMP2+XS2(I)
22923 WRITE(LO,'(5X,A,2E13.4)') 'sum X1/2 (soft):',XTMP1,XTMP2
22925 IF(MHPAR1.GT.0) THEN
22927 & 'NR IDX MSPR hard X / hard X ISR / flavor particle 1,2:'
22930 WRITE(LO,'(5X,3I3,4E12.3,2I3)')
22931 & K,I,NPROHD(I),X0HD(I,1),X0HD(I,2),XHD(I,1),XHD(I,2),
22932 & NINHD(I,1),NINHD(I,2)
22933 XTMP1 = XTMP1+XHD(I,1)
22934 XTMP2 = XTMP2+XHD(I,2)
22936 WRITE(LO,'(1X,A,2E13.4)') 'sum X1/2 (soft+hard):',XTMP1,XTMP2
22937 WRITE(LO,'(5X,A)') 'hard momenta particle1:'
22941 WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,1),L=1,4),
22944 WRITE(LO,'(5X,A)') 'hard momenta particle2:'
22948 WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,2),L=1,4),
22955 C event rejected, print debug information
22957 IFAIL(4) = IFAIL(4)+1
22958 IF(IDEB(24).GE.2) THEN
22959 WRITE(LO,'(1X,2A,/,10X,7I5)') 'PHO_POMSCA: ',
22960 & 'rejection (MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ)',
22961 & MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ
22962 WRITE(LO,'(5X,A,I4,1P,2E12.4)') 'IP,Ecm,PTcut:',II,ECMP,PTWANT
22963 IF(IDEB(24).GE.5) THEN
22966 CALL PHO_PREVNT(-1)
22972 *$ CREATE PHO_HARX12.FOR
22974 CDECK ID>, PHO_HARX12
22975 SUBROUTINE PHO_HARX12
22976 C**********************************************************************
22978 C selection of x1 and x2 according to 1/x1*1/x2
22980 C**********************************************************************
22981 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22984 PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
22986 C input/output channels
22988 COMMON /POINOU/ LI,LO
22989 C data on most recent hard scattering
22990 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22991 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22992 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22993 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22994 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22995 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22996 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22997 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22998 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23001 Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
23002 Z2 = Z2MAX-DT_RNDM(X2)*Z2DIF
23003 IF ( (Z1+Z2).LT.ALNH ) GOTO 10
23007 W = SQRT(MAX(TINY,1.D0-AXX))
23012 *$ CREATE PHO_HARDX1.FOR
23014 CDECK ID>, PHO_HARDX1
23015 SUBROUTINE PHO_HARDX1
23016 C**********************************************************************
23018 C selection of x1 according to 1/x1
23021 C**********************************************************************
23022 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23025 PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
23027 C input/output channels
23029 COMMON /POINOU/ LI,LO
23030 C data on most recent hard scattering
23031 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23032 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23033 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23034 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23035 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23036 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23037 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23038 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23039 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23041 Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
23045 W = SQRT(MAX(TINY,1.D0-AXX))
23050 *$ CREATE PHO_HARKIN.FOR
23052 CDECK ID>, PHO_HARKIN
23053 SUBROUTINE PHO_HARKIN(IREJ)
23054 C***********************************************************************
23056 C selection of kinematic variables
23057 C (resolved and direct processes)
23059 C***********************************************************************
23060 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23063 PARAMETER ( TINY= 1.D-30, TINYP=1.D-14 )
23065 C input/output channels
23067 COMMON /POINOU/ LI,LO
23068 C event debugging information
23070 PARAMETER (NMAXD=100)
23071 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
23072 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23073 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
23074 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23075 C data of c.m. system of Pomeron / Reggeon exchange
23076 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23077 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23078 & SIDP,CODP,SIFP,COFP
23079 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23080 & SIDP,CODP,SIFP,COFP,NPOSP(2),
23081 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
23082 C data on most recent hard scattering
23083 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23084 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23085 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23086 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23087 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23088 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23089 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23090 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23091 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23092 C internal cross check information on hard scattering limits
23093 DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
23094 COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)
23096 PARAMETER ( Max_pro_2 = 16 )
23097 DIMENSION RM(-1:Max_pro_2)
23098 DATA RM / 3.31D0, 0.0D0,
23099 & 7.60D0, 0.65D0, 4.00D0, 0.65D0, 0.89D0,
23100 & 0.45D0, 0.89D0, 0.89D0, 0.0D0, 4.776D0,
23101 & 0.615D0,4.776D0,0.615D0,1.0D0, 0.0D0,
23107 C------------- resolved processes -----------
23110 V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
23112 R = (1.D0+W)*2.25D0*(V*V*(3.D0-U*V-V/(U*U))-U)
23113 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23114 & 'PHO_HARKIN:weight error',M
23115 IF ( R*W.LT.RM(1)*DT_RNDM(X2) ) GOTO 10
23116 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23117 ELSEIF ( M.EQ.2 .OR. M.EQ.4 ) THEN
23120 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
23122 R = (U*U+V*V)*((16.D0/27.D0)/U-(4.D0/3.D0)*V)*(WL/W)*AXX
23123 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23124 & 'PHO_HARKIN:weight error',M
23125 IF ( R*W.LT.RM(M)*DT_RNDM(X2) ) GOTO 20
23126 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23127 ELSEIF ( M.EQ.3 ) THEN
23129 V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
23131 R = (1.D0+W)*(1.D0+U*U)*(1.D0-(4.D0/9.D0)*V*V/U)
23132 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23133 & 'PHO_HARKIN:weight error',M
23134 IF ( R*W.LT.RM(3)*DT_RNDM(X2) ) GOTO 30
23135 ELSEIF ( M.EQ.5 ) THEN
23137 V =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
23139 R = (4.D0/9.D0)*(1.D0+U*U+V*V*(U*U+V*V))-(8.D0/27.D0)*U*U*V
23140 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23141 & 'PHO_HARKIN:weight error',M
23142 IF ( R*W.LT.RM(5)*DT_RNDM(X2) ) GOTO 50
23143 ELSEIF ( M.EQ.6 ) THEN
23145 V =-0.5D0*(1.D0+W)+DT_RNDM(X1)*W
23147 R = (4.D0/9.D0)*(U*U+V*V)*AXX
23148 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23149 & 'PHO_HARKIN:weight error',M
23150 IF ( R*W.LT.RM(6)*DT_RNDM(V) ) GOTO 60
23151 ELSEIF ( M.EQ.7 ) THEN
23153 V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
23155 R = (1.D0+W)*((2.D0/9.D0)*(1.D0+U*U+(1.D0+V*V)*V*V/(U*U))
23156 & -(4.D0/27.D0)*V/U)
23157 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23158 & 'PHO_HARKIN:weight error',M
23159 IF ( R*W.LT.RM(7)*DT_RNDM(X2) ) GOTO 70
23160 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23161 ELSEIF ( M.EQ.8 ) THEN
23163 V =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
23165 R = (4.D0/9.D0)*(1.D0+U*U)
23166 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23167 & 'PHO_HARKIN:weight error',M
23168 IF ( R*W.LT.RM(8)*DT_RNDM(X2) ) GOTO 80
23169 ELSEIF ( M.EQ.-1 ) THEN
23172 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
23174 R = (1.D0+V*V)*(V/(U*U)-(4.D0/9.D0))*(WL/W)*AXX
23175 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23176 & 'PHO_HARKIN:weight error',M
23177 IF ( R*W.LT.RM(-1)*DT_RNDM(X2) ) GOTO 90
23178 C------------- direct / single-resolved processes -----------
23179 ELSEIF ( M.EQ.10 ) THEN
23180 100 CALL PHO_HARDX1
23181 WL = LOG(AXX/(1.D0+W)**2)
23182 U =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
23183 R = -(8.D0/3.D0)*(U*U+1.D0)*WL*AXX
23184 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23185 & 'PHO_HARKIN:weight error',M
23186 IF ( R.LT.RM(10)*DT_RNDM(U) ) GOTO 100
23190 ELSEIF ( M.EQ.11) THEN
23191 110 CALL PHO_HARDX1
23193 U =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
23195 R = (U*U+V*V)/V*WL*AXX
23196 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23197 & 'PHO_HARKIN:weight error',M
23198 IF ( R.LT.RM(11)*DT_RNDM(X2) ) GOTO 110
23199 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23202 ELSEIF ( M.EQ.12 ) THEN
23203 120 CALL PHO_HARDX1
23204 WL = LOG(AXX/(1.D0+W)**2)
23205 V =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
23206 R = -(8.D0/3.D0)*(V*V+1.D0)*WL*AXX
23207 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23208 & 'PHO_HARKIN:weight error',M
23209 IF ( R.LT.RM(12)*DT_RNDM(V) ) GOTO 120
23210 ELSEIF ( M.EQ.13) THEN
23211 130 CALL PHO_HARDX1
23213 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
23215 R = (U*U+V*V)/U*WL*AXX
23216 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23217 & 'PHO_HARKIN:weight error',M
23218 IF ( R.LT.RM(13)*DT_RNDM(X2) ) GOTO 130
23219 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23220 C------------- (double) direct process -----------
23221 ELSEIF ((M.EQ.14).OR.(M.EQ.16)) THEN
23225 W = SQRT(MAX(TINY,1.D0-AXX))
23228 140 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
23231 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23232 & 'PHO_HARKIN:weight error',M
23233 IF ( R.LT.RM(14)*DT_RNDM(X2) ) GOTO 140
23234 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23235 C---------------------------------------------
23237 WRITE(LO,'(/1X,A,I3)')
23238 & 'PHO_HARKIN:ERROR:unsupported process (MSPR)',MSPR
23242 V = MAX(MIN(V,-TINYP ),-1.D0+TINYP)
23244 U = MAX(MIN(U,-TINYP ),-1.D0+TINYP)
23245 PT = SQRT(U*V*X1*X2)*ECMP
23246 ETAC = 0.5D0*LOG((U*X1)/(V*X2))
23247 ETAD = 0.5D0*LOG((V*X1)/(U*X2))
23249 ***************************************************************
23252 ETAMI(1,MM) = MIN(ETAMI(1,MM),ETAC)
23253 ETAMA(1,MM) = MAX(ETAMA(1,MM),ETAC)
23254 ETAMI(2,MM) = MIN(ETAMI(2,MM),ETAD)
23255 ETAMA(2,MM) = MAX(ETAMA(2,MM),ETAD)
23256 XXMI(1,MM) = MIN(XXMI(1,MM),X1)
23257 XXMA(1,MM) = MAX(XXMA(1,MM),X1)
23258 XXMI(2,MM) = MIN(XXMI(2,MM),X2)
23259 XXMA(2,MM) = MAX(XXMA(2,MM),X2)
23260 ***************************************************************
23262 IF(IDEB(81).GE.25) WRITE(LO,'(1X,A,/5X,6E12.3)')
23263 & 'PHO_HARKIN: V,PT,ETAC,ETAD,X1,X2',V,PT,ETAC,ETAD,X1,X2
23267 *$ CREATE PHO_HARWGH.FOR
23269 CDECK ID>, PHO_HARWGH
23270 SUBROUTINE PHO_HARWGH(PDS,PDA,PDB,FDISTR)
23271 C***********************************************************************
23273 C calculate product of PDFs and coupling constants
23274 C according to selected MSPR (process type)
23278 C output: PDS resulting from PDFs alone
23279 C FDISTR complete weight function
23280 C PDA,PDB fields containing the PDFs
23282 C***********************************************************************
23283 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23286 PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
23288 C input/output channels
23290 COMMON /POINOU/ LI,LO
23291 C event debugging information
23293 PARAMETER (NMAXD=100)
23294 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
23295 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23296 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
23297 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23298 C model switches and parameters
23300 INTEGER ISWMDL,IPAMDL
23301 DOUBLE PRECISION PARMDL
23302 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
23303 C data of c.m. system of Pomeron / Reggeon exchange
23304 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23305 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23306 & SIDP,CODP,SIFP,COFP
23307 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23308 & SIDP,CODP,SIFP,COFP,NPOSP(2),
23309 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
23310 C currently activated parton density parametrizations
23312 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
23313 DOUBLE PRECISION PDFLAM,PDFQ2M
23314 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
23315 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
23316 C hard scattering parameters used for most recent hard interaction
23318 DOUBLE PRECISION ALQCD2,BQCD
23319 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
23320 C some hadron information, will be deleted in future versions
23322 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
23323 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
23324 C scale parameters for parton model calculations
23325 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
23326 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
23327 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
23328 & NQQAL,NQQALI,NQQALF,NQQPD
23329 C data on most recent hard scattering
23330 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23331 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23332 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23333 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23334 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23335 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23336 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23337 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23338 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23339 C hard cross sections and MC selection weights
23341 PARAMETER ( Max_pro_2 = 16 )
23342 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
23343 & MH_acc_1,MH_acc_2
23344 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
23345 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
23346 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
23347 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
23348 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
23349 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
23351 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
23352 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
23353 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
23355 DOUBLE PRECISION PHO_ALPHAS,pho_alphae
23356 DIMENSION PDA(-6:6),PDB(-6:6)
23359 C set hard scale QQ for alpha and partondistr.
23360 IF ( NQQAL.EQ.1 ) THEN
23362 ELSEIF ( NQQAL.EQ.2 ) THEN
23363 QQAL = AQQAL*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
23364 ELSEIF ( NQQAL.EQ.3 ) THEN
23365 QQAL = AQQAL*X1*X2*ECMP*ECMP
23366 ELSEIF ( NQQAL.EQ.4 ) THEN
23367 QQAL = AQQAL*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
23369 IF ( NQQPD.EQ.1 ) THEN
23371 ELSEIF ( NQQPD.EQ.2 ) THEN
23372 QQPD = AQQPD*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
23373 ELSEIF ( NQQPD.EQ.3 ) THEN
23374 QQPD = AQQPD*X1*X2*ECMP*ECMP
23375 ELSEIF ( NQQPD.EQ.4 ) THEN
23376 QQPD = AQQPD*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
23378 C coupling constants, PDFs
23380 ALPHA1 = PHO_ALPHAS(QQAL,3)
23382 CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
23383 CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
23384 IF ( MSPR.EQ.1 .OR. MSPR.EQ.4 ) THEN
23385 PDS = PDA(0)*PDB(0)
23392 S2 = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
23393 S3 = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
23394 S4 = S4+PDA(I)+PDA(-I)
23395 S5 = S5+PDB(I)+PDB(-I)
23397 IF ((MSPR.EQ.2).OR.(MSPR.EQ.5).OR.(MSPR.EQ.6)) THEN
23399 ELSE IF((MSPR.EQ.3).OR.(MSPR.EQ.-1)) THEN
23400 PDS = PDA(0)*S5+PDB(0)*S4
23401 ELSE IF(MSPR.EQ.7) THEN
23403 ELSE IF(MSPR.EQ.8) THEN
23404 PDS = S4*S5-(S2+S3)
23407 ELSE IF(MSPR.LT.12) THEN
23408 ALPHA2 = PHO_ALPHAS(QQAL,2)
23409 IF(IDPDG1.EQ.22) THEN
23410 ALPHA1 = pho_alphae(QQAL)
23411 ELSE IF(IDPDG1.EQ.990) THEN
23412 ALPHA1 = PARMDL(74)
23414 CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
23418 S4 = S4+PDB(I)+PDB(-I)
23420 * IF(MOD(I,2).EQ.0) THEN
23421 * S6 = S6+(PDB(I)+PDB(-I))*4.D0/9.D0
23423 * S6 = S6+(PDB(I)+PDB(-I))*1.D0/9.D0
23425 S6 = S6+(PDB(I)+PDB(-I))*Q_ch2(I)
23427 IF(MSPR.EQ.10) THEN
23428 IF(IDPDG1.EQ.990) THEN
23436 ELSE IF(MSPR.LT.14) THEN
23437 ALPHA1 = PHO_ALPHAS(QQAL,1)
23438 IF(IDPDG2.EQ.22) THEN
23439 ALPHA2 = pho_alphae(QQAL)
23440 ELSE IF(IDPDG2.EQ.990) THEN
23441 ALPHA2 = PARMDL(74)
23443 CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
23447 S4 = S4+PDA(I)+PDA(-I)
23449 * IF(MOD(I,2).EQ.0) THEN
23450 * S6 = S6+(PDA(I)+PDA(-I))*4.D0/9.D0
23452 * S6 = S6+(PDA(I)+PDA(-I))*1.D0/9.D0
23454 S6 = S6+(PDA(I)+PDA(-I))*Q_ch2(I)
23456 IF(MSPR.EQ.12) THEN
23457 IF(IDPDG2.EQ.990) THEN
23465 ELSE IF(MSPR.EQ.14) THEN
23466 SSR = X1*X2*ECMP*ECMP
23467 IF(IDPDG1.EQ.22) THEN
23468 ALPHA1 = pho_alphae(SSR)
23469 ELSE IF(IDPDG1.EQ.990) THEN
23470 ALPHA1 = PARMDL(74)
23472 IF(IDPDG2.EQ.22) THEN
23473 ALPHA2 = pho_alphae(SSR)
23474 ELSE IF(IDPDG2.EQ.990) THEN
23475 ALPHA2 = PARMDL(74)
23479 WRITE(LO,'(/1X,A,I4)')
23480 & 'PHO_HARWGH:ERROR: invalid hard process number (MSPR)',MSPR
23485 FDISTR = HFac(MSPR)*ALPHA1*ALPHA2*PDS
23488 IF(IDEB(15).GE.20) WRITE(LO,'(1X,A,/5X,I3,2I6,4E10.3)')
23489 & 'PHO_HARWGH: MSPR,ID1,ID2,AL1,AL2,PDS,FDIS',
23490 & MSPR,IDPDG1,IDPDG2,ALPHA1,ALPHA2,PDS,FDISTR
23494 *$ CREATE PHO_HARSCA.FOR
23496 CDECK ID>, PHO_HARSCA
23497 SUBROUTINE PHO_HARSCA(IMODE,IP)
23498 C***********************************************************************
23500 C PHO_HARSCA determines the type of hard subprocess, the partons
23501 C taking part in this subprocess and the kinematic variables
23503 C input: IMODE 1 direct processes
23504 C 2 resolved processes
23505 C -1 initialization
23506 C -2 output of statistics
23507 C IP 1-4 particle combination (hadron/photon)
23509 C***********************************************************************
23510 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23513 PARAMETER( EPS = 1.D-10,
23516 C input/output channels
23518 COMMON /POINOU/ LI,LO
23519 C event debugging information
23521 PARAMETER (NMAXD=100)
23522 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
23523 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23524 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
23525 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23526 C model switches and parameters
23528 INTEGER ISWMDL,IPAMDL
23529 DOUBLE PRECISION PARMDL
23530 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
23531 C internal rejection counters
23533 PARAMETER (NMXJ=60)
23534 CHARACTER*10 REJTIT
23536 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
23537 C hard scattering parameters used for most recent hard interaction
23539 DOUBLE PRECISION ALQCD2,BQCD
23540 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
23541 C data of c.m. system of Pomeron / Reggeon exchange
23542 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23543 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23544 & SIDP,CODP,SIFP,COFP
23545 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23546 & SIDP,CODP,SIFP,COFP,NPOSP(2),
23547 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
23548 C names of hard scattering processes
23550 PARAMETER ( Max_pro_1 = 16 )
23552 COMMON /POHPRO/ PROC(0:Max_pro_1)
23553 C data on most recent hard scattering
23554 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23555 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23556 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23557 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23558 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23559 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23560 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23561 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23562 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23563 C hard scattering data
23565 PARAMETER ( MSCAHD = 50 )
23566 INTEGER LSCAHD,LSC1HD,LSIDX,
23567 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
23568 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
23569 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
23570 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
23571 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
23572 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
23573 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
23574 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
23575 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
23576 C hard cross sections and MC selection weights
23578 PARAMETER ( Max_pro_2 = 16 )
23579 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
23580 & MH_acc_1,MH_acc_2
23581 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
23582 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
23583 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
23584 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
23585 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
23586 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
23588 INTEGER IPFIL,IFAFIL,IFBFIL
23589 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
23590 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
23591 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
23592 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
23593 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
23594 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
23595 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
23596 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
23597 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
23598 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
23599 & IPFIL,IFAFIL,IFBFIL
23601 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
23602 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
23603 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
23607 C resolved processes
23608 IF(IMODE.EQ.2) THEN
23610 MH_pro_on(0,IP) = 0
23613 IF(MH_pro_on(M,IP).EQ.1) HWgx(9) = HWgx(9)+HWgx(M)
23615 IF(HWgx(9).LT.DEPS) THEN
23616 WRITE(LO,'(/1X,2A,I4,1P,E12.4)') 'PHO_HARSCA:ERROR: ',
23617 & 'no resolved process possible for IP',IP,HWgx(9)
23621 C ----------------------------------------------I
23622 C begin of iteration loop (resolved processes) I
23627 IF(IREJSC.GT.1000) THEN
23628 WRITE(LO,'(/1X,A,I10)')
23629 & 'PHO_HARSCA:ERROR: too many rejections (resolved)',IREJSC
23634 B = DT_RNDM(X1)*HWgx(9)
23638 IF ( MH_pro_on(MSPR,IP).EQ.1 ) SUM = SUM+HWgx(MSPR)
23639 IF ( SUM.LT.B .AND. MSPR.LT.8 ) GOTO 20
23641 IF(IDEB(78).GE.20) WRITE(LO,'(1x,a,i3,i6)')
23642 & 'PHO_HARSCA: resolved process (MSPR,IREJSC)',MSPR,IREJSC
23644 C find kin. variables X1,X2 and V
23645 CALL PHO_HARKIN(IREJ)
23647 IFAIL(29) = IFAIL(29)+1
23650 C calculate remaining distribution
23651 CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
23652 C actualize counter for cross-section calculation
23653 if(F.LE.1.D-15) then
23657 * XSECT(5,MSPR) = XSECT(5,MSPR)+F
23658 * XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
23659 MH_tried(MSPR,IP) = MH_tried(MSPR,IP)+1
23660 C check F against FMAX
23661 WEIGHT = F/(HWgx(MSPR)+DEPS)
23662 IF ( WEIGHT.LT.DT_RNDM(X2) ) GOTO 10
23663 C-------------------------------------------------------------------
23664 IF(WEIGHT.GT.1.D0) THEN
23665 WRITE(LO,1234) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR),WEIGHT
23666 1234 FORMAT(/,' PHO_HARSCA: (resolved) W>1 (MSPR,IP,ID1,2)',
23667 & 2I3,2I7,/' F,HWgx(MSPR),W',3E12.4)
23668 WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
23669 & ECMP,PTWANT,AS,AH,PT
23670 WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
23671 & ETAC,ETAD,X1,X2,V
23672 CALL PHO_PREVNT(-1)
23674 C-------------------------------------------------------------------
23676 C end of iteration loop (resolved processes) I
23677 C --------------------------------------------I
23679 C*********************************************************************
23683 ELSE IF(IMODE.EQ.1) THEN
23685 C single-resolved processes kinematically forbidden
23686 if(Z1DIF.lt.0.D0) then
23694 if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
23696 IF(MH_pro_on(M,IP).EQ.1) then
23697 if((M.eq.10).or.(M.eq.11)) then
23698 fac = FSUH(1)*FSUP(2)
23699 else if((M.eq.12).or.(M.eq.13)) then
23700 fac = FSUP(1)*FSUH(2)
23702 fac = FSUH(1)*FSUH(2)
23704 HWgx(15) = HWgx(15)+HWgx(M)*fac
23709 IF(MH_pro_on(M,IP).EQ.1) HWgx(15)=HWgx(15)+HWgx(M)
23712 IF(HWgx(15).LT.DEPS) THEN
23713 WRITE(LO,'(/1X,2A,I4)') 'PHO_HARSCA:ERROR: ',
23714 & 'no direct/single-resolved process possible (IP)',IP
23718 C ----------------------------------------------I
23719 C begin of iteration loop (direct processes) I
23724 IF(IREJSC.GT.1000) THEN
23725 WRITE(LO,'(/1X,A,I10)')
23726 & 'PHO_HARSCA:ERROR: too many rejections (direct)',IREJSC
23731 B = DT_RNDM(X1)*HWgx(15)
23734 if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
23737 IF(MH_pro_on(MSPR,IP).EQ.1) then
23738 if((MSPR.eq.10).or.(MSPR.eq.11)) then
23739 fac = FSUH(1)*FSUP(2)
23740 else if((MSPR.eq.12).or.(MSPR.eq.13)) then
23741 fac = FSUP(1)*FSUH(2)
23743 fac = FSUH(1)*FSUH(2)
23745 SUM = SUM+HWgx(MSPR)*fac
23747 IF ( SUM.LT.B .AND. MSPR.LT.14 ) GOTO 150
23751 IF(MH_pro_on(MSPR,IP).EQ.1) SUM = SUM+HWgx(MSPR)
23752 IF ( SUM.LT.B .AND. MSPR.LT.14 ) GOTO 200
23755 IF(IDEB(78).GE.20) WRITE(LO,'(1x,a,i3,i6)')
23756 & 'PHO_HARSCA: direct process (MSPR,IREJSC)',MSPR,IREJSC
23758 C find kin. variables X1,X2 and V
23759 CALL PHO_HARKIN(IREJ)
23761 IFAIL(28) = IFAIL(28)+1
23765 C calculate remaining distribution
23766 CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
23768 C counter for cross-section calculation
23769 if(F.LE.1.D-15) then
23773 * XSECT(5,MSPR) = XSECT(5,MSPR)+F
23774 * XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
23775 MH_tried(MSPR,IP) = MH_tried(MSPR,IP)+1
23776 C check F against FMAX
23777 WEIGHT = F/(HWgx(MSPR)+DEPS)
23778 IF(WEIGHT.LT.DT_RNDM(X2)) GOTO 100
23779 C-------------------------------------------------------------------
23780 IF(WEIGHT.GT.1.D0) THEN
23781 WRITE(LO,1235) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR),WEIGHT
23782 1235 FORMAT(/,' PHO_HARSCA: (direct) W>1 (MSPR,IP,ID1,2)',
23783 & 2I3,2I7,/,' F,HWgx(MSPR),W',3E12.4)
23784 WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
23785 & ECMP,PTWANT,AS,AH,PT
23786 WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
23787 & ETAC,ETAD,X1,X2,V
23788 CALL PHO_PREVNT(-1)
23790 C-------------------------------------------------------------------
23792 C end of iteration loop (direct processes) I
23793 C --------------------------------------------I
23795 ELSE IF(IMODE.EQ.-1) THEN
23797 C initialize cross section calculations
23799 DO 40 M=-1,Max_pro_2
23801 * XSECT(I,M) = 0.D0
23810 IF(IDEB(78).GE.0) THEN
23811 WRITE(LO,'(/1X,A,/1X,A)')
23812 & 'PHO_HARSCA: activated hard processes',
23813 & '------------------------------------'
23814 WRITE(LO,'(5X,A)') 'PROCESS, IP= 1 ... 4 (on/off)'
23815 DO 42 M=1,Max_pro_2
23816 WRITE(LO,'(1X,I3,5X,A,4I3)') M,PROC(M),
23817 & (MH_pro_on(M,J),J=1,4)
23822 ELSE IF(IMODE.EQ.-2) THEN
23824 C calculation of process statistics
23838 MH_tried(3,K) = MH_tried(3,K)+MH_tried(-1,K)
23839 MH_acc_1(3,K) = MH_acc_1(3,K)+MH_acc_1(-1,K)
23840 MH_acc_2(3,K) = MH_acc_2(3,K)+MH_acc_2(-1,K)
23843 MH_tried(9,K) = MH_tried(9,K)+MH_tried(M,K)
23844 MH_acc_1(9,K) = MH_acc_1(9,K)+MH_acc_1(M,K)
23845 MH_acc_2(9,K) = MH_acc_2(9,K)+MH_acc_2(M,K)
23848 MH_tried(15,K) = MH_tried(15,K)+MH_tried(M,K)
23849 MH_acc_1(15,K) = MH_acc_1(15,K)+MH_acc_1(M,K)
23850 MH_acc_2(15,K) = MH_acc_2(15,K)+MH_acc_2(M,K)
23852 MH_tried(0,K) = MH_tried(9,K)+MH_tried(15,K)
23853 MH_acc_1(0,K) = MH_acc_1(9,K)+MH_acc_1(15,K)
23854 MH_acc_2(0,K) = MH_acc_2(9,K)+MH_acc_2(15,K)
23857 IF(IDEB(78).GE.1) THEN
23858 WRITE(LO,'(/1X,A,/1X,A)')
23859 & 'PHO_HARSCA: internal rejection statistics',
23860 & '-----------------------------------------'
23862 IF(MH_tried(0,K).GT.0) THEN
23863 WRITE(LO,'(5X,A,I3)')
23864 & 'process (sampled/accepted) for IP:',K
23866 WRITE(LO,'(1X,I3,1X,A,2X,3I12,F10.4)') M,PROC(M),
23867 & MH_tried(M,K),MH_acc_1(M,K),MH_acc_2(K,K),
23868 & dble(MH_acc_1(M,K))/dble(max(1,MH_tried(M,K)))
23876 WRITE(LO,'(/1X,2A,I10)') 'PHO_HARSCA:ERROR: ',
23877 & 'unsupported mode',IMODE
23881 C the event is accepted now
23882 C actualize counter for accepted events
23883 MH_acc_1(MSPR,IP) = MH_acc_1(MSPR,IP)+1
23884 IF(MSPR.EQ.-1) MSPR = 3
23886 C find flavor of initial partons
23889 SCHECK = DT_RNDM(SUM)*PDS-EPS
23890 IF ( MSPR.EQ.1 .OR. MSPR.EQ.4 ) THEN
23893 ELSEIF ( MSPR.EQ.2 .OR. MSPR.EQ.5 .OR. MSPR.EQ.6 ) THEN
23895 IF ( IA.EQ.0 ) GOTO 610
23896 SUM = SUM+PDF1(IA)*PDF2(-IA)
23897 IF ( SUM.GE.SCHECK ) GOTO 620
23900 ELSEIF ( MSPR.EQ.3 ) THEN
23903 IF ( IA.EQ.0 ) GOTO 630
23904 SUM = SUM+PDF1(0)*PDF2(IA)
23905 IF ( SUM.GE.SCHECK ) GOTO 640
23906 SUM = SUM+PDF1(IA)*PDF2(0)
23907 IF ( SUM.GE.SCHECK ) GOTO 650
23912 ELSEIF ( MSPR.EQ.7 ) THEN
23914 IF ( IA.EQ.0 ) GOTO 660
23915 SUM = SUM+PDF1(IA)*PDF2(IA)
23916 IF ( SUM.GE.SCHECK ) GOTO 670
23919 ELSEIF ( MSPR.EQ.8 ) THEN
23921 IF ( IA.EQ.0 ) GOTO 690
23923 IF ( ABS(IB).EQ.ABS(IA) .OR. IB.EQ.0 ) GOTO 680
23924 SUM = SUM+PDF1(IA)*PDF2(IB)
23925 IF ( SUM.GE.SCHECK ) GOTO 700
23929 ELSEIF ( MSPR.EQ.10 ) THEN
23932 IF ( IB.NE.0 ) THEN
23933 IF(IDPDG1.EQ.22) THEN
23934 * IF(MOD(ABS(IB),2).EQ.0) THEN
23935 * SUM = SUM+PDF2(IB)*4.D0/9.D0
23937 * SUM = SUM+PDF2(IB)*1.D0/9.D0
23939 SUM = SUM+PDF2(IB)*Q_ch2(IB)
23943 IF ( SUM.GE.SCHECK ) GOTO 720
23947 ELSEIF ( MSPR.EQ.12 ) THEN
23950 IF ( IA.NE.0 ) THEN
23951 IF(IDPDG2.EQ.22) THEN
23952 * IF(MOD(ABS(IA),2).EQ.0) THEN
23953 * SUM = SUM+PDF1(IA)*4.D0/9.D0
23955 * SUM = SUM+PDF1(IA)*1.D0/9.D0
23957 SUM = SUM+PDF1(IA)*Q_ch2(IA)
23961 IF ( SUM.GE.SCHECK ) GOTO 820
23965 ELSEIF ((MSPR.EQ.11).OR.(MSPR.EQ.13).OR.(MSPR.EQ.14)) THEN
23970 IF((ABS(IA).GT.NF).OR.(ABS(IB).GT.NF)) THEN
23971 write(LO,*) 'PHO_HARSCA: rejection, final check IA,IB',IA,IB
23972 write(LO,*) 'EVENT,MSPR,IA,IB,NF: ',KEVENT,MSPR,IA,IB,NF
23976 C find flavour of final partons
23980 IF ( MSPR.EQ.2 ) THEN
23983 ELSEIF ( MSPR.EQ.4 ) THEN
23984 IC = INT(FLOAT(NF+NF)*DT_RNDM(SUM))+1
23985 IF ( IC.GT.NF ) IC = NF-IC
23987 ELSEIF ( MSPR.EQ.6 ) THEN
23988 IC = INT(FLOAT(NF+NF-2)*DT_RNDM(SUM))+1
23989 IF ( IC.GT.NF-1 ) IC = NF-1-IC
23990 IF ( ABS(IC).EQ.ABS(IA) ) IC = SIGN(NF,IC)
23992 ELSEIF ( MSPR.EQ.11) THEN
23995 IF ( IC.NE.0 ) THEN
23996 IF(IDPDG1.EQ.22) THEN
23997 * IF(MOD(ABS(IC),2).EQ.0) THEN
24002 SUM = SUM + Q_ch2(IC)
24008 SCHECK = DT_RNDM(SUM)*SUM-EPS
24011 IF ( IC.NE.0 ) THEN
24012 IF(IDPDG1.EQ.22) THEN
24013 * IF(MOD(ABS(IC),2).EQ.0) THEN
24018 SUM = SUM + Q_ch2(IC)
24022 IF ( SUM.GE.SCHECK ) GOTO 750
24027 ELSEIF ( MSPR.EQ.12) THEN
24030 ELSEIF ( MSPR.EQ.13) THEN
24033 IF ( IC.NE.0 ) THEN
24034 IF(IDPDG2.EQ.22) THEN
24035 * IF(MOD(ABS(IC),2).EQ.0) THEN
24040 SUM = SUM + Q_ch2(IC)
24046 SCHECK = DT_RNDM(SUM)*SUM-EPS
24049 IF ( IC.NE.0 ) THEN
24050 IF(IDPDG2.EQ.22) THEN
24051 * IF(MOD(ABS(IC),2).EQ.0) THEN
24056 SUM = SUM + Q_ch2(IC)
24060 IF ( SUM.GE.SCHECK ) GOTO 850
24065 ELSEIF ( MSPR.EQ.14) THEN
24070 IF(MOD(ABS(IC),2).EQ.0) THEN
24071 IF(IDPDG1.EQ.22) FAC1 = 4.D0
24072 IF(IDPDG2.EQ.22) FAC2 = 4.D0
24074 SUM = SUM + FAC1*FAC2
24076 IF(IPAMDL(64).NE.0) THEN
24077 IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) SUM = SUM + 81.D0
24079 SCHECK = DT_RNDM(SUM)*SUM-EPS
24084 IF(MOD(ABS(IC),2).EQ.0) THEN
24085 IF(IDPDG1.EQ.22) FAC1 = 4.D0
24086 IF(IDPDG2.EQ.22) FAC2 = 4.D0
24088 SUM = SUM + FAC1*FAC2
24089 IF ( SUM.GE.SCHECK ) GOTO 950
24094 IF(DT_RNDM(FAC1).GT.0.5D0) CALL PHO_SWAPI(IC,ID)
24099 XM3 = PHO_PMASS(IC,3)
24104 XM4 = PHO_PMASS(ID,3)
24106 IF(ABS(IC).EQ.15) GOTO 955
24108 C valence quarks involved?
24111 IF(IDPDG1.EQ.22) THEN
24112 CALL PHO_QPMPDF(IA,X1,QQPD,0.D0,PVIRTP(1),FXP)
24113 IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(IA)-FXP) IV1 = 1
24115 IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(-IA)) IV1 = 1
24120 IF(IDPDG2.EQ.22) THEN
24121 CALL PHO_QPMPDF(IB,X2,QQPD,0.D0,PVIRTP(2),FXP)
24122 IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(IB)-FXP) IV2 = 1
24124 IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(-IB)) IV2 = 1
24128 C fill event record
24131 CALL PHO_SFECFE(SINPHI,COSPHI)
24145 PHO1(1) = PT*COSPHI
24146 PHO1(2) = PT*SINPHI
24147 PHO1(3) = -ECM2*(U*X1-V*X2)
24148 PHO1(4) = -ECM2*(U*X1+V*X2)
24152 PHO2(3) = -ECM2*(V*X1-U*X2)
24153 PHO2(4) = -ECM2*(V*X1+U*X2)
24156 C convert to mass shell
24157 CALL PHO_MSHELL(PHO1,PHO2,XM3,XM4,PHO1,PHO2,IREJ)
24159 IF(IDEB(78).GE.5) WRITE(LO,'(1X,A,1P,3E11.3)')
24160 & 'PHO_HARSCA: rejection by PHO_MSHELL (PT,M1,M2)',
24164 PTfin = SQRT(PHO1(1)**2+PHO1(2)**2)
24167 IF(IDEB(78).GE.20) THEN
24168 SHAT = X1*X2*ECMP*ECMP
24169 WRITE(LO,'(1X,A,5I4)') 'PHO_HARSCA: MSPR,IA,IB,IC,ID',
24171 WRITE(LO,'(5X,A,1P,4E11.3)') 'X1/2,MU2,Q2 ',X1,X2,QQPD,QQAL
24172 WRITE(LO,'(5X,A,1P,4E11.3)') 'U,V,PT,SHAT ',U,V,PT,SHAT
24173 WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI1 ',PHI1
24174 WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI2 ',PHI2
24175 WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO1 ',PHO1
24176 WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO2 ',PHO2
24181 *$ CREATE PHO_HARFAC.FOR
24183 CDECK ID>, PHO_HARFAC
24184 SUBROUTINE PHO_HARFAC(PTCUT,ECMI)
24185 C*********************************************************************
24187 C initialization: find scaling factors and maxima of remaining
24190 C input: PTCUT transverse momentum cutoff
24193 C output: Hfac(-1:Max_pro_2) field for sampling hard processes
24195 C*********************************************************************
24196 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24199 PARAMETER ( MXABWT = 96 )
24201 C input/output channels
24203 COMMON /POINOU/ LI,LO
24204 C data of c.m. system of Pomeron / Reggeon exchange
24205 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
24206 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
24207 & SIDP,CODP,SIFP,COFP
24208 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
24209 & SIDP,CODP,SIFP,COFP,NPOSP(2),
24210 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
24212 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
24213 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
24214 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
24215 C hard scattering parameters used for most recent hard interaction
24217 DOUBLE PRECISION ALQCD2,BQCD
24218 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
24219 C integration precision for hard cross sections (obsolete)
24220 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
24221 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
24222 C data on most recent hard scattering
24223 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24224 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24225 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24226 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24227 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24228 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24229 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24230 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24231 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24232 C hard cross sections and MC selection weights
24234 PARAMETER ( Max_pro_2 = 16 )
24235 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
24236 & MH_acc_1,MH_acc_2
24237 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
24238 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
24239 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
24240 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
24241 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24242 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24244 DIMENSION ABSZ(MXABWT),WEIG(MXABWT)
24245 DIMENSION S(-1:Max_pro_2),S1(-1:Max_pro_2),S2(-1:Max_pro_2),
24246 & F124(-1:Max_pro_2)
24247 DATA F124 / 1.D0,0.D0,
24248 & 4.D0,2.D0,2.D0,2.D0,4.D0,1.D0,4.D0,4.D0,0.D0,1.D0,
24249 & 2.D0,1.D0,2.D0,1.D0,0.D0,1.D0 /
24252 AH = (2.D0*PTCUT/ECMI)**2
24256 CALL PHO_GAUSET(0.D0,1.D0,NPOINT,ABSZ,WEIG)
24257 DO 10 M=-1,Max_pro_2
24261 C resolved processes
24270 Z2 = (1.D0-Z1)*ABSZ(I2)
24273 W = SQRT(1.D0-FAXX)
24283 VA =-0.5D0*W1/(W1+Z*W)
24285 VB =-0.5D0*FAXX/(W1+2.D0*W*Z)
24287 VC =-EXP(HLN+Z*WLOG)
24289 VE =-0.5D0*(1.D0+W)+Z*W
24291 S(1) = S(1)+(1.+W)*2.25*(VA*VA*(3.-UA*VA-VA/(UA*UA))-UA)*
24293 S(2) = S(2)+(VC*VC+UC*UC)*((16./27.)/UC-(4./3.)*VC)*FWW*
24295 S(3) = S(3)+(1.+W)*(1.+UA*UA)*(1.-(4./9.)*VA*VA/UA)*WEIG(I)
24296 S(5) = S(5)+((4./9.)*(1.+UB*UB+(UB*UB+VB*VB)*VB*VB)-
24297 & (8./27.)*UA*UA*VA)*WEIG(I)
24298 S(6) = S(6)+(4./9.)*(UE*UE+VE*VE)*FAXX*WEIG(I)
24299 S(7) = S(7)+(1.+W)*((2./9.)*(1.+UA*UA+(1.+VA*VA)*VA*VA/
24300 & (UA*UA))-(4./27.)*VA/UA)*WEIG(I)
24301 S(8) = S(8)+(4./9.)*(1.+UB*UB)*WEIG(I)
24302 S(-1) = S(-1)+(1.+VC*VC)*(VC/(UC*UC)-(4./9.))*FWW*WEIG(I)
24304 S(4) = S(2)*(9./32.)
24306 S2(M) = S2(M)+S(M)*WEIG(I2)*W
24310 S1(M) = S1(M)+S2(M)*(1.D0-Z1)*WEIG(I1)
24314 S1(6) = S1(6)*MAX(0,NF-1)
24317 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
24318 & .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24323 W = SQRT(1.D0-FAXX)
24326 WL = LOG(FAXX/(1.D0+W)**2)
24328 FWW2 = FAXX*WLOG/ALN
24335 UA =-(1.D0+W)/2.D0*EXP(Z*WL)
24337 VB =-EXP(HLN+Z*WLOG)
24339 S(10) = S(10)+(8.D0/3.D0)*(1.D0+UA*UA)*WEIG(I)*FWW1
24340 S(11) = S(11)-(VB*VB+UB*UB)/UB*WEIG(I)*FWW2
24343 S1(M) = S1(M)+S(M)*WEIG(I1)
24348 C quark charges fractions
24349 IF(IDPDG1.EQ.22) THEN
24352 CHRNF = CHRNF + Q_ch2(I)
24354 S1(11) = S1(11)*CHRNF
24355 ELSE IF(IDPDG1.EQ.990) THEN
24360 IF(IDPDG2.EQ.22) THEN
24363 CHRNF = CHRNF + Q_ch2(I)
24365 S1(13) = S1(13)*CHRNF
24366 ELSE IF(IDPDG2.EQ.990) THEN
24374 FFF = PI*GEV2MB*ALN*ALN/(AH*SS)
24375 DO 90 M=-1,Max_pro_2
24376 Hfac(M) = MAX(FFF*F124(M)*S1(M),0.D0)
24379 C double direct process
24380 IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
24381 & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
24384 IF(IDPDG1.EQ.22) THEN
24389 IF(IDPDG2.EQ.22) THEN
24394 FAC = FAC+F1*F2*3.D0
24396 ZZ = SQRT(1.D0-4.D0*PTCUT*PTCUT/SS)
24397 Hfac(14) = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)
24402 *$ CREATE PHO_HARWGX.FOR
24404 CDECK ID>, PHO_HARWGX
24405 SUBROUTINE PHO_HARWGX(PTCUT,ECM)
24406 C**********************************************************************
24408 C find maximum of remaining weight for MC sampling
24410 C input: PTCUT transverse momentum cutoff
24413 C output: HWgx(-1:Max_pro_2) field for sampling hard processes
24415 C**********************************************************************
24416 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24419 PARAMETER ( NKM = 10 )
24420 PARAMETER ( TINY = 1.D-20 )
24422 C input/output channels
24424 COMMON /POINOU/ LI,LO
24425 C event debugging information
24427 PARAMETER (NMAXD=100)
24428 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24429 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24430 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24431 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24432 C data on most recent hard scattering
24433 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24434 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24435 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24436 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24437 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24438 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24439 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24440 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24441 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24442 C hard cross sections and MC selection weights
24444 PARAMETER ( Max_pro_2 = 16 )
24445 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
24446 & MH_acc_1,MH_acc_2
24447 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
24448 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
24449 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
24450 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
24451 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24452 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24454 DIMENSION Z(3),D(3),FF(0:NKM),PDA(-6:6),PDB(-6:6),XM1(NKM),
24455 & XM2(NKM),PTM(NKM),ZMX(3,NKM),DMX(3,NKM),IMX(NKM),IPO(NKM)
24456 DIMENSION IFTAB(-1:Max_pro_2)
24457 DATA IFTAB / 4,0,1,2,4,1,2,2,3,5,0,6,7,8,9,10,0,10 /
24460 AH = (2.D0*PTCUT/ECM)**2
24482 C start configuration
24484 Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24490 ELSE IF(IST.EQ.2) THEN
24497 ELSE IF(IST.EQ.3) THEN
24498 Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24504 ELSE IF(IST.EQ.4) THEN
24505 Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24513 CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F2)
24514 C process possible?
24515 IF(F2.LE.0.D0) GOTO 35
24523 CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
24524 IF ( F2.GT.F3 ) Z(I) = Z(I)-D(I)
24525 IF ( F2.GT.F3 ) D(I) =-D(I)
24530 CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
24531 IF ( F3.GT.F2 ) GOTO 20
24533 Z(I) = ZZ+0.5*D(I)*(F3-F1)/MAX(TINY,F2+F2-F1-F3)
24534 IF ( ABS(ZZ-Z(I)).GT.D(I)*0.1D0 )
24535 & CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F1)
24536 IF ( F1.LE.F2 ) Z(I) = ZZ
24539 IF((ABS(FOLD-F2)/MAX(TINY,F2).GT.0.002D0).OR.(IT.LT.3)) GOTO 10
24541 IF(F2.GT.FF(NKON)) THEN
24542 FF(NKON) = MAX(F2,0.D0)
24561 IF(IDEB(38).GE.5) THEN
24562 WRITE(LO,'(/1X,A)')
24563 & 'PHO_HARWGX: maximum of weight (I,IT,IS,FF,Z(1-3),D(1-3))'
24565 IF(IMX(I).NE.0) WRITE(LO,'(1X,I2,I3,I2,7E10.3)') I,IMX(I),
24566 & IPO(I),FF(I),ZMX(1,I),ZMX(2,I),ZMX(3,I),DMX(1,I),
24567 & DMX(2,I),DMX(3,I)
24571 DO 70 I=-1,Max_pro_2
24572 HWgx(I) = MAX(FF(IFTAB(I))*Hfac(I),0.D0)
24576 IF(IDEB(38).GE.5) THEN
24577 WRITE(LO,'(/1X,A)') 'PHO_HARWGX: total weights'
24578 WRITE(LO,'(5X,A)') 'I X1 X2 PT HWgx(I) FDIS'
24579 DO 80 I=-1,Max_pro_2
24580 IF((IFTAB(I).NE.0).AND.(HWgx(I).GT.0.D0)) THEN
24582 X1 = MIN(XM1(IFTAB(I)),0.9999999999D0)
24583 X2 = MIN(XM2(IFTAB(I)),0.9999999999D0)
24585 CALL PHO_HARWGH(PDS,PDA,PDB,FDIS)
24586 WRITE(LO,'(1X,I3,5E12.3)') I,X1,X2,PT,HWgx(I),FDIS
24593 *$ CREATE PHO_HARWGI.FOR
24595 CDECK ID>, PHO_HARWGI
24596 SUBROUTINE PHO_HARWGI(ECMX,PTCUT,NKON,Z,FDIS)
24597 C**********************************************************************
24599 C auxiliary subroutine to find maximum of remaining weight
24601 C input: ECMX current CMS energy
24602 C PTCUT current pt cutoff
24603 C NKON process label 1..5 resolved
24604 C 6..7 direct particle 1
24605 C 8..9 direct particle 2
24607 C Z(3) transformed variable
24609 C output: remaining weight
24611 C**********************************************************************
24612 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24617 PARAMETER ( NKM = 10 )
24618 PARAMETER ( TINY = 1.D-30,
24621 C input/output channels
24623 COMMON /POINOU/ LI,LO
24624 C event debugging information
24626 PARAMETER (NMAXD=100)
24627 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24628 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24629 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24630 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24631 C model switches and parameters
24633 INTEGER ISWMDL,IPAMDL
24634 DOUBLE PRECISION PARMDL
24635 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24636 C data of c.m. system of Pomeron / Reggeon exchange
24637 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
24638 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
24639 & SIDP,CODP,SIFP,COFP
24640 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
24641 & SIDP,CODP,SIFP,COFP,NPOSP(2),
24642 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
24643 C currently activated parton density parametrizations
24645 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
24646 DOUBLE PRECISION PDFLAM,PDFQ2M
24647 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
24648 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
24649 C hard scattering parameters used for most recent hard interaction
24651 DOUBLE PRECISION ALQCD2,BQCD
24652 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
24653 C some hadron information, will be deleted in future versions
24655 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
24656 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
24657 C scale parameters for parton model calculations
24658 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24659 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24660 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24661 & NQQAL,NQQALI,NQQALF,NQQPD
24662 C data on most recent hard scattering
24663 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24664 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24665 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24666 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24667 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24668 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24669 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24670 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24671 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24673 DOUBLE PRECISION PHO_ALPHAS,pho_alphae
24674 DIMENSION F(NKM),PDA(-6:6),PDB(-6:6)
24678 IF(IDEB(64).GE.25) WRITE(LO,'(1X,A,/5X,5E12.3,I5)')
24679 & 'PHO_HARWGI: ECM,PT,Z,NK',ECMX,PTCUT,Z,NKON
24680 C check input values
24681 IF ( Z(1).LT.0.D0 .OR. Z(1).GT.1.D0 ) RETURN
24682 IF ( Z(2).LT.0.D0 .OR. Z(2).GT.1.D0 ) RETURN
24683 IF ( Z(3).LT.0.D0 .OR. Z(3).GT.1.D0 ) RETURN
24685 Y1 = EXP(ALNH*Z(1))
24687 C resolved kinematic
24688 Y2 =-(1.D0-Y1)+2.D0*(1.D0-Y1)*Z(2)
24689 X1 = 0.5D0*(Y2+SQRT(Y2*Y2+4.D0*Y1))
24691 X1 = MIN(X1,0.999999999999D0)
24692 X2 = MIN(X2,0.999999999999D0)
24693 ELSE IF(NKON.LE.7) THEN
24694 C direct kinematic 1
24696 X2 = MIN(Y1,0.999999999999D0)
24697 ELSE IF(NKON.LE.9) THEN
24698 C direct kinematic 2
24699 X1 = MIN(Y1,0.999999999999D0)
24702 C double direct kinematic
24706 W = SQRT(MAX(TINY,1.D0-AH/Y1))
24707 V =-0.5D0+W*(Z(3)-0.5D0)
24709 PT = MAX(SQRT(U*V*Y1*ECMX*ECMX),PTCUT)
24711 C set hard scale QQ for alpha and partondistr.
24712 IF ( NQQAL.EQ.1 ) THEN
24714 ELSEIF ( NQQAL.EQ.2 ) THEN
24715 QQAL = AQQAL*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
24716 ELSEIF ( NQQAL.EQ.3 ) THEN
24717 QQAL = AQQAL*Y1*ECMX*ECMX
24718 ELSEIF ( NQQAL.EQ.4 ) THEN
24719 QQAL = AQQAL*Y1*ECMX*ECMX*(U*V)**(1./3.)
24721 IF ( NQQPD.EQ.1 ) THEN
24723 ELSEIF ( NQQPD.EQ.2 ) THEN
24724 QQPD = AQQPD*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
24725 ELSEIF ( NQQPD.EQ.3 ) THEN
24726 QQPD = AQQPD*Y1*ECMX*ECMX
24727 ELSEIF ( NQQPD.EQ.4 ) THEN
24728 QQPD = AQQPD*Y1*ECMX*ECMX*(U*V)**(1./3.)
24735 C resolved processes
24736 ALPHA1 = PHO_ALPHAS(QQAL,3)
24738 CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
24739 CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
24740 C calculate full distribution FDIS
24742 F(2) = F(2)+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
24743 F(3) = F(3)+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
24744 F(4) = F(4)+PDA(I)+PDA(-I)
24745 F(5) = F(5)+PDB(I)+PDB(-I)
24747 F(1) = PDA(0)*PDB(0)
24748 T = PDA(0)*F(5)+PDB(0)*F(4)
24749 F(5) = F(4)*F(5)-(F(2)+F(3))
24751 ELSE IF(NKON.LE.7) THEN
24752 C direct processes particle 1
24753 IF(IDPDG1.EQ.22) THEN
24754 ALPHA1 = pho_alphae(QQAL)
24757 ELSE IF(IDPDG1.EQ.990) THEN
24758 ALPHA1 = PARMDL(74)
24765 ALPHA2 = PHO_ALPHAS(QQAL,2)
24766 CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
24769 F(6) = F(6)+(PDB(I)+PDB(-I))*(CH1-CH2*MOD(I,2))
24772 ELSE IF(NKON.LE.9) THEN
24773 C direct processes particle 2
24774 ALPHA1 = PHO_ALPHAS(QQAL,1)
24775 IF(IDPDG2.EQ.22) THEN
24776 ALPHA2 = pho_alphae(QQAL)
24779 ELSE IF(IDPDG2.EQ.990) THEN
24780 ALPHA2 = PARMDL(74)
24787 CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
24790 F(8) = F(8)+(PDA(I)+PDA(-I))*(CH1-CH2*MOD(I,2))
24794 C double direct process
24796 IF(IDPDG1.EQ.22) THEN
24797 ALPHA1 = pho_alphae(SSR)
24798 ELSE IF(IDPDG1.EQ.990) THEN
24799 ALPHA1 = PARMDL(74)
24804 IF(IDPDG2.EQ.22) THEN
24805 ALPHA2 = pho_alphae(SSR)
24806 ELSE IF(IDPDG2.EQ.990) THEN
24807 ALPHA2 = PARMDL(74)
24815 FDIS = MAX(0.D0,F(NKON)*ALPHA1*ALPHA2)
24818 IF(IDEB(64).GE.20) WRITE(LO,'(1X,A,/2X,I3,2I6,7E11.3)')
24819 & 'PHO_HARWGI: NKON,ID1,ID2,AL1,AL2,X1,X2,PT,F(NKON),FDIS',
24820 & NKON,IDPDG1,IDPDG2,ALPHA1,ALPHA2,X1,X2,PT,F(NKON),FDIS
24824 *$ CREATE PHO_HARINI.FOR
24826 CDECK ID>, PHO_HARINI
24827 SUBROUTINE PHO_HARINI(IP,IDP1,IDP2,PV1,PV2,NOUT,MODE)
24828 C**********************************************************************
24830 C initialize calculation of hard cross section
24832 C must not be called during MC generation
24834 C***********************************************************************
24835 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24838 PARAMETER ( DEPS = 1.D-10 )
24840 C input/output channels
24842 COMMON /POINOU/ LI,LO
24843 C event debugging information
24845 PARAMETER (NMAXD=100)
24846 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24847 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24848 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24849 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24850 C model switches and parameters
24852 INTEGER ISWMDL,IPAMDL
24853 DOUBLE PRECISION PARMDL
24854 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24855 C currently activated parton density parametrizations
24857 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
24858 DOUBLE PRECISION PDFLAM,PDFQ2M
24859 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
24860 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
24862 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
24863 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
24864 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
24865 C scale parameters for parton model calculations
24866 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24867 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24868 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24869 & NQQAL,NQQALI,NQQALF,NQQPD
24870 C data of c.m. system of Pomeron / Reggeon exchange
24871 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
24872 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
24873 & SIDP,CODP,SIFP,COFP
24874 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
24875 & SIDP,CODP,SIFP,COFP,NPOSP(2),
24876 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
24877 C obsolete cut-off information
24878 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
24879 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
24880 C hard scattering parameters used for most recent hard interaction
24882 DOUBLE PRECISION ALQCD2,BQCD
24883 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
24885 double precision pho_alphas
24889 C set local Pomeron c.m. system data
24895 CALL PHO_ACTPDF(IDPDG1,1)
24896 CALL PHO_ACTPDF(IDPDG2,2)
24897 C initialize alpha_s calculation
24898 DUMMY = PHO_ALPHAS(0.D0,-4)
24899 C initialize scales with defaults
24900 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
24901 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24903 AQQALI = PARMDL(86)
24904 AQQALF = PARMDL(89)
24907 NQQALI = IPAMDL(86)
24908 NQQALF = IPAMDL(89)
24912 AQQALI = PARMDL(85)
24913 AQQALF = PARMDL(88)
24916 NQQALI = IPAMDL(85)
24917 NQQALF = IPAMDL(88)
24920 ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24922 AQQALI = PARMDL(85)
24923 AQQALF = PARMDL(88)
24926 NQQALI = IPAMDL(85)
24927 NQQALF = IPAMDL(88)
24931 AQQALI = PARMDL(84)
24932 AQQALF = PARMDL(87)
24935 NQQALI = IPAMDL(84)
24936 NQQALF = IPAMDL(87)
24939 IF(PARMDL(109+IP).LT.DEPS) PARMDL(109+IP) = AQQAL
24940 IF(PARMDL(113+IP).LT.DEPS) PARMDL(113+IP) = AQQALI
24941 IF(PARMDL(117+IP).LT.DEPS) PARMDL(117+IP) = AQQALF
24942 IF(PARMDL(121+IP).LT.DEPS) PARMDL(121+IP) = AQQPD
24943 IF(IPAMDL(64+IP).LT.0) IPAMDL(64+IP) = NQQAL
24944 IF(IPAMDL(68+IP).LT.0) IPAMDL(68+IP) = NQQALI
24945 IF(IPAMDL(72+IP).LT.0) IPAMDL(72+IP) = NQQALF
24946 IF(IPAMDL(76+IP).LT.0) IPAMDL(76+IP) = NQQPD
24947 AQQAL = PARMDL(109+IP)
24948 AQQALI = PARMDL(113+IP)
24949 AQQALF = PARMDL(117+IP)
24950 AQQPD = PARMDL(121+IP)
24951 NQQAL = IPAMDL(64+IP)
24952 NQQALI = IPAMDL(68+IP)
24953 NQQALF = IPAMDL(72+IP)
24954 NQQPD = IPAMDL(76+IP)
24955 PTCUT(1) = PARMDL(36)
24956 PTCUT(2) = PARMDL(37)
24957 PTCUT(3) = PARMDL(38)
24958 PTCUT(4) = PARMDL(39)
24959 PTANO(1) = PARMDL(130)
24960 PTANO(2) = PARMDL(131)
24961 PTANO(3) = PARMDL(132)
24962 PTANO(4) = PARMDL(133)
24963 RFLAG = '(energy-independent)'
24964 IF(IPAMDL(7).GT.0) RFLAG = '(energy-dependent)'
24966 C write out all settings
24967 IF((IDEB(66).GE.15).OR.(MODE.GT.0)) THEN
24968 WRITE(NOUT,1050) IP,IDPDG1,IDPDG2,PTCUT(IP),RFLAG,
24969 & PDFNAM(1),IGRP(1),ISET(1),IEXT(1),
24970 & PDFNAM(2),IGRP(2),ISET(2),IEXT(2),
24971 & PDFLAM,NF,NQQAL,AQQAL,NQQPD,AQQPD
24973 & ' PHO_HARINI: hard scattering parameters for IP:',I3/,
24974 & 5X,'particle 1 / particle 2:',2I8,/,
24975 & 5X,'min. PT :',F7.1,2X,A,/,
24976 & 5X,'PDF side 1:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
24977 & 5X,'PDF side 2:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
24978 & 5X,'LAMBDA1,2 (4 active flavours):',2F8.3,/,
24979 & 5X,'max. number of active flavours NF :',I3,/,
24980 & 5X,'NQQAL/AQQAL/NQQPD/AQQPD:',I5,F8.3,I5,F8.3)
24985 *$ CREATE PHO_HARINT.FOR
24987 CDECK ID>, PHO_HARINT
24988 SUBROUTINE PHO_HARINT(IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM)
24989 C**********************************************************************
24991 C interpolate cross sections and weights for hard scattering
24993 C input: IPP particle combination (neg. for add. user cuts)
24994 C ECM CMS energy (GeV)
24995 C P2V1/2 particle virtualities (pos., GeV**2)
24996 C I1 first subprocess to calculate
24997 C I2 last subprocess to calculate
24998 C <-1 only scales and cutoffs calculated
24999 C K1 first variable to calculate
25000 C K2 last variable to calculate
25001 C MSPOM cross sections to use for pt distribution
25005 C for K1 < 3 the soft pt distribution is also calculated
25007 C output: interpolated values in HWgx, HSig, Hdpt
25009 C***********************************************************************
25010 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25013 PARAMETER ( DEPS = 1.D-15,
25016 C input/output channels
25018 COMMON /POINOU/ LI,LO
25019 C event debugging information
25021 PARAMETER (NMAXD=100)
25022 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
25023 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25024 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
25025 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25026 C model switches and parameters
25028 INTEGER ISWMDL,IPAMDL
25029 DOUBLE PRECISION PARMDL
25030 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25031 C Reggeon phenomenology parameters
25032 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25033 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25034 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25035 & ALREG,ALREGP,GR(2),B0REG(2),
25036 & GPPP,GPPR,B0PPP,B0PPR,
25037 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25038 C parameters of 2x2 channel model
25039 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
25040 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
25041 C data needed for soft-pt calculation
25042 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
25043 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
25044 C scale parameters for parton model calculations
25045 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25046 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25047 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25048 & NQQAL,NQQALI,NQQALF,NQQPD
25049 C obsolete cut-off information
25050 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
25051 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
25052 C event weights and generated cross section
25053 INTEGER IPOWGC,ISWCUT,IVWGHT
25054 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
25055 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
25056 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
25057 C parameters for DGLAP backward evolution in ISR
25059 DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
25060 COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
25061 C hard cross sections and MC selection weights
25063 PARAMETER ( Max_pro_2 = 16 )
25064 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
25065 & MH_acc_1,MH_acc_2
25066 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
25067 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
25068 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
25069 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
25070 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
25071 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
25072 C interpolation tables for hard cross section and MC selection weights
25073 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
25074 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
25075 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
25076 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
25077 & HQ2a_tab,HQ2b_tab,HEcm_tab
25079 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25080 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25081 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25082 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25083 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
25084 & HEcm_tab(1:Max_tab_E,0:4),
25085 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
25086 C data on most recent hard scattering
25087 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
25088 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
25089 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
25090 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
25091 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
25092 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
25093 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
25094 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
25095 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
25096 C energy-interpolation table
25098 PARAMETER ( IEETA2 = 20 )
25100 DOUBLE PRECISION SIGTAB,SIGECM
25101 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
25103 DOUBLE PRECISION XP,PTS
25104 DIMENSION XP(2),PTS(0:2,2)
25109 IF(IDEB(58).GE.25) WRITE(LO,'(1X,2A,/,5X,I2,3E12.3,5I4)')
25110 & 'PHO_HARINT: called with ',
25111 & 'IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM',
25112 & IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM
25116 C default minimum bias cutoff
25117 PTCUT(IP) = pho_ptcut(ECM,IP)
25119 C user defined additional cutoff
25120 PTCUT(IP) = HSWCUT(4+IP)
25125 Q2CUT = MIN(PTWANT**2,PARMDL(125+IP))
25126 Q2MISR(1) = MAX(P2V1,Q2CUT)
25127 Q2MISR(2) = MAX(P2V2,Q2CUT)
25128 C cutoff for direct photon contribution to photon PDF
25129 PTANO(IP) = MIN(PTCUT(IP),PARMDL(129+IP))
25131 C scales for hard scattering
25132 AQQAL = PARMDL(109+IP)
25133 AQQALI = PARMDL(113+IP)
25134 AQQALF = PARMDL(117+IP)
25135 AQQPD = PARMDL(121+IP)
25136 NQQAL = IPAMDL(64+IP)
25137 NQQALI = IPAMDL(68+IP)
25138 NQQALF = IPAMDL(72+IP)
25139 NQQPD = IPAMDL(76+IP)
25140 IF(IDEB(58).GE.15) WRITE(LO,'(1X,A,4I3,4E10.3)')
25141 & 'PHO_HARINT: scales:',
25142 & NQQAL,NQQALI,NQQALF,NQQPD,AQQAL,AQQALI,AQQALF,AQQPD
25144 IF(I2.LT.-1) RETURN
25147 IF(IPP.LT.0) IL = 0
25149 C double-log interpolation
25150 IF(ECM.LT.2.1D0*PTCUT(IP)) THEN
25161 IF((ECM.GT.HEcm_tab(I,IL)).AND.(I.LT.IH_Ecm_up(IL))) GOTO 310
25165 fac = LOG(ECM/HEcm_tab(I-1,IL))
25166 & /LOG(HEcm_tab(I,IL)/HEcm_tab(I-1,IL))
25168 C factor due to phase space integration
25169 XX = LOG(Hfac_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
25170 & *LOG((Hfac_tab(M,I,Ia,Ib,IL)+DEPS)
25171 & /(Hfac_tab(M,I-1,Ia,Ib,IL)+DEPS))
25173 IF(XX.LT.DEPS2) XX = 0.D0
25176 XX = LOG(HWgx_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
25177 & *LOG((HWgx_tab(M,I,Ia,Ib,IL)+DEPS)
25178 & /(HWgx_tab(M,I-1,Ia,Ib,IL)+DEPS))
25180 IF(XX.LT.DEPS2) XX = 0.D0
25182 C hard cross section
25183 XX = LOG(HSig_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
25184 & *LOG((HSig_tab(M,I,Ia,Ib,IL)+DEPS)
25185 & /(HSig_tab(M,I-1,Ia,Ib,IL)+DEPS))
25187 IF(XX.LT.DEPS2) XX = 0.D0
25189 C differential hard cross section
25190 XX = LOG(Hdpt_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
25191 & *LOG((Hdpt_tab(M,I,Ia,Ib,IL)+DEPS)
25192 & /(Hdpt_tab(M,I-1,Ia,Ib,IL)+DEPS))
25194 IF(XX.LT.DEPS2) XX = 0.D0
25199 IF((K1.LT.3).AND.(K2.GE.3)) THEN
25201 IF((I1.GT.9).OR.(I2.LT.9)) THEN
25202 WRITE(LO,'(1X,2A,2I4)') 'PHO_HARINT: ',
25203 & 'hard cross section not calculated ',I1,I2
25207 C load soft cross sections from interpolation table
25208 IF(ECM.LE.SIGECM(IP,1)) THEN
25211 ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
25213 IF(ECM.LE.SIGECM(IP,I)) GOTO 205
25219 WRITE(LO,'(/1X,A,I3,1P,2E11.3)')
25220 & 'PHO_HARINT: energy too high (IP,Ecm,Emax)',
25221 & IP,ECM,SIGECM(IP,ISIMAX)
25222 CALL PHO_PREVNT(-1)
25227 IF(L1.NE.L2) FAC2=LOG(ECM/SIGECM(IP,L1))
25228 & /LOG(SIGECM(IP,L2)/SIGECM(IP,L1))
25230 SIGS = FAC2*(SIGTAB(IP,56,L2)+SIGTAB(IP,57,L2))+
25231 & FAC1*(SIGTAB(IP,56,L1)+SIGTAB(IP,57,L1))
25235 CALL PHO_SOFTPT(-1,PTWANT,PTWANT,XP,IV,PTS)
25241 IF(IDEB(58).GE.15) THEN
25242 WRITE(LO,'(1X,A,I10,3I2,2E10.3)')
25243 & 'PHO_HARINT: weights EV,IP,K1/2,ECM,PTC',
25244 & KEVENT,IP,K1,K2,ECM,PTCUT(IP)
25246 WRITE(LO,'(5X,2I3,1p,4E12.3)')
25247 & M,MH_pro_on(M,IP),Hfac(M),HWgx(M),HSig(M),Hdpt(M)
25253 *$ CREATE PHO_PTCUT.FOR
25255 DOUBLE PRECISION FUNCTION PHO_PTCUT(ECM,IP)
25256 C***********************************************************************
25258 C calculate energy-dependent transverse momentum cutoff
25260 C***********************************************************************
25266 double precision ECM
25269 C input/output channels
25271 COMMON /POINOU/ LI,LO
25272 C event debugging information
25274 PARAMETER (NMAXD=100)
25275 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
25276 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25277 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
25278 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25279 C model switches and parameters
25281 INTEGER ISWMDL,IPAMDL
25282 DOUBLE PRECISION PARMDL
25283 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25285 pho_ptcut = PARMDL(35+IP)
25287 IF(IPAMDL(7).EQ.1) THEN
25288 C Bopp et al. type (DPMJET)
25289 pho_ptcut = PARMDL(35+IP)
25290 & + max(0.D0,0.12D0*(LOG10(ECM/50.D0))**3)
25291 ELSE IF(IPAMDL(7).EQ.2) THEN
25292 C Gribov-Levin-Ryskin type
25293 pho_ptcut = PARMDL(35+IP)
25294 & + 0.065D0*exp(0.9D0*sqrt(2.D0*log(Ecm)))
25299 *$ CREATE PHO_HARMCI.FOR
25301 CDECK ID>, PHO_HARMCI
25302 SUBROUTINE PHO_HARMCI(IP,EMAXF)
25303 C**********************************************************************
25305 C initialize MC sampling and calculate hard cross section
25307 C input: IP particle combination (neg. number for user cut)
25308 C EMAXF maximum CMS energy for
25309 C interpolation table in reference to PTCUT(1..4)
25311 C***********************************************************************
25312 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25315 PARAMETER (DEPS = 1.D-10,
25318 C input/output channels
25320 COMMON /POINOU/ LI,LO
25321 C event debugging information
25323 PARAMETER (NMAXD=100)
25324 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
25325 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25326 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
25327 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25329 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25330 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25331 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25332 C global event kinematics and particle IDs
25333 INTEGER IFPAP,IFPAB
25334 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
25335 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
25336 C data of c.m. system of Pomeron / Reggeon exchange
25337 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25338 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25339 & SIDP,CODP,SIFP,COFP
25340 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25341 & SIDP,CODP,SIFP,COFP,NPOSP(2),
25342 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
25343 C model switches and parameters
25345 INTEGER ISWMDL,IPAMDL
25346 DOUBLE PRECISION PARMDL
25347 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25348 C obsolete cut-off information
25349 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
25350 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
25351 C scale parameters for parton model calculations
25352 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25353 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25354 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25355 & NQQAL,NQQALI,NQQALF,NQQPD
25356 C names of hard scattering processes
25358 PARAMETER ( Max_pro_1 = 16 )
25360 COMMON /POHPRO/ PROC(0:Max_pro_1)
25361 C hard cross sections and MC selection weights
25363 PARAMETER ( Max_pro_2 = 16 )
25364 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
25365 & MH_acc_1,MH_acc_2
25366 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
25367 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
25368 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
25369 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
25370 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
25371 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
25372 C interpolation tables for hard cross section and MC selection weights
25373 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
25374 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
25375 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
25376 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
25377 & HQ2a_tab,HQ2b_tab,HEcm_tab
25379 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25380 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25381 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25382 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25383 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
25384 & HEcm_tab(1:Max_tab_E,0:4),
25385 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
25386 C event weights and generated cross section
25387 INTEGER IPOWGC,ISWCUT,IVWGHT
25388 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
25389 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
25390 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
25393 DIMENSION DSIG(0:Max_pro_2),DSPT(0:Max_pro_2)
25395 C initialization for all pt cutoffs
25402 PTC = pho_ptcut(parmdl(19),I)
25405 C skip unassigned PTCUT
25406 IF(PTC.LT.0.5D0) GOTO 1000
25414 Hfac_tab(M,Ie,Ia,Ib,I) = 0.D0
25415 HWgx_tab(M,Ie,Ia,Ib,I) = 0.D0
25416 HSig_tab(M,Ie,Ia,Ib,I) = 0.D0
25417 Hdpt_tab(M,Ie,Ia,Ib,I) = 0.D0
25423 ELLOW = LOG(2.05*PTC)
25424 DELTA = (LOG(EMAXF)-ELLOW)/DBLE(IH_Ecm_up(I)-1)
25426 IF(DELTA.LE.0.D0) GOTO 1000
25428 C switch between external particles and Pomeron
25434 ELSE IF(I.EQ.3) THEN
25439 ELSE IF(I.EQ.2) THEN
25451 C initialize PT scales
25452 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
25453 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25454 FPS(I) = PARMDL(105)
25455 FPH(I) = PARMDL(106)
25457 FPS(I) = PARMDL(103)
25458 FPH(I) = PARMDL(104)
25460 ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25461 FPS(I) = PARMDL(103)
25462 FPH(I) = PARMDL(104)
25464 FPS(I) = PARMDL(101)
25465 FPH(I) = PARMDL(102)
25468 C initialize hard scattering
25470 CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8)+1)
25472 CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8))
25475 C energy/virtuality grid
25476 do Ie=1,IH_Ecm_up(IL)
25477 HEcm_tab(Ie,IL) = EXP(ELLOW+DELTA*(IE-1))
25479 do Ia=1,IH_Q2a_up(IL)
25480 HQ2a_tab(Ia,IL) = 0.D0
25482 do Ib=1,IH_Q2b_up(IL)
25483 HQ2b_tab(Ib,IL) = 0.D0
25486 C initialization for several energies and particle virtualities
25487 do Ie=1,IH_Ecm_up(IL)
25488 do Ia=1,IH_Q2a_up(IL)
25489 do Ib=1,IH_Q2b_up(IL)
25491 EE = HEcm_tab(IE,IL)
25492 Q2a = HQ2a_tab(Ia,IL)
25493 Q2b = HQ2b_tab(Ib,IL)
25494 CALL PHO_HARINT(IP,EE,0.D0,0.D0,0,-2,0,0,1)
25495 IF(IDEB(8).GE.5) WRITE(LO,'(1X,A,2E10.3,2I7)')
25496 & 'PHO_HARMCI: initialization PT,ECM,ID1,ID2:',
25497 & PTCUT(I),EE,IDPDG1,IDPDG2
25498 Hfac_tab(0,Ie,Ia,Ib,IL) = PTCUT(I)
25499 CALL PHO_HARFAC(PTCUT(I),EE)
25500 CALL PHO_HARWGX(PTCUT(I),EE)
25501 CALL PHO_HARXTO(EE,PTCUT(I),PTCUT(I),DSIG,DSPT)
25502 IF(IDEB(8).GE.10) THEN
25503 WRITE(LO,'(1X,A,/,1X,A)')
25504 & 'hard cross sections SIGH(mb),DSIG/DPT(mb/GeV**2)',
25505 & '------------------------------------------------'
25507 WRITE(LO,'(10X,A,1P2E14.4)')
25508 & PROC(M),DREAL(DSIG(M)),DSPT(M)
25512 C store in interpolation tables
25513 Hfac_tab(-1,IE,Ia,Ib,IL) = Hfac(-1)
25514 HWgx_tab(-1,IE,Ia,Ib,IL) = HWgx(-1)
25516 Hfac_tab(M,IE,Ia,Ib,IL) = Hfac(M)
25517 HWgx_tab(M,IE,Ia,Ib,IL) = HWgx(M)
25518 HSig_tab(M,IE,Ia,Ib,IL) = DREAL(DSIG(M))*MH_pro_on(M,I)
25519 Hdpt_tab(M,IE,Ia,Ib,IL) = DSPT(M)*MH_pro_on(M,I)
25522 C summed quantities
25523 HSig_tab(9,IE,Ia,Ib,IL) = 0.D0
25524 Hdpt_tab(9,IE,Ia,Ib,IL) = 0.D0
25526 IF(MH_pro_on(M,I).GT.0) THEN
25527 HSig_tab(9,IE,Ia,Ib,IL) =
25528 & HSig_tab(9,IE,Ia,Ib,IL) + HSig_tab(M,IE,Ia,Ib,IL)
25529 Hdpt_tab(9,IE,Ia,Ib,IL) =
25530 & Hdpt_tab(9,IE,Ia,Ib,IL) + Hdpt_tab(M,IE,Ia,Ib,IL)
25533 HSig_tab(15,IE,Ia,Ib,IL) = 0.D0
25534 Hdpt_tab(15,IE,Ia,Ib,IL) = 0.D0
25536 IF(MH_pro_on(M,I).GT.0) THEN
25537 HSig_tab(15,IE,Ia,Ib,IL) =
25538 & HSig_tab(15,IE,Ia,Ib,IL) + HSig_tab(M,IE,Ia,Ib,IL)
25539 Hdpt_tab(15,IE,Ia,Ib,IL) =
25540 & Hdpt_tab(15,IE,Ia,Ib,IL) + Hdpt_tab(M,IE,Ia,Ib,IL)
25543 HSig_tab(0,IE,Ia,Ib,IL) =
25544 & HSig_tab(9,IE,Ia,Ib,IL) + HSig_tab(15,IE,Ia,Ib,IL)
25545 Hdpt_tab(0,IE,Ia,Ib,IL) =
25546 & Hdpt_tab(9,IE,Ia,Ib,IL) + Hdpt_tab(15,IE,Ia,Ib,IL)
25552 C debug output of weights
25554 IF(IDEB(8).GE.5) THEN
25555 WRITE(LO,'(/1X,A,5X,2I7,I3,F7.2,/1X,A)')
25556 & 'PHO_HARMCI: weights, maxima (ID1/2,IP,PTC)',
25557 & IDPDG1,IDPDG2,IP,PTCUT(I),
25558 & '------------------------------------------'
25560 IF((M.EQ.0).OR.(M.EQ.9).OR.(M.EQ.15)) GOTO 512
25561 WRITE(LO,'(2X,A,I3,2I7)')
25562 & 'PHO_HARMCI: ECM Hfac, HWgx, HSig, Hdpt for MSTR,ID1,ID2',
25564 do k=1,IH_Ecm_up(IL)
25565 do ia=1,IH_Q2a_up(IL)
25566 do ib=1,IH_Q2b_up(IL)
25567 WRITE(LO,'(3X,1p,7E10.3)') HEcm_tab(k,IL),
25568 & HQ2a_tab(ia,IL),HQ2b_tab(ib,IL),
25569 & Hfac_tab(M,k,ia,ib,IL),HWgx_tab(M,k,ia,ib,IL),
25570 & HSig_tab(M,k,ia,ib,IL),Hdpt_tab(M,k,ia,ib,IL)
25580 *$ CREATE PHO_HARXR3.FOR
25582 CDECK ID>, PHO_HARXR3
25583 SUBROUTINE PHO_HARXR3(ECMH,PT,ETAC,ETAD,DSIGMC)
25584 C**********************************************************************
25586 C differential cross section DSIG/(DETAC*DETAD*DPT)
25588 C input: ECMH CMS energy
25590 C ETAC pseudorapidity of parton C
25591 C ETAD pseudorapidity of parton D
25593 C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac/detad
25595 C**********************************************************************
25596 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25599 PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-20)
25601 PARAMETER ( Max_pro_2 = 16 )
25603 DIMENSION DSIGMC(0:Max_pro_2)
25604 DIMENSION DSIGM(0:Max_pro_2)
25606 C input/output channels
25608 COMMON /POINOU/ LI,LO
25610 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25611 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25612 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25613 C Reggeon phenomenology parameters
25614 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25615 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25616 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25617 & ALREG,ALREGP,GR(2),B0REG(2),
25618 & GPPP,GPPR,B0PPP,B0PPR,
25619 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25620 C currently activated parton density parametrizations
25622 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
25623 DOUBLE PRECISION PDFLAM,PDFQ2M
25624 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
25625 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
25626 C hard scattering parameters used for most recent hard interaction
25628 DOUBLE PRECISION ALQCD2,BQCD
25629 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25630 C scale parameters for parton model calculations
25631 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25632 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25633 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25634 & NQQAL,NQQALI,NQQALF,NQQPD
25636 DOUBLE PRECISION PHO_ALPHAS
25637 DIMENSION PDA(-6:6),PDB(-6:6)
25640 DSIGMC(I) = CMPLX(0.D0,0.D0)
25646 C kinematic conversions
25647 XA = PT*(EC+ED)/ECMH
25649 IF((XA.GE.1.D0).OR.(XB.GE.1.D0)) THEN
25650 WRITE(LO,'(/1X,A,2E12.4)') 'PHO_HARXR3:ERROR:X1 OR X2 > 1',XA,XB
25653 SP = XA*XB*ECMH*ECMH
25659 C set hard scale QQ for alpha and partondistr.
25660 IF ( NQQAL.EQ.1 ) THEN
25662 ELSEIF ( NQQAL.EQ.2 ) THEN
25663 QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25664 ELSEIF ( NQQAL.EQ.3 ) THEN
25666 ELSEIF ( NQQAL.EQ.4 ) THEN
25667 QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25669 IF ( NQQPD.EQ.1 ) THEN
25671 ELSEIF ( NQQPD.EQ.2 ) THEN
25672 QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25673 ELSEIF ( NQQPD.EQ.3 ) THEN
25675 ELSEIF ( NQQPD.EQ.4 ) THEN
25676 QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25679 ALPHA = PHO_ALPHAS(QQAL,3)
25680 FACTOR = PI2*GEV2MB*PT*(ALPHA/SP)**2*AKFAC
25681 C parton distributions (times x)
25682 CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
25683 CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
25690 S2 = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
25691 S3 = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
25692 S4 = S4+PDA(I)+PDA(-I)
25693 S5 = S5+PDB(I)+PDB(-I)
25695 C partial cross sections (including color and symmetry factors)
25696 C resolved photon matrix elements (light quarks)
25697 DSIGM(1) = 2.25D0*(3.-((UP*TP)+UP/TT+TP/UU))
25698 DSIGM(6) = (4.D0/9.D0)*(UU+TT)
25699 DSIGM(8) = (4.D0/9.D0)*(1.D0+UU)/TT
25700 DSIGM(2) = (16.D0/27.D0)*(UU+TT)/(UP*TP)-3.D0*DSIGM(6)
25701 DSIGM(3) = ((1.D0+UU)/TT)-(4.D0/9.D0)*(1.D0+UU)/UP
25702 DSIGM(4) = (9.D0/32.D0)*DSIGM(2)
25703 DSIGM(5) = DSIGM(6)+DSIGM(8)-(8.D0/27.D0)*UU/TP
25704 DSIGM(7) = 0.5D0*(DSIGM(8)+(4.D0/9.D0)*(1.D0+TT)/UU-
25705 & (8.D0/27.D0)/(UP*TP))
25707 DSIGM(1) = FACTOR*DSIGM(1)*S1
25708 DSIGM(2) = FACTOR*DSIGM(2)*S2
25709 DSIGM(3) = FACTOR*DSIGM(3)*(PDA(0)*S5+PDB(0)*S4)
25710 DSIGM(4) = FACTOR*DSIGM(4)*S1*NF
25711 DSIGM(5) = FACTOR*DSIGM(5)*S2
25712 DSIGM(6) = FACTOR*DSIGM(6)*S2*MAX(0,(NF-1))
25713 DSIGM(7) = FACTOR*DSIGM(7)*S3
25714 DSIGM(8) = FACTOR*DSIGM(8)*(S4*S5-(S2+S3))
25717 FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25720 IF(DSIGM(I).LT.EPS) DSIGM(I) = 0.D0
25721 DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25722 DSIGMC(9) = DSIGMC(9)+DSIGMC(I)
25726 *$ CREATE PHO_HARXR2.FOR
25728 CDECK ID>, PHO_HARXR2
25729 SUBROUTINE PHO_HARXR2(ECMH,PT,ETAC,DSIGMC)
25730 C**********************************************************************
25732 C differential cross section DSIG/(DETAC*DPT)
25734 C input: ECMH CMS energy
25736 C ETAC pseudorapidity of parton C
25738 C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
25740 C**********************************************************************
25741 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25744 PARAMETER ( TINY= 1.D-20 )
25746 PARAMETER ( Max_pro_2 = 16 )
25748 DIMENSION DSIGMC(0:Max_pro_2)
25750 C input/output channels
25752 COMMON /POINOU/ LI,LO
25753 C integration precision for hard cross sections (obsolete)
25754 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25755 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25758 DIMENSION DSIG1(0:Max_pro_2)
25759 DIMENSION ABSZ(32),WEIG(32)
25762 DSIGMC(M) = CMPLX(0.D0,0.D0)
25768 IF ( ARG.LE.EC .OR. ARG.LE.1.D0/EC ) RETURN
25770 EDL =-LOG(ARG-1.D0/EC)
25772 CALL PHO_GAUSET(EDL,EDU,NPOINT,ABSZ,WEIG)
25774 CALL PHO_HARXR3(ECMH,PT,ETAC,ABSZ(I),DSIG1)
25776 PCTRL= DREAL(DSIG1(M))/TINY
25777 IF( PCTRL.GE.1.D0 ) THEN
25778 DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
25784 *$ CREATE PHO_HARXD2.FOR
25786 CDECK ID>, PHO_HARXD2
25787 SUBROUTINE PHO_HARXD2(ECMH,PT,ETAC,DSIGMC)
25788 C**********************************************************************
25790 C differential cross section DSIG/(DETAC*DPT) for direct processes
25792 C input: ECMH CMS energy of scattering system
25794 C ETAC pseudorapidity of parton C
25796 C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
25798 C**********************************************************************
25799 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25802 PARAMETER ( Max_pro_2 = 16 )
25804 DIMENSION DSIGMC(0:Max_pro_2)
25805 PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-25)
25807 C input/output channels
25809 COMMON /POINOU/ LI,LO
25810 C model switches and parameters
25812 INTEGER ISWMDL,IPAMDL
25813 DOUBLE PRECISION PARMDL
25814 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25815 C data of c.m. system of Pomeron / Reggeon exchange
25816 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25817 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25818 & SIDP,CODP,SIFP,COFP
25819 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25820 & SIDP,CODP,SIFP,COFP,NPOSP(2),
25821 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
25822 C Reggeon phenomenology parameters
25823 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25824 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25825 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25826 & ALREG,ALREGP,GR(2),B0REG(2),
25827 & GPPP,GPPR,B0PPP,B0PPR,
25828 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25829 C currently activated parton density parametrizations
25831 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
25832 DOUBLE PRECISION PDFLAM,PDFQ2M
25833 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
25834 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
25835 C hard scattering parameters used for most recent hard interaction
25837 DOUBLE PRECISION ALQCD2,BQCD
25838 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25839 C some hadron information, will be deleted in future versions
25841 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
25842 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
25843 C scale parameters for parton model calculations
25844 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25845 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25846 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25847 & NQQAL,NQQALI,NQQALF,NQQPD
25849 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25850 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25851 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25853 DOUBLE PRECISION PHO_ALPHAS,pho_alphae
25854 DIMENSION PDA(-6:6),PDB(-6:6),DSIGM(0:Max_pro_2)
25859 DSIGMC(I) = CMPLX(0.D0,0.D0)
25862 DSIGMC(15) = CMPLX(0.D0,0.D0)
25865 C direct particle 1
25866 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
25869 C kinematic conversions
25872 IF ( XB.GE.1.D0 ) THEN
25873 WRITE(LO,'(/1X,A,2E12.4)')
25874 & 'PHO_HARXD2:ERROR: XB>1 (XA,XB)',XA,XB
25877 SP = XA*XB*ECMH*ECMH
25883 C set hard scale QQ for alpha and partondistr.
25884 IF ( NQQAL.EQ.1 ) THEN
25886 ELSEIF ( NQQAL.EQ.2 ) THEN
25887 QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25888 ELSEIF ( NQQAL.EQ.3 ) THEN
25890 ELSEIF ( NQQAL.EQ.4 ) THEN
25891 QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25893 IF ( NQQPD.EQ.1 ) THEN
25895 ELSEIF ( NQQPD.EQ.2 ) THEN
25896 QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25897 ELSEIF ( NQQPD.EQ.3 ) THEN
25899 ELSEIF ( NQQPD.EQ.4 ) THEN
25900 QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25903 ALPHA2 = PHO_ALPHAS(QQAL,2)
25904 IF(IDPDG1.EQ.22) THEN
25905 ALPHA1 = pho_alphae(QQAL)
25906 ELSE IF(IDPDG1.EQ.990) THEN
25907 ALPHA1 = PARMDL(74)
25909 FACTOR = -PI2*GEV2MB*UP/PT*ALPHA1*ALPHA2/SP*AKFAC
25910 C parton distribution (times x)
25911 CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
25916 IF(IDPDG1.EQ.22) THEN
25918 * IF(MOD(I,2).EQ.0) THEN
25919 * S2 = S2 + (PDB(I)+PDB(-I))*TWO32
25922 * S2 = S2 + (PDB(I)+PDB(-I))*ONE32
25925 S2 = S2 + (PDB(I)+PDB(-I))*Q_ch2(I)
25928 ELSE IF(IDPDG1.EQ.990) THEN
25930 S2 = S2 + PDB(I)+PDB(-I)
25934 C partial cross sections (including color and symmetry factors)
25935 C direct photon matrix elements
25936 DSIGM(10) = -8.D0/3.D0*(UU+1.D0)/UP
25937 DSIGM(11) = (UU+TT)/(UP*TP)
25939 DSIGM(10) = FACTOR*DSIGM(10)*S2
25940 DSIGM(11) = FACTOR*DSIGM(11)*S1*S3
25943 FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25946 IF(DSIGM(I).LT.0.D0) THEN
25947 WRITE(LO,'(1X,A,I3,1P,2E12.4)')
25948 & 'PHO_HARXD2: neg. cross section',I,DSIGM(I),ECMH
25951 DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25952 DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
25956 C direct particle 2
25957 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25959 ED = 1.D0/(ECMH/PT-1.D0/EC)
25960 C kinematic conversions
25961 XA = PT*(EC+ED)/ECMH
25963 IF ( XA.GE.1.D0 ) THEN
25964 WRITE(LO,'(/1X,A,2E12.4)')
25965 & 'PHO_HARXD2:ERROR:XA>1 (XA,XB)',XA,XB
25968 SP = XA*XB*ECMH*ECMH
25974 C set hard scale QQ for alpha and partondistr.
25975 IF ( NQQAL.EQ.1 ) THEN
25977 ELSEIF ( NQQAL.EQ.2 ) THEN
25978 QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25979 ELSEIF ( NQQAL.EQ.3 ) THEN
25981 ELSEIF ( NQQAL.EQ.4 ) THEN
25982 QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25984 IF ( NQQPD.EQ.1 ) THEN
25986 ELSEIF ( NQQPD.EQ.2 ) THEN
25987 QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25988 ELSEIF ( NQQPD.EQ.3 ) THEN
25990 ELSEIF ( NQQPD.EQ.4 ) THEN
25991 QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25994 ALPHA1 = PHO_ALPHAS(QQAL,1)
25995 IF(IDPDG2.EQ.22) THEN
25996 ALPHA2 = pho_alphae(QQAL)
25997 ELSE IF(IDPDG2.EQ.990) THEN
25998 ALPHA2 = PARMDL(74)
26000 FACTOR = -PI2*GEV2MB*TP/PT*ALPHA1*ALPHA2/SP*AKFAC
26001 C parton distribution (times x)
26002 CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
26007 IF(IDPDG2.EQ.22) THEN
26009 * IF(MOD(I,2).EQ.0) THEN
26010 * S2 = S2 + (PDA(I)+PDA(-I))*TWO32
26013 * S2 = S2 + (PDA(I)+PDA(-I))*ONE32
26016 S2 = S2 + (PDA(I)+PDA(-I))*Q_ch2(I)
26019 ELSE IF(IDPDG2.EQ.990) THEN
26021 S2 = S2 + PDA(I)+PDA(-I)
26025 C partial cross sections (including color and symmetry factors)
26026 C direct photon matrix elements
26027 DSIGM(12) = -8.D0/3.D0*(TT+1.D0)/TP
26028 DSIGM(13) = (UU+TT)/(UP*TP)
26030 DSIGM(12) = FACTOR*DSIGM(12)*S2
26031 DSIGM(13) = FACTOR*DSIGM(13)*S3*S1
26034 FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
26037 IF(DSIGM(I).LT.0.D0) THEN
26038 WRITE(LO,'(1X,A,I3,1P,2E12.4)')
26039 & 'PHO_HARXD2: neg. cross section:',I,DSIGM(I),ECMH
26042 DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
26043 DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
26048 *$ CREATE PHO_HARXPT.FOR
26050 CDECK ID>, PHO_HARXPT
26051 SUBROUTINE PHO_HARXPT(ECMH,PT,IPRO,DSIGMC)
26052 C**********************************************************************
26054 C differential cross section DSIG/DPT
26056 C input: ECMH CMS energy of scattering system
26058 C IPRO 1 resolved processes
26059 C 2 direct processes
26060 C 3 resolved and direct processes
26062 C output: DSIGMC(0:12) QCD-PM cross sections dsigma/dpt
26064 C**********************************************************************
26065 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26068 PARAMETER ( Max_pro_2 = 16 )
26070 DIMENSION DSIGMC(0:Max_pro_2)
26071 PARAMETER ( TINY= 1.D-10, ONEP1=1.1, EPS=1.D-25)
26073 C input/output channels
26075 COMMON /POINOU/ LI,LO
26077 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
26078 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
26079 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
26080 C model switches and parameters
26082 INTEGER ISWMDL,IPAMDL
26083 DOUBLE PRECISION PARMDL
26084 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
26085 C data of c.m. system of Pomeron / Reggeon exchange
26086 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
26087 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
26088 & SIDP,CODP,SIFP,COFP
26089 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
26090 & SIDP,CODP,SIFP,COFP,NPOSP(2),
26091 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
26092 C Reggeon phenomenology parameters
26093 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
26094 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
26095 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
26096 & ALREG,ALREGP,GR(2),B0REG(2),
26097 & GPPP,GPPR,B0PPP,B0PPR,
26098 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
26099 C integration precision for hard cross sections (obsolete)
26100 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
26101 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
26102 C hard scattering parameters used for most recent hard interaction
26104 DOUBLE PRECISION ALQCD2,BQCD
26105 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
26106 C some hadron information, will be deleted in future versions
26108 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
26109 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
26111 double precision pho_alphae
26114 DIMENSION DSIG1(0:Max_pro_2)
26115 DIMENSION ABSZ(32),WEIG(32)
26117 DO 10 M=0,Max_pro_2
26118 DSIGMC(M) = CMPLX(0.D0,0.D0)
26119 DSIG1(M) = CMPLX(0.D0,0.D0)
26122 C resolved and direct processes
26124 IF ( AMT.GE.1.D0 ) RETURN
26125 ECU = LOG((SQRT(1.D0-AMT*AMT)+1.D0)/AMT)
26128 CALL PHO_GAUSET(ECL,ECU,NPOINT,ABSZ,WEIG)
26130 DSIG1(9) = CMPLX(0.D0,0.D0)
26131 DSIG1(15) = CMPLX(0.D0,0.D0)
26133 CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
26134 ELSE IF(IPRO.EQ.2) THEN
26135 CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
26137 CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
26138 CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
26140 DO 20 M=1,Max_pro_2
26141 DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
26146 IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
26147 & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
26150 ALPHAE = pho_alphae(SS)
26152 IF(IDPDG1.EQ.22) THEN
26153 * F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
26154 F1 = Q_ch2(I)*ALPHAE
26158 IF(IDPDG2.EQ.22) THEN
26159 * F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
26160 F2 = Q_ch2(I)*ALPHAE
26164 FAC = FAC+F1*F2*3.D0
26166 C direct cross sections
26167 ZZ = SQRT(1.D0-4.D0*PT*PT/SS+TINY)
26168 T1 = -SS/2.D0*(1.D0+ZZ)
26169 T2 = -SS/2.D0*(1.D0-ZZ)
26170 XM = -2.D0*PT/ZZ*((SS+T1)/T1+T1/(SS+T1)+(SS+T2)/T2+T2/(SS+T2))
26172 DSIGMC(14) = GEV2MB*2.D0*PI*FAC/(SS*SS)*XM*AKFAC
26174 C leptonic part (e, mu, tau)
26176 IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
26177 DSIGMC(16) = DSIGMC(14)/FAC*3.D0*ALPHAE**2
26178 C simulation of tau together with quarks
26179 IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
26183 DSIGMC(15) = DSIGMC(15)+DSIGMC(14)
26184 DSIGMC(0) = DSIGMC(9)+DSIGMC(15)
26188 *$ CREATE PHO_HARXTO.FOR
26190 CDECK ID>, PHO_HARXTO
26191 SUBROUTINE PHO_HARXTO(ECMH,PTCUTR,PTCUTD,DSIGMC,DSDPTC)
26192 C**********************************************************************
26194 C total hard cross section (perturbative QCD, Parton Model)
26196 C input: ECMH CMS energy of scattering system
26197 C PTCUTR PT cutoff for resolved processes
26198 C PTCUTD PT cutoff for direct processes (photon, Pomeron)
26200 C output: DSIGMC(0:MARPR2) cross sections for given cutoff
26201 C DSDPTC(0:MARPR2) differential cross sections at cutoff
26203 C note: COMPLEX*16 DSIGMC
26204 C DOUBLE PRECISION DSDPTC
26206 C**********************************************************************
26207 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26210 PARAMETER ( Max_pro_2 = 16 )
26212 DIMENSION DSIGMC(0:Max_pro_2),DSDPTC(0:Max_pro_2)
26214 C input/output channels
26216 COMMON /POINOU/ LI,LO
26217 C model switches and parameters
26219 INTEGER ISWMDL,IPAMDL
26220 DOUBLE PRECISION PARMDL
26221 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
26222 C data of c.m. system of Pomeron / Reggeon exchange
26223 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
26224 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
26225 & SIDP,CODP,SIFP,COFP
26226 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
26227 & SIDP,CODP,SIFP,COFP,NPOSP(2),
26228 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
26229 C Reggeon phenomenology parameters
26230 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
26231 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
26232 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
26233 & ALREG,ALREGP,GR(2),B0REG(2),
26234 & GPPP,GPPR,B0PPP,B0PPR,
26235 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
26237 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
26238 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
26239 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
26240 C integration precision for hard cross sections (obsolete)
26241 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
26242 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
26243 C some hadron information, will be deleted in future versions
26245 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
26246 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
26247 C hard scattering parameters used for most recent hard interaction
26249 DOUBLE PRECISION ALQCD2,BQCD
26250 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
26252 double precision pho_alphae
26255 DIMENSION DSIG1(0:Max_pro_2)
26256 DIMENSION ABSZ(32),WEIG(32)
26260 DO 10 M=0,Max_pro_2
26261 DSIGMC(M)= CMPLX(0.D0,0.D0)
26265 IF ( PTCUTR.GE.EEC ) GOTO 100
26267 C integration for resolved processes
26269 PTMAX = MIN(FAC*PTMIN,EEC)
26271 CALL PHO_HARXPT(ECMH,PTMIN,1,DSIG1)
26273 DSDPTC(M) = DREAL(DSIG1(M))
26275 DSIGH = DREAL(DSIG1(9))
26276 PTMXX = 0.95D0*PTMAX
26277 CALL PHO_HARXPT(ECMH,PTMXX,1,DSIG1)
26278 DSIGL = DREAL(DSIG1(9))
26279 EX = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
26282 IF ( PTMIN.GE.PTMAX ) GOTO 40
26285 CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
26288 PT = R**(1.0D0/EX1)
26289 CALL PHO_HARXPT(ECMH,PT,1,DSIG1)
26290 F = WEIG(I)*PT/(R*EX1)
26292 DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
26300 DSIGMC(0) = DSIGMC(9)
26301 DSDPTC(0) = DSDPTC(9)
26303 C integration for direct processes
26304 IF((PTCUTD.GE.EEC).OR.(PTCUTD.LT.0.5D0)) RETURN
26306 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
26307 & .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
26309 PTMAX = MIN(FAC*PTMIN,EEC)
26311 CALL PHO_HARXPT(ECMH,PTMIN,2,DSIG1)
26312 IF(DREAL(DSIG1(15)).LT.1.D-15) GOTO 170
26314 DSDPTC(M) = DREAL(DSIG1(M))
26316 DSIGH = DREAL(DSIG1(15)-DSIG1(14))
26317 PTMXX = 0.95D0*PTMAX
26318 CALL PHO_HARXPT(ECMH,PTMXX,2,DSIG1)
26319 DSIGL = DREAL(DSIG1(15)-DSIG1(14))
26320 EX = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
26323 IF ( PTMIN.GE.PTMAX ) GOTO 140
26326 CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
26329 PT = R**(1.0D0/EX1)
26330 CALL PHO_HARXPT(ECMH,PT,2,DSIG1)
26331 F = WEIG(I)*PT/(R*EX1)
26333 DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
26344 C double direct process
26345 IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
26346 & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
26349 ALPHAE = pho_alphae(SS)
26351 IF(IDPDG1.EQ.22) THEN
26352 * F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
26353 F1 = Q_ch2(I)*ALPHAE
26357 IF(IDPDG2.EQ.22) THEN
26358 * F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
26359 F2 = Q_ch2(I)*ALPHAE
26363 FACC = FACC + F1*F2*3.D0
26366 ZZ = SQRT(1.D0-4.D0*PTCUTD*PTCUTD/SS)
26367 R = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)*GEV2MB
26368 C hadronic cross section
26369 DSIGMC(14) = R*FACC*AKFAC
26370 C leptonic cross section
26371 IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
26372 DSIGMC(16) = R*3.D0*ALPHAE**2*AKFAC
26373 C simulation of tau together with quarks
26374 IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
26375 DSIGMC(16) = DSIGMC(16)*2.D0/3.D0
26377 DSIGMC(16) = CMPLX(0.D0,0.D0)
26379 C sum of direct part
26380 DSIGMC(15) = CMPLX(0.D0,0.D0)
26382 DSIGMC(15) = DSIGMC(15) + DSIGMC(I)
26385 C total sum (hadronic)
26386 DSIGMC(0) = DSIGMC(9) + DSIGMC(15)
26387 DSDPTC(0) = DSDPTC(9) + DSDPTC(15)
26391 *$ CREATE PHO_HARISR.FOR
26393 CDECK ID>, PHO_HARISR
26394 SUBROUTINE PHO_HARISR(IHPOM,P1,P2,IPF1,IPF2,IPA1,IPA2,IV1,IV2,Q2H,
26395 & XH1,XH2,XHMAX1,XHMAX2,IPB1,IPB2,IVO1,IVO2,XISR1,XISR2,IREJ)
26396 C********************************************************************
26398 C initial state radiation according to DGLAP evolution equations
26399 C (backward evolution, no spin effects)
26401 C input: IHPOM index of hard Pomeron
26402 C negative: delete all previous entries
26403 C P1,P2 4 momenta of hard scattered final partons
26404 C (in CMS of hard scattering)
26405 C IPF1,2 flavours of final partons
26406 C IPA1,2 flavours of initial partons
26407 C IV1,2 valence quark labels (0/1)
26408 C Q2H momentum transfer (squared, positive)
26409 C XH1,XH2 x values of initial partons
26410 C XHMAX1,2 max. x values allowed
26412 C output: all emitted partons in /POPISR/, final state
26413 C partons are the first two entries
26414 C shower evolution traced in /PODGL1/
26415 C IPB1,2 flavours of new initial partons
26416 C XISR1,2 x values of new initial partons
26417 C IVO1,2 valence quark labels (0/1)
26419 C attention: quark numbering according to PDG convention,
26422 C********************************************************************
26423 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26426 PARAMETER (RHOMAS = 0.766D0,
26430 DIMENSION P1(4),P2(4)
26432 C input/output channels
26434 COMMON /POINOU/ LI,LO
26435 C event debugging information
26437 PARAMETER (NMAXD=100)
26438 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
26439 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26440 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
26441 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26442 C internal rejection counters
26444 PARAMETER (NMXJ=60)
26445 CHARACTER*10 REJTIT
26447 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
26448 C model switches and parameters
26450 INTEGER ISWMDL,IPAMDL
26451 DOUBLE PRECISION PARMDL
26452 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
26453 C data of c.m. system of Pomeron / Reggeon exchange
26454 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
26455 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
26456 & SIDP,CODP,SIFP,COFP
26457 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
26458 & SIDP,CODP,SIFP,COFP,NPOSP(2),
26459 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
26460 C some hadron information, will be deleted in future versions
26462 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
26463 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
26464 C currently activated parton density parametrizations
26466 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
26467 DOUBLE PRECISION PDFLAM,PDFQ2M
26468 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
26469 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
26470 C scale parameters for parton model calculations
26471 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
26472 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
26473 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
26474 & NQQAL,NQQALI,NQQALF,NQQPD
26475 C parameters for DGLAP backward evolution in ISR
26477 DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
26478 COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
26479 C initial state parton radiation (internal part)
26480 INTEGER MXISR3,MXISR4
26481 PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
26482 INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
26483 DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
26484 COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
26485 & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
26486 & IFL1(2,MXISR3),IFL2(2,MXISR3),
26487 & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
26489 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
26490 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
26491 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
26492 C particles created by initial state evolution
26493 INTEGER MXISR1,MXISR2
26494 PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
26495 INTEGER IFLISR,IPOISR,IMXISR
26496 DOUBLE PRECISION PHISR
26497 COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
26498 & IPOISR(2,2,MXISR2),IMXISR(2)
26500 DOUBLE PRECISION PYP,EER,THER,QMAXR
26503 DIMENSION XHMA(2),NEXT(2),PD1(-6:6),PD2(-6:6),WGGAP(-6:6),
26504 & WGPDF(-6:6),XHMI(2),GB(4),PM(4),PN(4),PC(2,4),Q2(2),
26505 & IVAL(2),IPAL(2),IL(2),IFSUM(2),IDMO(2)
26511 IF(IDEB(79).GE.10) THEN
26512 WRITE(LO,'(1X,A,/1X,I10,3I3,5E11.3,2(/5X,4E12.3))')
26513 & 'PHO_HARISR: KEV,IHPOM,IP1,IP2,Q2H,XH1,XH2,XHM1,XHM2:',
26514 & KEVENT,IHPOM,IPA1,IPA2,Q2H,XH1,XH2,XHMAX1,XHMAX2,P1,P2
26516 IF(IHPOM.EQ.0) RETURN
26523 C copy final state partons to local fields
26526 IF(IHIDX.GT.MXISR2) THEN
26527 WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26528 & '/POPISR/ for hard scattering labels (IHIDX,MXISR2):',
26534 IF(IHPOM.LT.0) IMXISR(K) = 0
26535 IPOISR(K,1,IHIDX) = IMXISR(K)+1
26536 IPAL(K) = IPOISR(K,1,IHIDX)
26539 PHISR(1,I,IPAL(1)) = P1(I)
26540 PHISR(2,I,IPAL(2)) = P2(I)
26542 IFLISR(1,IPAL(1)) = IPF1
26543 IFLISR(2,IPAL(2)) = IPF2
26545 C check limitations, initialize /PODGL1/
26546 IF((Q2H.GT.Q2MISR(1)).AND.(XH1.LT.XHMAX1)) THEN
26553 IF((Q2H.GT.Q2MISR(2)).AND.(XH2.LT.XHMAX2)) THEN
26568 IF((IPA1.EQ.22).OR.(IPA1.EQ.990)) NEXT(1) = 0
26571 IF((IPA2.EQ.22).OR.(IPA2.EQ.990)) NEXT(2) = 0
26573 IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,/5X,2I2,3E12.3)')
26574 & 'PHO_HARISR:INITIAL TESTS (NEXT1,2 Q2H Q21,2)',NEXT,Q2H,Q2MISR
26575 IF(NEXT(1)+NEXT(2).EQ.0) GOTO 800
26577 C initialize parton shower loop
26578 B0QCD = (33.D0-2.D0*NFSISR)/6.D0
26579 AL2ISR(1) = PDFLAM(1)
26580 AL2ISR(2) = PDFLAM(2)
26583 XHMI(1) = PMISR(1)/PCMP
26584 XHMI(2) = PMISR(2)/PCMP
26587 SHAT1 = XH1*XH2*ECMP**2
26588 IF(IPAMDL(109).EQ.1) THEN
26591 PT2SH(1,1) = Q2H*(1.D0-Q2H/SHAT1)
26593 PT2SH(2,1) = PT2SH(1,1)
26594 IF(PT2SH(1,1).LT.Q2MISR(1)) NEXT(1) = 0
26595 IF(PT2SH(2,1).LT.Q2MISR(2)) NEXT(2) = 0
26596 THSH(1,1) = 2.D0*SQRT(Q2H/SHAT1)
26597 THSH(2,1) = THSH(1,1)
26601 IF(IREJ.NE.0) GOTO 800
26603 C main generation loop
26604 C -------------------------------------------------
26606 C choose parton side to become solved
26607 IF((NEXT(1)+NEXT(2)).EQ.2) THEN
26608 IF(Q2SH(1,ISH(1)).GT.Q2SH(2,ISH(2))) THEN
26610 ELSE IF(Q2SH(2,ISH(2)).GT.Q2SH(1,ISH(1))) THEN
26613 IP = MAX(INT(DT_RNDM(SHAT1)*2.D0+0.999999D0),1)
26615 ELSE IF(NEXT(1).EQ.1) THEN
26617 ELSE IF(NEXT(2).EQ.1) THEN
26623 C INDX now parton position of parton to become solved
26624 C IP now side to be treated
26626 Q2P = Q2SH(IP,INDX)
26627 PT2 = PT2SH(IP,INDX)
26628 IFLB = IFL1(IP,INDX)
26629 C check available x
26631 C cutoff by x limitation: no further development
26632 IF((XHMA(IP)-XP).LT.XMIP*2.D0) THEN
26634 Q2SH(IP,INDX) = 0.D0
26635 IF(IDEB(79).GE.17) THEN
26636 WRITE(LO,'(1X,A,/5X,3E12.4,2I3)')
26637 & 'PHO_HARISR: evolution x-stop (XP,XMIP,XHMA,IP,INDX)',
26638 & XP,XMIP,XHMA(IP),IP,INDX
26642 C initial value of evolution variable t
26643 TT = LOG(AQQALI*Q2P/AL2ISR(IP))
26644 DO 110 I=-NFSISR,NFSISR
26650 ZMAX = XP/(XP+XMIP)
26652 C q --> q g, g --> g g
26654 WGGAP(0) = CF*((ZMAX**2-ZMIN**2)/2.D0-2.D0*(ZMAX-ZMIN)
26655 & +2.D0*LOG(ZMAX/ZMIN))
26657 WGGAP(I) = WGGAP(0)
26658 WGGAP(-I) = WGGAP(0)
26660 WGGAP(0) = 6.D0*((ZMIN**3-ZMAX**3)/3.D0+(ZMAX**2-ZMIN**2)/2.D0
26661 & -2.D0*(ZMAX-ZMIN)+LOG(ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)))
26662 C q --> g q, g --> q qb
26663 ELSE IF(ABS(IFLB).LE.6) THEN
26664 WGGAP(IFLB) = CF*((ZMIN**2-ZMAX**2)/2.D0-ZMAX+ZMIN
26665 & -2.D0*LOG((1.D0-ZMAX)/(1.D0-ZMIN)))
26666 IF(IVAL(IP).EQ.0) WGGAP(0) = 0.5D0*(2./3.*(ZMAX**3-ZMIN**3)
26667 & -ZMAX**2+ZMIN**2+ZMAX-ZMIN)
26669 WRITE(LO,'(/1X,A,I7)')
26670 & 'PHO_HARISR:ERROR: unsupported particle ID',IFLB
26673 C anomalous/resolved evolution
26675 IF(IPAMDL(110).GE.1) THEN
26676 IF((IDMO(IP).EQ.22).AND.(IFLB.NE.0)
26677 & .AND.(IFLB.NE.21)) THEN
26679 IF(NQQALI.EQ.1) THEN
26684 CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26686 CALL PHO_QPMPDF(IFLB,XP,SCALE2,PTA1,PVIRTP(IP),WGDIR)
26687 XI = DT_RNDM(XP)*PD1(IFLB)
26688 IF(WGDIR.GT.XI) THEN
26690 IF(IDEB(79).GE.17) WRITE(LO,'(1X,2A,/5X,4E12.5,I2,I3)')
26692 & 'direct splitting (WGDIR,WGPDF,X,SCALE2,IP,IFLB)',
26693 & WGDIR,PD1(IFLB),XP,SCALE2,IP,IFLB
26694 Q2SH(IP,INDX) = 0.D0
26702 C rejection loop for z,t sampling
26703 C ------------------------------------
26706 IF(NITER.GE.NTRY) THEN
26707 WRITE(LO,'(1X,A,2I6)')
26708 & 'PHO_HARISR: too many rejections',NITER,NTRY
26709 CALL PHO_PREVNT(-1)
26715 IF(IPDFC.EQ.0) THEN
26716 IF(NQQALI.EQ.1) THEN
26721 CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26726 DO 210 I=-NFSISR,NFSISR
26727 WGPDF(I) = PD1(I)/(PD1(IFLB)+1.D-12)*5.D0
26728 WGTOT = WGTOT+WGPDF(I)*WGGAP(I)
26732 C sample new t value
26733 TT = TT*EXP(MAX(-10.D0,LOG(DT_RNDM(SHAT1))*B0QCD/WGTOT))
26734 Q2NEW = AL2ISR(IP)*EXP(TT)/AQQALI
26736 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.5)')
26737 & 'PHO_HARISR: pre-selected Q2:',Q2NEW
26738 C compare to limits
26739 IF(Q2NEW.LT.Q2MISR(IP)) THEN
26740 Q2SH(IP,INDX) = 0.D0
26742 IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,2E10.3,2I3)')
26743 & 'PHO_HARISR: evolution Q2-stop (Q2,Q2MIN,IP,INDX):',
26744 & Q2NEW,Q2MISR(IP),IP,INDX
26747 Q2SH(IP,INDX) = Q2NEW
26748 TT = LOG(AQQALI*Q2NEW/AL2ISR(IP))
26749 C selection of flavours
26750 XI = WGTOT*DT_RNDM(TT)
26754 XI = XI-WGPDF(IFLA)*WGGAP(IFLA)
26755 IF((XI.GT.0.D0).AND.(IFLA.LT.NFSISR)) GOTO 220
26757 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,2I3)')
26758 & 'PHO_HARISR: pre-selected IFLA (IFLA,IFLB):',IFLA,IFLB
26760 CALL PHO_HARZSP(IFLA,IFLB,NFSISR,ZMIN,ZMAX,ZZ)
26762 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.3)')
26763 & 'PHO_HARISR: pre-selected ZZ',ZZ
26765 THETA = 4.D0*ZZ**2*Q2NEW/((ECMP*XP)**2*(1.D0-ZZ))
26766 IF(THETA.GT.THSH(IP,INDX)) THEN
26767 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,2E12.3)')
26768 & 'PHO_HARISR: reject by angle (NEW/OLD)',
26769 & THETA,THSH(IP,INDX)
26772 C rejection weight given by new PDFs
26774 PT2NEW = Q2NEW*(1.D0-ZZ)
26775 IF(NQQALI.EQ.1) THEN
26776 SCALE2 = PT2NEW*AQQPD
26778 SCALE2 = Q2NEW*AQQPD
26780 IF(SCALE2.LT.Q2MISR(IP)) THEN
26781 Q2SH(IP,INDX) = 0.D0
26783 IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,2E10.3,2I3)')
26784 & 'PHO_HARISR: evol.Q2-stop (SCALE2,Q2MIN,IP,INDX):',
26785 & Q2NEW,Q2MISR(IP),IP,INDX
26788 CALL PHO_PDF(IP,XNEW,SCALE2,0.D0,PD2)
26789 IF(PD2(IFLA).LT.1.D-10) GOTO 200
26790 CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26791 PD1(IFLB) = MAX(PD1(IFLB),1.D-10)
26792 WGF = PD2(IFLA)/PD1(IFLB)/(WGPDF(IFLA)+1.D-12)
26793 IF(NQQALI.EQ.1) WGF = WGF*LOG(Q2NEW*AQQALI/AL2ISR(IP))
26794 & /LOG(PT2NEW*AQQALI/AL2ISR(IP))
26795 IF((WGF.GT.1.D0).AND.(IDEB(79).GE.2)) THEN
26796 WRITE(LO,'(1X,A,E12.3)')
26797 & 'PHO_HARISR: final weight:',WGF
26798 WRITE(LO,'(6X,A,I7,2I3,3E11.3)')
26799 & 'EV,IFLA,IFLB,Q2,PT2,Z:',KEVENT,IFLA,IFLB,Q2NEW,PT2NEW,ZZ
26801 IF(WGF.LT.DT_RNDM(XNEW)) GOTO 200
26803 IF(IDEB(79).GE.15) THEN
26804 WRITE(LO,'(1X,A,/3X,3I3,3E11.3)')
26805 & 'PHO_HARISR: accepted IP,IFLA,IFLB,PT2,Q2,Z:',
26806 & IP,IFLA,IFLB,PT2NEW,Q2NEW,ZZ
26809 IF(INDX.GE.MXISR3) THEN
26810 WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26811 & '/POINT6/ for parton radiation (INDX,MXISR3):',INDX,MXISR3
26816 C branching accepted, registration
26817 Q2SH(IP,INDX) = Q2NEW
26818 PT2SH(IP,INDX) = PT2NEW
26820 IFL2(IP,INDX) = IFLA-IFLB
26821 Q2SH(IP,INDX+1) = Q2NEW
26822 PT2SH(IP,INDX+1) = PT2SH(IP,INDX)
26823 XPSH(IP,INDX+1) = XNEW
26824 THSH(IP,INDX+1) = THETA
26825 IFL1(IP,INDX+1) = IFLA
26826 ISH(IP) = ISH(IP)+1
26830 IF(NACC.GT.MXISR4) THEN
26831 WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26832 & '/POINT6/ for parton radiation (NACC,MXISR4):',NACC,MXISR4
26839 IBRA(2,NACC) = INDX
26842 C generation of next branching
26843 IF(NEXT(1)+NEXT(2).NE.0) GOTO 100
26847 C new initial flavours, x values
26848 IPB1 = IFL1(1,ISH(1))
26849 IPB2 = IFL1(2,ISH(2))
26850 XISR1 = XPSH(1,ISH(1))
26851 XISR2 = XPSH(2,ISH(2))
26856 IF(ISH(1).GT.1) THEN
26857 CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
26858 IF(IDPDG1.EQ.22) THEN
26859 CALL PHO_QPMPDF(IPB1,XISR1,Q2MISR(1),0.D0,PVIRTP(1),FXP)
26860 IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(IPB1)-FXP) IVAL(1) = 1
26862 CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
26863 IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(-IPB1)) IVAL(1) = 1
26868 IF(ISH(2).GT.1) THEN
26869 CALL PHO_PDF(2,XISR2,Q2MISR(2),0.D0,PD1)
26870 IF(IDPDG2.EQ.22) THEN
26871 CALL PHO_QPMPDF(IPB2,XISR2,Q2MISR(2),0.D0,PVIRTP(2),FXP)
26872 IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(IPB2)-FXP) IVAL(2) = 1
26874 IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(-IPB2)) IVAL(2) = 1
26879 C parton kinematics
26881 C final partons in CMS
26882 PM(3) = (XH1-XH2)*ECMP/2.D0
26883 PM(4) = (XH1+XH2)*ECMP/2.D0
26884 SH = XH1*XH2*ECMP**2
26888 CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P1(1),P1(2),P1(3),
26889 & P1(4),PTOT1,PHISR(1,1,IPAL(1)),PHISR(1,2,IPAL(1)),
26890 & PHISR(1,3,IPAL(1)),PHISR(1,4,IPAL(1)))
26891 CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P2(1),P2(2),P2(3),
26892 & P2(4),PTOT1,PHISR(2,1,IPAL(2)),PHISR(2,2,IPAL(2)),
26893 & PHISR(2,3,IPAL(2)),PHISR(2,4,IPAL(2)))
26899 IL(IPA) = IBRA(2,I)
26900 C new initial partons in CMS
26903 SHZ = SH/ZPSH(IPA,IL(IPA))
26905 Q2(1) = Q2SH(1,IL(1))
26906 Q2(2) = Q2SH(2,IL(2))
26909 PC(1,3) = SQRT((SH+Q2(1)+Q2(2))**2-4.D0*Q2(1)*Q2(2))
26911 PC(1,4) = (SH-Q2(1)+Q2(2))/(2.D0*SSH)
26915 PC(2,4) = SSH-PC(1,4)
26916 XMS4 = PHO_PMASS(IFL2(IPA,IL(IPA)),1)**2
26917 EE3 = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
26918 S1 = SH+Q2(IPA)+Q2(IPB)
26919 S3 = SHZ+Q2(IPB)+Q2SH(IPA,IL(IPA)+1)
26920 R1 = SQRT(S1**2-4.D0*Q2(IPA)*Q2(IPB))
26921 R3 = SQRT(S3**2-4.D0*Q2(IPB)*Q2SH(IPA,IL(IPA)+1))
26922 IF(Q2(IPB).LT.0.1D0) THEN
26923 XMS4M = (Q2(IPA)/ZPSH(IPA,IL(IPA))-Q2SH(IPA,IL(IPA)+1))
26924 & *(SH/(SH+Q2(IPA))-SH/(SHZ+Q2SH(IPA,IL(IPA)+1)))
26926 XMS4M = (S1*S3-R1*R3)/(2.D0*Q2(IPB))
26927 & -Q2(IPA)-Q2SH(IPA,IL(IPA)+1)
26930 C max. virtuality for time-like showers
26931 QMAX = MIN(XMS4M,PARMDL(95)*Q2(IPA))
26932 IF((IPAMDL(111).GE.1).AND.(QMAX.GT.PARMDL(94))) THEN
26933 C generate time-like parton shower
26934 KF = IFL2(IPA,IL(IPA))
26935 IF(KF.EQ.0) KF = 21
26936 EER = MIN(EE3-PC(IPA,4),ECMP)
26939 CALL PY1ENT(1,KF,EER,THER,THER)
26941 CALL PYSHOW(1,0,QMAXR)
26943 IF(IDEB(79).GE.25) THEN
26944 WRITE(LO,'(1X,2A,/,5X,1P,4E12.4)') 'PHO_HARISR: ',
26945 & 'PYSHOW called for EE,QMAX,XMS4M,Q2(IPA)',
26946 & EER,QMAX,XMS4M,Q2(IPA)
26959 IF(PYK(K,1).LE.4) THEN
26962 IF(KK.GT.MXISR1) THEN
26963 WRITE(LO,'(1X,2A,2I5)') 'PHO_HARISR: no space ',
26964 & 'left in /POPISR/ (KK,MXISR1):',KK,MXISR1
26969 PHISR(IPA,1,KK) = PYP(K,1)
26970 PJX = PJX+PHISR(IPA,1,KK)
26971 PHISR(IPA,2,KK) = PYP(K,2)
26972 PJY = PJY+PHISR(IPA,2,KK)
26973 PHISR(IPA,3,KK) = PYP(K,3)
26974 PJZ = PJZ+PHISR(IPA,3,KK)
26975 PHISR(IPA,4,KK) = PYP(K,4)
26976 PJE = PJE+PHISR(IPA,4,KK)
26977 IFLISR(IPA,KK) = PYK(K,2)
26979 IF(IFLISR(IPA,KK).EQ.21) IFLISR(IPA,KK) = 0
26980 IF(IFLISR(IPA,KK).EQ.5) IFLISR(IPA,KK) = 3
26981 IF(IFLISR(IPA,KK).EQ.-5) IFLISR(IPA,KK) = -3
26984 NGEN = KK-IPAL(IPA)
26985 XMS4 = (PJE+PJZ)*(PJE-PJZ)-PJX**2-PJY**2
26986 PP4 = SQRT(PJE**2-XMS4)
26987 EE3 = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
26989 IF(IDEB(79).GE.20) WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)')
26991 & 'time-like shower: PJE,PJX,PJY,PJZ,PP4,XMS4',
26992 & PJE,PJX,PJY,PJZ,PP4,XMS4
26995 PZ3 = (2.D0*PC(IPA,4)*EE3+Q2(IPA)+Q2SH(IPA,IL(IPA)+1)+XMS4)
26996 & /(2.D0*PC(IPA,3))
26997 PT3 = (EE3+PZ3)*(EE3-PZ3)+Q2SH(IPA,IL(IPA)+1)
26998 IF(PT3.LT.0.D0) THEN
26999 IF(IDEB(79).GE.5) WRITE(LO,'(1X,A,E12.3)')
27000 & 'PHO_HARISR: rejection due to PT3',PT3
27004 CALL PHO_SFECFE(SFE,CFE)
27009 C time-like shower generated
27010 EE4 = EE3-PC(IPA,4)
27011 PZ4 = PZ3-PC(IPA,3)
27012 PP4 = SQRT(PT3**2+PZ4**2)
27014 GAM = (EE4*PJE-PP4*PJZ)/XMS4
27015 BEG = (PJE*PP4-EE4*PJZ)/XMS4
27018 SIDD = SQRT(PX3**2+PY3**2)/PP4
27021 IF(PP4*SIDD.GT.1.D-5) THEN
27022 COFD = PX3/(SIDD*PP4)
27023 SIFD = PY3/(SIDD*PP4)
27024 ANORF = SQRT(COFD*COFD+SIFD*SIFD)
27028 C copy partons back
27032 PX = PHISR(IPA,1,KK)
27033 PY = PHISR(IPA,2,KK)
27034 PZ = PHISR(IPA,3,KK)
27035 COH= PHISR(IPA,4,KK)
27036 EE = GAM*COH+BEG*PZ
27037 PZ = GAM*PZ +BEG*COH
27038 PHISR(IPA,4,KK) = EE
27039 CALL PHO_TRANS(PX,PY,PZ,CODD,SIDD,COFD,SIFD,
27040 & PHISR(IPA,1,KK),PHISR(IPA,2,KK),PHISR(IPA,3,KK))
27044 C no time-like shower generated
27045 IPAL(IPA) = IPAL(IPA)+1
27046 PHISR(IPA,1,IPAL(IPA)) = PX3
27047 PHISR(IPA,2,IPAL(IPA)) = PY3
27048 PHISR(IPA,3,IPAL(IPA)) = PZ3-PC(IPA,3)
27049 PHISR(IPA,4,IPAL(IPA)) = EE3-PC(IPA,4)
27050 IFLISR(IPA,IPAL(IPA)) = IFL2(IPA,IL(IPA))
27056 C boost / rotate into new CMS
27058 GB(K) = (PC(1,K)+PC(2,K))/SSHZ
27060 CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),PC(1,1),PC(1,2),
27061 & PC(1,3),PC(1,4),PTOT1,PM(1),PM(2),PM(3),PM(4))
27063 SIG= SQRT(PM(1)**2+PM(2)**2)/PTOT1
27066 IF(PTOT1*SIG.GT.1.D-5) THEN
27067 COH=PM(1)/(SIG*PTOT1)
27068 SIH=PM(2)/(SIG*PTOT1)
27069 ANORF=SQRT(COH*COH+SIH*SIH)
27074 DO 844 L=IPOISR(K,1,IHIDX),IPAL(K)
27075 CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),
27076 & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),
27077 & PTOT1,PM(1),PM(2),PM(3),PM(4))
27078 CALL PHO_TRANI(PM(1),PM(2),PM(3),COG,SIG,COH,SIH,PN(1),
27080 CALL PHO_TRANS(PN(1),PN(2),PN(3),1.D0,0.D0,COH,SIH,
27081 & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L))
27082 PHISR(K,4,L) = PM(4)
27086 C boost back to global CMS
27087 PM(3) = (XISR1-XISR2)/2.D0
27088 PM(4) = (XISR1+XISR2)/2.D0
27089 SSH = SQRT(XISR1*XISR2)
27093 DO 944 L=IPOISR(K,1,IHIDX),IPAL(K)
27094 CALL PHO_ALTRA(GB(4),0.D0,0.D0,GB(3),PHISR(K,1,L),
27095 & PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),PTOT1,PM(1),
27096 & PM(2),PM(3),PM(4))
27097 PHISR(K,1,L) = PM(1)
27098 PHISR(K,2,L) = PM(2)
27099 PHISR(K,3,L) = PM(3)
27100 PHISR(K,4,L) = PM(4)
27104 IPOISR(1,2,IHIDX) = IPAL(1)
27105 IPOISR(2,2,IHIDX) = IPAL(2)
27106 IMXISR(1) = IPAL(1)
27107 IMXISR(2) = IPAL(2)
27110 IF(IDEB(79).GE.10) THEN
27111 WRITE(LO,'(1X,A,2I10/,6X,A,2E12.3,2I5)') 'NUMBER OF EMISSIONS',
27112 & ISH(1)-1,ISH(2)-1,'NEW X1,X2,IFL1,ILF2',XISR1,XISR2,IPB1,IPB2
27114 WRITE(LO,'(1X,A,2I5,/6X,A)')
27115 & 'PHO_HARISR: ISR configuration (NITER,NACC)',NITER,NACC,
27116 & ' SIDE NO. IFLB IFLC Q2SH PT2SH XH ZZ'
27120 WRITE(LO,'(5X,4I5,4E11.3)')
27121 & K,I,IFL1(K,I),IFL2(K,I),Q2SH(K,I),PT2SH(K,I),XPSH(K,I),
27125 C check of final configuration
27132 WRITE(LO,'(1X,A)') 'PHO_HARISR: outgoing partons'
27134 DO 744 L=IPOISR(K,1,IHIDX),IPOISR(K,2,IHIDX)
27135 WRITE(LO,'(6X,2I4,I6,4E11.3)') K,L,IFLISR(K,L),
27136 & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L)
27137 IFSUM(K) = IFSUM(K)+ IFLISR(K,L)
27138 PX3 = PX3 + PHISR(K,1,L)
27139 PY3 = PY3 + PHISR(K,2,L)
27140 PZ3 = PZ3 + PHISR(K,3,L)
27141 EE3 = EE3 + PHISR(K,4,L)
27144 IFSUM(1) = IFSUM(1)-IPB1
27145 IFSUM(2) = IFSUM(2)-IPB2
27146 PZ3 = PZ3 -(XISR1-XISR2)*ECMP/2.D0
27147 EE3 = EE3 -(XISR1+XISR2)*ECMP/2.D0
27148 WRITE(LO,'(1X,A,2I4,4E11.3)') 'CHECK:IFL1,2 PCM(1-4)',
27149 & IFSUM,PX3,PY3,PZ3,EE3
27153 *$ CREATE PHO_HARZSP.FOR
27155 CDECK ID>, PHO_HARZSP
27156 SUBROUTINE PHO_HARZSP(IFLA,IFLB,NFSH,ZMIN,ZMAX,ZZ)
27157 C*********************************************************************
27159 C sampling of z values from DGLAP kernels
27161 C input: IFLA,IFLB parton flavours
27162 C NFSH flavours involved in hard processes
27163 C ZMIN minimal ZZ allowed
27164 C ZMAX maximal ZZ allowed
27166 C output: ZZ z value
27168 C*********************************************************************
27169 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27172 PARAMETER ( DEPS = 1.D-10 )
27174 C input/output channels
27176 COMMON /POINOU/ LI,LO
27177 C event debugging information
27179 PARAMETER (NMAXD=100)
27180 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27181 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27182 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27183 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27184 C internal rejection counters
27186 PARAMETER (NMXJ=60)
27187 CHARACTER*10 REJTIT
27189 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
27191 IF(ZMAX.LE.ZMIN) THEN
27192 WRITE(LO,'(1X,A,2E12.3)')
27193 & 'PHO_HARZSP: ZMAX<ZMIN (ZMAX,ZMIN)',ZMAX,ZMIN
27194 CALL PHO_PREVNT(-1)
27202 C1 = ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)
27203 C2 = (1.D0-ZMIN)/ZMIN
27205 ZZ = 1.D0/(1.D0+C2/C1**DT_RNDM(ZMIN))
27206 IF(((1.D0-ZZ*(1.D0-ZZ))**2).LT.DT_RNDM(ZMAX)) GOTO 100
27207 ELSE IF(ABS(IFLA).LE.NFSH) THEN
27211 ZZ = ZMIN*C1**DT_RNDM(ZMIN)
27212 IF((0.5D0*(1.D0+(1.D0-ZZ)**2)).LT.DT_RNDM(ZMAX)) GOTO 200
27216 ELSE IF(ABS(IFLB).LE.NFSH) THEN
27221 ZZ = ZMIN+C1*DT_RNDM(ZMIN)
27222 IF((2.D0*ZZ*(ZZ-1.D0)+1.D0).LT.DT_RNDM(ZMAX)) GOTO 300
27223 ELSE IF(ABS(IFLA).LE.NFSH) THEN
27225 C1 = (1.D0-ZMAX)/(1.D0-ZMIN)
27228 ZZ = 1.D0-C2*C1**DT_RNDM(ZMIN)
27229 IF(0.5D0*(1.D0+ZZ**2).LT.DT_RNDM(ZMAX)) GOTO 400
27237 IF(IDEB(80).GE.20) WRITE(LO,'(1X,A,2I3,3E11.3)')
27238 & 'PHO_HARZSP: IFLA,IFLB,ZZ,ZMIN,ZMAX',
27239 & IFLA,IFLB,ZZ,ZMIN,ZMAX
27243 WRITE(LO,'(/1X,A,2I7)') 'PHO_HARZSP:ERROR: invalid flavours A,B',
27249 *$ CREATE PHO_ALPHAE.FOR
27251 CDECK ID>, PHO_ALPHAE
27252 DOUBLE PRECISION FUNCTION PHO_ALPHAE(Q2)
27253 C**********************************************************************
27255 C calculation of ALPHA_em
27257 C input: Q2 scale in GeV**2
27259 C**********************************************************************
27265 DOUBLE PRECISION Q2
27267 C input/output channels
27269 COMMON /POINOU/ LI,LO
27270 C model switches and parameters
27272 INTEGER ISWMDL,IPAMDL
27273 DOUBLE PRECISION PARMDL
27274 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27276 DOUBLE PRECISION PYALEM
27278 pho_alphae = 1.D0/137.D0
27280 if(ipamdl(120).eq.1) then
27282 pho_alphae = PYALEM(Q2)
27288 *$ CREATE PHO_ALPHAS.FOR
27290 CDECK ID>, PHO_ALPHAS
27291 DOUBLE PRECISION FUNCTION PHO_ALPHAS(Q2,IMODE)
27292 C**********************************************************************
27294 C calculation of ALPHA_S
27296 C input: IMODE = 1 lambda_QCD**2 for PDF 1 evolution
27297 C 2 lambda_QCD**2 for PDF 2 evolution
27298 C 3 lambda_QCD**2 for hard scattering
27299 C Q2 scale in GeV**2
27301 C initialization needed:
27302 C IMODE = 0 lambda values taken from PDF table
27303 C -1 given Q2 is 4-flavour lambda 1
27304 C -2 given Q2 is 4-flavour lambda 2
27305 C -3 given Q2 is 4-flavour lambda 3
27308 C**********************************************************************
27314 DOUBLE PRECISION Q2
27317 C input/output channels
27319 COMMON /POINOU/ LI,LO
27320 C model switches and parameters
27322 INTEGER ISWMDL,IPAMDL
27323 DOUBLE PRECISION PARMDL
27324 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27325 C hard scattering parameters used for most recent hard interaction
27327 DOUBLE PRECISION ALQCD2,BQCD
27328 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
27329 C currently activated parton density parametrizations
27331 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
27332 DOUBLE PRECISION PDFLAM,PDFQ2M
27333 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
27334 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
27340 IF(IMODE.GT.0) THEN
27342 IF(Q2.LT.PARMDL(148)) THEN
27344 ELSE IF(Q2.LT.PARMDL(149)) THEN
27346 ELSE IF(Q2.LT.PARMDL(150)) THEN
27352 PHO_ALPHAS = BQCD(NFbeta)/LOG(Q2/ALQCD2(IMODE,NFbeta))
27355 ELSE IF(IMODE.EQ.0) THEN
27359 ALQCD2(I,2) = PDFLAM(1)*PDFLAM(2)
27361 ALQCD2(I,2) = PDFLAM(I)*PDFLAM(I)
27363 ALQCD2(I,1) = PARMDL(148)
27364 & *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
27365 ALQCD2(I,3) = PARMDL(149)
27366 & *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
27367 ALQCD2(I,4) = PARMDL(150)
27368 & *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))
27372 ELSE IF(IMODE.LT.0) THEN
27374 if(IMODE.eq.-4) then
27376 ALQCD2(I,2) = SQRT(ALQCD2(1,2)*ALQCD2(2,2))
27381 ALQCD2(I,1) = PARMDL(148)
27382 & *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
27383 ALQCD2(I,3) = PARMDL(149)
27384 & *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
27385 ALQCD2(I,4) = PARMDL(150)
27386 & *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))
27392 *$ CREATE PHO_DFWRAP.FOR
27394 CDECK ID>, PHO_DFWRAP
27395 SUBROUTINE PHO_DFWRAP(MODE,JM1,JM2)
27396 C**********************************************************************
27398 C wrapper for diffraction dissociation in hadron-nucleus and
27399 C nucleus-nucleus collisions with DPMJET
27401 C input: MODE 1: transformation into CMS
27402 C 2: transformation into Lab
27403 C JM1/2 indices of old mother particles
27404 C JM1/2N indices of new mother particles
27406 C**********************************************************************
27412 INTEGER MODE,JM1,JM2
27414 C input/output channels
27416 COMMON /POINOU/ LI,LO
27417 C event debugging information
27419 PARAMETER (NMAXD=100)
27420 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27421 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27422 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27423 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27425 C standard particle data interface
27428 PARAMETER (NMXHEP=4000)
27430 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
27431 DOUBLE PRECISION PHEP,VHEP
27432 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27433 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
27435 C extension to standard particle data interface (PHOJET specific)
27436 INTEGER IMPART,IPHIST,ICOLOR
27437 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
27439 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
27440 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
27441 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
27442 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
27443 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
27445 DOUBLE PRECISION GAMBED(4),P1(4),P2(4),P3(4),P4(4),XM1,XM2
27446 DOUBLE PRECISION SS,ECMD,PTOT1,CODD,SIDD,COFD,SIFD,ANORF
27448 INTEGER I,NHEPS,JM1S,JM2S,JM1N,JM2N,IREJ
27450 C transformation into CMS
27462 P1(1) = PHEP(1,JM1)+PHEP(1,JM2)
27463 P1(2) = PHEP(2,JM1)+PHEP(2,JM2)
27464 P1(3) = PHEP(3,JM1)+PHEP(3,JM2)
27465 P1(4) = PHEP(4,JM1)+PHEP(4,JM2)
27466 SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
27469 GAMBED(I) = P1(I)/ECMD
27471 CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
27472 & PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
27473 & PHEP(4,JM1),PTOT1,P1(1),P1(2),P1(3),P1(4))
27476 SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
27479 IF(PTOT1*SIDD.GT.1.D-5) THEN
27480 COFD = P1(1)/(SIDD*PTOT1)
27481 SIFD = P1(2)/(SIDD*PTOT1)
27482 ANORF= SQRT(COFD*COFD+SIFD*SIFD)
27487 C initial particles in CMS
27491 P1(3) = ECMD/2.D0*XPSUB
27496 P2(3) = -ECMD/2.D0*XTSUB
27499 CALL PHO_MSHELL(P1,P2,XM1,XM2,P3,P4,IREJ)
27501 CALL PHO_REGPAR(1,IDHEP(JM1),IMPART(JM1),JM1,JM2,
27502 & P3(1),P3(2),P3(3),P3(4),IPHIST(1,JM1),IPHIST(2,JM1),
27503 & ICOLOR(1,JM1),ICOLOR(2,JM1),JM1N,1)
27505 CALL PHO_REGPAR(1,IDHEP(JM2),IMPART(JM2),JM2,JM1,
27506 & P4(1),P4(2),P4(3),P4(4),IPHIST(1,JM2),IPHIST(2,JM2),
27507 & ICOLOR(1,JM2),ICOLOR(2,JM2),JM2N,1)
27512 C transformation into lab.
27514 ELSE IF(MODE.EQ.2) THEN
27516 CALL PHO_LTRHEP(JM1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
27517 & GAMBED(1),GAMBED(2),GAMBED(3))
27522 C clean up after rejection
27524 ELSE IF(MODE.EQ.-2) THEN
27533 WRITE(LO,'(1X,A,I6)') 'PHO_DFWRAP: invalid MODE parameter:',MODE
27539 *$ CREATE PHO_DIFDIS.FOR
27541 CDECK ID>, PHO_DIFDIS
27542 SUBROUTINE PHO_DIFDIS(IDIF1,IDIF2,IMOTH1,IMOTH2,SPROB,IMODE,
27543 & MSOFT,MHARD,IREJ)
27544 C***********************************************************************
27546 C sampling of diffractive events of different kinds,
27547 C (produced particles stored in /POEVT1/)
27549 C input: IDIF1/2 diffractive process particle 1/2
27550 C 0 elastic/quasi-elastic scattering
27551 C 1 diffraction dissociation
27552 C IMOTH1/2 index of mother particles in /POEVT1/
27553 C SPROB suppression factor (survival probability) for
27554 C resolved diffraction dissociation
27555 C IMODE mode of operation
27556 C 0 sampling of diffractive cut
27557 C 1 sampling of enhanced cut
27558 C 2 sampling of diffractive cut without
27559 C scattering (needed for double-pomeron)
27560 C -1 initialization
27561 C -2 output of statistics
27563 C output: MSOFT number of generated soft strings
27564 C MHARD number of generated hard strings
27565 C IDIF1/2 diffraction label for particle 1/2 in /PROCES/
27566 C 0 quasi elastic scattering
27567 C 1 low-mass diffractive dissociation
27568 C 2 soft high-mass diffractive dissociation
27569 C 3 hard resolved diffractive dissociation
27570 C 4 hard direct diffractive dissociation
27571 C IREJ rejection label
27572 C 0 successful generation of partons
27575 C***********************************************************************
27576 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27579 PARAMETER ( EPS = 1.D-7,
27582 C input/output channels
27584 COMMON /POINOU/ LI,LO
27585 C event debugging information
27587 PARAMETER (NMAXD=100)
27588 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27589 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27590 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27591 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27592 C general process information
27593 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
27594 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
27595 C internal rejection counters
27597 PARAMETER (NMXJ=60)
27598 CHARACTER*10 REJTIT
27600 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
27601 C global event kinematics and particle IDs
27602 INTEGER IFPAP,IFPAB
27603 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
27604 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
27605 C c.m. kinematics of diffraction
27607 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
27608 & SIDD,CODD,SIFD,COFD,PDCMS
27609 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
27610 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
27611 C obsolete cut-off information
27612 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
27613 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
27615 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
27616 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
27617 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
27618 C model switches and parameters
27620 INTEGER ISWMDL,IPAMDL
27621 DOUBLE PRECISION PARMDL
27622 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27623 C Reggeon phenomenology parameters
27624 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
27625 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
27626 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
27627 & ALREG,ALREGP,GR(2),B0REG(2),
27628 & GPPP,GPPR,B0PPP,B0PPR,
27629 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
27630 C parameters of 2x2 channel model
27631 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
27632 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
27633 C table of particle indices for recursive PHOJET calls
27635 PARAMETER ( MAXIPX = 100 )
27636 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
27637 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
27638 & IPOIX1,IPOIX2,IPOIX3
27640 C standard particle data interface
27643 PARAMETER (NMXHEP=4000)
27645 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
27646 DOUBLE PRECISION PHEP,VHEP
27647 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27648 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
27650 C extension to standard particle data interface (PHOJET specific)
27651 INTEGER IMPART,IPHIST,ICOLOR
27652 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
27654 C event weights and generated cross section
27655 INTEGER IPOWGC,ISWCUT,IVWGHT
27656 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
27657 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
27658 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
27660 DOUBLE PRECISION P1,P2,XMASS,AMP,PP,PD1,PD2
27661 DIMENSION P1(5),P2(5),XMASS(2),AMP(2),PP(7,2),PD1(7),PD2(7)
27662 DIMENSION IDPDG(2),IDBAM(2),IPAR(2),IPOSP(2,2),IRPDG(2),IVEC(2),
27663 & IRBAM(2),IFL1P(2),IFL2P(2),ISAM(2),JSAM(2),KSAM(2),
27666 IF(IMODE.EQ.-1) THEN
27669 ELSE IF(IMODE.EQ.-2) THEN
27670 C output of statistics
27678 IF(IDEB(45).GE.10) THEN
27679 WRITE(LO,'(1X,2A,/16X,7I6)') 'PHO_DIFDIS: (1) ',
27680 & 'IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
27681 & IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE
27685 C save current status
27695 JDA11 = JDAHEP(1,IMOTH1)
27696 JDA21 = JDAHEP(2,IMOTH1)
27697 JDA12 = JDAHEP(1,IMOTH2)
27698 JDA22 = JDAHEP(2,IMOTH2)
27699 ISTH1 = ISTHEP(IMOTH1)
27700 ISTH2 = ISTHEP(IMOTH2)
27706 IDPDG(I) = IDHEP(NPOSD(I))
27707 IDBAM(I) = IMPART(NPOSD(I))
27708 AMP(I) = PHO_PMASS(IDBAM(I),0)
27709 IF(IDPDG(I).EQ.22) THEN
27710 PMASSD(I) = 0.765D0
27711 PVIRTD(I) = PHEP(5,NPOSD(I))**2
27713 PMASSD(I) = PHO_PMASS(IDBAM(I),0)
27718 P1(1) = PHEP(1,IMOTH1)+PHEP(1,IMOTH2)
27719 P1(2) = PHEP(2,IMOTH1)+PHEP(2,IMOTH2)
27720 P1(3) = PHEP(3,IMOTH1)+PHEP(3,IMOTH2)
27721 P1(4) = PHEP(4,IMOTH1)+PHEP(4,IMOTH2)
27722 SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
27724 IF(IDEB(45).GE.15) WRITE(LO,'(1X,A,E12.4)')
27725 & 'PHO_DIFDIS: availabe energy',ECMD
27726 C check total available energy
27727 IF((AMP(1)+AMP(2)+0.1D0).GE.ECMD) THEN
27728 IF(IDEB(45).GE.2) WRITE(LO,'(1X,2A,/5X,A,1P,3E11.3)')
27730 & 'not enough energy for inelastic diffraction',
27731 & 'ECM, particle masses:',ECMD,AMP
27732 IFAIL(7) = IFAIL(7)+1
27738 GAMBED(I) = P1(I)/ECMD
27740 CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
27741 & PHEP(1,IMOTH1),PHEP(2,IMOTH1),PHEP(3,IMOTH1),
27742 & PHEP(4,IMOTH1),PTOT1,P1(1),P1(2),P1(3),P1(4))
27745 SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
27748 IF(PTOT1*SIDD.GT.1.D-5) THEN
27749 COFD = P1(1)/(SIDD*PTOT1)
27750 SIFD = P1(2)/(SIDD*PTOT1)
27751 ANORF= SQRT(COFD*COFD+SIFD*SIFD)
27755 C initial particles in CMS
27762 PDCMS(3,2) = -PTOT1
27763 PDCMS(4,2) = ECMD-P1(4)
27764 C get new CM momentum
27765 AM12 = PMASSD(1)**2
27766 AM22 = PMASSD(2)**2
27767 PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)
27769 C coherence constraint (min/max diffractive mass allowed)
27770 IF(IMODE.EQ.2) THEN
27771 THRM1 = PARMDL(71)/SQRT(1-PARMDL(72))
27772 THRM1 = MAX(THRM1,PARMDL(70)*PARMDL(71))
27773 THRM2 = SQRT(1-PARMDL(72))*ECMD
27774 THRM2 = MIN(THRM2,ECMD/PARMDL(70))
27777 THRM2 = PARMDL(45)*ECMD
27778 C check kinematic limits
27779 IF(THRM2.LE.(4.D0*PARMDL(162))) IPAR(1) = MIN(IPAR(1),1)
27780 IF(THRM2.LE.(4.D0*PARMDL(163))) IPAR(2) = MIN(IPAR(2),1)
27783 C check energy vs. coherence constraints
27784 IF(MAX(PARMDL(162),PMASSD(1)+THRM1).GE.THRM2) IPAR(1) = 0
27785 IF(MAX(PARMDL(163),PMASSD(2)+THRM1).GE.THRM2) IPAR(2) = 0
27787 C no phase space available
27788 IF(IPAR(1)+IPAR(2).EQ.0) THEN
27789 IF(IDEB(45).GE.2) WRITE(LO,'(1X,2A,1P,E11.3,2(/5X,A,2E11.3))')
27791 & 'not enough phase space for ine. diffraction (Ecm)',ECMD,
27792 & 'side 1: min. mass, upper mass limit:',
27793 & MAX(PARMDL(162),PMASSD(1)+THRM1),THRM2,
27794 & 'side 2: min. mass, upper mass limit:',
27795 & MAX(PARMDL(163),PMASSD(2)+THRM1),THRM2
27796 IFAIL(7) = IFAIL(7)+1
27806 C main rejection loop
27807 C -------------------------------
27811 IFAIL(13) = IFAIL(13)+1
27812 IF(ITRY.GE.ITRYM) THEN
27813 IF(IDEB(45).GE.2) WRITE(LO,'(1X,A,I10,2I3)')
27814 & 'PHO_DIFDIS: rejection (KEVE,IPAR1/2) ',KEVENT,IPAR
27815 IFAIL(7) = IFAIL(7)+1
27826 C reset mother-daugther relations
27828 JDAHEP(1,IMOTH1) = JDA11
27829 JDAHEP(2,IMOTH1) = JDA21
27830 JDAHEP(1,IMOTH2) = JDA12
27831 JDAHEP(2,IMOTH2) = JDA22
27832 ISTHEP(IMOTH1) = ISTH1
27833 ISTHEP(IMOTH2) = ISTH2
27842 C calculation of kinematics
27844 C sampling of masses
27847 IFL1P(I) = IDPDG(I)
27848 IFL2P(I) = IDBAM(I)
27854 IF(IPAR(I).EQ.0) THEN
27855 C vector meson dominance assumed
27857 CALL PHO_VECRES(IVEC(I),XMASS(I),IFL1P(I),IFL2P(I))
27858 C diffraction dissociation
27859 ELSE IF(IPAR(I).EQ.1) THEN
27860 XMMIN = MAX(PARMDL(161+I),PMASSD(I)+THRM1)
27861 PREF2 = PMASSD(I)**2
27862 XMASS(I) = PHO_DFMASS(XMMIN,THRM2,PREF2,PVIRTD(I),ISWMDL(22))
27864 WRITE(LO,'(/1X,A,2I3)')
27865 & 'PHO_DIFDIS:ERROR:invalid IPAR1,IPAR2',IPAR(1),IPAR(2)
27870 C sampling of momentum transfer
27871 CALL PHO_DIFSLP(IPAR(1),IPAR(2),IVEC(1),IVEC(2),XMASS(1),XMASS(2),
27872 & THRM2,TT,SLWGHT,IREJ)
27875 IF(NSLP.LT.100) GOTO 55
27876 WRITE(LO,'(1X,2A,/10X,2I3,2E12.3)') 'PHO_DIFDIS: ',
27877 & 'too many slope rejections:IPAR1,IPAR2,M1,M2',IPAR,XMASS
27882 C correct for t-M^2 correlation in diffraction
27883 IF(DT_RNDM(TT).GT.SLWGHT) THEN
27885 IF(NCOR.LT.100) GOTO 55
27886 WRITE(LO,'(1X,2A,I10)') 'PHO_DIFDIS: ',
27887 & 'too many rejections due to t-M**2 correlation (EVE)',KEVENT
27893 IF(IDEB(45).GE.5) THEN
27894 WRITE(LO,'(1X,A,/5X,2I3,3E12.3)')
27895 & 'PHO_DIFDIS: IPAR1,IPAR2,XMASS1,XMASS2,TT',IPAR,XMASS,TT
27897 C not double pomeron scattering
27898 IF(IMODE.NE.2) THEN
27899 C sample diffractive interaction processes
27901 IF(IPAR(I).NE.0) THEN
27902 C find particle combination
27903 IF(IDPDG(I).EQ.IFPAP(1)) THEN
27905 ELSE IF(IDPDG(I).EQ.IFPAP(2)) THEN
27907 ELSE IF(IDPDG(I).EQ.990) THEN
27912 C sample dissociation process
27913 CALL PHO_DIFPRO(IP,ISWMDL(16),IDPDG(I),990,XMASS(I),
27914 & PVIRTD(I),0.D0,SPROB,IPROC(I),ISAM(I),JSAM(I),
27916 IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
27917 C store process label
27918 IF(IDIR(I).GT.0) THEN
27920 ELSE IF(KSAM(I).GT.0) THEN
27922 ELSE IF(ISAM(I).GT.0) THEN
27926 C mass fine correction
27927 CALL PHO_MASSAD(IDPDG(I),IFL1P(I),IFL2P(I),PMASSD(I),
27928 & XMASS(I),XMNEW,IRPDG(I),IRBAM(I))
27932 C diffractive pomeron-hadron interaction
27933 IPAR(I) = 10+IPROC(I)
27936 IF(IDEB(45).GE.15) WRITE(LO,'(1X,A,/10X,I3,E12.4,5I3)')
27937 & 'PHO_DIFDIS: IP,XMASS,IPROC,ISAM,JSAM,KSAM,IDIR',
27938 & IP,XMASS(I),IPROC(I),ISAM(I),JSAM(I),KSAM(I),IDIR(I)
27942 C actualize debug information
27943 IF(IMODE.EQ.1) THEN
27947 C calculate new momenta in CMS
27948 CALL PHO_DIFKIN(XMASS(1),XMASS(2),TT,P1,P2,IREJ)
27949 IF(IREJ.NE.0) GOTO 50
27955 C comment line for diffraction
27956 CALL PHO_REGPAR(30,IPROCE,IMODE,NPOSD(1),NPOSD(2),XMASS(1),
27957 & XMASS(2),TT,ECMD,IPAR(1),IPAR(2),IDPDG(1),IDPDG(2),ICPOS,1)
27958 C write diffractive strings/particles
27966 PP(6,I1) = SIGN(PHEP(5,NPOSD(I1))**2,PHEP(5,NPOSD(I1)))
27968 IGEN = IPHIST(2,NPOSD(I1))
27969 if(IGEN.eq.0) IGEN = -I1*10
27970 CALL PHO_DIFPAR(NPOSD(I1),NPOSD(I2),IGEN,IFL1P(I1),IFL2P(I1),
27971 & IPAR(I1),PD1,PD2,IPOSP(1,I1),IPOSP(2,I1),IMODE,IREJ)
27973 IFAIL(7+I) = IFAIL(7+I)+1
27974 IF(IDEB(45).GE.3) WRITE(LO,'(1X,A,2I3,E11.3)')
27975 & 'PHO_DIFDIS: rejection by PHO_DIFPAR (I,IPAR,XM)',
27976 & I,IPAR(I),XMASS(I)
27979 ICOLOR(I1,ICPOS) = IPOSP(1,I1)
27981 C double-pomeron scattering?
27982 IF(IMODE.EQ.2) GOTO 150
27984 C diffractive final states
27987 IF(IPAR(I).EQ.0) THEN
27988 C vector meson production
27989 IF(IDPDG(I).EQ.22) THEN
27990 IF(ISWMDL(21).GE.0) THEN
27992 IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
27993 CALL PHO_SDECAY(IPOSP(1,I),ISP,2)
27995 C hadronic state of multi-pomeron coupling
27996 ELSE IF(IDPDG(I).EQ.990) THEN
27997 CALL PHO_SDECAY(IPOSP(1,I),0,2)
28000 IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
28001 IF(ISAM(I)+JSAM(I)+KSAM(I).EQ.0) JSAM(I) = 1
28002 IF(IDIR(I).GT.0) THEN
28004 ELSE IF(KSAM(I).GT.0) THEN
28006 ELSE IF(ISAM(I).GT.0) THEN
28012 IPAR(I) = 10+IPROC(I)
28014 IPHIST(I,ICPOS) = IPAR(I)
28015 C update debug informantion
28022 IF((IRPDG(I).NE.0).AND.(ISWMDL(23).GT.0)) THEN
28024 C resonance decay, pi+pi- background
28025 P1(1) = PHEP(1,IPOSP(1,I))+PHEP(1,IPOSP(2,I))
28026 P1(2) = PHEP(2,IPOSP(1,I))+PHEP(2,IPOSP(2,I))
28027 P1(3) = PHEP(3,IPOSP(1,I))+PHEP(3,IPOSP(2,I))
28028 P1(4) = PHEP(4,IPOSP(1,I))+PHEP(4,IPOSP(2,I))
28029 CALL PHO_REGPAR(1,IRPDG(I),IRBAM(I),IPOSP(1,I),IPOSP(2,I),
28030 & P1(1),P1(2),P1(3),P1(4),0,2,0,0,IPOS,1)
28032 IF(IDPDG(I).EQ.22) THEN
28034 IF(ISWMDL(21).GE.0) THEN
28036 IF(ISWMDL(21).GE.2) ISP = IPAMDL(4)
28037 CALL PHO_SDECAY(IPOS,ISP,2)
28040 CALL PHO_SDECAY(IPOS,IPAMDL(3),2)
28045 C particle-pomeron scattering
28046 IF(IPAR(I).LE.4) THEN
28047 C non-diffractive particle-pomeron scattering
28048 IGEN = IPHIST(2,NPOSD(I))
28056 CALL PHO_STDPAR(IPOSP(1,I),IPOSP(2,I),IGEN,
28057 & ISAM(I),JSAM(I),KSAM(I),IDIR(I),IREJ)
28059 C diffractive particle-pomeron scattering
28061 IPORES(IPOIX2) = IPROC(I)
28062 IPOPOS(1,IPOIX2) = IPOSP(1,I)
28063 IPOPOS(2,IPOIX2) = IPOSP(2,I)
28070 IFAIL(20+I) = IFAIL(20+I)+1
28071 IF(IPAR(I).GT.1) THEN
28072 IF(IPAR(I).EQ.3) IFAIL(7+2*I) = IFAIL(7+2*I)+1
28073 IF(IPAR(I).EQ.4) IFAIL(8+2*I) = IFAIL(8+2*I)+1
28074 IF(IDIR(I).GT.0) THEN
28076 ELSE IF(KSAM(I).GT.0) THEN
28077 KSAM(I) = KSAM(I)-1
28078 ELSE IF(ISAM(I).GT.0) THEN
28079 ISAM(I) = ISAM(I)-1
28083 IF(IDEB(45).GE.2) WRITE(LO,'(1X,A,2I3,E11.3)')
28084 & 'PHO_DIFDIS: rejection PHO_STDPAR (I,IPAR,XM)',
28085 & I,IPAR(I),XMASS(I)
28093 C update debug information
28094 KSPOM = KSPOMS+ISAM(1)+ISAM(2)
28095 KSREG = KSREGS+JSAM(1)+JSAM(2)
28096 KHPOM = KHPOMS+KSAM(1)+KSAM(2)
28097 KHDIR = KHDIRS+IDIR(1)+IDIR(2)
28102 IF(IDEB(45).GE.10) THEN
28103 WRITE(LO,'(1X,2A,/18X,7I6)') 'PHO_DIFDIS: (2) ',
28104 & 'IPAR1,IPAR2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
28105 & IPAR,NPOSD,MSOFT,MHARD,IMODE
28107 IF(IDEB(45).GE.15) THEN
28108 WRITE(LO,'(2(/1X,A))') 'PHO_DIFDIS: output of /POEVT1/',
28109 & '------------------------------'
28115 *$ CREATE PHO_DIFPRO.FOR
28117 CDECK ID>, PHO_DIFPRO
28118 SUBROUTINE PHO_DIFPRO(IP,ICUT,ID1,ID2,XMASS,P2V1,P2V2,SPROB,
28119 & IPROC,ISAM,JSAM,KSAM,IDIR)
28120 C*********************************************************************
28122 C sampling of diffraction dissociation process
28124 C input: IP particle combination
28125 C ICUT user imposed limitations
28126 C ID1/2 PDG particle code of scattering particles
28127 C XMASS diffractively produced mass (GeV)
28128 C P2V1/2 virtuality of scattering particles (Gev**2)
28129 C SPROB suppression factor for resolved single and
28130 C double diffraction dissociation
28132 C output: IRPOC process ID
28133 C ISAM number of cut pomerons (soft)
28134 C JSAM number of cut reggeons
28135 C KSAM number of cut pomerons (hard)
28136 C IDIR direct hard interaction
28138 C*********************************************************************
28139 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28142 C input/output channels
28144 COMMON /POINOU/ LI,LO
28145 C event debugging information
28147 PARAMETER (NMAXD=100)
28148 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28149 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28150 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28151 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28152 C general process information
28153 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
28154 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
28155 C model switches and parameters
28157 INTEGER ISWMDL,IPAMDL
28158 DOUBLE PRECISION PARMDL
28159 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28160 C energy-interpolation table
28162 PARAMETER ( IEETA2 = 20 )
28164 DOUBLE PRECISION SIGTAB,SIGECM
28165 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
28172 IF(XMASS.GT.3.D0) THEN
28173 C rapidity gap survival probability
28175 IF(ISWMDL(28).GE.1) SPRO = SPROB
28176 C sample interaction
28178 CALL PHO_SAMPRO(IP,ID1,ID2,XMASS,P2V1,P2V2,SPRO,IPROC)
28182 IF(IPROC.EQ.1) CALL PHO_SAMPRB(XMASS,IP,ISAM,JSAM,KSAM)
28183 C non-diffractive hadron-pomeron interaction
28184 IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
28185 C option for suppression of multiple interaction
28188 IF(ISAM+KSAM+IDIR.GT.0) THEN
28196 ELSE IF(ICUT.EQ.1) THEN
28198 ELSE IF(KSAM.GT.0) THEN
28202 ELSE IF(ISAM.GT.0) THEN
28208 ELSE IF(ICUT.EQ.2) THEN
28210 ELSE IF(ICUT.EQ.3) THEN
28216 *$ CREATE PHO_DIFPAR.FOR
28218 CDECK ID>, PHO_DIFPAR
28219 SUBROUTINE PHO_DIFPAR(IMOTH1,IMOTH2,IGENM,IFL1,IFL2,IPAR,P1,P2,
28220 & IPOSH1,IPOSH2,IMODE,IREJ)
28221 C***********************************************************************
28223 C perform string construction for diffraction dissociation
28225 C input: IMOTH1,2 index of mother particles in POEVT1
28226 C IGENM production process of mother particles
28227 C IFL1,IFL2 particle numbers
28228 C (IDPDG,IDBAM for quasi-elas. hadron)
28229 C IPAR 0 quasi-elasic scattering
28230 C 1 single string configuration
28231 C 2 two string configuration
28232 C P1 massive 4 momentum of first
28233 C P1(6) virtuality/squ.mass of particle (GeV**2)
28234 C P1(7) virtuality of Pomeron (neg, GeV**2)
28235 C P2 massive 4 momentum of second particle
28236 C IMODE 1 diffraction dissociation
28237 C 2 double-pomeron scattering
28239 C output: IPOSH1,2 index of the particles in /POEVT1/
28240 C IREJ 0 successful string construction
28241 C 1 no string construction possible
28243 C***********************************************************************
28244 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28247 DIMENSION P1(7),P2(7)
28249 PARAMETER ( EPS = 1.D-7,
28252 C input/output channels
28254 COMMON /POINOU/ LI,LO
28255 C event debugging information
28257 PARAMETER (NMAXD=100)
28258 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28259 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28260 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28261 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28262 C internal rejection counters
28264 PARAMETER (NMXJ=60)
28265 CHARACTER*10 REJTIT
28267 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
28268 C c.m. kinematics of diffraction
28270 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
28271 & SIDD,CODD,SIFD,COFD,PDCMS
28272 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
28273 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
28274 C model switches and parameters
28276 INTEGER ISWMDL,IPAMDL
28277 DOUBLE PRECISION PARMDL
28278 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28280 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28281 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28282 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28284 C standard particle data interface
28287 PARAMETER (NMXHEP=4000)
28289 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28290 DOUBLE PRECISION PHEP,VHEP
28291 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28292 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28294 C extension to standard particle data interface (PHOJET specific)
28295 INTEGER IMPART,IPHIST,ICOLOR
28296 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28298 DIMENSION PCH1(2,4)
28305 if(IGENM.le.-10) IGEN = 0
28309 IF((IFL1.EQ.92).OR.(IFL1.EQ.91)) THEN
28310 if(IGEN.eq.0) IGEN = 3
28311 C pi+/pi- isotropic background
28312 CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,
28313 & P1(1),P1(2),P1(3),P1(4),0,IGEN,0,0,IPOSH1,1)
28314 CALL PHO_SDECAY(IPOSH1,0,-2)
28318 if(IFL1.ne.IDHEP(IMOTH1)) IGEN = 3
28320 C registration of particle or resonance
28321 CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,P1(1),P1(2),P1(3),
28322 & P1(4),0,IGEN,0,0,IPOSH1,1)
28325 C diffraction dissociation
28326 ELSE IF((IPAR.GE.1).AND.(IPAR.LE.18)) THEN
28327 C calculation of resulting particle momenta
28328 IF(IMOTH1.EQ.NPOSD(1)) THEN
28334 PCH1(2,I) = PDCMS(I,K)-P2(I)
28335 PCH1(1,I) = P1(I)-PCH1(2,I)
28339 if(IMODE.LT.2) then
28340 if(IGEN.eq.0) IGEN = -IGENM/10+4
28341 CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,PCH1(1,1),
28342 & PCH1(1,2),PCH1(1,3),PCH1(1,4),-1,IGEN,IC1,IC2,IPOSH1,1)
28344 if(IGEN.eq.0) IGEN = 4
28346 CALL PHO_REGPAR(1,990,0,IMOTH2,IMOTH1,PCH1(2,1),PCH1(2,2),
28347 & PCH1(2,3),PCH1(2,4),-1,IGEN,IC1,IC2,IPOSH2,1)
28351 WRITE(LO,'(/1X,A,I6)') 'PHO_DIFPAR:ERROR: invalid IPAR:',IPAR
28355 C back transformation
28356 CALL PHO_LTRHEP(ILTR1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
28357 & GAMBED(1),GAMBED(2),GAMBED(3))
28361 *$ CREATE PHO_QELAST.FOR
28363 CDECK ID>, PHO_QELAST
28364 SUBROUTINE PHO_QELAST(IPROC,JM1,JM2,IREJ)
28365 C**********************************************************************
28367 C sampling of quasi elastic processes
28369 C input: IPROC 2 purely elastic scattering
28370 C IPROC 3 q-ela. omega/omega/phi/pi+pi- production
28371 C IPROC 4 double pomeron scattering
28372 C IPROC -1 initialization
28373 C IPROC -2 output of statistics
28374 C JM1/2 index of initial particle 1/2
28376 C output: initial and final particles in /POEVT1/ involving
28377 C polarized resonances in /POEVT1/ and decay
28380 C IREJ 0 successful
28382 C 50 user rejection
28384 C**********************************************************************
28385 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28388 PARAMETER ( NTAB = 20,
28393 C input/output channels
28395 COMMON /POINOU/ LI,LO
28396 C event debugging information
28398 PARAMETER (NMAXD=100)
28399 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28400 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28401 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28402 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28403 C global event kinematics and particle IDs
28404 INTEGER IFPAP,IFPAB
28405 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28406 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28407 C c.m. kinematics of diffraction
28409 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
28410 & SIDD,CODD,SIFD,COFD,PDCMS
28411 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
28412 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
28413 C model switches and parameters
28415 INTEGER ISWMDL,IPAMDL
28416 DOUBLE PRECISION PARMDL
28417 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28419 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28420 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28421 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28423 INTEGER IPFIL,IFAFIL,IFBFIL
28424 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
28425 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
28426 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
28427 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
28428 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
28429 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
28430 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
28431 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
28432 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
28433 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
28434 & IPFIL,IFAFIL,IFBFIL
28436 C standard particle data interface
28439 PARAMETER (NMXHEP=4000)
28441 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28442 DOUBLE PRECISION PHEP,VHEP
28443 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28444 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28446 C extension to standard particle data interface (PHOJET specific)
28447 INTEGER IMPART,IPHIST,ICOLOR
28448 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28450 DOUBLE PRECISION P,PK1,PK2,PMI,RMASS
28451 DIMENSION P(4,2),PK1(5),PK2(5),PMI(2),RMASS(2)
28452 DIMENSION IFL(2),IDPRO(4)
28453 character*15 pho_pname
28454 CHARACTER*8 VMESA(0:4),VMESB(0:4)
28455 DIMENSION ISAMVM(4,4)
28456 DATA IDPRO / 113,223,333,92 /
28457 DATA VMESA / 'vmeson ','rho ','omega ','phi ',
28459 DATA VMESB / 'vmeson ','rho ','omega ','phi ',
28462 C sampling of elastic/quasi-elastic processes
28463 IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
28468 PMI(I) = PHEP(5,NPOSD(I))
28469 IF(PMI(I).LT.0.1D0) PMI(I) = 0.765D0
28472 PK1(1) = PHEP(1,JM1)+PHEP(1,JM2)
28473 PK1(2) = PHEP(2,JM1)+PHEP(2,JM2)
28474 PK1(3) = PHEP(3,JM1)+PHEP(3,JM2)
28475 PK1(4) = PHEP(4,JM1)+PHEP(4,JM2)
28476 SS = (PK1(4)+PK1(3))*(PK1(4)-PK1(3))-PK1(1)**2-PK1(2)**2
28479 IF(ECMD.LE.PMI(1)+PMI(2)) THEN
28480 IF(IDEB(34).GE.3) WRITE(LO,'(1X,A,I12,3E12.4)')
28481 & 'PHO_QELAST: too small mass (EV,ECM,M1,M2)',KEVENT,
28488 GAMBED(I) = PK1(I)/ECMD
28490 CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
28491 & PHEP(1,NPOSD(1)),PHEP(2,NPOSD(1)),PHEP(3,NPOSD(1)),
28492 & PHEP(4,NPOSD(1)),PTOT1,PK1(1),PK1(2),PK1(3),PK1(4))
28494 CODD = PK1(3)/PTOT1
28495 SIDD = SQRT(PK1(1)**2+PK1(2)**2)/PTOT1
28498 IF(PTOT1*SIDD.GT.1.D-5) THEN
28499 COFD = PK1(1)/(SIDD*PTOT1)
28500 SIFD = PK1(2)/(SIDD*PTOT1)
28501 ANORF = SQRT(COFD*COFD+SIFD*SIFD)
28508 PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)
28510 C production process of mother particles
28511 IGEN = IPHIST(2,NPOSD(1))
28512 if(IGEN.eq.0) IGEN = IPROC
28515 C main rejection label
28517 C determine process and final particles
28518 IFL(1) = IDHEP(NPOSD(1))
28519 IFL(2) = IDHEP(NPOSD(2))
28520 IF(IPROC.EQ.3) THEN
28524 IF(ITRY.GT.50) THEN
28525 IF(IDEB(34).GE.3) WRITE(LO,'(1X,A,I12,I5,E12.4)')
28526 & 'PHO_QELAST: mass rejection (EV,ITRY,ECM)',KEVENT,
28531 XI = DT_RNDM(PCMD)*SIGVM(0,0)-DEPS
28535 IF(XI.LE.0.D0) GOTO 130
28539 IF(IFL(1).EQ.22) IFL(1) = IDPRO(I)
28540 IF(IFL(2).EQ.22) IFL(2) = IDPRO(J)
28541 ISAMVM(I,J) = ISAMVM(I,J)+1
28543 C sample new masses
28544 CALL PHO_SAMASS(IFL(1),RMASS(1))
28545 CALL PHO_SAMASS(IFL(2),RMASS(2))
28546 IF(RMASS(1)+RMASS(2).GE.ECMD) GOTO 100
28547 ELSE IF(IPROC.EQ.2) THEN
28551 RMASS(1) = PHO_PMASS(NPOSD(1),2)
28552 RMASS(2) = PHO_PMASS(NPOSD(2),2)
28554 WRITE(LO,'(/1X,A,I6)') 'PHO_QELAST:ERROR: invalid IPROC',IPROC
28557 C sample momentum transfer
28558 CALL PHO_DIFSLP(0,0,I,J,RMASS(1),RMASS(2),RMASS(1),TT,
28560 IF(IDEB(34).GE.5) WRITE(LO,'(1X,A,2I6,I3,3E11.3)')
28561 & 'PHO_QELAST: IF1,2,T,RM1,RM2',IFL,IPROC,TT,RMASS
28562 C calculate new momenta
28563 CALL PHO_DIFKIN(RMASS(1),RMASS(2),TT,PK1,PK2,IREJ)
28564 IF(IREJ.NE.0) GOTO 50
28569 C comment line for elastic/quasi-elastic scattering
28570 CALL PHO_REGPAR(35,IPROC,0,NPOSD(1),NPOSD(2),RMASS(1),RMASS(2),
28571 & TT,ECMD,IFL(1),IFL(2),IDHEP(NPOSD(1)),IDHEP(NPOSD(2)),ICPOS,1)
28577 IF((IFL(I).EQ.92).OR.(IFL(I).EQ.91)) THEN
28578 C pi+/pi- isotropic background
28580 CALL PHO_REGPAR(1,113,0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
28581 & P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
28582 ICOLOR(I,ICPOS) = IPOS
28583 CALL PHO_SDECAY(IPOS,0,-2)
28587 if(IFL(I).ne.IDHEP(NPOSD(I))) IGEN = 3
28588 CALL PHO_REGPAR(1,IFL(I),0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
28589 & P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
28590 ICOLOR(I,ICPOS) = IPOS
28594 C search for vector mesons
28596 C decay according to polarization
28597 IF((IDHEP(JMOHEP(1,I)).EQ.22).AND.(ISWMDL(21).GE.0)) THEN
28599 IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
28600 CALL PHO_SDECAY(I,ISP,2)
28604 C back transformation
28605 CALL PHO_LTRHEP(I1,I2,CODD,SIDD,COFD,SIFD,GAMBED(4),GAMBED(1),
28606 & GAMBED(2),GAMBED(3))
28608 C initialization of tables
28609 ELSE IF(IPROC.EQ.-1) THEN
28617 IF(IFPAP(1).NE.22) VMESA(1) = PHO_PNAME(IFPAP(1),1)
28618 IF(IFPAP(2).NE.22) VMESB(1) = PHO_PNAME(IFPAP(2),1)
28619 CALL PHO_SAMASS(-1,RMASS(1))
28622 C output of statistics
28623 ELSE IF(IPROC.EQ.-2) THEN
28624 IF(ICALL.LT.10) RETURN
28625 WRITE(LO,'(/,1X,A,I10/,1X,A)')
28626 & 'PHO_QELAST: statistics of (quasi-)elastic processes',ICALL,
28627 & '---------------------------------------------------'
28628 WRITE(LO,'(1X,A,I10)')
28629 & 'sampled elastic processes:',ISAMEL
28630 WRITE(LO,'(1X,A,I10)')
28631 & 'sampled quasi-elastic vectormeson production:',ISAMQE
28632 WRITE(LO,'(15X,4(4X,A))') (VMESB(I),I=1,4)
28634 WRITE(LO,'(5X,A,4I12)') VMESA(I),(ISAMVM(I,K),K=1,4)
28636 CALL PHO_SAMASS(-2,RMASS(1))
28638 WRITE(LO,'(/1X,2A,I3)') 'PHO_QELAST:ERROR: ',
28639 & 'unknown process ID',IPROC
28645 *$ CREATE PHO_CDIFF.FOR
28647 CDECK ID>, PHO_CDIFF
28648 SUBROUTINE PHO_CDIFF(IMOTH1,IMOTH2,MSOFT,MHARD,IMODE,IREJ)
28649 C**********************************************************************
28651 C preparation of /POEVT1/ for double-pomeron scattering
28653 C input: IMOTH1/2 index of mother particles in /POEVT1/
28655 C IMODE 1 sampling of pomeron-pomeron scattering
28656 C -1 initialization
28657 C -2 output of statistics
28659 C output: MSOFT number of generated soft strings
28660 C MHARD number of generated hard strings
28663 C 50 user rejection
28665 C**********************************************************************
28666 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28669 PARAMETER ( EPS = 1.D-10,
28672 C input/output channels
28674 COMMON /POINOU/ LI,LO
28675 C event debugging information
28677 PARAMETER (NMAXD=100)
28678 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28679 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28680 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28681 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28682 C internal rejection counters
28684 PARAMETER (NMXJ=60)
28685 CHARACTER*10 REJTIT
28687 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
28688 C model switches and parameters
28690 INTEGER ISWMDL,IPAMDL
28691 DOUBLE PRECISION PARMDL
28692 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28693 C general process information
28694 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
28695 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
28696 C Reggeon phenomenology parameters
28697 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
28698 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
28699 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
28700 & ALREG,ALREGP,GR(2),B0REG(2),
28701 & GPPP,GPPR,B0PPP,B0PPR,
28702 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
28703 C parameters of 2x2 channel model
28704 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
28705 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
28707 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28708 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28709 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28710 C energy-interpolation table
28712 PARAMETER ( IEETA2 = 20 )
28714 DOUBLE PRECISION SIGTAB,SIGECM
28715 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
28716 C table of particle indices for recursive PHOJET calls
28718 PARAMETER ( MAXIPX = 100 )
28719 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
28720 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
28721 & IPOIX1,IPOIX2,IPOIX3
28723 C standard particle data interface
28726 PARAMETER (NMXHEP=4000)
28728 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28729 DOUBLE PRECISION PHEP,VHEP
28730 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28731 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28733 C extension to standard particle data interface (PHOJET specific)
28734 INTEGER IMPART,IPHIST,ICOLOR
28735 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28739 if(IMODE.ne.1) return
28743 C select first diffraction
28744 IF(DT_RNDM(DUM).GT.0.5D0) THEN
28754 C save current status
28764 JDA11 = JDAHEP(1,IMOTH1)
28765 JDA21 = JDAHEP(2,IMOTH1)
28766 JDA12 = JDAHEP(1,IMOTH2)
28767 JDA22 = JDAHEP(2,IMOTH2)
28768 ISTH1 = ISTHEP(IMOTH1)
28769 ISTH2 = ISTHEP(IMOTH2)
28772 C find mother particle production process
28773 IGEN = IPHIST(2,IMOTH1)
28774 if(IGEN.eq.0) IGEN = 4
28776 C main generation loop
28785 C reset mother-daugther relations
28787 JDAHEP(1,IMOTH1) = JDA11
28788 JDAHEP(2,IMOTH1) = JDA21
28789 JDAHEP(1,IMOTH2) = JDA12
28790 JDAHEP(2,IMOTH2) = JDA22
28791 ISTHEP(IMOTH1) = ISTH1
28792 ISTHEP(IMOTH2) = ISTH2
28796 C rejection counter
28798 IF(ITRY2.GT.1) THEN
28799 IFAIL(39) = IFAIL(39)+1
28800 IF(ITRY2.GE.ITRYM) GOTO 50
28802 C generate two diffractive events
28803 CALL PHO_DIFDIS(I1,I2,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
28804 IF(IREJ.NE.0) GOTO 50
28805 CALL PHO_DIFDIS(I2,I1,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
28806 IF(IREJ.NE.0) GOTO 50
28807 C mass of pomeron-pomeron system
28808 DO 100 I2 = NHEP,1,-1
28809 IF(IDHEP(I2).EQ.990) GOTO 110
28812 DO 120 I1 = I2-1,1,-1
28813 IF(IDHEP(I1).EQ.990) GOTO 130
28817 PD(I) = PHEP(I,I1)+PHEP(I,I2)
28819 XMASS = (PD(4)-PD(3))*(PD(4)+PD(3))-PD(1)**2-PD(2)**2
28820 IF(IDEB(59).GE.20) WRITE(LO,'(1X,A,2I3,E12.4)')
28821 & 'PHO_CDIFF: IPOM1,IPOM2,MASS**2',I1,I2,XMASS
28822 IF(XMASS.LT.0.1D0) GOTO 60
28823 XMASS = SQRT(XMASS)
28824 IF(XMASS.LT.PARMDL(71)) GOTO 60
28826 C sample pomeron-pomeron interaction process
28827 CALL PHO_DIFPRO(4,ISWMDL(17),990,990,XMASS,0.D0,0.D0,1.D0,
28828 & IPROC,ISAM,JSAM,KSAM,IDIR)
28830 C non-diffractive pomeron-pomeron interactions
28831 IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
28833 IF(ISAM+JSAM+KSAM+IDIR.EQ.0) JSAM = 1
28835 IF(IDEB(59).GE.15) WRITE(LO,'(1X,A,/5X,I3,E12.4,4I5)')
28836 & 'PHO_CDIFF: IP,XMASS,ISAM,JSAM,KSAM,IDIR,',
28837 & IP,XMASS,ISAM,JSAM,KSAM,IDIR
28838 C store debug information
28841 ELSE IF(KSAM.GT.0) THEN
28843 ELSE IF(ISAM.GT.0) THEN
28849 IF(ISAM+JSAM.GT.0) KSDPO = 1
28850 IF(KSAM+IDIR.GT.0) KHDPO = 1
28857 C generate pomeron-pomeron interaction
28858 CALL PHO_STDPAR(I1,I2,IGEN,ISAM,JSAM,KSAM,IDIR,IREJ)
28860 IFAIL(3) = IFAIL(3)+1
28862 IF(IPAR.EQ.3) IFAIL(9) = IFAIL(9)+1
28864 IFAIL(10) = IFAIL(10)+1
28866 ELSE IF(KSAM.GT.0) THEN
28868 ELSE IF(ISAM.GT.0) THEN
28873 IF(IDEB(59).GE.2) WRITE(LO,'(1X,A,2I3,E11.3)')
28874 & 'PHO_CDIFF: rejection by PHO_STDPAR (I,IPAR,XM)',
28880 C diffractive pomeron-pomeron interactions
28883 IPORES(IPOIX2) = IPROC
28884 IPOPOS(1,IPOIX2) = I1
28885 IPOPOS(2,IPOIX2) = I2
28890 C update debug information
28891 KSPOM = KSPOMS+ISAM
28892 KSREG = KSREGS+JSAM
28893 KHPOM = KHPOMS+KSAM
28894 KHDIR = KHDIRS+IDIR
28895 C comment line for central diffraction
28896 CALL PHO_REGPAR(40,4,IPAR,IMOTH1,IMOTH2,PD(1),PD(2),PD(3),PD(4),
28897 & I1,I2,IDHEP(IMOTH1),IDHEP(IMOTH2),IPOS,1)
28898 PHEP(5,IPOS) = XMASS
28900 IF(IDEB(59).GE.15) THEN
28901 WRITE(LO,'(2(/1X,A))') 'PHO_CDIFF: output of /POEVT1/',
28902 & '-----------------------------'
28907 C treatment of rejection
28910 IFAIL(40) = IFAIL(40)+1
28911 IF(IDEB(59).GE.3) THEN
28913 & 'PHO_CDIFF: rejection (ITRY,ITRYM)',ITRY2,ITRYM
28914 IF(IDEB(59).GE.10) THEN
28917 CALL PHO_PREVNT(-1)
28923 *$ CREATE PHO_SAMASS.FOR
28925 CDECK ID>, PHO_SAMASS
28926 SUBROUTINE PHO_SAMASS(IFLA,RMASS)
28927 C**********************************************************************
28929 C resonance mass sampling of quasi elastic processes
28931 C input: IFLA PDG number of particle
28932 C IFLA -1 initialization
28933 C IFLA -2 output of statistics
28935 C output: RMASS particle mass (in GeV)
28937 C**********************************************************************
28938 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28941 PARAMETER(EPS = 1.D-10 )
28943 C input/output channels
28945 COMMON /POINOU/ LI,LO
28946 C event debugging information
28948 PARAMETER (NMAXD=100)
28949 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28950 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28951 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28952 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28953 C model switches and parameters
28955 INTEGER ISWMDL,IPAMDL
28956 DOUBLE PRECISION PARMDL
28957 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28958 C parameters of the "simple" Vector Dominance Model
28959 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
28960 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
28962 PARAMETER(NTABM=50)
28963 DIMENSION XMA(4,NTABM),XMC(4,NTABM),RMA(4,NTABM)
28964 DIMENSION SUM(4),ICALL(4)
28966 C*****************************************************************
28967 C initialization of tables
28968 IF(IFLA.EQ.-1) THEN
28974 DELTAM=(RMAX(I)-RMIN(I))/DBLE(NSTEP-1)
28976 RMA(I,K)=RMIN(I)+DELTAM*DBLE(K-1)
28979 C calculate table of dsig/dm
28980 CALL PHO_DSIGDM(RMA,XMA,NSTEP)
28982 IF(IDEB(35).GE.1) THEN
28983 WRITE(LO,'(/5X,A)') 'table: mass (GeV) DSIG/DM (mub/GeV)'
28984 WRITE(LO,'(1X,A,/1X,A)')
28985 & ' (m, rho, m, omega, m, phi, m, pi+pi-)',
28986 & ' -------------------------------------------------------'
28988 WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMA(1,K),
28989 & RMA(2,K),XMA(2,K),RMA(3,K),XMA(3,K),RMA(4,K),XMA(4,K)
28992 C make second table for sampling
28996 SUM(I) = SUM(I) + (XMA(I,K-1)+XMA(I,K))/2.D0
29003 XMC(I,K) = XMC(I,K)/XMC(I,NSTEP)
29006 IF(IDEB(35).GE.10) THEN
29007 WRITE(LO,'(/5X,A)') 'PHO_DSIGDM: normalized summed table:'
29008 WRITE(LO,'(1X,A,/1X,A)')
29009 & ' (m, rho, m, omega, m, phi, m, pi+pi-)',
29010 & ' -------------------------------------------------------'
29012 WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMC(1,K),
29013 & RMA(2,K),XMC(2,K),RMA(3,K),XMC(3,K),RMA(4,K),XMC(4,K)
29017 C**************************************************
29018 C output of statistics
29019 ELSE IF(IFLA.EQ.-2) THEN
29020 WRITE(LO,'(2(/1X,A))') 'PHO_SAMASS: statistics',
29021 & '----------------------'
29022 WRITE(LO,'(4(/8X,A,I10))') 'rho: ',ICALL(1),
29023 & 'omega: ',ICALL(2),'phi: ',ICALL(3),'pi+pi-:',ICALL(4)
29026 C********************************************************
29027 C sampling of RMASS
29029 C quasi-elastic vector meson production
29030 IF(IFLA.EQ.113) THEN
29032 ELSE IF(IFLA.EQ.223) THEN
29034 ELSE IF(IFLA.EQ.333) THEN
29036 ELSE IF(IFLA.EQ.92) THEN
29038 C quasi-elastic production of h*
29039 ELSE IF(IFLA.EQ.91) THEN
29042 C elastic hadron scattering
29044 RMASS = PHO_PMASS(IFLA,1)
29045 IF(IDEB(35).GE.20) WRITE(LO,'(1X,A,I7,E12.3)')
29046 & 'PHO_SAMASS: IFLA,MASS',IFLA,RMASS
29050 C sample mass of vector mesonsn / two-pi background
29051 XI = DT_RNDM(RMASS) + EPS
29053 IF((XMC(KP,1).LE.XI).AND.(XMC(KP,NSTEP).GE.XI)) THEN
29057 IF((KMAX-KMIN).EQ.1) GOTO 400
29059 IF(XI.LE.XMC(KP,KK)) THEN
29067 WRITE(LO,'(1X,A)') 'PHO_SAMASS:ERROR:XI out of range'
29068 WRITE(LO,'(5X,A,I7,I6,3E12.4)') 'EVENT,IFLA,XI,XImin,XImax',
29069 & KEVENT,IFLA,XI,XMC(KP,1),XMC(KP,NSTEP)
29072 C fine interpolation
29073 RMASS = RMA(KP,KMIN)+
29074 & (RMA(KP,KMAX)-RMA(KP,KMIN))/
29075 & (XMC(KP,KMAX)-XMC(KP,KMIN))
29076 & *(XI-XMC(KP,KMIN))
29077 IF(IDEB(35).GE.20) THEN
29078 IF(IDEB(35).GE.25) WRITE(LO,'(1X,A,3E15.3)')
29079 & 'PHO_SAMASS: MLEFT,MRIGHT,RMASS',
29080 & RMA(KP,KMIN),RMA(KP,KMAX),RMASS
29081 WRITE(LO,'(1X,A,I7,E12.3)') 'PHO_SAMASS: IFLA,MASS',
29084 ICALL(KP) = ICALL(KP)+1
29089 *$ CREATE PHO_DSIGDM.FOR
29091 CDECK ID>, PHO_DSIGDM
29092 SUBROUTINE PHO_DSIGDM(RMA,XMA,NSTEP)
29093 C**********************************************************************
29095 C differential cross section DSIG/DM of low mass enhancement
29097 C input: RMA(4,NTABM) mass values
29098 C output: XMA(4,NTABM) DSIG/DM of resonances
29100 C 2 omega production
29102 C 4 pi-pi continuum
29104 C**********************************************************************
29105 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29108 PARAMETER ( EPS = 1.D-10 )
29110 PARAMETER(NTABM=50)
29111 DIMENSION XMA(4,NTABM),RMA(4,NTABM)
29113 C input/output channels
29115 COMMON /POINOU/ LI,LO
29116 C event debugging information
29118 PARAMETER (NMAXD=100)
29119 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29120 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29121 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29122 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29123 C model switches and parameters
29125 INTEGER ISWMDL,IPAMDL
29126 DOUBLE PRECISION PARMDL
29127 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29128 C parameters of the "simple" Vector Dominance Model
29129 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
29130 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
29133 C rho meson shape (mass dependent width)
29134 QRES = SQRT(VMAS(1)**2 - 4.D0*PIMASS**2)
29137 QQ = SQRT(XMASS**2 - 4.D0*PIMASS**2)
29138 GAMMA = GAMM(1)*(QQ/QRES)**3
29139 XMA(1,I) = XMASS*GAMMA*(VMAS(1)/XMASS)**PARMDL(170)
29140 & /((VMAS(1)**2-XMASS**2)**2+VMAS(1)**2*GAMMA**2)
29142 C omega/phi meson (constant width)
29146 XMA(K,I) = XMASS*GAMM(K)
29147 & /((VMAS(K)**2-XMASS**2)**2+VMAS(K)**2*GAMM(K)**2)
29153 XMA(4,I) = (XMASS-0.29D0)**2/XMASS
29158 *$ CREATE PHO_SDECAY.FOR
29160 CDECK ID>, PHO_SDECAY
29161 SUBROUTINE PHO_SDECAY(NPOS,ISP,ILEV)
29162 C**********************************************************************
29164 C decay of single resonance of /POEVT1/:
29165 C decay in helicity frame according to polarization, isotropic
29166 C decay and decay with limited transverse phase space possible
29169 C reference to particle number of CPC has to exist
29171 C input: NPOS position in /POEVT1/
29172 C ISP 0 decay according to phase space
29173 C 1 decay according to transversal polarization
29174 C 2 decay according to longitudinal polarization
29175 C 3 decay with limited phase space
29176 C ILEV decay mode to use
29178 C 2 strong and ew of tau, charm, and bottom
29179 C 3 strong and electro-weak decays
29180 C negative: remove mother resonance after decay
29182 C output: /POEVT1/,/POEVT2/ final particles according to decay mode
29184 C**********************************************************************
29185 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29188 PARAMETER ( EPS = 1.D-15,
29191 C input/output channels
29193 COMMON /POINOU/ LI,LO
29194 C event debugging information
29196 PARAMETER (NMAXD=100)
29197 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29198 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29199 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29200 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29201 C model switches and parameters
29203 INTEGER ISWMDL,IPAMDL
29204 DOUBLE PRECISION PARMDL
29205 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29207 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29208 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29209 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29211 C standard particle data interface
29214 PARAMETER (NMXHEP=4000)
29216 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
29217 DOUBLE PRECISION PHEP,VHEP
29218 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
29219 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
29221 C extension to standard particle data interface (PHOJET specific)
29222 INTEGER IMPART,IPHIST,ICOLOR
29223 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
29225 C general particle data
29226 double precision xm_list,tau_list,gam_list,
29227 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
29228 & xm_bb82_list,xm_bb102_list
29229 integer ich3_list,iba3_list,iq_list,
29230 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
29231 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
29232 & xm_psm2_list(6,6),xm_vem2_list(6,6),
29233 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
29234 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
29235 & ich3_list(300),iba3_list(300),iq_list(3,300),
29236 & id_psm_list(6,6),id_vem_list(6,6),
29237 & id_b8_list(6,6,6),id_b10_list(6,6,6)
29238 C particle decay data
29239 double precision wg_sec_list
29240 integer idec_list,isec_list
29241 COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
29243 C auxiliary data for three particle decay
29244 DOUBLE PRECISION ECM,PCM,COD,COF,SIF
29245 COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
29247 DIMENSION WGHD(20),KCH(20),ID(3)
29250 IF(IDEB(36).GE.15) WRITE(LO,'(1X,A,3I5)')
29251 & 'PHO_SDECAY: NPOS,ISP,ILEV',NPOS,ISP,ILEV
29254 IF(ISTHEP(NPOS).GT.11) RETURN
29257 IDcpc = IMPART(NPOS)
29258 IF(IDcpc.EQ.0) return
29259 IDabs = iabs(IDcpc)
29260 if(idec_list(1,IDabs).eq.0) return
29262 C different decay modi (times)
29263 IF(IMODE.EQ.1) THEN
29264 if(idec_list(1,IDabs).ne.1) return
29265 ELSE IF(IMODE.EQ.2) THEN
29266 if(idec_list(1,IDabs).gt.2) return
29267 ELSE IF(IMODE.EQ.3) THEN
29268 if(idec_list(1,IDabs).gt.3) return
29270 WRITE(LO,'(/1X,A,I5)') 'PHO_SDECAY: invalid mode (ILEV)',ILEV
29274 C decay products, check for mass limitations
29277 AMIST = PHEP(5,NPOS)
29278 DO 100 I=idec_list(2,IDabs),idec_list(3,IDabs)
29281 ID(L) = isec_list(L,I)
29282 IF(ID(L).NE.0) AMSUM = AMSUM+pho_pmass(ID(L),0)
29284 IF(AMSUM.LT.AMIST) THEN
29286 WGHD(K) = wg_sec_list(I)
29291 WRITE(LO,'(/1X,A,I6,3E12.4)')
29292 & 'PHO_SDECAY: particle mass too small (NPOS,MA,DCYM)',
29298 C sample new decay channel
29299 XI = (DT_RNDM(AMSUM)-EPS)*WGSUM
29304 WGSUM = WGSUM+WGHD(K)
29305 IF(XI.GT.WGSUM) GOTO 500
29307 ID(1) = isec_list(1,IK)
29308 ID(2) = isec_list(2,IK)
29309 ID(3) = isec_list(3,IK)
29310 if(IDcpc.lt.0) then
29311 ID(1) = ipho_anti(ID(1))
29312 ID(2) = ipho_anti(ID(2))
29313 if(ID(3).ne.0) ID(3) = ipho_anti(ID(3))
29317 PTOT = SQRT(PHEP(1,NPOS)**2+PHEP(2,NPOS)**2+PHEP(3,NPOS)**2)
29318 CXS = PHEP(1,NPOS)/PTOT
29319 CYS = PHEP(2,NPOS)/PTOT
29320 CZS = PHEP(3,NPOS)/PTOT
29323 GAM = PHEP(4,NPOS)/AMIST
29325 IF(ID(3).EQ.0) THEN
29326 C two particle decay
29327 CALL PHO_SDECY2(AMIST,pho_pmass(ID(1),0),pho_pmass(ID(2),0),ISP)
29329 C three particle decay
29330 CALL PHO_SDECY3(AMIST,pho_pmass(ID(1),0),pho_pmass(ID(2),0),
29331 & pho_pmass(ID(3),0),ISP)
29335 IF(NHEP.NE.NPOS) THEN
29336 WRITE(LO,'(/1X,2A,2I5)') 'PHO_SDECAY:ERROR: ',
29337 & 'cannot remove resonance (NPOS,NHEP)',NPOS,NHEP
29340 IMO1 = JMOHEP(1,NPOS)
29341 IMO2 = JMOHEP(2,NPOS)
29347 IPH1 = IPHIST(1,NPOS)
29348 IPH2 = IPHIST(2,NPOS)
29350 C back transformation and registration
29352 IF(ID(I).NE.0) THEN
29353 CALL PHO_LTRANS(GAM,GBET,CXS,CYS,CZS,COD(I),COF(I),SIF(I),
29354 & PCM(I),ECM(I),PTOT,CX,CY,CZ,EE)
29358 CALL PHO_REGPAR(1,0,ID(I),IMO1,IMO2,XX,YY,ZZ,EE,
29359 & IPH1,IPH2,0,0,IPOS,1)
29365 IF(IDEB(36).GE.20) THEN
29366 WRITE(LO,'(2(/1X,A))') 'PHO_SDECAY: /POEVT1/',
29367 & '--------------------'
29373 *$ CREATE PHO_SDECY2.FOR
29375 CDECK ID>, PHO_SDECY2
29376 SUBROUTINE PHO_SDECY2(UMO,AM1,AM2,ISP)
29377 C**********************************************************************
29379 C isotropic/anisotropic two particle decay in CM system,
29380 C (transversely/longitudinally polarized boson into two
29381 C pseudo-scalar mesons)
29383 C**********************************************************************
29384 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29387 C input/output channels
29389 COMMON /POINOU/ LI,LO
29390 C auxiliary data for three particle decay
29391 DOUBLE PRECISION ECM,PCM,COD,COF,SIF
29392 COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
29397 ECM(1)=(UMO2+AM11-AM22)/(2.D0*UMO)
29399 WAU=ECM(1)*ECM(1)-AM11
29400 IF(WAU.LT.0.D0) THEN
29401 WRITE(LO,'(/1X,A,E12.4)') 'PHO_SDECY2:ERROR:too small mass',WAU
29407 CALL PHO_SFECFE(SIF(1),COF(1))
29410 COD(1) = 2.D0*DT_RNDM(UMO)-1.D0
29411 ELSE IF(ISP.EQ.1) THEN
29412 C transverse polarization
29414 COD(1) = 2.D0*DT_RNDM(AM22)-1.D0
29415 SID12 = 1.D0-COD(1)*COD(1)
29416 IF(SID12.LT.DT_RNDM(AM1)) GOTO 400
29417 ELSE IF(ISP.EQ.2) THEN
29418 C longitudinal polarization
29420 COD(1) = 2.D0*DT_RNDM(AM2)-1.D0
29421 COD12 = COD(1)*COD(1)
29422 IF(COD12.LT.DT_RNDM(AM11)) GOTO 500
29424 WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY2:ERROR: ',
29425 & 'invalid polarization',ISP
29435 *$ CREATE PHO_SDECY3.FOR
29437 CDECK ID>, PHO_SDECY3
29438 SUBROUTINE PHO_SDECY3(UMO,AM1,AM2,AM3,ISP)
29439 C**********************************************************************
29441 C isotropic/anisotropic three particle decay in CM system,
29442 C (transversely/longitudinally polarized boson into three
29443 C pseudo-scalar mesons)
29445 C**********************************************************************
29446 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29449 PARAMETER ( DEPS = 1.D-30,
29452 C input/output channels
29454 COMMON /POINOU/ LI,LO
29455 C auxiliary data for three particle decay
29456 DOUBLE PRECISION ECM,PCM,COD,COF,SIF
29457 COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
29459 DIMENSION F(5),XX(5)
29461 C calculation of maximum of S2 phase space weight
29465 UFAK=1.0000000000001D0
29466 IF (GU.GT.GO) UFAK=0.99999999999999D0
29479 S22=GU+(I-1.D0)*DS2
29481 RHO2=PHO_XLAM(S22,UMO2,AM11)*PHO_XLAM(S22,AM22,AM33)/(S22+EPS)
29482 IF(RHO2.LT.RHO1) GOTO 125
29486 S2SUP=(S22-S21)/2.D0+S21
29487 SUPRHO=PHO_XLAM(S2SUP,UMO2,AM11)*PHO_XLAM(S2SUP,AM22,AM33)
29489 SUPRHO=SUPRHO*1.05D0
29491 IF(GU.LT.GO.AND.XO.LT.GU) XO=GU
29492 IF(GU.GT.GO.AND.XO.GT.GU) XO=GU
29498 F(1)=PHO_XLAM(XO,UMO2,AM11)*PHO_XLAM(XO,AM22,AM33)/(XO+EPS)
29499 F(2)=PHO_XLAM(X1,UMO2,AM11)*PHO_XLAM(X1,AM22,AM33)/(X1+EPS)
29501 X4=(XX(1)+XX(2))*0.5D0
29502 X5=(XX(2)+XX(3))*0.5D0
29503 F(4)=PHO_XLAM(X4,UMO2,AM11)*PHO_XLAM(X4,AM22,AM33)/(X4+EPS)
29504 F(5)=PHO_XLAM(X5,UMO2,AM11)*PHO_XLAM(X5,AM22,AM33)/(X5+EPS)
29510 IF(F(II).LT.F(III)) THEN
29525 IF (XX(II).LT.XX(III)) THEN
29543 IF(ITH.GT.200) THEN
29544 WRITE(LO,'(/1X,A,I10)')
29545 & 'PHO_SDECY3:ERROR: too many iterations',ITH
29548 S2=AM23+DT_RNDM(AM2)*((UMO-AM1)**2-AM23)
29549 Y=DT_RNDM(AM23)*SUPRHO
29550 RHO=PHO_XLAM(S2,UMO2,AM11)*PHO_XLAM(S2,AM22,AM33)/S2
29551 IF(Y.GT.RHO) GOTO 200
29554 S1=DT_RNDM(AM2)*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)
29555 & /(2.D0*S2)-RHO/2.D0
29556 S3=UMO2+AM11+AM22+AM33-S1-S2
29557 ECM(1)=(UMO2+AM11-S2)/UMOO
29558 ECM(2)=(UMO2+AM22-S3)/UMOO
29559 ECM(3)=(UMO2+AM33-S1)/UMOO
29560 PCM(1)=SQRT((ECM(1)+AM1)*(ECM(1)-AM1))
29561 PCM(2)=SQRT((ECM(2)+AM2)*(ECM(2)-AM2))
29562 PCM(3)=SQRT((ECM(3)+AM3)*(ECM(3)-AM3))
29564 C calculation of angles: TH between p1,p2; TH1 p3,p1; TH2 p3,p2
29565 IF((PCM(1).LE.EPS).OR.(PCM(2).LE.EPS)) THEN
29566 COSTH=(DT_RNDM(S1)-0.5D0)*2.D0
29568 COSTH=(ECM(1)*ECM(2)+0.5D0*(AM11+AM22-S1))/(PCM(1)*PCM(2))
29570 COSTH2=(PCM(3)*PCM(3)+PCM(2)*PCM(2)-PCM(1)*PCM(1))
29571 & /(2.D0*PCM(2)*PCM(3))
29572 SINTH2=SQRT(1.D0-COSTH2*COSTH2)
29573 SINTH1=COSTH2*SQRT(1.D0-COSTH*COSTH)-COSTH*SINTH2
29574 COSTH1=COSTH*COSTH2+SINTH2*SQRT(1.D0-COSTH*COSTH)
29576 C selection of the sperical coordinates of particle 3
29577 CALL PHO_SFECFE(SIF(3),COF(3))
29580 COD(3) = 2.D0*DT_RNDM(S2)-1.D0
29581 ELSE IF(ISP.EQ.1) THEN
29582 C transverse polarization
29584 COD(3) = 2.D0*DT_RNDM(S1)-1.D0
29585 SID32 = 1.D0-COD(3)*COD(3)
29586 IF(SID32.LT.DT_RNDM(COSTH)) GOTO 400
29587 ELSE IF(ISP.EQ.2) THEN
29588 C longitudinal polarization
29590 COD(3) = 2.D0*DT_RNDM(COSTH2)-1.D0
29591 COD32 = COD(3)*COD(3)
29592 IF(COD32.LT.DT_RNDM(SINTH1)) GOTO 500
29594 WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY3:ERROR: ',
29595 & 'invalid polarization',ISP
29599 C selection of the rotation angle of p1-p2 plane along p3
29601 CALL PHO_SFECFE(SFE,CFE)
29613 SID3 = SQRT((1.D0+COD(3))*(1.D0-COD(3)))
29614 COD(1)=CX11*COD(3)+CZ11*SID3
29615 IF((1.D0-COD(1)*COD(1)).LT.DEPS) THEN
29616 WRITE(LO,'(1X,A,5E12.4)') 'PHO_SDECY3: COS(TH1) > 1',
29617 & COD(1),COF(3),SID3,CX11,CZ11
29618 CALL PHO_PREVNT(-1)
29621 SID1=SQRT((1.D0+COD(1))*(1.D0-COD(1)))
29622 COF(1)=(CX11*SID3*COF(3)-CY11*SIF(3)-CZ11*COD(3)*COF(3))/SID1
29623 SIF(1)=(CX11*SID3*SIF(3)+CY11*COF(3)-CZ11*COD(3)*SIF(3))/SID1
29624 COD(2)=CX22*COD(3)+CZ22*SID3
29625 SID2=SQRT((1.D0+COD(2))*(1.D0-COD(2)))
29626 COF(2)=(CX22*SID3*COF(3)-CY22*SIF(3)-CZ22*COD(3)*COF(3))/SID2
29627 SIF(2)=(CX22*SID3*SIF(3)+CY22*COF(3)-CZ22*COD(3)*SIF(3))/SID2
29631 *$ CREATE PHO_DFMASS.FOR
29633 CDECK ID>, PHO_DFMASS
29634 DOUBLE PRECISION FUNCTION PHO_DFMASS(XMIN,XMAX,PREF2,PVIRT2,IMODE)
29635 C**********************************************************************
29637 C sampling of Mx diffractive mass distribution within
29638 C limits XMIN, XMAX
29640 C input: XMIN,XMAX mass limitations (GeV)
29641 C PREF2 original particle mass/ reference mass
29642 C (squared, GeV**2)
29643 C PVIRT2 particle virtuality
29644 C IMODE M**2 mass distribution
29646 C 2 1/(M**2+Q**2)**alpha
29647 C -1 1/(M**2-Mref**2+Q**2)
29648 C -2 1/(M**2-Mref**2+Q**2)**alpha
29650 C output: diffractive mass (GeV)
29652 C**********************************************************************
29653 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29656 PARAMETER(EPS = 1.D-10)
29658 C input/output channels
29660 COMMON /POINOU/ LI,LO
29661 C event debugging information
29663 PARAMETER (NMAXD=100)
29664 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29665 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29666 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29667 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29668 C model switches and parameters
29670 INTEGER ISWMDL,IPAMDL
29671 DOUBLE PRECISION PARMDL
29672 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29674 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29675 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29676 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29678 IF((XMIN.GE.XMAX).OR.(XMIN.LE.0.3D0)) THEN
29679 WRITE(LO,'(/1X,2A,3E12.4)') 'PHO_DFMASS:ERROR: ',
29680 & 'invalid mass limits',XMIN,XMAX,PREF2
29681 CALL PHO_PREVNT(-1)
29682 PHO_DFMASS = 0.135D0
29686 IF(IMODE.GT.0) THEN
29689 PM2 = PREF2 - PVIRT2
29693 IF(ABS(IMODE).EQ.1) THEN
29694 XMIN2 = LOG(XMIN**2-PM2)
29695 XMAX2 = LOG(XMAX**2-PM2)
29696 XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
29699 C supercritical pomeron
29700 ELSE IF(ABS(IMODE).EQ.2) THEN
29701 DDELTA = 1.D0-PARMDL(48)
29702 XMIN2 = (XMIN**2-PM2)**DDELTA
29703 XMAX2 = (XMAX**2-PM2)**DDELTA
29704 XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
29705 XMA2 = XI**(1.D0/DDELTA)+PM2
29707 WRITE(LO,'(/,1X,A,I3)')
29708 & 'PHO_DFMASS:ERROR: unsupported mode',IMODE
29712 PHO_DFMASS = SQRT(XMA2)
29714 IF(IDEB(43).GE.15) THEN
29715 WRITE(LO,'(1X,A,4E12.3)') 'PHO_DFMASS:Mmin,Mmax,Mref,Mass',
29716 & XMIN,XMAX,PREF2,SQRT(XMA2)
29721 *$ CREATE PHO_DIFSLP.FOR
29723 CDECK ID>, PHO_DIFSLP
29724 SUBROUTINE PHO_DIFSLP(IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,XMX,
29726 C**********************************************************************
29728 C sampling of T (Mandelstam variable) distribution within
29729 C certain limits TMIN, TMAX
29731 C input: IDF1,2 type of diffractive vertex
29732 C 0 elastic/quasi-elastic scattering
29733 C 1 diffraction dissociation
29734 C IVEC1,2 vector meson IDs in case of quasi-elastic
29735 C scattering, otherwise 0
29736 C XM1 mass of diffractive system 1 (GeV)
29737 C XM2 mass of diffractive system 2 (GeV)
29738 C XMX max. mass of diffractive system (GeV)
29740 C output: TT squared momentum transfer ( < 0, GeV**2)
29741 C SLWGHT weight to allow for mass-dependent slope
29742 C IREJ 0 successful sampling
29743 C 1 masses too big for given T range
29745 C**********************************************************************
29746 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29749 PARAMETER(EPS = 1.D-10)
29751 C input/output channels
29753 COMMON /POINOU/ LI,LO
29754 C event debugging information
29756 PARAMETER (NMAXD=100)
29757 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29758 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29759 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29760 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29761 C model switches and parameters
29763 INTEGER ISWMDL,IPAMDL
29764 DOUBLE PRECISION PARMDL
29765 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29766 C internal rejection counters
29768 PARAMETER (NMXJ=60)
29769 CHARACTER*10 REJTIT
29771 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
29772 C c.m. kinematics of diffraction
29774 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
29775 & SIDD,CODD,SIFD,COFD,PDCMS
29776 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
29777 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
29779 INTEGER IPFIL,IFAFIL,IFBFIL
29780 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
29781 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
29782 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
29783 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
29784 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
29785 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
29786 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
29787 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
29788 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
29789 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
29790 & IPFIL,IFAFIL,IFBFIL
29791 C Reggeon phenomenology parameters
29792 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
29793 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
29794 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
29795 & ALREG,ALREGP,GR(2),B0REG(2),
29796 & GPPP,GPPR,B0PPP,B0PPR,
29797 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
29798 C parameters of 2x2 channel model
29799 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
29800 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
29801 C parameters of the "simple" Vector Dominance Model
29802 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
29803 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
29805 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29806 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29807 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29814 C range of momentum transfer t
29817 C determine min. abs(t) necessary to produce masses
29819 PCMP2 = PHO_XLAM(SS,XM12,XM22)**2/(4.D0*SS)
29820 IF(PCMP2.LE.0.D0) THEN
29825 TMINP = PMASSD(1)**2+XM12+2.D0*PCMD*SQRT(PCMP2)
29826 & -2.D0*SQRT((PMASSD(1)**2+PCM2)*(XM12+PCMP2))
29828 IF(TMINP.LT.TMAX) THEN
29829 IF(IDEB(44).GE.3) THEN
29830 WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
29831 & 'too large Tmin (XM1/2,TMIN,TMAX,TMINP)',
29832 & XM1,XM2,TMIN,TMAX,TMINP
29834 IFAIL(32) = IFAIL(32)+1
29839 TMINA = MIN(TMIN,TMINP)
29841 C calculation of slope (mass-dependent parametrization)
29842 IF(IDF1+IDF2.GT.0) THEN
29843 C diffraction dissociation
29844 XMP12 = XM1**2+PVIRTD(1)
29845 XMP22 = XM2**2+PVIRTD(2)
29848 CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
29849 FAC = 4.D0*(PMASSD(1)*PMASSD(2))**2
29850 SLOPE = DBLE(IDF1+IDF2)*B0PPP
29851 & +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
29852 & /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
29853 SLOPE = MAX(SLOPE,1.D0)
29859 ELSE IF(IDF1.EQ.0) THEN
29862 XMP12 = XMA1**2+PVIRTD(1)
29863 XMP22 = XMA2**2+PVIRTD(2)
29866 CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
29867 SLMIN = DBLE(IDF1+IDF2)*B0PPP
29868 & +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
29869 & /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
29870 SLMIN = MAX(SLMIN,1.D0)
29872 C elastic/quasi-elastic scattering
29873 IF(ISWMDL(13).EQ.0) THEN
29874 C external slope values
29875 C PRINT LO,'PHO_DIFSLP:ERROR: this option is not installed !'
29877 ELSE IF(ISWMDL(13).EQ.1) THEN
29879 IF(IVEC1*IVEC2.EQ.0) THEN
29882 SLOPE = SLOVM(IVEC1,IVEC2)
29886 WRITE(LO,'(/1X,A,I5)') 'SASDSDT:ERROR: invalid ISWMDL(13)',
29892 C determine max. abs(t) to avoid underflows
29893 TMAXP = -25.D0/SLOPE
29894 TMAXA = MAX(TMAX,TMAXP)
29896 IF(TMINA.LT.TMAXA) THEN
29897 IF(IDEB(44).GE.3) THEN
29898 WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
29899 & 'too small Tmax (XM1/2,TMINA,TMAXA,SLOPE)',
29900 & XM1,XM2,TMINA,TMAXA,SLOPE
29902 IFAIL(32) = IFAIL(32)+1
29908 C sampling from corrected range of T
29909 TMINE = EXP(SLMIN*TMINA)
29910 TMAXE = EXP(SLMIN*TMAXA)
29911 XI = (TMINE-TMAXE)*DT_RNDM(SLMIN)+TMAXE
29913 SLWGHT = EXP((SLOPE-SLMIN)*TT)
29916 IF(IDEB(44).GE.15) THEN
29917 WRITE(LO,'(1X,A,1P,E12.3/5X,A,2I2,2X,2I2,2E10.2,/5X,A,5E10.2)')
29918 & 'PHO_DIFSLP: sampled momentum transfer:',TT,
29919 & 'IDF1/2,IVEC1/2,XM1/2:',IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,
29920 & 'Tmi,Tmx,SLMIN,SLOPE,WGHT:',TMINP,TMAXP,SLMIN,SLOPE,SLWGHT
29924 *$ CREATE PHO_DIFKIN.FOR
29926 CDECK ID>, PHO_DIFKIN
29927 SUBROUTINE PHO_DIFKIN(XMP1,XMP2,TT,PMOM1,PMOM2,IREJ)
29928 C**********************************************************************
29930 C calculation of diffractive kinematics
29932 C input: XMP1 mass of outgoing particle system 1 (GeV)
29933 C XMP2 mass of outgoing particle system 2 (GeV)
29934 C TT momentum transfer (GeV**2, negative)
29936 C output: PMOM1(5) four momentum of outgoing system 1
29937 C PMOM2(5) four momentum of outgoing system 2
29938 C IREJ 0 kinematics consistent
29939 C 1 kinematics inconsistent
29941 C**********************************************************************
29942 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29945 PARAMETER(EPS = 1.D-10,
29948 C input/output channels
29950 COMMON /POINOU/ LI,LO
29951 C event debugging information
29953 PARAMETER (NMAXD=100)
29954 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29955 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29956 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29957 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29958 C c.m. kinematics of diffraction
29960 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
29961 & SIDD,CODD,SIFD,COFD,PDCMS
29962 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
29963 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
29965 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29966 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29967 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29969 DOUBLE PRECISION PMOM1,PMOM2
29970 DIMENSION PMOM1(5),PMOM2(5)
29973 IF(IDEB(49).GT.10) WRITE(LO,'(1X,A,/5X,5E12.4)')
29974 & 'PHO_DIFKIN: Ecmd,Pcmd,Mini-1,Mini-2,TT:',
29975 & ECMD,PCMD,XMP1,XMP2,TT
29977 C general kinematic constraints
29979 IF(ECMD.LE.1.1D0*(XMP1+XMP2)) RETURN
29981 C new squared cms momentum
29986 PCMP2 = PHO_XLAM(SS,XMP12,XMP22)**2/(4.D0*SS)
29988 C new longitudinal/transverse momentum
29989 E1I = SQRT(PCM2+PMASSD(1)**2)
29990 E1F = SQRT(PCMP2+XMP12)
29991 E2F = SQRT(PCMP2+XMP22)
29992 PLONG = (TT+PCM2+PCMP2-(E1I-E1F)**2)/(2.D0*PCMD)
29993 PTRAN = PCMP2-PLONG**2
29995 C check consistency of kinematics
29996 IF(PTRAN.LT.0.D0) THEN
29997 IF(IDEB(49).GE.1) THEN
29998 WRITE(LO,'(1X,2A,I10)') 'PHO_DIFKIN: ',
29999 & 'inconsistent kinematics in event call: ',KEVENT
30000 WRITE(LO,'(1X,A,/5X,1p,6E11.3)')
30001 & 'PHO_DIFKIN: XMP1,XMP2,TT,PCMP,PLONG,PTRANS',
30002 & XMP1,XMP2,TT,SQRT(PCMP2),PLONG,SIGN(SQRT(ABS(PTRAN)),PTRAN)
30007 PTRAN = SQRT(PTRAN)
30009 XI = PI2*DT_RNDM(PTRAN)
30011 C outgoing momenta in cm. system
30013 PMOM1(1) = PTRAN*COS(XI)
30014 PMOM1(2) = PTRAN*SIN(XI)
30019 PMOM2(1) = -PMOM1(1)
30020 PMOM2(2) = -PMOM1(2)
30025 C debug output / precision check
30026 IF(IDEB(49).GE.0) THEN
30028 XM1 = (PMOM1(4)-PMOM1(3))*(PMOM1(4)+PMOM1(3))
30029 & -PMOM1(1)**2-PMOM1(2)**2
30030 XM1 = SIGN(SQRT(ABS(XM1)),XM1)
30031 XM2 = (PMOM2(4)-PMOM2(3))*(PMOM2(4)+PMOM2(3))
30032 & -PMOM2(1)**2-PMOM2(2)**2
30033 XM2 = SIGN(SQRT(ABS(XM2)),XM2)
30034 IF((ABS(XM1-XMP1).GT.DEPS).OR.(ABS(XM1-XMP1).GT.DEPS)) THEN
30035 WRITE(LO,'(1X,2A,/5X,4E11.4)') 'PHO_DIFKIN: ',
30036 & 'inconsistent masses: MINI-1,MOUT-1,MINI-2,MOUT-2',
30037 & XMP1,XM1,XMP2,XM2
30038 CALL PHO_PREVNT(-1)
30041 IF(IDEB(49).GT.10) THEN
30042 WRITE(LO,'(1X,A,5E11.3,/1X,A,5E11.3)')
30043 & 'PHO_DIFKIN: P1',PMOM1,' P2',PMOM2
30049 *$ CREATE PHO_VECRES.FOR
30051 CDECK ID>, PHO_VECRES
30052 SUBROUTINE PHO_VECRES(IVEC,RMASS,IDPDG,IDBAM)
30053 C**********************************************************************
30055 C sampling of vector meson resonance in diffractive processes
30056 C (nothing done for hadrons)
30058 C input: /POSVDM/ VDMFAC factors
30060 C output: IVEC 0 incoming hadron
30064 C 4 pi+/pi- background
30065 C RMASS mass of vector meson (GeV)
30066 C IDPDG particle ID according to PDG
30067 C IDBAM particle ID according to CPC
30069 C**********************************************************************
30070 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30073 PARAMETER(EPS = 1.D-10)
30075 C input/output channels
30077 COMMON /POINOU/ LI,LO
30078 C event debugging information
30080 PARAMETER (NMAXD=100)
30081 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30082 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30083 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30084 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30085 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
30086 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
30087 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
30088 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
30089 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
30090 C parameters of the "simple" Vector Dominance Model
30091 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
30092 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
30094 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
30095 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
30096 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
30098 C particle code translation
30099 DIMENSION ITRANS(4)
30100 C rho0,omega,phi,pi+/pi-
30101 DATA ITRANS /113, 223, 333, 92 /
30105 C vector meson production
30106 IF(IDPDG.EQ.22) THEN
30107 XI = DT_RNDM(RMASS)*(VMFA(1)+VMFA(2)+VMFA(3)+VMFA(4))
30110 SUM = SUM + VMFA(K)
30111 IF(XI.LE.SUM) GOTO 65
30116 IDBAM = ipho_pdg2id(IDPDG)
30118 C sample mass of vector meson
30119 CALL PHO_SAMASS(IDPDG,RMASS)
30121 C hadronic resonance of multi-pomeron coupling
30122 ELSE IF(IDPDG.EQ.990) THEN
30125 IDBAM = ipho_pdg2id(IDPDG)
30127 C sample mass of two-pion system
30128 CALL PHO_SAMASS(IDPDG,RMASS)
30130 C hadron remnants in inucleus interactions
30131 ELSE IF(IDPDG.EQ.81) THEN
30132 IF(IHFLD(1,1).EQ.0) THEN
30133 CALL PHO_SEAFLA(1,IFL1,IFL2,RMASS)
30134 CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
30136 CALL PHO_HACODE(IHFLD(1,1),IHFLD(1,2),IDBA1,IDBA2)
30138 RMAS1 = PHO_PMASS(IDBA1,0)
30139 RMAS2 = PHO_PMASS(IDBA2,0)
30140 IF((IDBA2.NE.0).AND.
30141 & (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
30148 IDPDG = IPHO_ID2PDG(IDBAM)
30150 ELSE IF(IDPDG.EQ.82) THEN
30151 IF(IHFLD(2,1).EQ.0) THEN
30152 CALL PHO_SEAFLA(2,IFL1,IFL2,RMASS)
30153 CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
30155 CALL PHO_HACODE(IHFLD(2,1),IHFLD(2,2),IDBA1,IDBA2)
30157 RMAS1 = PHO_PMASS(IDBA1,0)
30158 RMAS2 = PHO_PMASS(IDBA2,0)
30159 IF((IDBA2.NE.0).AND.
30160 & (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
30167 IDPDG = IPHO_ID2PDG(IDBAM)
30171 IF(IDEB(47).GE.5) THEN
30172 WRITE(LO,'(1X,A,/10X,3I7,E12.4)')
30173 & 'PHO_VECRES: IDPDG-OLD,IDPDG,IDBAM,MASS',
30174 & IDPDO,IDPDG,IDBAM,RMASS
30179 *$ CREATE PHO_DIFRES.FOR
30181 CDECK ID>, PHO_DIFRES
30182 SUBROUTINE PHO_DIFRES(IDMOTH,IVAL1,IVAL2,
30183 & IDPDG,IDBAM,RMASS,RGAM,RWG,LISTL)
30184 C**********************************************************************
30186 C list of resonance states for low mass resonances
30188 C input: IDMOTH PDG ID of mother particle
30189 C IVAL1,2 quarks (photon only)
30191 C output: IDPDG list of PDG IDs for possible resonances
30192 C IDBAM list of corresponding CPC IDs
30194 C RGAMS decay width
30195 C RMASS additional weight factor
30196 C LISTL entries in current list
30198 C**********************************************************************
30199 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30202 DIMENSION IDPDG(10),IDBAM(10),RMASS(10),RGAM(10),RWG(10)
30204 PARAMETER (EPS = 1.D-10,
30207 C input/output channels
30209 COMMON /POINOU/ LI,LO
30210 C event debugging information
30212 PARAMETER (NMAXD=100)
30213 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30214 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30215 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30216 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30217 C particle ID translation table
30218 integer ID_pdg_list,ID_list,ID_pdg_max
30219 character*12 name_list
30220 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
30222 C general particle data
30223 double precision xm_list,tau_list,gam_list,
30224 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
30225 & xm_bb82_list,xm_bb102_list
30226 integer ich3_list,iba3_list,iq_list,
30227 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
30228 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
30229 & xm_psm2_list(6,6),xm_vem2_list(6,6),
30230 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
30231 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
30232 & ich3_list(300),iba3_list(300),iq_list(3,300),
30233 & id_psm_list(6,6),id_vem_list(6,6),
30234 & id_b8_list(6,6,6),id_b10_list(6,6,6)
30236 DIMENSION RWGHT(20),IRPDG(20),IRBAM(20)
30237 DATA IRPDG /113, 223, 333, 50223, 40113, 60223, 10333, 30113,
30238 & 12212, 42212, -12212, -42212,
30240 DATA RWGHT /1.D0, 0.11D0, 0.1D0, 0.11D0, 1.D0, 0.11D0, 0.1D0,
30241 & 1.D0, 1.D0, 1.D0, 1.D0, 1.D0,
30249 if(IRPDG(i).ne.0) then
30250 IRBAM(i) = ipho_pdg2id(IRPDG(i))
30256 C copy table with particles and isospin weights
30258 IF(IDMOTH.EQ.22) THEN
30261 ELSE IF(IDMOTH.EQ.2212) THEN
30264 ELSE IF(IDMOTH.EQ.-2212) THEN
30273 IDBAM(LISTL) = IRBAM(I)
30274 IDPDG(LISTL) = IRPDG(I)
30275 RMASS(LISTL) = xm_list(iabs(IDBAM(LISTL)))
30276 RGAM(LISTL) = gam_list(iabs(IDBAM(LISTL)))
30277 RWG(LISTL) = RWGHT(I)
30281 IF(IDEB(85).GE.20) THEN
30282 WRITE(LO,'(1X,A,3I7)') 'PHO_DIFRES: mother,quarks',IDMOTH,
30285 WRITE(LO,'(1X,I3,2I7,E12.4)') I,IDBAM(I),IDPDG(I),RMASS(I)
30291 *$ CREATE PHO_MASSAD.FOR
30293 CDECK ID>, PHO_MASSAD
30294 SUBROUTINE PHO_MASSAD(IFLMO,IFL1,IFL2,
30295 & PMASS,XMCON,XMOUT,IDPDG,IDcpc)
30296 C***********************************************************************
30298 C fine-correction of low mass strings to mass of corresponding
30299 C resonance or two particle threshold
30301 C input: IFLMO PDG ID of mother particle
30302 C IFL1,2 requested parton flavours
30303 C (not used at the moment)
30304 C PMASS reference mass (mass of mother particle)
30305 C XMCON conjecture of mass
30307 C output: XMOUT output mass (adjusted input mass)
30308 C moved ot nearest mass possible
30309 C IDPDG PDG resonance ID
30310 C IDcpc CPC resonance ID
30312 C**********************************************************************
30313 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30316 PARAMETER ( DEPS = 1.D-8 )
30318 C input/output channels
30320 COMMON /POINOU/ LI,LO
30321 C event debugging information
30323 PARAMETER (NMAXD=100)
30324 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30325 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30326 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30327 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30328 C model switches and parameters
30330 INTEGER ISWMDL,IPAMDL
30331 DOUBLE PRECISION PARMDL
30332 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
30333 C general particle data
30334 double precision xm_list,tau_list,gam_list,
30335 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
30336 & xm_bb82_list,xm_bb102_list
30337 integer ich3_list,iba3_list,iq_list,
30338 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
30339 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
30340 & xm_psm2_list(6,6),xm_vem2_list(6,6),
30341 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
30342 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
30343 & ich3_list(300),iba3_list(300),iq_list(3,300),
30344 & id_psm_list(6,6),id_vem_list(6,6),
30345 & id_b8_list(6,6,6),id_b10_list(6,6,6)
30346 C particle decay data
30347 double precision wg_sec_list
30348 integer idec_list,isec_list
30349 COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
30352 DIMENSION XWG(10),RMA(10),RGA(10),RWG(10),IRPDG(10),IRBAM(10)
30359 C resonance treatment activated?
30360 IF(ISWMDL(23).EQ.0) RETURN
30362 CALL PHO_DIFRES(IFLMO,IFL1,IFL2,IRPDG,IRBAM,RMA,RGA,RWG,LISTL)
30363 IF(LISTL.LT.1) THEN
30364 IF(IDEB(7).GE.2) WRITE(LO,'(1X,A,3I7)')
30365 & 'PHO_MASSAD: no resonances for (IFMO,IF1,IF2)',
30370 PMASSL = (PMASS+0.15D0)**2
30372 C determine resonance probability
30374 RPROB = (PMASSL+DM2)*(XMINP2-PMASSL)/(DM2*XMINP2)
30375 IF(RPROB.LT.DT_RNDM(PMASSL)) THEN
30376 C sample new resonance
30379 XWG(I) = RWG(I)/RMA(I)**2
30380 XWGSUM = XWGSUM+XWG(I)
30394 XI = XWGSUM*DT_RNDM(XMOUT)
30397 XWGSUM = XWGSUM-XWG(I)
30398 IF((XI.LT.XWGSUM).AND.(I.LT.LISTL)) GOTO 200
30404 C sample new mass (from Breit-Wigner cross section)
30405 ALO = ATAN((PMASSL-XMRES2)/(XMRES*GARES))
30406 AHI = ATAN((5.D0-XMRES2)/(XMRES*GARES))
30407 XI = (AHI-ALO)*DT_RNDM(XMRES)+ALO
30408 XMOUT = XMRES*GARES*TAN(XI)+XMRES2
30409 XMOUT = SQRT(XMOUT)
30411 C check mass for decay
30414 DO 250 IK=idec_list(2,ID),idec_list(3,ID)
30417 IF(isec_list(I,IK).NE.0)
30418 & AMSUM = AMSUM + xm_list(iabs(isec_list(I,IK)))
30420 AMDCY = MIN(AMDCY,AMSUM)
30422 IF(AMDCY.GE.XMOUT) GOTO 150
30426 & WRITE(LO,'(1X,2A,/1X,3I6,2E10.3,2I7,2E10.3)')
30428 & 'IFMO,IF1,IF2,XMCON,XMOUT,IDPDG,IDcpc,RMA,RGA',
30429 & IFLMO,IFL1,IFL2,XMCON,XMOUT,IDPDG,IDcpc,RMA(I),RGA(I)
30436 & WRITE(LO,'(1X,A,/1X,3I6,2E10.3)')
30437 & 'PHO_MASSAD: string sampled: IFMO,IF1,IF2,XMCON,XMOUT',
30438 & IFLMO,IFL1,IFL2,XMCON,XMOUT
30442 *$ CREATE PHO_PDF.FOR
30445 SUBROUTINE PHO_PDF(NPAR,X,SCALE2,P2VIR,PD)
30446 C***************************************************************
30448 C call different PDF sets for different particle types
30450 C input: NPAR 1 IGRP(1),ISET(1)
30451 C 2 IGRP(2),ISET(2)
30452 C X momentum fraction
30453 C SCALE2 squared scale (GeV**2)
30454 C P2VIR particle virtuality (positive, GeV**2)
30456 C output PD(-6:6) field containing the x*PDF fractions
30458 C***************************************************************
30459 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30464 C input/output channels
30466 COMMON /POINOU/ LI,LO
30467 C currently activated parton density parametrizations
30469 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
30470 DOUBLE PRECISION PDFLAM,PDFQ2M
30471 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
30472 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
30473 C event debugging information
30475 PARAMETER (NMAXD=100)
30476 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30477 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30478 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30479 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30480 C model switches and parameters
30482 INTEGER ISWMDL,IPAMDL
30483 DOUBLE PRECISION PARMDL
30484 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
30486 DIMENSION PARAM(20),VALUE(20)
30489 REAL XR,P2R,Q2R,F2GM,XPDFGM
30490 DIMENSION XPDFGM(-6:6)
30492 C check of kinematic boundaries
30495 IF(IDEB(37).GE.0) THEN
30496 WRITE(LO,'(/,1X,A,E15.8/)')
30497 & 'PHO_PDF: x>1 (corrected to x=1)',X
30498 CALL PHO_PREVNT(-1)
30500 XI = 0.99999999999D0
30501 ELSE IF(X.LE.0.D0) THEN
30502 IF(IDEB(37).GE.0) THEN
30503 WRITE(LO,'(/,1X,A,E15.8/)') 'PHO_PDF: X <= 0 ',X
30504 CALL PHO_PREVNT(-1)
30514 IF((NPAR.EQ.1).OR.(NPAR.EQ.2)) THEN
30518 IF(IEXT(NPAR).EQ.0) THEN
30519 IF(ITYPE(NPAR).EQ.1) THEN
30521 IF(IGRP(NPAR).EQ.5) THEN
30522 IF(ISET(NPAR).EQ.3) THEN
30523 CALL PHO_DOR92HO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
30528 ELSE IF(ISET(NPAR).EQ.4) THEN
30529 CALL PHO_DOR92LO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
30534 ELSE IF(ISET(NPAR).EQ.5) THEN
30535 CALL PHO_DOR94HO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
30536 C heavy quarks from GRV92-HO
30538 ALAM2 = 0.248 * 0.248
30539 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30543 AKC = -0.625 - 0.523 * S
30545 BC = 1.896 + 1.616 * S
30546 DC = 4.12 + 0.683 * S
30547 EC = 4.36 + 1.328 * S
30548 ESC = 0.677 + 0.679 * S
30549 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30553 AKB = 0.0 - 0.193 * S
30556 DB = 3.447 + 0.927 * S
30557 EB = 4.68 + 1.259 * S
30558 ESB = 1.892 + 2.199 * S
30559 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30561 ELSE IF(ISET(NPAR).EQ.6) THEN
30562 CALL PHO_DOR94LO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
30563 C heavy quarks from GRV92-LO
30566 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30572 BC = 4.24 - 0.804 * S
30573 DC = 3.46 + 1.076 * S
30574 EC = 4.61 + 1.490 * S
30575 ESC = 2.555 + 1.961 * S
30576 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30583 DB = 2.929 + 1.396 * S
30584 EB = 4.71 + 1.514 * S
30585 ESB = 4.02 + 1.239 * S
30586 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30588 ELSE IF(ISET(NPAR).EQ.7) THEN
30589 CALL PHO_DOR94DI(XI,SCALE2, UV, DV, DEL, UDB, SB, GL)
30590 C heavy quarks from GRV92-HO
30592 ALAM2 = 0.248 * 0.248
30593 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30597 AKC = -0.625 - 0.523 * S
30599 BC = 1.896 + 1.616 * S
30600 DC = 4.12 + 0.683 * S
30601 EC = 4.36 + 1.328 * S
30602 ESC = 0.677 + 0.679 * S
30603 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30607 AKB = 0.0 - 0.193 * S
30610 DB = 3.447 + 0.927 * S
30611 EB = 4.68 + 1.259 * S
30612 ESB = 1.892 + 2.199 * S
30613 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30615 ELSE IF(ISET(NPAR).EQ.8) THEN
30616 CALL PHO_DOR98LO(XI,SCALE2,UV,DV,US,DS,SB,GL)
30619 C heavy quarks from GRV92-LO
30622 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30628 BC = 4.24 - 0.804 * S
30629 DC = 3.46 + 1.076 * S
30630 EC = 4.61 + 1.490 * S
30631 ESC = 2.555 + 1.961 * S
30632 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30639 DB = 2.929 + 1.396 * S
30640 EB = 4.71 + 1.514 * S
30641 ESB = 4.02 + 1.239 * S
30642 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30644 ELSE IF(ISET(NPAR).EQ.9) THEN
30645 * CALL PHO_DOR98SC(XI,SCALE2,UV,DV,US,DS,SB,GL)
30648 C heavy quarks from GRV92-LO
30651 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30657 BC = 4.24 - 0.804 * S
30658 DC = 3.46 + 1.076 * S
30659 EC = 4.61 + 1.490 * S
30660 ESC = 2.555 + 1.961 * S
30661 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30668 DB = 2.929 + 1.396 * S
30669 EB = 4.71 + 1.514 * S
30670 ESB = 4.02 + 1.239 * S
30671 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30677 PD(-2) = 0.5D0*(UDB-DEL)
30678 PD(-1) = 0.5D0*(UDB+DEL)
30686 ELSE IF(ITYPE(NPAR).EQ.2) THEN
30687 C pion PDFs (default for pi+)
30688 IF(IGRP(NPAR).EQ.5) THEN
30689 IF(ISET(NPAR).EQ.1) THEN
30690 CALL PHO_DORPHO (XI,SCALE2,VA,GL,QB,CB,BB)
30692 ELSE IF(ISET(NPAR).EQ.2) THEN
30693 CALL PHO_DORPLO (XI,SCALE2,VA,GL,QB,CB,BB)
30708 ELSE IF(ITYPE(NPAR).EQ.3) THEN
30710 IF(IGRP(NPAR).EQ.5) THEN
30711 IF(ISET(NPAR).EQ.1) THEN
30712 CALL PHO_DORGH0 (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30714 ELSE IF(ISET(NPAR).EQ.2) THEN
30715 CALL PHO_DORGHO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30717 ELSE IF(ISET(NPAR).EQ.3) THEN
30718 CALL PHO_DORGLO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30721 C reweight with Drees-Godbole factor
30723 IF(P2VIR.GT.0.001D0) THEN
30724 WGX = LOG(SCALE2/(P2VIR+PARMDL(144)))
30725 & /LOG(SCALE2/PARMDL(144))
30726 WGX = MAX(WGX,0.D0)
30728 PD(-5) = BB*WGX/137.D0
30729 PD(-4) = CB*WGX/137.D0
30730 PD(-3) = SB*WGX/137.D0
30731 PD(-2) = UB*WGX/137.D0
30732 PD(-1) = DB*WGX/137.D0
30733 PD(0) = GL*WGX*WGX/137.D0
30739 ELSE IF(IGRP(NPAR).EQ.8) THEN
30740 IF(ISET(NPAR).EQ.1) THEN
30741 CALL PHO_PHGAL (XI,SCALE2,PD)
30745 ELSE IF(ITYPE(NPAR).EQ.20) THEN
30749 PD(0) = 6.D0*(1.D0-XI)**5*PARMDL(26)*PARMDL(78)
30751 ELSE IF(MODE.EQ.2) THEN
30752 PD(0) = 6.D0*XI*(1.D0-XI)*PARMDL(26)*PARMDL(78)
30754 ELSE IF(MODE.EQ.3) THEN
30755 PD(0) = (0.18D0/XI+5.46D0)*(1.D0-XI)*PARMDL(26)*PARMDL(78)
30757 ELSE IF(MODE.EQ.4) THEN
30758 CALL PHO_CKMTPD(990,XI,SCALE2,PD)
30760 PD(I) = PD(I)*PARMDL(78)
30768 ELSE IF(IEXT(NPAR).EQ.2) THEN
30769 C PDFLIB call: new PDF numbering
30770 IF(NPAR.NE.NPAOLD) THEN
30771 PARAM(1) = 'NPTYPE'
30772 PARAM(2) = 'NGROUP'
30775 VALUE(1) = ITYPE(NPAR)
30776 VALUE(2) = ABS(IGRP(NPAR))
30777 VALUE(3) = ISET(NPAR)
30778 CALL PDFSET(PARAM,VALUE)
30780 IF(ITYPE(NPAR).EQ.3) THEN
30782 CALL STRUCTP(XI,SCALE2,P2VIR,IP2,PD(2),PD(1),PD(-2),PD(-1),
30783 & PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
30785 SCALE = SQRT(SCALE2)
30786 CALL STRUCTM(XI,SCALE,PD(2),PD(1),PD(-2),PD(-1),
30787 & PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
30792 IF(ITYPE(NPAR).EQ.1) THEN
30793 C proton valence quarks
30794 PD(1) = PD(1)+PD(-1)
30795 PD(2) = PD(2)+PD(-2)
30796 ELSE IF(ITYPE(NPAR).EQ.2) THEN
30800 PD(-1) = DVAL+PD(1)
30801 PD(2) = PD(2)+PD(-2)
30802 ELSE IF(ITYPE(NPAR).EQ.3) THEN
30803 C photon conventions
30809 ELSE IF(IEXT(NPAR).EQ.3) THEN
30810 C PHOLIB call: version 2.0
30811 CALL PHVAL(IGRP(NPAR),ISET(NPAR),XI,SCALE2,PD,IRET)
30813 WRITE(LO,'(/1X,A,I2)')
30814 & 'PHO_PDF:ERROR: non-vanishing PHVAL return code',IRET
30819 C photon PDFs depending on photon virtuality
30821 ELSE IF(IEXT(NPAR).EQ.4) THEN
30822 IF(IGRP(NPAR).EQ.1) THEN
30823 C Schuler/Sjostrand PDF (interface to single precision)
30828 CALL PHO_SASGAM(ISET(NPAR),XR,Q2R,P2R,IP2,F2GM,XPDFGM)
30830 PD(I) = DBLE(XPDFGM(I))
30833 ELSE IF(IGRP(NPAR).EQ.5) THEN
30834 C Gluck/Reya/Stratmann
30835 IF(ISET(NPAR).EQ.4) THEN
30836 CALL PHO_DORGLV (XI,SCALE2,P2VIR, UB, DB, SB, GL)
30837 CALL PHO_QPMPDF(4,XI,SCALE2,0.D0,P2VIR,CB)
30858 WRITE(LO,'(/1X,A,/10X,5I6)')
30859 & 'PHO_PDF:ERROR:unsupported PDF(NPAR,IEXT,ITYPE,IGRP,ISET)',
30860 & NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
30865 WRITE(LO,'(/1X,A,I5)') 'PHO_PDF:ERROR:invalid NPAR(1,2) ',NPAR
30870 C valence quark treatment
30872 IF(ITYPE(NPAR).EQ.2) THEN
30873 C meson conventions
30874 IF(IPARID(NPAR).EQ.111) THEN
30875 C pi0 valence quarks
30876 PD(-1) = (PD(1)+PD(-1))/2.D0
30878 PD(-2) = (PD(2)+PD(-2))/2.D0
30880 ELSE IF(ABS(IPARID(NPAR)).EQ.321) THEN
30882 VALS = PD(-1)-PD(1)
30884 PD(-3) = PD(-3)+VALS
30885 ELSE IF( (IPARID(NPAR).EQ.311)
30886 & .OR.(IPARID(NPAR).EQ.310)
30887 & .OR.(IPARID(NPAR).EQ.130)) THEN
30889 VALS = PD(-1)-PD(1)
30890 VALU = PD(2)-PD(-2)
30893 PD(2) = PD(2)+VALU/2.D0
30894 PD(-2) = PD(-2)+VALU/2.D0
30895 PD(3) = PD(3)+VALS/2.D0
30896 PD(-3) = PD(-3)+VALS/2.D0
30898 ELSE IF(ITYPE(NPAR).EQ.1) THEN
30899 C nucleon conventions
30900 IF(ABS(IPARID(NPAR)).EQ.2112) THEN
30901 C neutron valence quarks
30905 ELSE IF(ABS(IPARID(NPAR)).EQ.3222) THEN
30907 VALS = PD(1)-PD(-1)
30910 ELSE IF(ABS(IPARID(NPAR)).EQ.3112) THEN
30912 VALS = PD(1)-PD(-1)
30913 VALD = PD(2)-PD(-2)
30918 ELSE IF( (ABS(IPARID(NPAR)).EQ.3122)
30919 & .OR.(ABS(IPARID(NPAR)).EQ.3212)) THEN
30920 C (anti-)sigma0 and (anti-)lambda
30921 VALS = PD(1)-PD(-1)
30922 VALD = (PD(2)-PD(-2))/2.D0
30932 IF(IPARID(NPAR).LT.0) THEN
30940 C optionally remove valence quarks
30941 IF(IPAVA(NPAR).EQ.0) THEN
30943 PD(I) = MIN(PD(-I),PD(I))
30948 C debug information
30949 IF(IDEB(37).GE.30) WRITE(LO,
30950 & '(1X,A,I4,1P,3E12.4/,2X,A,6E10.3,/2X,A,E10.3,/2X,A,6E10.3)')
30951 & 'PHO_PDF: NPAR,X,SCALE**2,P2VIR',
30952 & NPAR,X,SCALE2,P2VIR,'PD(-6..-1)',(PD(I),I=-6,-1),
30953 & 'PD(0) ',PD(0),'PD(1..6) ',(PD(I),I=1,6)
30957 *$ CREATE PHO_QPMPDF.FOR
30959 CDECK ID>, PHO_QPMPDF
30960 SUBROUTINE PHO_QPMPDF(IQ,X,SCALE2,PTREF,PVIRT,FXP)
30961 C***************************************************************
30963 C contribution to photon PDF from box graph
30964 C (Bethe-Heitler process)
30966 C input: IQ quark flavour
30967 C SCALE2 scale (GeV**2, positive)
30968 C PTREF reference scale (GeV, positive)
30969 C X parton momentum fraction
30970 C PVIRT photon virtuality (GeV**2, positive)
30971 C FXP x*f(x,Q**2), x times parton density
30973 C***************************************************************
30974 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30977 C input/output channels
30979 COMMON /POINOU/ LI,LO
30980 C event debugging information
30982 PARAMETER (NMAXD=100)
30983 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30984 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30985 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30986 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30987 C internal rejection counters
30989 PARAMETER (NMXJ=60)
30990 CHARACTER*10 REJTIT
30992 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
30994 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
30995 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
30996 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
30999 DATA QM / 0.2D0,0.25D0,0.5D0,1.5D0,4.5D0,174.D0 /
31004 * QM2 = MAX(QM(I),PTREF)**2
31005 * QM2 = MAX(QM2,PVIRT)
31006 * BBE = (1.D0-X)*SCALE2
31007 * IF(BBE.LE.0.D0) THEN
31008 * IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
31009 * & 'PHO_QPMPDF: over mass limit (X,Q2,P2,QM)',X,SCALE2,
31012 * FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(2.D0*137.D0*PI)
31013 * & *((X**2+(1.D0-X)**2)*LOG(BBE/(QM2*X))+8.D0*X*(1.D0-X)-1.D0)
31014 C Bethe-Heitler process approximation for 2*x*p2/q2 << 1
31015 QM2 = MAX(QM(I),PTREF)**2
31016 W2 = SCALE2/X*(1.D0-X-X*PVIRT/SCALE2)
31017 IF(W2.GT.4.D0*QM2) THEN
31018 BE = SQRT(1.D0-4.D0*QM2/W2)
31019 BP = SQRT(1.D0+BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
31020 BM = SQRT(1.D0-BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
31021 * FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(137.D0*PI)*(BE*(-1.D0
31022 FXP = X*Q_ch2(I)*3.D0/(137.D0*PI)*(BE*(-1.D0
31023 & +6.D0*X-6.D0*X*X)+2.D0*X*X*((2.D0*QM2-PVIRT)/SCALE2
31024 & -4.D0*QM2*QM2/SCALE2**2)*(1.D0/BM-1.D0/BP)
31025 & +(X*X+(1.D0-X)**2+X*(1-3.D0*X)*4.D0*QM2/SCALE2
31026 & -X*X*8.D0*QM2*QM2/SCALE2**2)*LOG(BP/BM))
31028 IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
31029 & 'PHO_QPMPDF: under mass limit (X,Q2,P2,QM)',X,SCALE2,
31033 IF(IDEB(27).GE.20) WRITE(LO,'(1X,A,I3,1P,5E10.3)')
31034 & 'PHO_QPMPDF: X,Q2,P2,QM',I,X,SCALE2,PVIRT,QM(I),FXP
31037 *$ CREATE PHO_SETPDF.FOR
31039 CDECK ID>, PHO_SETPDF
31040 SUBROUTINE PHO_SETPDF(IDPDG,ITYP,IPAR,ISET,IEXT,IPAVAL,MODE)
31041 C***************************************************************
31043 C assigns PDF numbers to particles
31045 C input: IDPDG PDG number of particle
31046 C ITYP particle type
31047 C IPAR PDF paramertization
31048 C ISET number of set
31049 C IEXT library number for PDF calculation
31050 C IPAVAL (only output)
31051 C 1 PDF with valence quarks
31052 C 0 PDF without valence quarks
31053 C MODE -1 add entry to table
31054 C 1 read from table
31055 C 2 output of table
31057 C***************************************************************
31058 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31061 C input/output channels
31063 COMMON /POINOU/ LI,LO
31064 C event debugging information
31066 PARAMETER (NMAXD=100)
31067 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31068 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31069 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31070 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31071 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
31072 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
31073 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
31074 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
31075 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
31077 DIMENSION IPDFS(5,50)
31082 IF(IDPDG.EQ.81) THEN
31085 ELSE IF(IDPDG.EQ.82) THEN
31093 IF(IDCMP.EQ.IPDFS(1,I)) THEN
31098 IF(IDEB(80).GE.15) WRITE(LO,'(1X,A,I7,5X,3I4)')
31099 & 'PHO_SETPDF: ID,IPAR,ISET,IEXT',IDCMP,IPAR,ISET,IEXT
31103 IF(I.GT.IENTRY) THEN
31104 WRITE(LO,'(/1X,A,I7)')
31105 & 'PHO_SETPDF: no PDF assigned to ',IDCMP
31109 ELSE IF(MODE.EQ.-1) THEN
31111 IF(IDPDG.EQ.IPDFS(1,I)) THEN
31112 WRITE(LO,'(/1X,A,5I6)')
31113 & 'PHO_SETPDF: overwrite old particle PDF',
31114 & IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
31120 WRITE(LO,'(/1X,A,/1x,6I6)')
31121 & 'PHO_SETPDF:ERROR: no space left in IPDFS:',
31122 & I,IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
31128 IF(IDPDG.EQ.990) THEN
31130 ELSE IF(IDPDG.EQ.22) THEN
31132 ELSE IF(ABS(IDPDG).LT.1000) THEN
31141 ELSE IF(MODE.EQ.-2) THEN
31142 WRITE(LO,'(/1X,A)') 'PHO_SETPDF: PDFs assigned by user:'
31144 WRITE(LO,'(5X,I4,A,I7,A,4I5)') I,' particle:',IPDFS(1,I),
31145 & ' PDF-set ',IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
31148 WRITE(LO,'(/1X,A,I5)') 'PHO_SETPDF:ERROR: invalid mode ',MODE
31152 *$ CREATE PHO_GETPDF.FOR
31154 CDECK ID>, PHO_GETPDF
31155 SUBROUTINE PHO_GETPDF(NPAR,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
31156 C***************************************************************
31158 C get PDF information
31160 C input: NPAR 1 first PDF in /POPPDF/
31161 C 2 second PDF in /POPPDF/
31163 C output: PDFNA name of PDf parametrization
31164 C ALA QCD LAMBDA (4 flavours, in GeV)
31170 C***************************************************************
31171 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31176 C input/output channels
31178 COMMON /POINOU/ LI,LO
31180 C PHOLIB 4.15 common
31181 COMMON /W50512/ QCDL4,QCDL5
31182 COMMON /W50513/ XMIN,XMAX,Q2MIN,Q2MAX
31184 C PHOPDF version 2.0 common
31185 PARAMETER (MAXS=6,MAXP=10)
31187 COMMON/PHCOM1/ XLIM(MAXP,0:MAXS,2), Q2LIM(MAXP,0:MAXS,2),
31188 & NSET(MAXP,2),NFL(MAXP)
31189 COMMON/PHCOM2/ ALM(MAXP,0:MAXS),CHPAR(MAXP),IORD(MAXP,-MAXS:MAXS)
31191 C currently activated parton density parametrizations
31193 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
31194 DOUBLE PRECISION PDFLAM,PDFQ2M
31195 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
31196 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
31198 DIMENSION PARAM(20),VALUE(20)
31201 IF((NPAR.NE.1).AND.(NPAR.NE.2)) THEN
31202 WRITE(LO,'(/1X,A,I6)')
31203 & 'PHO_GETPDF:ERROR: invalid PDF number (1,2)',NPAR
31208 IF(IEXT(NPAR).EQ.0) THEN
31210 C internal parametrizations
31212 IF(ITYPE(NPAR).EQ.1) THEN
31214 IF(IGRP(NPAR).EQ.5) THEN
31215 IF(ISET(NPAR).EQ.3) THEN
31219 ELSE IF(ISET(NPAR).EQ.4) THEN
31223 ELSE IF(ISET(NPAR).EQ.5) THEN
31227 ELSE IF(ISET(NPAR).EQ.6) THEN
31231 ELSE IF(ISET(NPAR).EQ.7) THEN
31235 ELSE IF(ISET(NPAR).EQ.8) THEN
31239 ELSE IF(ISET(NPAR).EQ.9) THEN
31245 ELSE IF(ITYPE(NPAR).EQ.2) THEN
31247 IF(IGRP(NPAR).EQ.5) THEN
31248 IF(ISET(NPAR).EQ.1) THEN
31252 ELSE IF(ISET(NPAR).EQ.2) THEN
31258 ELSE IF(ITYPE(NPAR).EQ.3) THEN
31260 IF(IGRP(NPAR).EQ.5) THEN
31261 IF(ISET(NPAR).EQ.1) THEN
31265 ELSE IF(ISET(NPAR).EQ.2) THEN
31269 ELSE IF(ISET(NPAR).EQ.3) THEN
31274 ELSE IF(IGRP(NPAR).EQ.8) THEN
31275 IF(ISET(NPAR).EQ.1) THEN
31281 ELSE IF(ITYPE(NPAR).EQ.20) THEN
31283 IF(IGRP(NPAR).EQ.4) THEN
31284 CALL PHO_CKMTPA(990,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
31292 C external parametrizations
31294 ELSE IF(IEXT(NPAR).EQ.1) THEN
31295 C PDFLIB call: old numbering
31298 VALUE(1) = IGRP(NPAR)
31299 CALL PDFSET(PARAM,VALUE)
31306 ELSE IF(IEXT(NPAR).EQ.2) THEN
31307 C PDFLIB call: new numbering
31308 PARAM(1) = 'NPTYPE'
31309 PARAM(2) = 'NGROUP'
31312 VALUE(1) = ITYPE(NPAR)
31313 VALUE(2) = IGRP(NPAR)
31314 VALUE(3) = ISET(NPAR)
31315 CALL PDFSET(PARAM,VALUE)
31322 ELSE IF(IEXT(NPAR).EQ.3) THEN
31324 ALA = ALM(IGRP(NPAR),ISET(NPAR))
31326 PDFNA = CHPAR(IGRP(NPAR))
31328 C some special internal parametrizations
31330 ELSE IF(IEXT(NPAR).EQ.4) THEN
31331 C photon PDFs depending on virtualities
31332 IF(IGRP(NPAR).EQ.1) THEN
31333 C Schuler/Sjostrand parametrization
31335 IF(ISET(NPAR).EQ.1) THEN
31338 ELSE IF(ISET(NPAR).EQ.2) THEN
31341 ELSE IF(ISET(NPAR).EQ.3) THEN
31344 ELSE IF(ISET(NPAR).EQ.4) THEN
31348 ELSE IF(IGRP(NPAR).EQ.5) THEN
31349 C Gluck/Reya/Stratmann parametrization
31350 IF(ISET(NPAR).EQ.4) THEN
31356 ELSE IF(IEXT(NPAR).EQ.5) THEN
31357 C Schuler/Sjostrand anomalous only
31362 IF(ALA.LT.0.01D0) THEN
31363 WRITE(LO,'(/1X,2A,/10X,5I6)')
31364 & 'PHO_GETPDF:ERROR: ',
31365 & 'unsupported PDF (NPAR,IEXT,ITYPE,IGRP,ISET)',
31366 & NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
31372 *$ CREATE PHO_ACTPDF.FOR
31374 CDECK ID>, PHO_ACTPDF
31375 SUBROUTINE PHO_ACTPDF(IDPDG,K)
31376 C***************************************************************
31378 C activate PDF for QCD calculations
31380 C input: IDPDG PDG particle number
31381 C K 1 first PDF in /POPPDF/
31382 C 2 second PDF in /POPPDF/
31383 C -2 write current settings
31387 C***************************************************************
31388 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31391 C input/output channels
31393 COMMON /POINOU/ LI,LO
31394 C event debugging information
31396 PARAMETER (NMAXD=100)
31397 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31398 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31399 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31400 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31401 C currently activated parton density parametrizations
31403 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
31404 DOUBLE PRECISION PDFLAM,PDFQ2M
31405 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
31406 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
31410 C read PDF from table
31411 CALL PHO_SETPDF(IDPDG,ITYPE(K),IGRP(K),ISET(K),IEXT(K),
31414 C get PDF parameters
31415 CALL PHO_GETPDF(K,PDFNAM(K),PDFLAM(K),PDFQ2M(K),Q2MA,XMI,XMA)
31416 C initialize alpha_s calculation
31417 alam2 = PDFLAM(K)*PDFLAM(K)
31418 DUMMY = PHO_ALPHAS(alam2,-K)
31420 IF(IDEB(2).GE.20) THEN
31422 & 'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
31423 WRITE(LO,'(1X,A,I2,2E12.3,2X,A8,4I4,I7)') 'SIDE',K,
31424 & PDFLAM(K),PDFQ2M(K),PDFNAM(K),ITYPE(K),IGRP(K),ISET(K),
31425 & IEXT(K),IPARID(K)
31429 ELSE IF(K.EQ.-2) THEN
31431 C write table of current PDFs
31433 & 'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
31434 WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 1:',PDFLAM(1),
31435 & PDFQ2M(1),PDFNAM(1),ITYPE(1),IGRP(1),ISET(1),IEXT(1),
31437 WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 2:',PDFLAM(2),
31438 & PDFQ2M(2),PDFNAM(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),
31443 WRITE(LO,'(/1X,A,2I4)')
31444 & 'PHO_ACTPDF:ERROR: invalid arguments',IDPDG,K
31451 *$ CREATE PHO_PDFTST.FOR
31453 CDECK ID>, PHO_PDFTST
31454 SUBROUTINE PHO_PDFTST(IDPDG,SCALE2,P2MASS)
31455 C*********************************************************************
31457 C structure function test utility
31459 C input: IDPDG PDG ID of particle
31460 C SCALE2 squared scale (GeV**2)
31461 C P2MASS particle virtuality (pos, GeV**2)
31463 C output: tables of PDF, sum rule checking, table of F2
31465 C*********************************************************************
31466 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31469 C input/output channels
31471 COMMON /POINOU/ LI,LO
31472 C currently activated parton density parametrizations
31474 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
31475 DOUBLE PRECISION PDFLAM,PDFQ2M
31476 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
31477 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
31479 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
31480 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
31481 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
31483 DIMENSION PD(-6:6),PDSUM(-6:6),PDAVE(-6:6),FXP(4)
31486 CALL PHO_ACTPDF(IDPDG,1)
31487 CALL PHO_GETPDF(1,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
31489 WRITE(LO,'(/,A)') ' *** Structure Function Test Utility ***'
31490 WRITE(LO,'(A)') ' ======================================='
31492 WRITE(LO,'(/,A,3I10)')
31493 & ' used structure function:',ITYPE(1),IGRP(1),ISET(1)
31494 WRITE(LO,'(A,A)') ' corresponds to ',PDFNA
31495 WRITE(LO,'(A,E12.3)') ' used squared scale (GeV**2):',SCALE2
31496 WRITE(LO,'(A,E12.3)') ' particle virtuality (GeV**2):',P2MASS
31497 WRITE(LO,'(/1X,A)') 'x times parton densities'
31498 WRITE(LO,'(1X,A)') ' X PD(-4 - 4)'
31500 & ' ============================================================'
31502 C logarithmic loop over x values
31511 XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
31515 CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
31516 IF(X.NE.XCONTR) THEN
31517 WRITE(LO,*) ' x changed! old: ',XCONTR,' new: ',X
31519 WRITE(LO,'(1X,1P,10E11.4)') XCONTR,(PD(K),K=-4,4)
31520 XFIRST=XFIRST+XDELTA
31523 IF(IDPDG.EQ.22) THEN
31524 WRITE(LO,'(/1X,A)')
31525 & 'comparison PDF to contribution due to box diagram'
31526 WRITE(LO,'(1X,A)') ' X PD(1),PB(1), .... ,PD(4),PB(4)'
31528 & ' ============================================================'
31530 XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
31533 CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
31535 CALL PHO_QPMPDF(K,X,SCALE2,0.D0,P2MASS,FXP(K))
31537 WRITE(LO,'(1X,1P,9E11.4)') X,(PD(K),FXP(K),K=1,4)
31538 XFIRST=XFIRST+XDELTA
31542 C check momentum sum rule
31544 WRITE(LO,'(/1X,A)') 'PHO_PDFTST: estimate of quark sum rules'
31551 XX=DBLE(I)/DBLE(ITER)
31552 IF(XX.EQ.1.D0) XX = 0.999999D0
31553 CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
31555 PDSUM(K) = PDSUM(K)+PD(K)/XX
31556 PDAVE(K) = PDAVE(K)+PD(K)
31560 & 'Table: parton-ID, dx-integral over Q(X,Q**2), X*Q(X,Q**2)'
31563 PDSUM(I) = PDSUM(I)/DBLE(ITER)
31564 PDAVE(I) = PDAVE(I)/DBLE(ITER)
31565 XSUM = XSUM+PDAVE(I)
31566 WRITE(LO,'(9X,I3,3X,2E15.4)') I,PDSUM(I),PDAVE(I)
31568 WRITE(LO,'(1X,A)') 'PHO_PDFTST: valence flavours'
31570 WRITE(LO,'(9X,I3,E12.4)') I,PDSUM(I)-PDSUM(-I)
31572 WRITE(LO,'(1X,A,E12.4)') 'momentum sum rule',XSUM
31573 WRITE(LO,'(A/)') ' ============================================='
31577 WRITE(LO,'(/1X,A,E12.4,/1X,A)')
31578 & 'PHO_PDFTST: TABLE OF X, F2(X,Q**2) FOR Q**2',SCALE2,
31579 & '-----------------------------------------------------'
31582 XX=DBLE(I)/DBLE(ITER)
31583 IF(XX.EQ.1.D0) XX = 0.9999D0
31584 CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
31587 IF(K.NE.0) F2 = F2 + Q_ch2(K)*PD(K)
31589 WRITE(LO,'(5X,1P,2E14.5)') XX,F2
31591 WRITE(LO,'(A/)') ' ============================================='
31594 *$ CREATE PHO_REGPAR.FOR
31596 CDECK ID>, PHO_REGPAR
31597 SUBROUTINE PHO_REGPAR(ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4,
31598 & IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE)
31599 C**********************************************************************
31601 C registration of particle in /POEVT1/ and /POEVT2/
31603 C input: ISTH status code of particle
31604 C -2 initial parton hard scattering
31607 C 1 visible particle (no color)
31608 C 2 decayed particle
31609 C IDPDG PDG particle ID code
31610 C IDBAM CPC particle ID code
31611 C JM1,JM2 first and second mother index
31612 C P1..P4 four momentum
31613 C IPHIS1 extended history information
31614 C IPHIS1<100: JM1 from particle 1
31615 C IPHIS1>100: JM1 from particle 2
31617 C 2 valence diquark
31620 C (neg. for antipartons)
31621 C IPHIS2 extended history information
31622 C positive: JM2 from particle 1
31623 C negative: JM2 from particle 2
31625 C IC1,IC2 color labels for partons
31626 C IMODE 1 register given parton
31627 C 0 reset /POEVT1/ and /POEVT2/
31628 C 2 return data of entry IPOS
31630 C IPOS position of particle in /POEVT1/
31632 C**********************************************************************
31633 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31636 PARAMETER (DEPS = 1.D-20)
31638 C input/output channels
31640 COMMON /POINOU/ LI,LO
31641 C event debugging information
31643 PARAMETER (NMAXD=100)
31644 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31645 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31646 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31647 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31649 C standard particle data interface
31652 PARAMETER (NMXHEP=4000)
31654 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
31655 DOUBLE PRECISION PHEP,VHEP
31656 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
31657 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
31659 C extension to standard particle data interface (PHOJET specific)
31660 INTEGER IMPART,IPHIST,ICOLOR
31661 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
31663 IF(IMODE.EQ.1) THEN
31664 IF(IDEB(76).GE.26) THEN
31665 WRITE(LO,'(1X,A,/2X,I3,I6,3I4,4E10.3)')
31666 & 'PHO_REGPAR: ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4',
31667 & ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4
31668 WRITE(LO,'(1X,A,/2X,6I6)')
31669 & 'PHO_REGPAR: IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE',
31670 & IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE
31672 IF(NHEP.EQ.NMXHEP) THEN
31673 WRITE(LO,'(/1X,2A,2I6/)') 'PHO_REGPAR: ',
31674 & 'no space left in /POEVT1/ (NHEP,NMXHEP):',NHEP,NMXHEP
31680 IF(ABS(ISTH).LE.2) THEN
31681 IF((IDBAM.NE.0).AND.(IDPDG.EQ.0)) THEN
31682 IDPDGI = ipho_id2pdg(IDBAM)
31683 ELSE IF((IDBAM.EQ.0).AND.(IDPDG.NE.0)) THEN
31684 IDBAMI = ipho_pdg2id(IDPDG)
31688 ISTHEP(NHEP) = ISTH
31689 IDHEP(NHEP) = IDPDGI
31690 JMOHEP(1,NHEP) = JM1
31691 JMOHEP(2,NHEP) = JM2
31692 C update of mother-daugther relations
31693 IF(ABS(ISTH).LE.1) THEN
31695 IF(JDAHEP(1,JM1).EQ.0) THEN
31696 JDAHEP(1,JM1) = NHEP
31699 JDAHEP(2,JM1) = NHEP
31701 IF((JM2.NE.JM1).AND.(JM2.GT.0)) THEN
31702 IF(JDAHEP(1,JM2).EQ.0) THEN
31703 JDAHEP(1,JM2) = NHEP
31706 JDAHEP(2,JM2) = NHEP
31707 ELSE IF(JM2.LT.0) THEN
31708 DO 100 II=JM1+1,-JM2
31709 IF(JDAHEP(1,II).EQ.0) THEN
31710 JDAHEP(1,II) = NHEP
31713 JDAHEP(2,II) = NHEP
31721 IF((ABS(ISTH).LE.3).OR.(ISTH.EQ.20).OR.(ISTH.EQ.21)) THEN
31722 TMP=(P4-P3)*(P4+P3)-P1**2-P2**2
31723 PHEP(5,NHEP) = SIGN(SQRT(ABS(TMP)),TMP)
31725 PHEP(5,NHEP) = 0.D0
31729 C extended information
31730 IMPART(NHEP) = IDBAMI
31731 C extended history information
31732 IPHIST(1,NHEP) = IPHIS1
31733 IPHIST(2,NHEP) = IPHIS2
31734 C charge/baryon number or color labels
31736 ICOLOR(1,NHEP) = IPHO_CHR3(NHEP,2)
31737 ICOLOR(2,NHEP) = IPHO_BAR3(NHEP,2)
31739 ICOLOR(1,NHEP) = IC1
31740 ICOLOR(2,NHEP) = IC2
31744 IF(IDEB(76).GE.26) THEN
31745 WRITE(LO,'(1X,A,2I4,2X,2I4,E12.3,I5)')
31746 & 'PHO_REGPAR: IPHIST1/2,IC1/2,MASS,IPOS',IPHIST(1,NHEP),
31747 & IPHIST(2,NHEP),ICOLOR(1,NHEP),ICOLOR(2,NHEP),
31748 & PHEP(5,NHEP),IPOS
31751 ELSE IF(IMODE.EQ.0) THEN
31753 ELSE IF(IMODE.EQ.2) THEN
31754 IF((IPOS.LT.1).OR.(IPOS.GT.NHEP)) THEN
31755 WRITE(LO,'(1X,2A,2I8)') 'PHO_REGPAR: ',
31756 & 'index out of bounds (NHEP,IPOS)',NHEP,IPOS
31759 ISTH = ISTHEP(IPOS)
31760 IDPDG = IDHEP(IPOS)
31761 IDBAM = IMPART(IPOS)
31762 JM1 = JMOHEP(1,IPOS)
31763 JM2 = JMOHEP(2,IPOS)
31768 IPHIS1= IPHIST(1,IPOS)
31769 IPHIS2= IPHIST(2,IPOS)
31770 IC1 = ICOLOR(1,IPOS)
31771 IC2 = ICOLOR(2,IPOS)
31773 WRITE(LO,'(1X,A,I8)') 'PHO_REGPAR: invalid mode',IMODE
31777 *$ CREATE IPHO_CNV1.FOR
31779 CDECK ID>, IPHO_CNV1
31780 INTEGER FUNCTION IPHO_CNV1(IPART)
31781 C*********************************************************************
31783 C conversion of quark numbering scheme to PARTICLE DATA GROUP
31786 C input: old internal particle code of hard scattering
31792 C valence quarks changed to standard numbering
31794 C output: standard particle codes
31796 C*********************************************************************
31797 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31801 C change gluon number
31804 C change valence quark
31805 ELSE IF((II.GT.6).AND.(II.LT.13)) THEN
31806 IPHO_CNV1 = SIGN(II-6,IPART)
31812 *$ CREATE PHO_HACODE.FOR
31814 CDECK ID>, PHO_HACODE
31815 SUBROUTINE PHO_HACODE(ID1,ID2,IDcpc1,IDcpc2)
31816 C*********************************************************************
31818 C determination of hadron index from quarks
31820 C input: ID1,ID2 parton code according to PDG conventions
31822 C output: IDcpc1,2 CPC particle codes
31824 C*********************************************************************
31830 integer ID1,ID2,IDcpc1,IDcpc2
31832 C input/output channels
31834 COMMON /POINOU/ LI,LO
31835 C event debugging information
31837 PARAMETER (NMAXD=100)
31838 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31839 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31840 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31841 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31842 C general particle data
31843 double precision xm_list,tau_list,gam_list,
31844 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
31845 & xm_bb82_list,xm_bb102_list
31846 integer ich3_list,iba3_list,iq_list,
31847 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
31848 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
31849 & xm_psm2_list(6,6),xm_vem2_list(6,6),
31850 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
31851 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
31852 & ich3_list(300),iba3_list(300),iq_list(3,300),
31853 & id_psm_list(6,6),id_vem_list(6,6),
31854 & id_b8_list(6,6,6),id_b10_list(6,6,6)
31857 integer ii,jj,kk,i1,i2
31862 if(ID1*ID2.lt.0) then
31871 IDcpc1 = ID_psm_list(ii,jj)
31872 IDcpc2 = ID_vem_list(ii,jj)
31880 jj = (i1-ii*1000)/100
31885 kk = (i2-jj*1000)/100
31887 IDcpc1 = sign(ID_b8_list(ii,jj,kk),ID1)
31888 IDcpc2 = sign(ID_b10_list(ii,jj,kk),ID1)
31894 *$ CREATE PHO_ID2STR.FOR
31896 CDECK ID>, PHO_ID2STR
31897 SUBROUTINE PHO_ID2STR(ID1,ID2,NOBAM,IBAM1,IBAM2,IBAM3,IBAM4)
31898 C*********************************************************************
31900 C conversion of quark numbering scheme
31902 C input: standard particle codes:
31906 C output: NOBAM CPC string code
31907 C quark codes (PDG convention):
31913 C NOBAM = -1 invalid flavour combinations
31915 C*********************************************************************
31916 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31919 C input/output channels
31921 COMMON /POINOU/ LI,LO
31926 C quark-antiquark string
31927 IF((IDA1.LE.6).AND.(IDA2.LE.6)) THEN
31928 IF((ID1*ID2).GE.0) GOTO 100
31934 C quark-diquark string
31935 ELSE IF((IDA2.GT.6).AND.(IDA1.LE.6)) THEN
31936 IF((ID1*ID2).LE.0) GOTO 100
31939 IBAM3 = (ID2-IBAM2*1000)/100
31942 C diquark-quark string
31943 ELSE IF((IDA1.GT.6).AND.(IDA2.LE.6)) THEN
31944 IF((ID1*ID2).LE.0) GOTO 100
31946 IBAM2 = (ID1-IBAM1*1000)/100
31950 C gluon-gluon string
31951 ELSE IF((IDA1.EQ.21).AND.(IDA2.EQ.21)) THEN
31957 C diquark-antidiquark string
31958 ELSE IF((IDA1.GT.6).AND.(IDA2.GT.6)) THEN
31959 IF((ID1*ID2).GE.0) GOTO 100
31961 IBAM2 = (ID1-IBAM1*1000)/100
31963 IBAM4 = (ID2-IBAM3*1000)/100
31968 C invalid combination
31970 WRITE(LO,'(//1X,A,2I10)')
31971 & 'PHO_ID2STR: invalid flavors for string (ID1,ID2)',ID1,ID2
31976 *$ CREATE PHO_MKSLTR.FOR
31978 CDECK ID>, PHO_MKSLTR
31979 SUBROUTINE PHO_MKSLTR(P1,P2,GAM,GAMB)
31980 C********************************************************************
31982 C calculate successive Lorentz boots for arbitrary Lorentz trans.
31984 C input: P1 initial 4 vector
31985 C GAM(3),GAMB(3) Lorentz boost parameters
31987 C output: P2 final 4 vector
31989 C********************************************************************
31990 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31993 DIMENSION P1(4),P2(4),GAM(3),GAMB(3)
31997 P2(I)=GAM(I)*P1(I)+GAMB(I)*P2(4)
31998 P2(4)=GAM(I)*P2(4)+GAMB(I)*P1(I)
32002 *$ CREATE PHO_GETLTR.FOR
32004 CDECK ID>, PHO_GETLTR
32005 SUBROUTINE PHO_GETLTR(P1,P2,GAM,GAMB,DELE,IREJ)
32006 C********************************************************************
32008 C calculate Lorentz boots for arbitrary Lorentz transformation
32010 C input: P1 initial 4 vector
32011 C P2 final 4 vector
32013 C output: GAM(3),GAMB(3)
32014 C DELE energy deviation
32018 C********************************************************************
32019 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32022 PARAMETER ( DREL = 0.001D0 )
32024 C input/output channels
32026 COMMON /POINOU/ LI,LO
32028 DIMENSION P1(4),P2(4),GAM(3),GAMB(3),PA(4),PP(4)
32035 PM1 = P1(4)**2-P1(1)**2-P1(2)**2-P1(3)**2
32038 PP(4) = PM1+PP(1)**2+PP(2)**2+PP(3)**2
32039 IF(PP(4).LE.0.D0) RETURN
32040 PP(4) = SQRT(PP(4))
32041 GAMB(I) = (SQRT(PA(4)**2-PA(I)**2+PP(I)**2)*PP(I)
32042 & -PA(4)*PA(I))/(PA(4)**2+PP(I)**2)
32043 GAM(I) = 1.D0/SQRT(1.D0-GAMB(I)**2)
32044 GAMB(I) = GAMB(I)*GAM(I)
32051 C consistency check
32052 * IF(ABS(P2(4)-PP(4))/MAX(P2(4),PP(4)).GT.DREL) THEN
32053 * PM2 = P2(4)**2-P2(1)**2-P2(2)**2-P2(3)**2
32054 * WRITE(LO,'(/1X,A,2E12.5)')
32055 * & 'PHO_GETLTR: INCONSISTENT ENERGIES',P2(4),PP(4)
32056 * WRITE(LO,'(1X,A,2E12.4)') 'INPUT MASSES',PM1,PM2
32057 * WRITE(LO,'(1X,A,4E12.4)') 'INPUT ',P1
32058 * WRITE(LO,'(1X,A,4E12.4)') 'OUTPUT',P2
32059 * WRITE(LO,'(1X,A,4E12.4)') 'INTERN',PP
32063 *$ CREATE PHO_ALTRA.FOR
32065 CDECK ID>, PHO_ALTRA
32066 SUBROUTINE PHO_ALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
32067 C*********************************************************************
32069 C arbitrary Lorentz transformation
32071 C*********************************************************************
32072 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32075 EP=PCX*BGX+PCY*BGY+PCZ*BGZ
32080 P=SQRT(PX*PX+PY*PY+PZ*PZ)
32085 *$ CREATE PHO_LTRANS.FOR
32087 CDECK ID>, PHO_LTRANS
32088 SUBROUTINE PHO_LTRANS(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
32089 & PL,CXL,CYL,CZL,EL)
32090 C**********************************************************************
32092 C Lorentz transformation into lab - system
32094 C**********************************************************************
32095 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32098 PARAMETER ( TINY=1.D-08,TINY2=1.D-30 )
32100 C input/output channels
32102 COMMON /POINOU/ LI,LO
32104 SID=SQRT(1.D0-COD*COD)
32108 PLZ=GAM*PCMZ+BGAM*ECM
32109 PL=SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
32110 EL=GAM*ECM+BGAM*PCMZ
32112 C rotation into the original direction
32114 SIZ=SQRT(MAX((1.D0-COZ)*(1.D0+COZ),0.D0))
32116 * CALL PHO_DTRANS(CX,CY,CZ,COZ,SIZ,COF,SIF,CXL,CYL,CZL)
32127 IF (ABS(CX)-TINY) 1,1,2
32128 1 IF (ABS(CY)-TINY) 3,3,2
32131 * WRITE(LO,*)' PHO_DTRANS CX CY CZ =',CX,CY,CZ
32135 * WRITE(LO,*)' PHO_DTRANS CXL=SIZ*COF CYL=SIZ*SIF CZL=COZ'
32136 * WRITE(LO,*) CXL,CYL,CZL
32140 IF(AMAX.GT.TINY2) THEN
32143 A=AMAX*SQRT(1.D0+AR)
32145 * WRITE(LO,*)' PHO_DTRANS AMAX LE TINY2 '
32151 CXL=-CY*XI/A-CZ*CX*YI/A+CX*ZI
32152 CYL=CX*XI/A-CZ*CY*YI/A+CY*ZI
32157 *$ CREATE PHO_TRANS.FOR
32159 CDECK ID>, PHO_TRANS
32160 SUBROUTINE PHO_TRANS(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
32161 C**********************************************************************
32163 C rotation of coordinate frame (1) de rotation around y axis
32164 C (2) fe rotation around z axis
32165 C (inverse rotation to PHO_TRANI)
32167 C**********************************************************************
32168 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32171 X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
32172 Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
32173 Z=-SDE *XO +CDE *ZO
32177 *$ CREATE PHO_TRANI.FOR
32179 CDECK ID>, PHO_TRANI
32180 SUBROUTINE PHO_TRANI(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
32181 C**********************************************************************
32183 C rotation of coordinate frame (1) -fe rotation around z axis
32184 C (2) -de rotation around y axis
32185 C (inverse rotation to PHO_TRANS)
32187 C**********************************************************************
32188 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32191 X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
32193 Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
32197 *$ CREATE pho_cpcini.FOR
32199 CDECK ID>, pho_cpcini
32200 SUBROUTINE pho_cpcini(Nrows,Number,List)
32201 C***********************************************************************
32203 C initialization of particle hash table
32205 C input: Number vector with Nrows entries according to PDG
32208 C output: List vector with hash table
32210 C (this code is based on the function initpns written by
32211 C Gerry Lynch, LBL, January 1990)
32213 C***********************************************************************
32219 C input/output channels
32221 COMMON /POINOU/ LI,LO
32223 integer Number(*),List(*),Nrows
32225 Integer Nin,Nout,Ip,I
32231 C Loop over all of the elements in the Number vector
32233 Do 500 Ip = 1,Nrows
32236 C Calculate a list number for this particle id number
32237 If(Nin.Gt.99999.or.Nin.Le.0) Then
32239 Else If(Nin.Le.577) Then
32242 Nout = Mod(Nin,577)
32248 C Count the bad entries
32249 WRITE(LO,'(1x,a,i10)')
32250 & 'pho_cpcini: invalid particle ID',Nin
32253 If(List(Nout).eq.0) Then
32256 If(Nin.eq.Number(List(Nout))) Then
32257 WRITE(LO,'(1x,a,i10)')
32258 & 'pho_cpcini: double particle ID',Nin
32261 If(Nout.Gt.577) Nout = Mod(Nout, 577)
32269 *$ CREATE ipho_pdg2id.FOR
32271 CDECK ID>, ipho_pdg2id
32272 INTEGER FUNCTION ipho_pdg2id(IDpdg)
32273 C**********************************************************************
32275 C calculation internal particle code using the particle index i
32276 C according to the PDG proposal.
32278 C input: IDpdg PDG particle number
32279 C output: ipho_pdg2id internal particle code
32280 C (0 for invalid IDpdg)
32282 C the hash algorithm is based on a program by Gerry Lynch
32284 C**********************************************************************
32292 C input/output channels
32294 COMMON /POINOU/ LI,LO
32295 C event debugging information
32297 PARAMETER (NMAXD=100)
32298 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32299 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32300 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32301 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32302 C particle ID translation table
32303 integer ID_pdg_list,ID_list,ID_pdg_max
32304 character*12 name_list
32305 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32312 if((Nin.gt.99999).or.(Nin.eq.0)) then
32313 C invalid particle number
32314 if(ideb(71).gt.5) WRITE(LO,'(1x,A,I10)')
32315 & 'ipho_pdg2id: invalid PDG ID number ',IDpdg
32318 else If(Nin.le.577) then
32322 C use hash algorithm
32323 Nout = mod(Nin,577)
32328 C particle not in table
32329 if(ID_list(Nout).Eq.0) then
32330 if(ideb(71).ge.0) WRITE(LO,'(1x,A,I10)')
32331 & 'ipho_pdg2id: particle not in table ',IDpdg
32336 if(ID_pdg_list(ID_list(Nout)).eq.Nin) then
32337 C particle ID found
32338 ipho_pdg2id = sign(ID_list(Nout),IDpdg)
32341 C increment and try again
32343 If(Nout.gt.577) Nout = Mod(Nout,577)
32349 *$ CREATE IPHO_ID2PDG.FOR
32351 CDECK ID>, IPHO_ID2PDG
32352 INTEGER FUNCTION ipho_id2pdg(IDcpc)
32353 C**********************************************************************
32355 C conversion of internal particle code to PDG standard
32357 C input: IDcpc internal particle number
32358 C output: ipho_id2pdg PDG particle number
32359 C (0 for invalid IDcpc)
32361 C**********************************************************************
32369 C input/output channels
32371 COMMON /POINOU/ LI,LO
32372 C event debugging information
32374 PARAMETER (NMAXD=100)
32375 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32376 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32377 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32378 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32379 C particle ID translation table
32380 integer ID_pdg_list,ID_list,ID_pdg_max
32381 character*12 name_list
32382 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32388 if((IDabs.lt.1).or.(IDabs.gt.ID_pdg_max)) then
32393 ipho_id2pdg = sign(ID_pdg_list(IDabs),IDcpc)
32397 *$ CREATE IPHO_LU2PDG.FOR
32399 CDECK ID>, IPHO_LU2PDG
32400 INTEGER FUNCTION IPHO_LU2PDG(LUKF)
32401 C**********************************************************************
32403 C conversion of JETSET KF code to PDG code
32405 C**********************************************************************
32406 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32408 PARAMETER (NTAB=10)
32409 DIMENSION LU2PD(2,NTAB)
32410 DATA LU2PD / 4232, 4322,
32422 IF(LU2PD(1,I).EQ.LUKF) THEN
32423 IPHO_LU2PDG=LU2PD(2,I)
32431 *$ CREATE IPHO_PDG2LU.FOR
32433 CDECK ID>, IPHO_PDG2LU
32434 INTEGER FUNCTION IPHO_PDG2LU(IPDG)
32435 C**********************************************************************
32437 C conversion of PDG code to JETSET code
32439 C**********************************************************************
32440 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32443 DIMENSION LU2PD(2,NTAB)
32444 DATA LU2PD / 4232, 4322,
32454 IF(LU2PD(2,I).EQ.IPDG) THEN
32455 IPHO_PDG2LU=LU2PD(1,I)
32463 *$ CREATE pho_pname.FOR
32465 CDECK ID>, pho_pname
32466 CHARACTER*15 FUNCTION pho_pname(ID,mode)
32467 C***********************************************************************
32469 C returns particle name for given ID number
32471 C input: ID particle ID number
32472 C mode 0: ID treated as compressed particle code
32473 C 1: ID treated as PDG number
32475 C***********************************************************************
32483 C input/output channels
32485 COMMON /POINOU/ LI,LO
32487 C standard particle data interface
32490 PARAMETER (NMXHEP=4000)
32492 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32493 DOUBLE PRECISION PHEP,VHEP
32494 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32495 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32497 C extension to standard particle data interface (PHOJET specific)
32498 INTEGER IMPART,IPHIST,ICOLOR
32499 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32501 C particle ID translation table
32502 integer ID_pdg_list,ID_list,ID_pdg_max
32503 character*12 name_list
32504 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32506 C general particle data
32507 double precision xm_list,tau_list,gam_list,
32508 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32509 & xm_bb82_list,xm_bb102_list
32510 integer ich3_list,iba3_list,iq_list,
32511 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32512 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32513 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32514 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32515 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32516 & ich3_list(300),iba3_list(300),iq_list(3,300),
32517 & id_psm_list(6,6),id_vem_list(6,6),
32518 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32520 C external functions
32521 integer ipho_id2pdg,ipho_pdg2id
32524 integer IDpdg,i,ii,k,l,ichar,i_anti
32527 pho_pname = '(?????????????)'
32531 IDpdg = ipho_id2pdg(ID)
32532 if(IDpdg.eq.0) return
32533 else if(mode.eq.1) then
32534 i = ipho_pdg2id(ID)
32537 else if(mode.eq.2) then
32538 if(ISTHEP(ID).gt.11) then
32539 if(ISTHEP(ID).eq.20) then
32540 pho_pname = 'hard ini. part.'
32541 else if(ISTHEP(ID).eq.21) then
32542 pho_pname = 'hard fin. part.'
32543 else if(ISTHEP(ID).eq.25) then
32544 pho_pname = 'hard scattering'
32545 else if(ISTHEP(ID).eq.30) then
32546 pho_pname = 'diff. diss. '
32547 else if(ISTHEP(ID).eq.35) then
32548 pho_pname = 'elastic scatt. '
32549 else if(ISTHEP(ID).eq.40) then
32550 pho_pname = 'central scatt. '
32557 WRITE(LO,'(1x,a,2i4)')
32558 & 'pho_pname: invalid arguments (ID,mode): ',ID,mode
32563 if((ii.eq.0).or.(ii.gt.ID_pdg_max)) return
32565 name = name_list(ii)
32566 ichar = ich3_list(ii)*sign(1,i)
32567 if(mod(ichar,3).ne.0) then
32573 C find position of first blank character
32577 if(name(k:k).ne.' ') goto 100
32579 C append anti-particle sign
32583 i_anti = i_anti+iq_list(l,ii)
32585 if(iba3_list(ii).ne.0) then
32588 else if(((i_anti.ne.0).and.(ichar.eq.0))
32589 & .or.(IDpdg.eq.-12)
32590 & .or.(IDpdg.eq.-14)
32591 & .or.(IDpdg.eq.-16)) then
32597 C append charge sign
32598 if(ichar.eq.-2) then
32600 else if(ichar.eq.-1) then
32602 else if(ichar.eq.1) then
32604 else if(ichar.eq.2) then
32612 *$ CREATE ipho_anti.FOR
32614 CDECK ID>, ipho_anti
32615 INTEGER FUNCTION ipho_anti(ID)
32616 C**********************************************************************
32618 C determine antiparticle for given ID
32620 C input: ID gives CPC particle number
32622 C output: ipho_anti antiparticle code
32624 C**********************************************************************
32632 C input/output channels
32634 COMMON /POINOU/ LI,LO
32635 C event debugging information
32637 PARAMETER (NMAXD=100)
32638 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32639 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32640 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32641 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32642 C particle ID translation table
32643 integer ID_pdg_list,ID_list,ID_pdg_max
32644 character*12 name_list
32645 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32647 C general particle data
32648 double precision xm_list,tau_list,gam_list,
32649 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32650 & xm_bb82_list,xm_bb102_list
32651 integer ich3_list,iba3_list,iq_list,
32652 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32653 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32654 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32655 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32656 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32657 & ich3_list(300),iba3_list(300),iq_list(3,300),
32658 & id_psm_list(6,6),id_vem_list(6,6),
32659 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32661 C standard particle data interface
32664 PARAMETER (NMXHEP=4000)
32666 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32667 DOUBLE PRECISION PHEP,VHEP
32668 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32669 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32671 C extension to standard particle data interface (PHOJET specific)
32672 INTEGER IMPART,IPHIST,ICOLOR
32673 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32675 C external functions
32676 integer ipho_id2pdg,ipho_pdg2id
32679 integer IDabs,IDpdg,i_anti,l
32685 if(iba3_list(IDabs).ne.0) return
32687 C charged particles
32688 if(ich3_list(IDabs).ne.0) return
32691 IDpdg = ipho_id2pdg(ID)
32692 if(IDpdg.eq.310) then
32693 ID = ipho_pdg2id(130)
32695 else if(IDpdg.eq.130) then
32696 ID = ipho_pdg2id(310)
32700 C neutral mesons with open strangeness, charm, or beauty
32703 i_anti = i_anti+iq_list(l,IDabs)
32705 if(i_anti.ne.0) return
32709 if((IDpdg.eq.12).or.(IDpdg.eq.14).or.(IDpdg.eq.16)) return
32715 *$ CREATE ipho_chr3.FOR
32717 CDECK ID>, ipho_chr3
32718 INTEGER FUNCTION ipho_chr3(ID,mode)
32719 C**********************************************************************
32721 C output of three times the electric charge
32724 C 0 ID gives CPC particle number
32725 C 1 ID gives PDG particle number
32726 C 2 ID gives position of particle in /POEVT1/
32728 C**********************************************************************
32736 C input/output channels
32738 COMMON /POINOU/ LI,LO
32739 C event debugging information
32741 PARAMETER (NMAXD=100)
32742 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32743 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32744 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32745 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32747 C standard particle data interface
32750 PARAMETER (NMXHEP=4000)
32752 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32753 DOUBLE PRECISION PHEP,VHEP
32754 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32755 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32757 C extension to standard particle data interface (PHOJET specific)
32758 INTEGER IMPART,IPHIST,ICOLOR
32759 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32761 C particle ID translation table
32762 integer ID_pdg_list,ID_list,ID_pdg_max
32763 character*12 name_list
32764 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32766 C general particle data
32767 double precision xm_list,tau_list,gam_list,
32768 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32769 & xm_bb82_list,xm_bb102_list
32770 integer ich3_list,iba3_list,iq_list,
32771 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32772 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32773 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32774 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32775 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32776 & ich3_list(300),iba3_list(300),iq_list(3,300),
32777 & id_psm_list(6,6),id_vem_list(6,6),
32778 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32780 C external functions
32781 integer ipho_pdg2id
32790 else if(mode.eq.1) then
32791 i = ipho_pdg2id(ID)
32794 else if(mode.eq.2) then
32795 if(ISTHEP(ID).gt.11) return
32798 IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32799 ipho_chr3 = ICOLOR(1,ID)
32803 WRITE(LO,'(1x,a,2i4)')
32804 & 'ipho_chr3: invalid mode (ID,mode): ',ID,mode
32808 if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32809 WRITE(LO,'(1x,a,3i8)')
32810 & 'ipho_chr3: invalid arguments (ID,mode,i): ',ID,mode,i
32811 ipho_chr3 = 1.D0/dble(i)
32816 ipho_chr3 = ich3_list(iabs(i))*sign(1,i)
32820 *$ CREATE ipho_bar3.FOR
32822 CDECK ID>, ipho_bar3
32823 INTEGER FUNCTION ipho_bar3(ID,mode)
32824 C**********************************************************************
32826 C output of three times the baryon charge
32829 C 0 ID gives CPC particle number
32830 C 1 ID gives PDG particle number
32831 C 2 ID gives position of particle in /POEVT1/
32833 C**********************************************************************
32841 C input/output channels
32843 COMMON /POINOU/ LI,LO
32844 C event debugging information
32846 PARAMETER (NMAXD=100)
32847 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32848 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32849 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32850 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32852 C standard particle data interface
32855 PARAMETER (NMXHEP=4000)
32857 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32858 DOUBLE PRECISION PHEP,VHEP
32859 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32860 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32862 C extension to standard particle data interface (PHOJET specific)
32863 INTEGER IMPART,IPHIST,ICOLOR
32864 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32866 C particle ID translation table
32867 integer ID_pdg_list,ID_list,ID_pdg_max
32868 character*12 name_list
32869 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32871 C general particle data
32872 double precision xm_list,tau_list,gam_list,
32873 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32874 & xm_bb82_list,xm_bb102_list
32875 integer ich3_list,iba3_list,iq_list,
32876 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32877 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32878 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32879 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32880 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32881 & ich3_list(300),iba3_list(300),iq_list(3,300),
32882 & id_psm_list(6,6),id_vem_list(6,6),
32883 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32885 C external functions
32886 integer ipho_pdg2id
32895 else if(mode.eq.1) then
32896 i = ipho_pdg2id(ID)
32899 else if(mode.eq.2) then
32900 if(ISTHEP(ID).gt.11) return
32903 IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32904 ipho_bar3 = ICOLOR(2,ID)
32908 WRITE(LO,'(1x,a,2i4)')
32909 & 'ipho_bar3: invalid mode (ID,mode): ',ID,mode
32913 if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32914 WRITE(LO,'(1x,a,3i8)')
32915 & 'ipho_bar3: invalid arguments (ID,mode,i): ',ID,mode,i
32916 ipho_bar3 = 1.D0/dble(i)
32920 ipho_bar3 = iba3_list(iabs(i))*sign(1,i)
32924 *$ CREATE pho_pmass.FOR
32926 CDECK ID>, pho_pmass
32927 DOUBLE PRECISION FUNCTION pho_pmass(ID,mode)
32928 C***********************************************************************
32932 C input: mode -1 initialization
32933 C 0 ID gives CPC particle number
32934 C 1 ID gives PDG particle number,
32935 C (for quarks current masses are returned)
32936 C 2 ID gives position of particle in /POEVT1/
32937 C 3 ID gives PDG parton number,
32938 C (for quarks constituent masses are returned)
32940 C output: average particle mass (in GeV)
32942 C***********************************************************************
32948 integer ID,mode,MSTJ24
32950 C input/output channels
32952 COMMON /POINOU/ LI,LO
32953 C event debugging information
32955 PARAMETER (NMAXD=100)
32956 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32957 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32958 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32959 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32960 C model switches and parameters
32962 INTEGER ISWMDL,IPAMDL
32963 DOUBLE PRECISION PARMDL
32964 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
32966 C standard particle data interface
32969 PARAMETER (NMXHEP=4000)
32971 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32972 DOUBLE PRECISION PHEP,VHEP
32973 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32974 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32976 C extension to standard particle data interface (PHOJET specific)
32977 INTEGER IMPART,IPHIST,ICOLOR
32978 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32980 C particle ID translation table
32981 integer ID_pdg_list,ID_list,ID_pdg_max
32982 character*12 name_list
32983 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32985 C general particle data
32986 double precision xm_list,tau_list,gam_list,
32987 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32988 & xm_bb82_list,xm_bb102_list
32989 integer ich3_list,iba3_list,iq_list,
32990 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32991 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32992 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32993 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32994 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32995 & ich3_list(300),iba3_list(300),iq_list(3,300),
32996 & id_psm_list(6,6),id_vem_list(6,6),
32997 & id_b8_list(6,6,6),id_b10_list(6,6,6)
33000 DOUBLE PRECISION PARU,PARJ
33001 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33003 C external functions
33004 integer ipho_pdg2id,ipho_id2pdg
33006 DOUBLE PRECISION PYMASS
33015 else if(mode.eq.1) then
33016 i = ipho_pdg2id(ID)
33018 else if(mode.eq.2) then
33019 if(ISTHEP(ID).gt.11) return
33022 IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
33023 pho_pmass = PHEP(5,ID)
33026 else if(mode.eq.3) then
33028 if((i.gt.0).and.(i.le.6)) then
33029 pho_pmass = PARMDL(150+i)
33032 i = ipho_pdg2id(ID)
33035 else if(mode.eq.-1) then
33036 C initialization: take masses for quarks and di-quarks from JETSET
33040 IDpdg = ipho_id2pdg(i)
33042 xm_list(i) = PYMASS(IDpdg)
33048 WRITE(LO,'(1x,a,2i4)')
33049 & 'pho_pmass: invalid arguments (ID,mode): ',ID,mode
33053 if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
33054 WRITE(LO,'(1x,a,2i8)')
33055 & 'pho_pmass: invalid arguments (ID,mode): ',ID,mode
33056 pho_pmass = 1.D0/dble(i)
33060 pho_pmass = xm_list(iabs(i))
33064 *$ CREATE PHO_MEMASS.FOR
33066 CDECK ID>, PHO_MEMASS
33067 SUBROUTINE PHO_MEMASS(I,J,AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
33068 C**********************************************************************
33070 C determine meson masses corresponding to the input flavours
33072 C input: I,J,K quark flavours (PDG convention)
33074 C output: AMPS pseudo scalar meson mass
33075 C AMPS2 next possible two particle configuration
33076 C (two pseudo scalar mesons)
33077 C AMVE vector meson mass
33078 C AMVE2 next possible two particle configuration
33079 C (two vector mesons)
33080 C IPS,IVE meson numbers in CPC
33082 C**********************************************************************
33088 integer I,J,IPS,IVE
33089 double precision AMPS,AMPS2,AMVE,AMVE2
33091 C input/output channels
33093 COMMON /POINOU/ LI,LO
33094 C event debugging information
33096 PARAMETER (NMAXD=100)
33097 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33098 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33099 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33100 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33101 C particle ID translation table
33102 integer ID_pdg_list,ID_list,ID_pdg_max
33103 character*12 name_list
33104 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
33106 C general particle data
33107 double precision xm_list,tau_list,gam_list,
33108 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
33109 & xm_bb82_list,xm_bb102_list
33110 integer ich3_list,iba3_list,iq_list,
33111 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
33112 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
33113 & xm_psm2_list(6,6),xm_vem2_list(6,6),
33114 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
33115 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
33116 & ich3_list(300),iba3_list(300),iq_list(3,300),
33117 & id_psm_list(6,6),id_vem_list(6,6),
33118 & id_b8_list(6,6,6),id_b10_list(6,6,6)
33132 IPS = id_psm_list(ii,jj)
33133 IVE = id_vem_list(ii,jj)
33136 AMPS = xm_list(iabs(IPS))
33141 AMVE = xm_list(iabs(IVE))
33146 C next possible two-particle configurations (add phase space)
33147 AMPS2 = xm_psm2_list(ii,jj)*1.5D0
33148 AMVE2 = xm_vem2_list(ii,jj)*1.1D0
33152 *$ CREATE PHO_BAMASS.FOR
33154 CDECK ID>, PHO_BAMASS
33155 SUBROUTINE PHO_BAMASS(I,J,K,AM8,AM82,AM10,AM102,I8,I10)
33156 C**********************************************************************
33158 C determine baryon masses corresponding to the input flavours
33160 C input: I,J,K quark flavours (PDG convention)
33162 C output: AM8 octett baryon mass
33163 C AM82 next possible two particle configuration
33164 C (octett baryon and meson)
33165 C AM10 decuplett baryon mass
33166 C AM102 next possible two particle configuration
33167 C (decuplett baryon and meson,
33168 C baryon built up from first two quarks)
33169 C I8,I10 internal baryon numbers
33171 C**********************************************************************
33177 integer I,J,K,I8,I10
33178 double precision AM8,AM82,AM10,AM102
33180 C input/output channels
33182 COMMON /POINOU/ LI,LO
33183 C event debugging information
33185 PARAMETER (NMAXD=100)
33186 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33187 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33188 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33189 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33190 C particle ID translation table
33191 integer ID_pdg_list,ID_list,ID_pdg_max
33192 character*12 name_list
33193 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
33195 C general particle data
33196 double precision xm_list,tau_list,gam_list,
33197 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
33198 & xm_bb82_list,xm_bb102_list
33199 integer ich3_list,iba3_list,iq_list,
33200 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
33201 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
33202 & xm_psm2_list(6,6),xm_vem2_list(6,6),
33203 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
33204 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
33205 & ich3_list(300),iba3_list(300),iq_list(3,300),
33206 & id_psm_list(6,6),id_vem_list(6,6),
33207 & id_b8_list(6,6,6),id_b10_list(6,6,6)
33212 C find particle ID's
33216 I8 = id_b8_list(ii,jj,kk)
33217 I10 = id_b10_list(ii,jj,kk)
33219 C masses (if combination possible)
33227 AM10 = xm_list(I10)
33233 C next possible two-particle configurations (add phase space)
33234 AM82 = xm_b82_list(ii,jj,kk)*1.5D0
33235 AM102 = xm_b102_list(ii,jj,kk)*1.1D0
33239 *$ CREATE PHO_DQMASS.FOR
33241 CDECK ID>, PHO_DQMASS
33242 SUBROUTINE PHO_DQMASS(I,J,K,L,AM82,AM102)
33243 C**********************************************************************
33245 C determine minimal masses corresponding to the input flavours
33246 C (diquark a-diquark string system)
33248 C input: I,J,K,L quark flavours (PDG convention)
33250 C output: AM82 mass of two octett baryons
33251 C AM102 mass of two decuplett baryons
33253 C**********************************************************************
33260 double precision AM82,AM102
33262 C input/output channels
33264 COMMON /POINOU/ LI,LO
33265 C event debugging information
33267 PARAMETER (NMAXD=100)
33268 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33269 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33270 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33271 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33272 C general particle data
33273 double precision xm_list,tau_list,gam_list,
33274 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
33275 & xm_bb82_list,xm_bb102_list
33276 integer ich3_list,iba3_list,iq_list,
33277 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
33278 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
33279 & xm_psm2_list(6,6),xm_vem2_list(6,6),
33280 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
33281 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
33282 & ich3_list(300),iba3_list(300),iq_list(3,300),
33283 & id_psm_list(6,6),id_vem_list(6,6),
33284 & id_b8_list(6,6,6),id_b10_list(6,6,6)
33287 integer ii,jj,kk,ll
33294 AM82 = xm_bb82_list(ii,jj,kk,ll)
33295 AM102 = xm_bb102_list(ii,jj,kk,ll)
33299 *$ CREATE PHO_CHECK.FOR
33301 CDECK ID>, PHO_CHECK
33302 SUBROUTINE PHO_CHECK(MD,IDEV)
33303 C**********************************************************************
33305 C check quantum numbers of entries in /POEVT1/ and /POEVT2/
33306 C (energy, momentum, charge, baryon number conservation)
33308 C input: MD -1 check overall momentum conservation
33309 C and perform detailed check only in case of
33311 C 1 test all branchings, mother-daughter
33314 C output: IDEV 0 no deviations
33315 C 1 deviations found
33317 C**********************************************************************
33318 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33321 C input/output channels
33323 COMMON /POINOU/ LI,LO
33324 C event debugging information
33326 PARAMETER (NMAXD=100)
33327 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33328 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33329 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33330 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33331 C model switches and parameters
33333 INTEGER ISWMDL,IPAMDL
33334 DOUBLE PRECISION PARMDL
33335 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33336 C global event kinematics and particle IDs
33337 INTEGER IFPAP,IFPAB
33338 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
33339 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
33340 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
33341 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
33342 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
33343 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
33344 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
33346 C standard particle data interface
33349 PARAMETER (NMXHEP=4000)
33351 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33352 DOUBLE PRECISION PHEP,VHEP
33353 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33354 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33356 C extension to standard particle data interface (PHOJET specific)
33357 INTEGER IMPART,IPHIST,ICOLOR
33358 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33360 C color string configurations including collapsed strings and hadrons
33362 PARAMETER (MSTR=500)
33363 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33364 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33365 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33366 & NNCH(MSTR),IBHAD(MSTR),ISTR
33368 C count number of errors to avoid disk overflow
33372 C conservation check suppressed
33373 IF((IPAMDL(15).EQ.0).OR.(IDEB(20).LE.-10)) RETURN
33375 IF(IPAMDL(13).GT.0) THEN
33377 C DPMJET call with x limitations
33379 ECM1 = SQRT(XPSUB*XTSUB)*ECM
33385 C first two entries are considered as scattering particles
33386 EE1 = PHEP(4,1) + PHEP(4,2)
33387 PX1 = PHEP(1,1) + PHEP(1,2)
33388 PY1 = PHEP(2,1) + PHEP(2,2)
33389 PZ1 = PHEP(3,1) + PHEP(3,2)
33395 IF(MODE.EQ.-1) GOTO 500
33402 C recognize only decayed particles as mothers
33403 IF(ISTHEP(I).EQ.2) THEN
33404 C search for other mother particles
33407 IF(IPAMDL(178).NE.0)
33408 & WRITE(LO,'(1X,2A,I4)') 'PHO_CHECK: ',
33409 & 'entry marked as decayed but no dauther given:',I
33414 C sum over mother particles
33415 ICH1 = IPHO_CHR3(K1,2)
33416 IBA1 = IPHO_BAR3(K1,2)
33423 IF((K1.GT.I).OR.(K2.LT.I)) THEN
33424 WRITE(LO,'(/,1X,2A,3I4)') 'PHO_CHECK: ',
33425 & 'inconsistent mother/daughter relation found',I,K1,K2
33426 CALL PHO_PREVNT(-1)
33429 IF(ABS(ISTHEP(II)).LE.2) THEN
33430 ICH1 = ICH1 + IPHO_CHR3(II,2)
33431 IBA1 = IBA1 + IPHO_BAR3(II,2)
33432 EE1 = EE1 + PHEP(4,II)
33433 PX1 = PX1 + PHEP(1,II)
33434 PY1 = PY1 + PHEP(2,II)
33435 PZ1 = PZ1 + PHEP(3,II)
33438 ELSE IF((K2.GT.0).AND.(K2.NE.K1)) THEN
33439 ICH1 = ICH1 + IPHO_CHR3(K2,2)
33440 IBA1 = IBA1 + IPHO_BAR3(K2,2)
33441 EE1 = EE1 + PHEP(4,K2)
33442 PX1 = PX1 + PHEP(1,K2)
33443 PY1 = PY1 + PHEP(2,K2)
33444 PZ1 = PZ1 + PHEP(3,K2)
33447 C sum over daughter particles
33454 DO 200 II=JDAHEP(1,I),JDAHEP(2,I)
33455 IF(ABS(ISTHEP(II)).LE.2) THEN
33456 ICH2 = ICH2 + IPHO_CHR3(II,2)
33457 IBA2 = IBA2 + IPHO_BAR3(II,2)
33458 EE2 = EE2 + PHEP(4,II)
33459 PX2 = PX2 + PHEP(1,II)
33460 PY2 = PY2 + PHEP(2,II)
33461 PZ2 = PZ2 + PHEP(3,II)
33465 C conservation check
33466 ESC = MAX(MAX(EE1,EE2)*DDREL,DDABS)
33467 IF(ABS(EE1-EE2).GT.ESC) THEN
33468 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E10.3)')
33469 & 'PHO_CHECK: energy conservation violated for',
33470 & 'entry,initial,final:',I,EE1,EE2
33473 ESC = MAX(MAX(ABS(PX1),ABS(PX2))*DDREL,DDABS)
33474 IF(ABS(PX1-PX2).GT.ESC) THEN
33475 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33476 & 'PHO_CHECK: x-momentum conservation violated for',
33477 & 'entry,initial,final:',I,PX1,PX2
33480 ESC = MAX(MAX(ABS(PY1),ABS(PY2))*DDREL,DDABS)
33481 IF(ABS(PY1-PY2).GT.ESC) THEN
33482 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33483 & 'PHO_CHECK: y-momentum conservation violated for',
33484 & 'entry,initial,final:',I,PY1,PY2
33487 ESC = MAX(MAX(ABS(PZ1),ABS(PZ2))*DDREL,DDABS)
33488 IF(ABS(PZ1-PZ2).GT.ESC) THEN
33489 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33490 & 'PHO_CHECK: z-momentum conservation violated for',
33491 & 'entry,initial,final:',I,PZ1,PZ2
33494 IF(ICH1.NE.ICH2) THEN
33495 WRITE(LO,'(1X,A,/,5X,A,I3,2X,2I5)')
33496 & 'PHO_CHECK: charge conservation violated for',
33497 & 'entry,initial,final:',I,ICH1,ICH2
33500 IF(IBA1.NE.IBA2) THEN
33501 WRITE(LO,'(1X,2A,/,5X,A,I3,2X,2I5)') 'PHO_CHECK: ',
33502 & 'baryon charge conservation violated for',
33503 & 'entry,initial,final:',I,IBA1,IBA2
33506 IF(IDEB(20).GE.35) THEN
33508 & '(/,1X,A,A,2(2X,I4,A,I4),2(/,5X,A,4E13.4),/5X,A,4I5)')
33509 & 'PHO_CHECK diagnostics:',
33510 & '(1.mother/l.mother,1.daughter/l.daughter):',
33511 & K1,'/',K2,JDAHEP(1,I),'/',JDAHEP(2,I),
33512 & 'mother momenta ',PX1,PY1,PZ1,EE1,
33513 & 'daughter momenta ',PX2,PY2,PZ2,EE2,
33514 & 'charge,baryon no ',ICH1,ICH2,IBA1,IBA2
33519 IF(I.LE.NHEP) GOTO 100
33525 C write complete event in case of deviations
33526 IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
33531 IF(ISWMDL(6).GE.0) CALL PYLIST(1)
33536 C stop after too many errors
33537 IF(IERR.GT.IPAMDL(179)) THEN
33538 WRITE(LO,'(////1X,2A,I6,////)') 'PHO_CHECK:ERROR:',
33539 & 'too many inconsistencies found, program terminated',IERR
33545 C overall check only (less time consuming)
33557 C recognize only existing particles as possible daughters
33558 IF(ABS(ISTHEP(K)).EQ.1) THEN
33559 ICH2 = ICH2 + IPHO_CHR3(K,2)
33560 IBA2 = IBA2 + IPHO_BAR3(K,2)
33561 EE2 = EE2 + PHEP(4,K)
33562 PX2 = PX2 + PHEP(1,K)
33563 PY2 = PY2 + PHEP(2,K)
33564 PZ2 = PZ2 + PHEP(3,K)
33568 C check energy-momentum conservation
33571 IF(IPAMDL(13).GT.0) THEN
33573 C DPMJET call with x limitations
33574 ECM2 = SQRT((EE2-PZ2)*(EE2+PZ2)-PX2**2-PY2**2)
33575 IF(ABS(ECM1-ECM2).GT.ESC) THEN
33576 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33577 & 'PHO_CHECK: c.m. energy conservation violated',
33578 & 'initial/final energy:',ECM1,ECM2
33585 IF(ABS(EE1-EE2).GT.ESC) THEN
33586 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33587 & 'PHO_CHECK: energy conservation violated',
33588 & 'initial/final energy:',EE1,EE2
33591 IF(ABS(PX1-PX2).GT.ESC) THEN
33592 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33593 & 'PHO_CHECK: x-momentum conservation violated',
33594 & 'initial/final x-momentum:',PX1,PX2
33597 IF(ABS(PY1-PY2).GT.ESC) THEN
33598 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33599 & 'PHO_CHECK: y-momentum conservation violated',
33600 & 'initial/final y-momentum:',PY1,PY2
33603 IF(ABS(PZ1-PZ2).GT.ESC) THEN
33604 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33605 & 'PHO_CHECK: z-momentum conservation violated',
33606 & 'initial/final z-momentum:',PZ1,PZ2
33610 C check of quantum number conservation
33612 ICH1 = IPHO_CHR3(1,2) + IPHO_CHR3(2,2)
33613 IBA1 = IPHO_BAR3(1,2) + IPHO_BAR3(2,2)
33615 IF(ICH1.NE.ICH2) THEN
33616 WRITE(LO,'(1X,A,/,5X,A,2I5)')
33617 & 'PHO_CHECK: charge conservation violated',
33618 & 'initial/final charge sum',ICH1,ICH2
33621 IF(IBA1.NE.IBA2) THEN
33622 WRITE(LO,'(1X,2A,/,5X,A,2I5)') 'PHO_CHECK: ',
33623 & 'baryonic charge conservation violated',
33624 & 'initial/final baryonic charge sum',IBA1,IBA2
33630 C perform detailed checks in case of deviations
33631 IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
33632 IF(IPAMDL(13).GT.0) THEN
33637 WRITE(LO,'(/1X,2A,2E12.4)') 'PHO_CHECK: ',
33638 & 'increasing precision of tests to',DDREL,DDABS
33645 *$ CREATE PHO_ABORT.FOR
33647 CDECK ID>, PHO_ABORT
33648 SUBROUTINE PHO_ABORT
33649 C**********************************************************************
33651 C top MC event generation due to fatal error,
33652 C print all information of event generation and history
33654 C**********************************************************************
33655 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33658 C input/output channels
33660 COMMON /POINOU/ LI,LO
33661 C event debugging information
33663 PARAMETER (NMAXD=100)
33664 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33665 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33666 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33667 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33668 C model switches and parameters
33670 INTEGER ISWMDL,IPAMDL
33671 DOUBLE PRECISION PARMDL
33672 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33674 C standard particle data interface
33677 PARAMETER (NMXHEP=4000)
33679 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33680 DOUBLE PRECISION PHEP,VHEP
33681 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33682 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33684 C extension to standard particle data interface (PHOJET specific)
33685 INTEGER IMPART,IPHIST,ICOLOR
33686 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33688 C color string configurations including collapsed strings and hadrons
33690 PARAMETER (MSTR=500)
33691 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33692 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33693 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33694 & NNCH(MSTR),IBHAD(MSTR),ISTR
33695 C light-cone x fractions and c.m. momenta of soft cut string ends
33697 PARAMETER ( MAXSOF = 50 )
33698 INTEGER IJSI2,IJSI1
33699 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
33700 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
33701 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
33702 & IJSI1(MAXSOF),IJSI2(MAXSOF)
33703 C hard scattering data
33705 PARAMETER ( MSCAHD = 50 )
33706 INTEGER LSCAHD,LSC1HD,LSIDX,
33707 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
33708 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
33709 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
33710 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
33711 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
33712 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
33713 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
33714 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
33715 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
33717 WRITE(LO,'(//,1X,A,/,1X,A)')
33718 & 'PHO_ABORT: program execution stopped',
33719 & '===================================='
33720 WRITE(LO,'(/,1X,A,/,1X,A)') 'listing of available data follows:'
33722 CALL PHO_SETMDL(0,0,-2)
33723 CALL PHO_PREVNT(-1)
33724 CALL PHO_ACTPDF(0,-2)
33725 C print selected parton flavours
33726 WRITE(LO,'(1X,A,I4)') 'selected soft flavours: ',KSOFT
33728 WRITE(LO,'(10X,2I5)') IJSI1(I),IJSI2(I)
33730 WRITE(LO,'(1X,A,I4)') 'selected hard flavours: ',KHARD
33733 WRITE(LO,'(10X,A,I5)') 'process:',NPROHD(I)
33734 WRITE(LO,'(10X,A,2I4,7X,A,2I4)') 'initial:',NINHD(I,1),
33735 & NINHD(I,2),'final:',NOUTHD(I,1),NOUTHD(I,2)
33737 C print selected parton momenta
33738 WRITE(LO,'(1X,A,I4)') 'selected soft momenta: ',KSOFT
33740 WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PSOFT1(II,I),II=1,4)
33741 WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PSOFT2(II,I),II=1,4)
33743 WRITE(LO,'(1X,A,I4)') 'selected hard momenta: ',KHARD
33747 WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PPH(I3+II,1),II=1,4)
33748 WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PPH(I3+II,2),II=1,4)
33754 C fragmentation process
33759 IF(ISWMDL(6).GE.0) CALL PYLIST(1)
33764 WRITE(LO,'(////5X,A,///5X,A,///)')
33765 & 'PHO_ABORT: execution terminated due to fatal error',
33766 &'*** Simulating division by zero to get traceback information ***'
33767 ISTR = 100/IPAMDL(100)
33771 *$ CREATE PHO_TRACE.FOR
33773 CDECK ID>, PHO_TRACE
33774 SUBROUTINE PHO_TRACE(ISTART,ISWI,LEVEL)
33775 C**********************************************************************
33777 C trace program subroutines according to level,
33778 C original output levels will be saved
33780 C input: ISTART first event to trace
33781 C ISWI number of events to trace
33782 C 0 loop call, use old values
33783 C -1 restore original output levels
33784 C 1 store level and wait for event
33785 C LEVEL desired output level
33786 C 0 standard output
33787 C 3 internal rejections
33788 C 5 cross sections, slopes etc.
33789 C 10 parameter of subroutines and
33791 C 20 huge amount of debug output
33792 C 30 maximal possible output
33794 C**********************************************************************
33795 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
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 DIMENSION IMEM(NMAXD)
33815 IF(KEVENT.LT.ION) THEN
33817 ELSE IF(KEVENT.EQ.ION) THEN
33818 WRITE(LO,'(///,1X,A,///)')
33819 & 'PHO_TRACE: trace mode switched on'
33822 IDEB(I) = MAX(ILEVEL,IMEM(I))
33824 ELSE IF(KEVENT.EQ.IOFF) THEN
33825 WRITE(LO,'(//,1X,A,///)')
33826 & 'PHO_TRACE: trace mode switched off'
33831 ELSE IF(ISW.EQ.-1) THEN
33841 C check coincidence
33850 *$ CREATE PHO_PRSTRG.FOR
33852 CDECK ID>, PHO_PRSTRG
33853 SUBROUTINE PHO_PRSTRG
33854 C**********************************************************************
33856 C print information of /POSTRG/
33858 C**********************************************************************
33859 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33862 C input/output channels
33864 COMMON /POINOU/ LI,LO
33865 C event debugging information
33867 PARAMETER (NMAXD=100)
33868 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33869 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33870 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33871 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33873 C standard particle data interface
33876 PARAMETER (NMXHEP=4000)
33878 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33879 DOUBLE PRECISION PHEP,VHEP
33880 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33881 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33883 C extension to standard particle data interface (PHOJET specific)
33884 INTEGER IMPART,IPHIST,ICOLOR
33885 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33887 C color string configurations including collapsed strings and hadrons
33889 PARAMETER (MSTR=500)
33890 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33891 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33892 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33893 & NNCH(MSTR),IBHAD(MSTR),ISTR
33895 WRITE(LO,'(/,1X,A,I5)')
33896 & 'PHO_PRSTRG: number of strings soft+hard:',ISTR
33897 WRITE(LO,'(/,1X,A/,1X,A)') 'COMMON /POSTRG/:',
33898 & ' NOBAM ID1 ID2 ID3 ID4 NPO1/2/3/4 MASS'
33900 & ' ======================================================='
33902 WRITE(LO,'(1X,9I5,1P,E11.3)')
33903 & NCODE(I),IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),NPOS(1,I),
33904 & NPOS(2,I),NPOS(3,I),NPOS(4,I),PHEP(5,NPOS(1,I))
33909 *$ CREATE PHO_PREVNT.FOR
33911 CDECK ID>, PHO_PREVNT
33912 SUBROUTINE PHO_PREVNT(NPART)
33913 C**********************************************************************
33915 C print all information of event generation and history
33917 C input: NPART -1 minimal output: process IDs
33918 C 0 additional output of /POEVT1/
33919 C 1 additional output of /POSTRG/
33920 C 2 additional output of /HEPEVT/
33923 C**********************************************************************
33924 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33927 C input/output channels
33929 COMMON /POINOU/ LI,LO
33930 C event debugging information
33932 PARAMETER (NMAXD=100)
33933 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33934 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33935 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33936 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33937 C model switches and parameters
33939 INTEGER ISWMDL,IPAMDL
33940 DOUBLE PRECISION PARMDL
33941 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33942 C global event kinematics and particle IDs
33943 INTEGER IFPAP,IFPAB
33944 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
33945 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
33946 C general process information
33947 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
33948 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
33950 C standard particle data interface
33953 PARAMETER (NMXHEP=4000)
33955 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33956 DOUBLE PRECISION PHEP,VHEP
33957 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33958 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33960 C extension to standard particle data interface (PHOJET specific)
33961 INTEGER IMPART,IPHIST,ICOLOR
33962 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33964 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
33965 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
33966 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
33967 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
33968 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
33970 CHARACTER*15 PHO_PNAME
33972 IF(NPART.GE.0) WRITE(LO,'(/)')
33973 WRITE(LO,'(1X,A,1PE10.3)')
33974 & 'PHO_PREVNT: c.m. energy',ECM
33975 CALL PHO_SETPAR(-2,IH,NPART,0.D0)
33976 WRITE(LO,'(6X,A,A,/1X,I10,10I6)')
33977 & 'EV-CALL,ISPOM,IHPOM,ISREG,IHDIR,KSTRG,',
33978 & 'KHTRG,KSLOO,KHLOO,KSDPO,KHDPO',
33979 & KEVENT,KSPOM,KHPOM,KSREG,KHDIR,KSTRG,KHTRG,KSLOO,KHLOO,KSDPO,
33981 WRITE(LO,'(6X,A,I4,4I3)')
33982 & 'PROCESS-ID,IDNODF,IDIFF1,IDIFF2,IDDPOM',IPROCE,IDNODF,IDIFR1,
33985 IF(IPAMDL(13).GT.0) THEN
33986 WRITE(LO,'(1X,A)') 'PHO_PREVNT: DPMJET special settings:'
33987 WRITE(LO,'(5X,A,1P,4E11.3)') 'ECMN,PCMN,SECM,SPCM',
33988 & ECMN,PCMN,SECM,SPCM
33989 WRITE(LO,'(5X,A,1P,2E11.3)') 'XPSUB,XTSUB',XPSUB,XTSUB
33992 IF(NPART.LT.0) RETURN
33994 IF(NPART.GE.1) CALL PHO_PRSTRG
33996 WRITE(LO,'(/1X,A)') 'COMMON /POEVT1/:'
34001 WRITE(LO,'(/1X,A,A,/,1X,A,A)')
34002 & ' NO IST NAME MO-1 MO-2 DA-1 DA-2 CHA BAR',
34003 & ' IH1 IH2 CO1 CO2',
34004 & '========================================================',
34005 & '===================='
34007 CH = DBLE(IPHO_CHR3(IH,2)/3.D0)
34008 BA = DBLE(IPHO_BAR3(IH,2)/3.D0)
34009 WRITE(LO,'(1X,2I5,1X,A15,4I5,2F5.1,2I5,2I5)')
34010 & IH,ISTHEP(IH),PHO_PNAME(IH,2),
34011 & JMOHEP(1,IH),JMOHEP(2,IH),JDAHEP(1,IH),JDAHEP(2,IH),
34012 & CH,BA,IPHIST(1,IH),IPHIST(2,IH),
34013 & ICOLOR(1,IH),ICOLOR(2,IH)
34014 IF(ABS(ISTHEP(IH)).EQ.1) THEN
34015 ICHAS = ICHAS + IPHO_CHR3(IH,2)
34016 IBARFS = IBARFS + IPHO_BAR3(IH,2)
34018 IF(ABS(ISTHEP(IH)).EQ.1) THEN
34019 IF(IPHO_CHR3(IH,2).NE.0) IMULC = IMULC+1
34023 WRITE(LO,'(1X,2(3X,A,I3),2X,2(5X,A,I5))') 'sum charge:',ICHAS/3,
34024 & 'baryon:',IBARFS/3,'chr.mult:',IMULC,'tot.mult:',IMUL
34032 IF( (ABS(PHEP(3,IN)).LT.99999.D0)
34033 & .AND.(PHEP(4,IN).LT.99999.D0)) THEN
34034 WRITE(LO,8) IN,ISTHEP(IN),PHO_PNAME(IN,2),
34035 & (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
34037 WRITE(LO,11) IN,ISTHEP(IN),PHO_PNAME(IN,2),
34038 & (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
34040 IF(ABS(ISTHEP(IN)).EQ.1) THEN
34041 PXS = PXS + PHEP(1,IN)
34042 PYS = PYS + PHEP(2,IN)
34043 PZS = PZS + PHEP(3,IN)
34044 P0S = P0S + PHEP(4,IN)
34047 AMFS = P0S**2-PXS**2-PYS**2-PZS**2
34048 AMFS = SIGN(SQRT(ABS(AMFS)),AMFS)
34049 IF(P0S.LT.99999.D0) THEN
34050 WRITE(LO,10) ' sum: ',PXS,PYS,PZS,P0S,AMFS
34052 WRITE(LO,12) ' sum: ',PXS,PYS,PZS,P0S,AMFS
34056 5 FORMAT(2X,8H NUMBER ,8H STATUS ,8H IDENT. ,
34057 & 8H 1.MOTH.,8H 2.MOTH.,8H 1.DAUG.,8H L.DAUG.,
34058 & 8H CHARGE ,8H BARYON ,/)
34059 6 FORMAT(7I8,2F8.3)
34060 7 FORMAT(/,2X,' NR STAT NAME X-MOMENTA',
34061 & ' Y-MOMENTA Z-MOMENTA ENERGY MASS PT',/,
34062 & 2X,'-------------------------------',
34063 & '--------------------------------------------')
34064 8 FORMAT(I5,I4,1X,A15,2F8.3,3F10.3,F8.3)
34065 9 FORMAT(I10,14X,5F10.3)
34066 10 FORMAT(10X,A14,1X,2F8.3,3F10.3)
34067 11 FORMAT(I5,I4,1X,A15,2F8.2,2F10.1,F10.3,F8.3)
34068 12 FORMAT(10X,A14,1X,2F8.2,2F10.1,F10.3)
34070 IF(NPART.GE.2) CALL PYLIST(1)
34074 *$ CREATE PHO_LTRHEP.FOR
34076 CDECK ID>, PHO_LTRHEP
34077 SUBROUTINE PHO_LTRHEP(I1,I2,COD,SID,COF,SIF,GAM,BGX,BGY,BGZ)
34078 C*******************************************************************
34080 C Lorentz transformation of entries I1 to I2 in /POEVT1/
34082 C********************************************************************
34083 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34086 PARAMETER ( DIFF = 0.001D0,
34089 C input/output channels
34091 COMMON /POINOU/ LI,LO
34092 C event debugging information
34094 PARAMETER (NMAXD=100)
34095 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
34096 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34097 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
34098 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34100 C standard particle data interface
34103 PARAMETER (NMXHEP=4000)
34105 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
34106 DOUBLE PRECISION PHEP,VHEP
34107 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
34108 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
34110 C extension to standard particle data interface (PHOJET specific)
34111 INTEGER IMPART,IPHIST,ICOLOR
34112 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
34114 DO 100 I=I1,MIN(I2,NHEP)
34115 IF((ABS(ISTHEP(I)).LE.10).OR.(ISTHEP(I).EQ.21)) THEN
34116 CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
34119 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
34120 & PHEP(1,I),PHEP(2,I),PHEP(3,I),PHEP(4,I))
34121 ELSE IF(ISTHEP(I).EQ.20) THEN
34122 EE=SQRT(PHEP(1,I)**2+PHEP(2,I)**2+PHEP(3,I)**2)
34123 CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
34125 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
34126 & PHEP(1,I),PHEP(2,I),PHEP(3,I),PMASS)
34131 IF(IDEB(70).LT.1) RETURN
34132 DO 200 I=I1,MIN(NHEP,I2)
34133 IF(ABS(ISTHEP(I)).GT.10) GOTO 190
34134 PMASS = PHEP(4,I)**2-PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
34135 PMASS = SIGN(SQRT(ABS(PMASS)),PMASS)
34136 IF((ABS(PMASS-PHEP(5,I))/MAX(PHEP(5,I),1.D0)).GT.DIFF) THEN
34137 WRITE(LO,'(1X,A,I5,2E13.4)')
34138 & 'PHO_LTRHEP: inconsistent masses:',I,PMASS,PHEP(5,I)
34145 *$ CREATE PHO_PECMS.FOR
34147 CDECK ID>, PHO_PECMS
34148 SUBROUTINE PHO_PECMS(ID,PMASS1,PMASS2,ECM,PP,EE)
34149 C*******************************************************************
34151 C calculation of cms momentum and energy of massive particle
34152 C (ID= 1 using PMASS1, 2 using PMASS2)
34154 C output: PP cms momentum
34155 C EE energy in CMS of particle ID
34157 C********************************************************************
34158 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34161 C input/output channels
34163 COMMON /POINOU/ LI,LO
34164 C event debugging information
34166 PARAMETER (NMAXD=100)
34167 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
34168 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34169 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
34170 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34172 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
34173 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
34174 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
34177 PM1 = SIGN(PMASS1**2,PMASS1)
34178 PM2 = SIGN(PMASS2**2,PMASS2)
34179 PP = SQRT(S**2 - 2.D0*PM1*S - 2.D0*PM2*S - 2.D0*PM1*PM2
34180 & + PM1**2 + PM2**2)/(2.D0*ECM)
34183 EE = SQRT( PM1 + PP**2 )
34184 ELSE IF(ID.EQ.2) THEN
34185 EE = SQRT( PM2 + PP**2 )
34187 WRITE(LO,'(/1X,A,I3,/)')
34188 & 'PHO_PECMS:ERROR: invalid ID number:',ID
34194 *$ CREATE PHO_FRAINI.FOR
34196 CDECK ID>, PHO_FRAINI
34197 SUBROUTINE PHO_FRAINI(IDEFAU)
34198 C***********************************************************************
34200 C initialization of fragmentation packages
34201 C (currently LUND JETSET)
34203 C initialization for JETSET call in DTUNUC 1.04 (J.R. 6/93)
34204 C changed to work in PHOJET (R.E. 1/94)
34206 C input: IDEFAU 0 no hadronization at all
34207 C 1 do not touch any parameter of JETSET
34208 C 2 default parameters kept, decay length 10mm to
34209 C define stable particles
34210 C 3 load tuned parameters for JETSET 7.3
34211 C neg. value: prevent strange/charm hadrons from decaying
34213 C***********************************************************************
34214 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34217 PARAMETER (EPS=1.D-10)
34219 C input/output channels
34221 COMMON /POINOU/ LI,LO
34224 DOUBLE PRECISION P,V
34225 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
34228 DOUBLE PRECISION PARU,PARJ
34229 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34232 DOUBLE PRECISION PMAS,PARF,VCKM
34233 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34235 INTEGER MDCY,MDME,KFDP
34236 DOUBLE PRECISION BRAT
34237 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
34241 IDEFAB = ABS(IDEFAU)
34243 IF(IDEFAB.EQ.0) THEN
34244 WRITE(LO,'(/1X,A)') 'PHO_FRAINI: hadronization switched off'
34255 C declare stable particles
34256 IF(IDEFAB.GE.2) MSTJ(22) = 2
34258 C load optimized parameters
34259 IF(IDEFAB.GE.3) THEN
34268 C Lund sigma parameter in pt distribution
34273 C prevent particles decaying
34274 IF(IDEFAU.LT.0) THEN
34452 WRITE(LO,2355) IDEFAU,DEF2,PARJ(2),IDEF12,MSTJ(12),
34453 & DEF19,PARJ(19),DEF41,PARJ(41),DEF42,PARJ(42),DEF21,PARJ(21)
34454 2355 FORMAT(/' PHO_FRAINI: fragmentation initialization ISWMDL(6)',I3/,
34455 & ' --------------------------------------------------',/,
34456 & 5X,'parameter description default / current',/,
34457 & 5X,'PARJ( 2) strangeness suppression : ',2F7.3,/,
34458 & 5X,'MSTJ(12) popcorn : ',2I7,/,
34459 & 5X,'PARJ(19) popcorn : ',2F7.3,/,
34460 & 5X,'PARJ(41) Lund a : ',2F7.3,/,
34461 & 5X,'PARJ(42) Lund b : ',2F7.3,/,
34462 & 5X,'PARJ(21) sigma in pt distribution: ',2F7.3,/)
34466 *$ CREATE PHO_SETPAR.FOR
34468 CDECK ID>, PHO_SETPAR
34469 SUBROUTINE pho_setpar(Iside,IDpdg,IDcpc,Pvir)
34470 C**********************************************************************
34472 C assign a particle to either side 1 or 2
34473 C (including special treatment for remnants)
34475 C input: Iside 1,2 side selected for the particle
34476 C -2 output of current settings
34479 C 0 CPC determination in subroutine
34480 C -1 special particle remnant, IDPDG
34481 C is the particle number the remnant
34482 C corresponds to (see /POHDFL/)
34484 C**********************************************************************
34490 integer Iside,IDpdg,IDcpc
34491 double precision Pvir
34493 C input/output channels
34495 COMMON /POINOU/ LI,LO
34496 C event debugging information
34498 PARAMETER (NMAXD=100)
34499 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
34500 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34501 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
34502 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34503 C global event kinematics and particle IDs
34504 INTEGER IFPAP,IFPAB
34505 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
34506 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
34507 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
34508 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
34509 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
34510 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
34511 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
34512 C particle ID translation table
34513 integer ID_pdg_list,ID_list,ID_pdg_max
34514 character*12 name_list
34515 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
34517 C general particle data
34518 double precision xm_list,tau_list,gam_list,
34519 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
34520 & xm_bb82_list,xm_bb102_list
34521 integer ich3_list,iba3_list,iq_list,
34522 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
34523 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
34524 & xm_psm2_list(6,6),xm_vem2_list(6,6),
34525 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
34526 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
34527 & ich3_list(300),iba3_list(300),iq_list(3,300),
34528 & id_psm_list(6,6),id_vem_list(6,6),
34529 & id_b8_list(6,6,6),id_b10_list(6,6,6)
34530 C particle decay data
34531 double precision wg_sec_list
34532 integer idec_list,isec_list
34533 COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
34536 C external functions
34537 integer ipho_pdg2id,ipho_chr3,ipho_bar3
34538 double precision pho_pmass
34541 integer i,IDcpcN,IDcpcR,IDpdgN,IDpdgR,IDB,IFL1,IFL2,IFL3
34543 IF((Iside.EQ.1).OR.(Iside.EQ.2)) THEN
34546 IF(IDcpc.EQ.-1) THEN
34547 IF(Iside.EQ.1) THEN
34552 IDcpcR = ipho_pdg2id(IDpdgR)
34553 IDEQB(Iside) = ipho_pdg2id(IDpdg)
34554 IDEQP(Iside) = IDpdg
34555 C copy particle properties
34556 IDB = abs(IDEQB(Iside))
34557 xm_list(IDcpcR) = xm_list(IDB)
34558 tau_list(IDcpcR) = tau_list(IDB)
34559 gam_list(IDcpcR) = gam_list(IDB)
34560 IF(IHFLS(Iside).EQ.1) THEN
34561 ich3_list(IDcpcR) = ipho_chr3(IDEQB(Iside),0)
34562 iba3_list(IDcpcR) = ipho_bar3(IDEQB(Iside),0)
34564 ich3_list(IDcpcR) = 0
34565 iba3_list(IDcpcR) = 0
34568 IFL1 = IHFLD(Iside,1)
34569 IFL2 = IHFLD(Iside,2)
34571 IF(IHFLS(Iside).EQ.1) THEN
34572 IF(ABS(IHFLD(Iside,1)).GT.1000) THEN
34573 IFL1 = IHFLD(Iside,1)/1000
34574 IFL2 = MOD(IHFLD(Iside,1)/100,10)
34575 IFL3 = IHFLD(Iside,2)
34576 ELSE IF(ABS(IHFLD(Iside,2)).GT.1000) THEN
34577 IFL1 = IHFLD(Iside,1)
34578 IFL2 = IHFLD(Iside,2)/1000
34579 IFL3 = MOD(IHFLD(Iside,2)/100,10)
34582 iq_list(1,IDcpcR) = IFL1
34583 iq_list(2,IDcpcR) = IFL2
34584 iq_list(3,IDcpcR) = IFL3
34589 IF(IDEB(87).GE.5) THEN
34590 WRITE(LO,'(1X,A,I2,/5X,A,I7,4I6)')
34591 & 'pho_setpar: remnant assignment side',Iside,
34592 & 'IDPDG,IFL1,2,3,IVAL',IDPDGN,IFL1,IFL2,IFL3,IHFLS(Iside)
34594 ELSE IF(IDcpc.EQ.0) THEN
34599 IDcpcN = ipho_pdg2id(IDpdg)
34603 C initialize /POGCMS/
34604 IFPAP(Iside) = IDpdgN
34605 IFPAB(Iside) = IDcpcN
34606 PMASS(Iside) = pho_pmass(IDcpcN,0)
34607 IF(IFPAP(Iside).EQ.22) THEN
34608 PVIRT(Iside) = ABS(PVIR)
34610 PVIRT(Iside) = 0.D0
34613 ELSE IF(Iside.EQ.-2) THEN
34614 C output of current settings
34616 WRITE(LO,'(1X,A,I2,1X,A,I7,I4,1X,1P2E10.3)')
34617 & 'PHO_SETPAR: side',
34618 & I,'IDPDG,IDcpc,PMASS,PVIRT',IFPAP(I),IFPAB(I),PMASS(I),
34620 IF((IFPAP(I).EQ.81).OR.(IFPAP(I).EQ.82)) THEN
34621 WRITE(LO,'(5X,A,I7,I4,I2,3I5)')
34622 & 'remnant:IDPDG,IDcpc,IVAL,IFLA1,2',IDEQP(I),IDEQB(I),
34623 & IHFLS(I),IHFLD(I,1),IHFLD(I,2)
34627 WRITE(LO,'(/1X,A,I8)')
34628 & 'pho_setpar: invalid argument (Iside)',Iside
34633 *$ CREATE PHO_XLAM.FOR
34635 CDECK ID>, PHO_XLAM
34636 DOUBLE PRECISION FUNCTION PHO_XLAM(X,Y,Z)
34637 C**********************************************************************
34639 C auxiliary function for two/three particle decay mode
34640 C (standard LAMBDA**(1/2) function)
34642 C**********************************************************************
34643 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34647 XLAM=X*X-2.D0*X*(Y+Z)+YZ*YZ
34648 IF(XLAM.LT.0.D0) XLAM=-XLAM
34649 PHO_XLAM=SQRT(XLAM)
34652 *$ CREATE PHO_BESSJ0.FOR
34654 CDECK ID>, PHO_BESSJ0
34655 DOUBLE PRECISION FUNCTION PHO_BESSJ0(DX)
34656 C**********************************************************************
34658 C CERN (KERN) LIB function C312
34660 C modified by R. Engel (03/02/93)
34662 C**********************************************************************
34663 DOUBLE PRECISION DX
34664 DOUBLE PRECISION X,Y,V,H,ALFA,EIGHT
34665 DOUBLE PRECISION PI1,PI2,C1(0:14),C2(0:9),C3(0:10),B0,B1,B2,P,Q,R
34669 DATA PI1 /0.79788 45608 0287D0/, PI2 /0.78539 81633 9745D0/
34671 DATA C1( 0) /+0.15772 79714 7489D0/
34672 DATA C1( 1) /-0.00872 34423 5285D0/
34673 DATA C1( 2) /+0.26517 86132 0334D0/
34674 DATA C1( 3) /-0.37009 49938 7265D0/
34675 DATA C1( 4) /+0.15806 71023 3210D0/
34676 DATA C1( 5) /-0.03489 37694 1141D0/
34677 DATA C1( 6) /+0.00481 91800 6947D0/
34678 DATA C1( 7) /-0.00046 06261 6621D0/
34679 DATA C1( 8) /+0.00003 24603 2882D0/
34680 DATA C1( 9) /-0.00000 17619 4691D0/
34681 DATA C1(10) /+0.00000 00760 8164D0/
34682 DATA C1(11) /-0.00000 00026 7925D0/
34683 DATA C1(12) /+0.00000 00000 7849D0/
34684 DATA C1(13) /-0.00000 00000 0194D0/
34685 DATA C1(14) /+0.00000 00000 0004D0/
34687 DATA C2( 0) /+0.99946 03493 4752D0/
34688 DATA C2( 1) /-0.00053 65220 4681D0/
34689 DATA C2( 2) /+0.00000 30751 8479D0/
34690 DATA C2( 3) /-0.00000 00517 0595D0/
34691 DATA C2( 4) /+0.00000 00016 3065D0/
34692 DATA C2( 5) /-0.00000 00000 7864D0/
34693 DATA C2( 6) /+0.00000 00000 0517D0/
34694 DATA C2( 7) /-0.00000 00000 0043D0/
34695 DATA C2( 8) /+0.00000 00000 0004D0/
34696 DATA C2( 9) /-0.00000 00000 0001D0/
34698 DATA C3( 0) /-0.01555 58546 05337D0/
34699 DATA C3( 1) /+0.00006 83851 99426D0/
34700 DATA C3( 2) /-0.00000 07414 49841D0/
34701 DATA C3( 3) /+0.00000 00179 72457D0/
34702 DATA C3( 4) /-0.00000 00007 27192D0/
34703 DATA C3( 5) /+0.00000 00000 42201D0/
34704 DATA C3( 6) /-0.00000 00000 03207D0/
34705 DATA C3( 7) /+0.00000 00000 00301D0/
34706 DATA C3( 8) /-0.00000 00000 00033D0/
34707 DATA C3( 9) /+0.00000 00000 00004D0/
34708 DATA C3(10) /-0.00000 00000 00001D0/
34712 IF(V .LT. EIGHT) THEN
34719 B0=C1(I)-ALFA*B1-B2
34731 B0=C2(I)-ALFA*B1-B2
34738 B0=C3(I)-ALFA*B1-B2
34743 B1=PI1*SQRT(R)*(P*COS(B0)-Q*SIN(B0))
34749 *$ CREATE PHO_BESSI0.FOR
34751 CDECK ID>, PHO_BESSI0
34752 DOUBLE PRECISION FUNCTION PHO_BESSI0(X)
34753 C**********************************************************************
34755 C Bessel Function I0
34757 C**********************************************************************
34758 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34762 IF (AX .LT. 3.75D0) THEN
34765 & 1.0D0+Y*(3.5156229D0+Y*(3.0899424D0+Y*(1.2067492D0
34766 & +Y*(0.2659732D0+Y*(0.360768D-1+Y*0.45813D-2)))))
34770 & (EXP(AX)/SQRT(AX))*(0.39894228D0+Y*(0.1328592D-1
34771 & +Y*(0.225319D-2+Y*(-0.157565D-2+Y*(0.916281D-2
34772 & +Y*(-0.2057706D-1+Y*(0.2635537D-1+Y*(-0.1647633D-1
34773 & +Y*0.392377D-2))))))))
34778 *$ CREATE PHO_BESSI1.FOR
34780 CDECK ID>, PHO_BESSI1
34781 DOUBLE PRECISION FUNCTION PHO_BESSI1(X)
34782 C**********************************************************************
34784 C Bessel Function I1
34786 C**********************************************************************
34787 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34792 IF (AX .LT. 3.75D0) THEN
34795 & AX*(0.5D0+Y*(0.87890594D0+Y*(0.51498869D0+Y*(0.15084934D0
34796 & +Y*(0.2658733D-1+Y*(0.301532D-2+Y*0.32411D-3))))))
34800 & 0.2282967D-1+Y*(-0.2895312D-1+Y*(0.1787654D-1
34803 & 0.39894228D0+Y*(-0.3988024D-1+Y*(-0.362018D-2
34804 & +Y*(0.163801D-2+Y*(-0.1031555D-1+Y*BESLI1))))
34805 BESLI1 = BESLI1 * EXP(AX)/SQRT(AX)
34807 IF (X .LT. 0.D0) BESLI1 = -BESLI1
34809 PHO_BESSI1 = BESLI1
34813 *$ CREATE PHO_BESSK0.FOR
34815 CDECK ID>, PHO_BESSK0
34816 DOUBLE PRECISION FUNCTION PHO_BESSK0(X)
34817 C**********************************************************************
34819 C Modified Bessel Function K0
34821 C**********************************************************************
34822 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34825 IF (X .LT. 2.D0) THEN
34828 & (-LOG(X/2.D0)*PHO_BESSI0(X))+(-.57721566D0+Y*(0.42278420D0
34829 & +Y*(0.23069756D0+Y*(0.3488590D-1+Y*(0.262698D-2
34830 & +Y*(0.10750D-3+Y*0.740D-5))))))
34834 & (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(-0.7832358D-1
34835 & +Y*(0.2189568D-1+Y*(-0.1062446D-1+Y*(0.587872D-2
34836 & +Y*(-0.251540D-2+Y*0.53208D-3))))))
34841 *$ CREATE PHO_BESSK1.FOR
34843 CDECK ID>, PHO_BESSK1
34844 DOUBLE PRECISION FUNCTION PHO_BESSK1(X)
34845 C**********************************************************************
34847 C Modified Bessel Function K1
34849 C**********************************************************************
34850 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34853 IF (X .LT. 2.D0) THEN
34856 & (LOG(X/2.D0)*PHO_BESSI1(X))+(1.D0/X)*(1.D0+Y*(0.15443144D0
34857 & +Y*(-0.67278579D0+Y*(-0.18156897D0+Y*(-0.1919402D-1
34858 & +Y*(-0.110404D-2+Y*(-0.4686D-4)))))))
34862 & (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(0.23498619D0
34863 & +Y*(-0.3655620D-1+Y*(0.1504268D-1+Y*(-0.780353D-2
34864 & +Y*(0.325614D-2+Y*(-0.68245D-3)))))))
34869 *$ CREATE PHO_GAUSET.FOR
34871 CDECK ID>, PHO_GAUSET
34872 SUBROUTINE PHO_GAUSET(AX,BX,NX,Z,W)
34873 C********************************************************************
34875 C N-point gauss zeros and weights for the interval (AX,BX) are
34876 C stored in arrays Z and W respectively.
34878 C*********************************************************************
34879 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34882 COMMON /POGDAT/A(273),X(273),KTAB(96)
34883 DIMENSION Z(NX),W(NX)
34896 1 IF((N.LE.16).AND.(N.GT.1)) GO TO 2
34897 IF(N.EQ.20) GO TO 2
34898 IF(N.EQ.24) GO TO 2
34899 IF(N.EQ.32) GO TO 2
34900 IF(N.EQ.40) GO TO 2
34901 IF(N.EQ.48) GO TO 2
34902 IF(N.EQ.64) GO TO 2
34903 IF(N.EQ.80) GO TO 2
34904 IF(N.EQ.96) GO TO 2
34906 C the extended Gauss cases:
34907 IF((N/96)*96.EQ.N) GO TO 3
34909 C jump to center of intervall intrgration:
34912 C get Gauss point array
34915 C extract real points
34919 C extract values from big array
34923 C store them backward
34926 C store them forward
34931 C store central point (odd N)
34932 IF((N-M-M).EQ.0) RETURN
34935 W(M+1)=BETA*A(JMID)
34938 C get ND96 times chained 96 Gauss point array
34941 C print out message
34942 C -extract real points
34946 C extract values from big array
34952 DO 32 JD96=0,ND96-1
34953 ZCNTR= (ALPHA-BETA)+ BETA*FLOAT(2*JD96+1)/FLOAT(ND96)
34954 C store them backward
34955 Z(J+JD96*96)=ZCNTR-DELTA
34957 C store them forward
34959 Z(JP+JD96*96)=ZCNTR+DELTA
34960 W(JP+JD96*96)=WTEMP
34965 C the center of intervall cases:
34967 C put in constant weight and equally spaced central points
34970 WIN=(BX-AX)/FLOAT(N)
34971 Z(IN)=AX + (FLOAT(IN)-.5)*WIN
34976 *$ CREATE PHO_GAUDAT.FOR
34978 CDECK ID>, PHO_GAUDAT
34979 SUBROUTINE PHO_GAUDAT
34980 C*********************************************************************
34982 C store big arrays needed for Gauss integral, CERNLIB D106BD
34983 C (arrays A,X,ITAB copied on B,Y,LTAB)
34985 C*********************************************************************
34986 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34989 COMMON /POGDAT/ B(273),Y(273),LTAB(96)
34990 DIMENSION A(273),X(273),KTAB(96)
34992 C-----TABLE OF INITIAL SUBSCRIPTS FOR N=2(1)16(4)96
35029 C-----TABLE OF ABSCISSAE (X) AND WEIGHTS (A) FOR INTERVAL (-1,+1).
35032 DATA X(1)/0.577350269189626D0 /, A(1)/1.000000000000000D0 /
35034 DATA X(2)/0.774596669241483D0 /, A(2)/0.555555555555556D0 /
35035 DATA X(3)/0.000000000000000D0 /, A(3)/0.888888888888889D0 /
35037 DATA X(4)/0.861136311594053D0 /, A(4)/0.347854845137454D0 /
35038 DATA X(5)/0.339981043584856D0 /, A(5)/0.652145154862546D0 /
35040 DATA X(6)/0.906179845938664D0 /, A(6)/0.236926885056189D0 /
35041 DATA X(7)/0.538469310105683D0 /, A(7)/0.478628670499366D0 /
35042 DATA X(8)/0.000000000000000D0 /, A(8)/0.568888888888889D0 /
35044 DATA X(9)/0.932469514203152D0 /, A(9)/0.171324492379170D0 /
35045 DATA X(10)/0.661209386466265D0 /, A(10)/0.360761573048139D0 /
35046 DATA X(11)/0.238619186083197D0 /, A(11)/0.467913934572691D0 /
35048 DATA X(12)/0.949107912342759D0 /, A(12)/0.129484966168870D0 /
35049 DATA X(13)/0.741531185599394D0 /, A(13)/0.279705391489277D0 /
35050 DATA X(14)/0.405845151377397D0 /, A(14)/0.381830050505119D0 /
35051 DATA X(15)/0.000000000000000D0 /, A(15)/0.417959183673469D0 /
35053 DATA X(16)/0.960289856497536D0 /, A(16)/0.101228536290376D0 /
35054 DATA X(17)/0.796666477413627D0 /, A(17)/0.222381034453374D0 /
35055 DATA X(18)/0.525532409916329D0 /, A(18)/0.313706645877887D0 /
35056 DATA X(19)/0.183434642495650D0 /, A(19)/0.362683783378362D0 /
35058 DATA X(20)/0.968160239507626D0 /, A(20)/0.081274388361574D0 /
35059 DATA X(21)/0.836031107326636D0 /, A(21)/0.180648160694857D0 /
35060 DATA X(22)/0.613371432700590D0 /, A(22)/0.260610696402935D0 /
35061 DATA X(23)/0.324253423403809D0 /, A(23)/0.312347077040003D0 /
35062 DATA X(24)/0.000000000000000D0 /, A(24)/0.330239355001260D0 /
35064 DATA X(25)/0.973906528517172D0 /, A(25)/0.066671344308688D0 /
35065 DATA X(26)/0.865063366688985D0 /, A(26)/0.149451349150581D0 /
35066 DATA X(27)/0.679409568299024D0 /, A(27)/0.219086362515982D0 /
35067 DATA X(28)/0.433395394129247D0 /, A(28)/0.269266719309996D0 /
35068 DATA X(29)/0.148874338981631D0 /, A(29)/0.295524224714753D0 /
35070 DATA X(30)/0.978228658146057D0 /, A(30)/0.055668567116174D0 /
35071 DATA X(31)/0.887062599768095D0 /, A(31)/0.125580369464905D0 /
35072 DATA X(32)/0.730152005574049D0 /, A(32)/0.186290210927734D0 /
35073 DATA X(33)/0.519096129206812D0 /, A(33)/0.233193764591990D0 /
35074 DATA X(34)/0.269543155952345D0 /, A(34)/0.262804544510247D0 /
35075 DATA X(35)/0.000000000000000D0 /, A(35)/0.272925086777901D0 /
35077 DATA X(36)/0.981560634246719D0 /, A(36)/0.047175336386512D0 /
35078 DATA X(37)/0.904117256370475D0 /, A(37)/0.106939325995318D0 /
35079 DATA X(38)/0.769902674194305D0 /, A(38)/0.160078328543346D0 /
35080 DATA X(39)/0.587317954286617D0 /, A(39)/0.203167426723066D0 /
35081 DATA X(40)/0.367831498998180D0 /, A(40)/0.233492536538355D0 /
35082 DATA X(41)/0.125233408511469D0 /, A(41)/0.249147045813403D0 /
35084 DATA X(42)/0.984183054718588D0 /, A(42)/0.040484004765316D0 /
35085 DATA X(43)/0.917598399222978D0 /, A(43)/0.092121499837728D0 /
35086 DATA X(44)/0.801578090733310D0 /, A(44)/0.138873510219787D0 /
35087 DATA X(45)/0.642349339440340D0 /, A(45)/0.178145980761946D0 /
35088 DATA X(46)/0.448492751036447D0 /, A(46)/0.207816047536889D0 /
35089 DATA X(47)/0.230458315955135D0 /, A(47)/0.226283180262897D0 /
35090 DATA X(48)/0.000000000000000D0 /, A(48)/0.232551553230874D0 /
35092 DATA X(49)/0.986283808696812D0 /, A(49)/0.035119460331752D0 /
35093 DATA X(50)/0.928434883663574D0 /, A(50)/0.080158087159760D0 /
35094 DATA X(51)/0.827201315069765D0 /, A(51)/0.121518570687903D0 /
35095 DATA X(52)/0.687292904811685D0 /, A(52)/0.157203167158194D0 /
35096 DATA X(53)/0.515248636358154D0 /, A(53)/0.185538397477938D0 /
35097 DATA X(54)/0.319112368927890D0 /, A(54)/0.205198463721296D0 /
35098 DATA X(55)/0.108054948707344D0 /, A(55)/0.215263853463158D0 /
35100 DATA X(56)/0.987992518020485D0 /, A(56)/0.030753241996117D0 /
35101 DATA X(57)/0.937273392400706D0 /, A(57)/0.070366047488108D0 /
35102 DATA X(58)/0.848206583410427D0 /, A(58)/0.107159220467172D0 /
35103 DATA X(59)/0.724417731360170D0 /, A(59)/0.139570677926154D0 /
35104 DATA X(60)/0.570972172608539D0 /, A(60)/0.166269205816994D0 /
35105 DATA X(61)/0.394151347077563D0 /, A(61)/0.186161000015562D0 /
35106 DATA X(62)/0.201194093997435D0 /, A(62)/0.198431485327111D0 /
35107 DATA X(63)/0.000000000000000D0 /, A(63)/0.202578241925561D0 /
35109 DATA X(64)/0.989400934991650D0 /, A(64)/0.027152459411754D0 /
35110 DATA X(65)/0.944575023073233D0 /, A(65)/0.062253523938648D0 /
35111 DATA X(66)/0.865631202387832D0 /, A(66)/0.095158511682493D0 /
35112 DATA X(67)/0.755404408355003D0 /, A(67)/0.124628971255534D0 /
35113 DATA X(68)/0.617876244402644D0 /, A(68)/0.149595988816577D0 /
35114 DATA X(69)/0.458016777657227D0 /, A(69)/0.169156519395003D0 /
35115 DATA X(70)/0.281603550779259D0 /, A(70)/0.182603415044924D0 /
35116 DATA X(71)/0.095012509837637D0 /, A(71)/0.189450610455069D0 /
35118 DATA X(72)/0.993128599185094D0 /, A(72)/0.017614007139152D0 /
35119 DATA X(73)/0.963971927277913D0 /, A(73)/0.040601429800386D0 /
35120 DATA X(74)/0.912234428251325D0 /, A(74)/0.062672048334109D0 /
35121 DATA X(75)/0.839116971822218D0 /, A(75)/0.083276741576704D0 /
35122 DATA X(76)/0.746331906460150D0 /, A(76)/0.101930119817240D0 /
35123 DATA X(77)/0.636053680726515D0 /, A(77)/0.118194531961518D0 /
35124 DATA X(78)/0.510867001950827D0 /, A(78)/0.131688638449176D0 /
35125 DATA X(79)/0.373706088715419D0 /, A(79)/0.142096109318382D0 /
35126 DATA X(80)/0.227785851141645D0 /, A(80)/0.149172986472603D0 /
35127 DATA X(81)/0.076526521133497D0 /, A(81)/0.152753387130725D0 /
35129 DATA X(82)/0.995187219997021D0 /, A(82)/0.012341229799987D0 /
35130 DATA X(83)/0.974728555971309D0 /, A(83)/0.028531388628933D0 /
35131 DATA X(84)/0.938274552002732D0 /, A(84)/0.044277438817419D0 /
35132 DATA X(85)/0.886415527004401D0 /, A(85)/0.059298584915436D0 /
35133 DATA X(86)/0.820001985973902D0 /, A(86)/0.073346481411080D0 /
35134 DATA X(87)/0.740124191578554D0 /, A(87)/0.086190161531953D0 /
35135 DATA X(88)/0.648093651936975D0 /, A(88)/0.097618652104113D0 /
35136 DATA X(89)/0.545421471388839D0 /, A(89)/0.107444270115965D0 /
35137 DATA X(90)/0.433793507626045D0 /, A(90)/0.115505668053725D0 /
35138 DATA X(91)/0.315042679696163D0 /, A(91)/0.121670472927803D0 /
35139 DATA X(92)/0.191118867473616D0 /, A(92)/0.125837456346828D0 /
35140 DATA X(93)/0.064056892862605D0 /, A(93)/0.127938195346752D0 /
35142 DATA X(94)/0.997263861849481D0 /, A(94)/0.007018610009470D0 /
35143 DATA X(95)/0.985611511545268D0 /, A(95)/0.016274394730905D0 /
35144 DATA X(96)/0.964762255587506D0 /, A(96)/0.025392065309262D0 /
35145 DATA X(97)/0.934906075937739D0 /, A(97)/0.034273862913021D0 /
35146 DATA X(98)/0.896321155766052D0 /, A(98)/0.042835898022226D0 /
35147 DATA X(99)/0.849367613732569D0 /, A(99)/0.050998059262376D0 /
35148 DATA X(100)/0.794483795967942D0/, A(100)/0.058684093478535D0/
35149 DATA X(101)/0.732182118740289D0/, A(101)/0.065822222776361D0/
35150 DATA X(102)/0.663044266930215D0/, A(102)/0.072345794108848D0/
35151 DATA X(103)/0.587715757240762D0/, A(103)/0.078193895787070D0/
35152 DATA X(104)/0.506899908932229D0/, A(104)/0.083311924226946D0/
35153 DATA X(105)/0.421351276130635D0/, A(105)/0.087652093004403D0/
35154 DATA X(106)/0.331868602282127D0/, A(106)/0.091173878695763D0/
35155 DATA X(107)/0.239287362252137D0/, A(107)/0.093844399080804D0/
35156 DATA X(108)/0.144471961582796D0/, A(108)/0.095638720079274D0/
35157 DATA X(109)/0.048307665687738D0/, A(109)/0.096540088514727D0/
35159 DATA X(110)/0.998237709710559D0/, A(110)/0.004521277098533D0/
35160 DATA X(111)/0.990726238699457D0/, A(111)/0.010498284531152D0/
35161 DATA X(112)/0.977259949983774D0/, A(112)/0.016421058381907D0/
35162 DATA X(113)/0.957916819213791D0/, A(113)/0.022245849194166D0/
35163 DATA X(114)/0.932812808278676D0/, A(114)/0.027937006980023D0/
35164 DATA X(115)/0.902098806968874D0/, A(115)/0.033460195282547D0/
35165 DATA X(116)/0.865959503212259D0/, A(116)/0.038782167974472D0/
35166 DATA X(117)/0.824612230833311D0/, A(117)/0.043870908185673D0/
35167 DATA X(118)/0.778305651426519D0/, A(118)/0.048695807635072D0/
35168 DATA X(119)/0.727318255189927D0/, A(119)/0.053227846983936D0/
35169 DATA X(120)/0.671956684614179D0/, A(120)/0.057439769099391D0/
35170 DATA X(121)/0.612553889667980D0/, A(121)/0.061306242492928D0/
35171 DATA X(122)/0.549467125095128D0/, A(122)/0.064804013456601D0/
35172 DATA X(123)/0.483075801686178D0/, A(123)/0.067912045815233D0/
35173 DATA X(124)/0.413779204371605D0/, A(124)/0.070611647391286D0/
35174 DATA X(125)/0.341994090825758D0/, A(125)/0.072886582395804D0/
35175 DATA X(126)/0.268152185007253D0/, A(126)/0.074723169057968D0/
35176 DATA X(127)/0.192697580701371D0/, A(127)/0.076110361900626D0/
35177 DATA X(128)/0.116084070675255D0/, A(128)/0.077039818164247D0/
35178 DATA X(129)/0.038772417506050D0/, A(129)/0.077505947978424D0/
35180 DATA X(130)/0.998771007252426D0/, A(130)/0.003153346052305D0/
35181 DATA X(131)/0.993530172266350D0/, A(131)/0.007327553901276D0/
35182 DATA X(132)/0.984124583722826D0/, A(132)/0.011477234579234D0/
35183 DATA X(133)/0.970591592546247D0/, A(133)/0.015579315722943D0/
35184 DATA X(134)/0.952987703160430D0/, A(134)/0.019616160457355D0/
35185 DATA X(135)/0.931386690706554D0/, A(135)/0.023570760839324D0/
35186 DATA X(136)/0.905879136715569D0/, A(136)/0.027426509708356D0/
35187 DATA X(137)/0.876572020274247D0/, A(137)/0.031167227832798D0/
35188 DATA X(138)/0.843588261624393D0/, A(138)/0.034777222564770D0/
35189 DATA X(139)/0.807066204029442D0/, A(139)/0.038241351065830D0/
35190 DATA X(140)/0.767159032515740D0/, A(140)/0.041545082943464D0/
35191 DATA X(141)/0.724034130923814D0/, A(141)/0.044674560856694D0/
35192 DATA X(142)/0.677872379632663D0/, A(142)/0.047616658492490D0/
35193 DATA X(143)/0.628867396776513D0/, A(143)/0.050359035553854D0/
35194 DATA X(144)/0.577224726083972D0/, A(144)/0.052890189485193D0/
35195 DATA X(145)/0.523160974722233D0/, A(145)/0.055199503699984D0/
35196 DATA X(146)/0.466902904750958D0/, A(146)/0.057277292100403D0/
35197 DATA X(147)/0.408686481990716D0/, A(147)/0.059114839698395D0/
35198 DATA X(148)/0.348755886292160D0/, A(148)/0.060704439165893D0/
35199 DATA X(149)/0.287362487355455D0/, A(149)/0.062039423159892D0/
35200 DATA X(150)/0.224763790394689D0/, A(150)/0.063114192286254D0/
35201 DATA X(151)/0.161222356068891D0/, A(151)/0.063924238584648D0/
35202 DATA X(152)/0.097004699209462D0/, A(152)/0.064466164435950D0/
35203 DATA X(153)/0.032380170962869D0/, A(153)/0.064737696812683D0/
35205 DATA X(154)/0.999305041735772D0/, A(154)/0.001783280721696D0/
35206 DATA X(155)/0.996340116771955D0/, A(155)/0.004147033260562D0/
35207 DATA X(156)/0.991013371476744D0/, A(156)/0.006504457968978D0/
35208 DATA X(157)/0.983336253884625D0/, A(157)/0.008846759826363D0/
35209 DATA X(158)/0.973326827789910D0/, A(158)/0.011168139460131D0/
35210 DATA X(159)/0.961008799652053D0/, A(159)/0.013463047896718D0/
35211 DATA X(160)/0.946411374858402D0/, A(160)/0.015726030476024D0/
35212 DATA X(161)/0.929569172131939D0/, A(161)/0.017951715775697D0/
35213 DATA X(162)/0.910522137078502D0/, A(162)/0.020134823153530D0/
35214 DATA X(163)/0.889315445995114D0/, A(163)/0.022270173808383D0/
35215 DATA X(164)/0.865999398154092D0/, A(164)/0.024352702568710D0/
35216 DATA X(165)/0.840629296252580D0/, A(165)/0.026377469715054D0/
35217 DATA X(166)/0.813265315122797D0/, A(166)/0.028339672614259D0/
35218 DATA X(167)/0.783972358943341D0/, A(167)/0.030234657072402D0/
35219 DATA X(168)/0.752819907260531D0/, A(168)/0.032057928354851D0/
35220 DATA X(169)/0.719881850171610D0/, A(169)/0.033805161837141D0/
35221 DATA X(170)/0.685236313054233D0/, A(170)/0.035472213256882D0/
35222 DATA X(171)/0.648965471254657D0/, A(171)/0.037055128540240D0/
35223 DATA X(172)/0.611155355172393D0/, A(172)/0.038550153178615D0/
35224 DATA X(173)/0.571895646202634D0/, A(173)/0.039953741132720D0/
35225 DATA X(174)/0.531279464019894D0/, A(174)/0.041262563242623D0/
35226 DATA X(175)/0.489403145707052D0/, A(175)/0.042473515123653D0/
35227 DATA X(176)/0.446366017253464D0/, A(176)/0.043583724529323D0/
35228 DATA X(177)/0.402270157963991D0/, A(177)/0.044590558163756D0/
35229 DATA X(178)/0.357220158337668D0/, A(178)/0.045491627927418D0/
35230 DATA X(179)/0.311322871990210D0/, A(179)/0.046284796581314D0/
35231 DATA X(180)/0.264687162208767D0/, A(180)/0.046968182816210D0/
35232 DATA X(181)/0.217423643740007D0/, A(181)/0.047540165714830D0/
35233 DATA X(182)/0.169644420423992D0/, A(182)/0.047999388596458D0/
35234 DATA X(183)/0.121462819296120D0/, A(183)/0.048344762234802D0/
35235 DATA X(184)/0.072993121787799D0/, A(184)/0.048575467441503D0/
35236 DATA X(185)/0.024350292663424D0/, A(185)/0.048690957009139D0/
35238 DATA X(186)/0.999553822651630D0/, A(186)/0.001144950003186D0/
35239 DATA X(187)/0.997649864398237D0/, A(187)/0.002663533589512D0/
35240 DATA X(188)/0.994227540965688D0/, A(188)/0.004180313124694D0/
35241 DATA X(189)/0.989291302499755D0/, A(189)/0.005690922451403D0/
35242 DATA X(190)/0.982848572738629D0/, A(190)/0.007192904768117D0/
35243 DATA X(191)/0.974909140585727D0/, A(191)/0.008683945269260D0/
35244 DATA X(192)/0.965485089043799D0/, A(192)/0.010161766041103D0/
35245 DATA X(193)/0.954590766343634D0/, A(193)/0.011624114120797D0/
35246 DATA X(194)/0.942242761309872D0/, A(194)/0.013068761592401D0/
35247 DATA X(195)/0.928459877172445D0/, A(195)/0.014493508040509D0/
35248 DATA X(196)/0.913263102571757D0/, A(196)/0.015896183583725D0/
35249 DATA X(197)/0.896675579438770D0/, A(197)/0.017274652056269D0/
35250 DATA X(198)/0.878722567678213D0/, A(198)/0.018626814208299D0/
35251 DATA X(199)/0.859431406663111D0/, A(199)/0.019950610878141D0/
35252 DATA X(200)/0.838831473580255D0/, A(200)/0.021244026115782D0/
35253 DATA X(201)/0.816954138681463D0/, A(201)/0.022505090246332D0/
35254 DATA X(202)/0.793832717504605D0/, A(202)/0.023731882865930D0/
35255 DATA X(203)/0.769502420135041D0/, A(203)/0.024922535764115D0/
35256 DATA X(204)/0.744000297583597D0/, A(204)/0.026075235767565D0/
35257 DATA X(205)/0.717365185362099D0/, A(205)/0.027188227500486D0/
35258 DATA X(206)/0.689637644342027D0/, A(206)/0.028259816057276D0/
35259 DATA X(207)/0.660859898986119D0/, A(207)/0.029288369583267D0/
35260 DATA X(208)/0.631075773046871D0/, A(208)/0.030272321759557D0/
35261 DATA X(209)/0.600330622829751D0/, A(209)/0.031210174188114D0/
35262 DATA X(210)/0.568671268122709D0/, A(210)/0.032100498673487D0/
35263 DATA X(211)/0.536145920897131D0/, A(211)/0.032941939397645D0/
35264 DATA X(212)/0.502804111888784D0/, A(212)/0.033733214984611D0/
35265 DATA X(213)/0.468696615170544D0/, A(213)/0.034473120451753D0/
35266 DATA X(214)/0.433875370831756D0/, A(214)/0.035160529044747D0/
35267 DATA X(215)/0.398393405881969D0/, A(215)/0.035794393953416D0/
35268 DATA X(216)/0.362304753499487D0/, A(216)/0.036373749905835D0/
35269 DATA X(217)/0.325664370747701D0/, A(217)/0.036897714638276D0/
35270 DATA X(218)/0.288528054884511D0/, A(218)/0.037365490238730D0/
35271 DATA X(219)/0.250952358392272D0/, A(219)/0.037776364362001D0/
35272 DATA X(220)/0.212994502857666D0/, A(220)/0.038129711314477D0/
35273 DATA X(221)/0.174712291832646D0/, A(221)/0.038424993006959D0/
35274 DATA X(222)/0.136164022809143D0/, A(222)/0.038661759774076D0/
35275 DATA X(223)/0.097408398441584D0/, A(223)/0.038839651059051D0/
35276 DATA X(224)/0.058504437152420D0/, A(224)/0.038958395962769D0/
35277 DATA X(225)/0.019511383256793D0/, A(225)/0.039017813656306D0/
35279 DATA X(226)/0.999689503883230D0/, A(226)/0.000796792065552D0/
35280 DATA X(227)/0.998364375863181D0/, A(227)/0.001853960788946D0/
35281 DATA X(228)/0.995981842987209D0/, A(228)/0.002910731817934D0/
35282 DATA X(229)/0.992543900323762D0/, A(229)/0.003964554338444D0/
35283 DATA X(230)/0.988054126329623D0/, A(230)/0.005014202742927D0/
35284 DATA X(231)/0.982517263563014D0/, A(231)/0.006058545504235D0/
35285 DATA X(232)/0.975939174585136D0/, A(232)/0.007096470791153D0/
35286 DATA X(233)/0.968326828463264D0/, A(233)/0.008126876925698D0/
35287 DATA X(234)/0.959688291448742D0/, A(234)/0.009148671230783D0/
35288 DATA X(235)/0.950032717784437D0/, A(235)/0.010160770535008D0/
35289 DATA X(236)/0.939370339752755D0/, A(236)/0.011162102099838D0/
35290 DATA X(237)/0.927712456722308D0/, A(237)/0.012151604671088D0/
35291 DATA X(238)/0.915071423120898D0/, A(238)/0.013128229566961D0/
35292 DATA X(239)/0.901460635315852D0/, A(239)/0.014090941772314D0/
35293 DATA X(240)/0.886894517402420D0/, A(240)/0.015038721026994D0/
35294 DATA X(241)/0.871388505909296D0/, A(241)/0.015970562902562D0/
35295 DATA X(242)/0.854959033434601D0/, A(242)/0.016885479864245D0/
35296 DATA X(243)/0.837623511228187D0/, A(243)/0.017782502316045D0/
35297 DATA X(244)/0.819400310737931D0/, A(244)/0.018660679627411D0/
35298 DATA X(245)/0.800308744139140D0/, A(245)/0.019519081140145D0/
35299 DATA X(246)/0.780369043867433D0/, A(246)/0.020356797154333D0/
35300 DATA X(247)/0.759602341176647D0/, A(247)/0.021172939892191D0/
35301 DATA X(248)/0.738030643744400D0/, A(248)/0.021966644438744D0/
35302 DATA X(249)/0.715676812348967D0/, A(249)/0.022737069658329D0/
35303 DATA X(250)/0.692564536642171D0/, A(250)/0.023483399085926D0/
35304 DATA X(251)/0.668718310043916D0/, A(251)/0.024204841792364D0/
35305 DATA X(252)/0.644163403784967D0/, A(252)/0.024900633222483D0/
35306 DATA X(253)/0.618925840125468D0/, A(253)/0.025570036005349D0/
35307 DATA X(254)/0.593032364777572D0/, A(254)/0.026212340735672D0/
35308 DATA X(255)/0.566510418561397D0/, A(255)/0.026826866725591D0/
35309 DATA X(256)/0.539388108324357D0/, A(256)/0.027412962726029D0/
35310 DATA X(257)/0.511694177154667D0/, A(257)/0.027970007616848D0/
35311 DATA X(258)/0.483457973920596D0/, A(258)/0.028497411065085D0/
35312 DATA X(259)/0.454709422167743D0/, A(259)/0.028994614150555D0/
35313 DATA X(260)/0.425478988407300D0/, A(260)/0.029461089958167D0/
35314 DATA X(261)/0.395797649828908D0/, A(261)/0.029896344136328D0/
35315 DATA X(262)/0.365696861472313D0/, A(262)/0.030299915420827D0/
35316 DATA X(263)/0.335208522892625D0/, A(263)/0.030671376123669D0/
35317 DATA X(264)/0.304364944354496D0/, A(264)/0.031010332586313D0/
35318 DATA X(265)/0.273198812591049D0/, A(265)/0.031316425596861D0/
35319 DATA X(266)/0.241743156163840D0/, A(266)/0.031589330770727D0/
35320 DATA X(267)/0.210031310460567D0/, A(267)/0.031828758894411D0/
35321 DATA X(268)/0.178096882367618D0/, A(268)/0.032034456231992D0/
35322 DATA X(269)/0.145973714654896D0/, A(269)/0.032206204794030D0/
35323 DATA X(270)/0.113695850110665D0/, A(270)/0.032343822568575D0/
35324 DATA X(271)/0.081297495464425D0/, A(271)/0.032447163714064D0/
35325 DATA X(272)/0.048812985136049D0/, A(272)/0.032516118713868D0/
35326 DATA X(273)/0.016276744849602D0/, A(273)/0.032550614492363D0/
35328 IF(IBD.NE.0) RETURN
35339 *$ CREATE PHO_DZEROX.FOR
35341 CDECK ID>, PHO_DZEROX
35342 DOUBLE PRECISION FUNCTION PHO_DZEROX(A0,B0,EPS,MAXF,F,MODE)
35343 C**********************************************************************
35347 C J.C.P. Bus and T.J. Dekker, Two Efficient Algorithms with
35348 C Guaranteed Convergence for Finding a Zero of a Function,
35349 C ACM Trans. Math. Software 1 (1975) 330-345.
35351 C (MODE = 1: Algorithm M; MODE = 2: Algorithm R)
35355 C***********************************************************************
35356 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35359 C input/output channels
35361 COMMON /POINOU/ LI,LO
35364 PARAMETER (NAME = 'PHO_DZEROX')
35366 DIMENSION IM1(2),IM2(2),LMT(2)
35369 PARAMETER (Z1 = 1, HALF = Z1/2)
35371 DATA IM1 /2,3/, IM2 /-1,3/
35373 IF(MODE .NE. 1 .AND. MODE .NE. 2) THEN
35375 WRITE(LO,100) NAME,MODE
35380 IF(FA*FB .GT. 0) THEN
35393 3 IF(ABS(FC) .LT. ABS(FB)) THEN
35408 IF(ABS(HB) .GT. TOL) THEN
35409 IF(IE .GT. IM1(MODE)) THEN
35412 TOL=TOL*SIGN(Z1,HB)
35428 IF(IE .EQ. IM2(MODE)) P=P+P
35429 IF(P .EQ. 0 .OR. P .LE. Q*TOL) THEN
35431 ELSEIF(P .LT. HB*Q) THEN
35443 IF(MF .GT. MAXF) THEN
35448 IF(FB .EQ. 0 .OR. SIGN(Z1,FC) .EQ. SIGN(Z1,FB)) GO TO 1
35449 IF(W .EQ. HB) GO TO 2
35456 100 FORMAT(1X,A,': mode = ',I3,' illegal')
35457 101 FORMAT(1X,A,': F(A) and F(B) have the same sign')
35458 102 FORMAT(1X,A,': too many function calls')
35462 *$ CREATE PHO_EXPINT.FOR
35464 CDECK ID>, PHO_EXPINT
35465 DOUBLE PRECISION FUNCTION PHO_EXPINT(RXM)
35466 C***********************************************************************
35468 C function to calculate E_i(x) = -E_1(-x)
35470 C based on CERNLIB C337 (changed by R.Engel 10/1993)
35472 C***********************************************************************
35473 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35476 C input/output channels
35478 COMMON /POINOU/ LI,LO
35480 DOUBLE PRECISION P1(5),Q1(5),P2(7),Q2(7),P3(6),Q3(6),P4(8),Q4(8)
35481 DOUBLE PRECISION A1(8),B1(8),A2(8),B2(8),A3(6),B3(6),XL(6)
35482 DOUBLE PRECISION X,Y,AP,BP,DP,AQ,BQ,DQ,X0,V
35484 DATA X0 /0.37250 74107 8137D0/
35485 DATA XL /-24.0D0,-12.0D0,-6.0D0,0.0D0,1.0D0,4.0D0/
35487 1/+4.29312 52343 210D+0, +3.98941 53870 321D+1,
35488 2 +2.92525 18866 921D+2, +4.25696 82638 592D+2,
35489 3 -4.34981 43832 952D+2/
35491 1/+1.00000 00000 000D+0, +1.88992 88395 003D+1,
35492 2 +1.50950 38744 251D+2, +5.68052 52718 987D+2,
35493 3 +7.53585 64359 843D+2/
35495 1/+4.30967 83946 939D-1, +6.90522 52278 444D+0,
35496 2 +2.30192 55939 133D+1, +2.43784 08879 132D+1,
35497 3 +9.04161 55694 633D+0, +9.99979 57705 159D-1,
35498 4 +4.65627 10797 510D-7/
35500 1/+1.03400 13040 487D-1, +3.31909 21359 330D+0,
35501 2 +2.04494 78501 379D+1, +4.12807 84189 142D+1,
35502 3 +3.24264 21069 514D+1, +1.00411 64382 905D+1,
35503 4 +1.00000 00000 000D+0/
35505 1/-2.39099 64453 136D+0, -1.47982 19500 504D+2,
35506 2 -2.54376 33976 890D+2, -1.19557 61038 372D+2,
35507 3 -1.96304 08535 939D+1, -9.99999 99990 360D-1/
35509 1/+1.77600 70940 351D+2, +5.30685 09610 812D+2,
35510 2 +4.62230 27156 148D+2, +1.56818 43364 539D+2,
35511 3 +2.16304 08494 238D+1, +1.00000 00000 000D+0/
35513 1/-8.66937 33995 107D+0, -5.49142 26552 109D+2,
35514 2 -4.21001 61535 707D+3, -2.49301 39345 865D+5,
35515 3 -1.19623 66934 925D+5, -2.21744 62775 885D+7,
35516 4 +3.89280 42131 120D+6, -3.91546 07380 910D+8/
35518 1/+3.41718 75000 000D+1, -1.60708 92658 722D+3,
35519 2 +3.57300 29805 851D+4, -4.83547 43616 216D+5,
35520 3 +4.28559 62461 175D+6, -2.49033 37574 054D+7,
35521 4 +8.91925 76757 561D+7, -1.65254 29972 521D+8/
35523 1/-2.18086 38152 072D+0, -2.19010 23385 488D+1,
35524 2 +9.30816 38566 217D+0, +2.50762 81129 356D+1,
35525 3 -3.31842 53199 722D+1, +6.01217 99083 008D+1,
35526 4 -4.32531 13287 813D+1, +1.00443 10922 808D+0/
35528 1/+0.00000 00000 000D+0, +3.93707 70185 272D+0,
35529 2 +3.00892 64837 292D+2, -6.25041 16167 188D+0,
35530 3 +1.00367 43951 673D+3, +1.43256 73812 194D+1,
35531 4 +2.73624 11988 933D+3, +5.27468 85196 291D-1/
35533 1/-3.48334 65360 285D+0, -1.86545 45488 340D+1,
35534 2 -8.28561 99414 064D+0, -3.23467 33030 540D+1,
35535 3 +1.79601 68876 925D+1, +1.75656 31546 961D+0,
35536 4 -1.95022 32128 966D+0, +9.99994 29607 471D-1/
35538 1/+0.00000 00000 000D+0, +6.95000 65588 743D+1,
35539 2 +5.72837 19383 732D+1, +2.57776 38423 844D+1,
35540 3 +7.60761 14800 773D+2, +2.89516 72792 514D+1,
35541 4 -3.43942 26689 987D+0, +1.00083 86740 264D+0/
35543 1/-2.77809 28934 438D+1, -1.01047 90815 760D+1,
35544 2 -9.14830 08216 736D+0, -5.02233 17461 851D+0,
35545 3 -3.00000 77799 358D+0, +1.00000 00000 704D+0/
35547 1/+0.00000 00000 000D+0, +1.22399 93926 823D+2,
35548 2 +2.72761 00778 779D+0, -7.18975 18395 045D+0,
35549 3 -2.99901 18065 262D+0, +1.99999 99428 260D+0/
35551 C conversion to E_i function
35554 IF(X .LE. XL(1)) THEN
35557 1 AP=A3(I)-X+B3(I)/AP
35558 Y=(EXP(-X)/X)*(1.D0-(A3(6)+B3(6)/AP)/X)
35559 ELSEIF(X .LE. XL(2)) THEN
35562 2 AP=A2(I)-X+B2(I)/AP
35563 Y=(EXP(-X)/X)*(A2(8)+B2(8)/AP)
35564 ELSEIF(X .LE. XL(3)) THEN
35567 3 AP=A1(I)-X+B1(I)/AP
35568 Y=(EXP(-X)/X)*(A1(8)+B1(8)/AP)
35569 ELSEIF(X .LT. XL(4)) THEN
35570 V=-2.D0*(X/3.D0+1.D0)
35582 14 DQ=Q4(I)-AQ+V*BQ
35583 Y=-LOG(-X/X0)+(X+X0)*(DP-AP)/(DQ-AQ)
35584 ELSEIF(X .EQ. XL(4)) THEN
35585 * CALL KERMTR('C337.1',LGFILE,MFLAG,RFLAG)
35587 * IF(LGFILE .EQ. 0) THEN
35588 * WRITE(LO,100) ENAME
35590 * WRITE(LGFILE,100) ENAME
35593 * IF(.NOT.RFLAG) CALL ABEND
35596 ELSEIF(X .LT. XL(5)) THEN
35603 ELSEIF(X .LE. XL(6)) THEN
35618 Y=EXP(-X)*Y*(1.D0+Y*AP/AQ)
35620 C sign conversion to E_i
35625 *$ CREATE PHO_RNDBET.FOR
35627 CDECK ID>, PHO_RNDBET
35628 DOUBLE PRECISION FUNCTION PHO_RNDBET(GAM,ETA)
35629 C********************************************************************
35631 C RANDOM NUMBER GENERATION FROM BETA
35632 C DISTRIBUTION IN REGION 0 < X < 1.
35633 C F(X) = X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM) / (GAMM(GAM
35636 C********************************************************************
35637 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35640 Y = PHO_RNDGAM(1.D0,GAM)
35641 Z = PHO_RNDGAM(1.D0,ETA)
35643 PHO_RNDBET = Y/(Y+Z)
35647 *$ CREATE PHO_RNDGAM.FOR
35649 CDECK ID>, PHO_RNDGAM
35650 DOUBLE PRECISION FUNCTION PHO_RNDGAM(ALAM,ETA)
35651 C********************************************************************
35653 C RANDOM NUMBER SELECTION FROM GAMMA DISTRIBUTION
35654 C F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)
35656 C********************************************************************
35657 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35663 IF(F.EQ.0.D0) GOTO 20
35664 10 R = DT_RNDM(ETA)
35666 IF (NCOU.GE.11) GOTO 20
35667 IF(R.LT.F/(F+2.71828D0)) GOTO 30
35668 YYY=LOG(DT_RNDM(F)+1.0D-9)/F
35669 IF(ABS(YYY).GT.50.D0) GOTO 20
35671 IF(LOG(DT_RNDM(Y)+1.0D-9).GT.-Y) GOTO 10
35675 30 Y = 1.D0-LOG(DT_RNDM(R)+1.0D-9)
35676 IF(DT_RNDM(Y).GT.Y**(F-1.D0)) GOTO 10
35677 40 IF(N.EQ.0) GOTO 70
35680 60 Z = Z*DT_RNDM(Y)
35681 Y = Y-LOG(Z+1.0D-9)
35682 70 PHO_RNDGAM = Y/ALAM
35686 *$ CREATE PHO_SFECFE.FOR
35688 CDECK ID>, PHO_SFECFE
35689 SUBROUTINE PHO_SFECFE(SFE,CFE)
35690 C**********************************************************************
35692 C fast random SIN(X) COS(X) selection
35694 C**********************************************************************
35695 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35704 IF(XY.GT.1.D0) GOTO 1
35707 IF(DT_RNDM(XY).LT.0.5D0) THEN
35712 *$ CREATE PHO_SWAPD.FOR
35714 CDECK ID>, PHO_SWAPD
35715 SUBROUTINE PHO_SWAPD(D1,D2)
35716 C********************************************************************
35718 C exchange of argument values (double precision)
35720 C********************************************************************
35721 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35727 *$ CREATE PHO_SWAPI.FOR
35729 CDECK ID>, PHO_SWAPI
35730 SUBROUTINE PHO_SWAPI(I1,I2)
35731 C********************************************************************
35733 C exchange of argument values (integer)
35735 C********************************************************************
35736 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35742 *$ CREATE PHO_HADCSL.FOR
35744 CDECK ID>, PHO_HADCSL
35745 SUBROUTINE PHO_HADCSL(ID1,ID2,ECM,PLAB,IMODE,
35746 & SIGTOT,SIGEL,SIGDIF,SLOPE,RHO)
35747 C***********************************************************************
35749 C low-energy cross section parametrizations
35751 C input: ID1,ID2 PDG IDs of particles (meson first)
35752 C ECM c.m. energy (GeV)
35753 C PLAB lab. momentum (second particle at rest)
35754 C IMODE 1 ECM given, PLAB ignored
35755 C 2 PLAB given, ECM ignored
35757 C output: SIGTOT total cross section (mb)
35758 C SIGEL elastic cross section (mb)
35759 C SIGDIF diffracive cross section (sd-1,sd-2,dd), (mb)
35760 C SLOPE forward elastic slope (GeV**-2)
35761 C RHO real/imaginary part of elastic amplitude
35765 C - low-energy data interpolation uses PDG fits from 1992 issue
35766 C - high-energy extrapolation by Donnachie-Landshoff like fit made
35768 C - analytic extension of amplitude to calculate rho
35770 C***********************************************************************
35776 INTEGER ID1,ID2,IMODE
35777 DOUBLE PRECISION ECM,PLAB,SIGTOT,SIGEL,SIGDIF(3),SLOPE,RHO
35779 C input/output channels
35781 COMMON /POINOU/ LI,LO
35783 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
35784 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
35785 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
35786 C model switches and parameters
35788 INTEGER ISWMDL,IPAMDL
35789 DOUBLE PRECISION PARMDL
35790 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
35793 DOUBLE PRECISION SIGTO1,SIGTO2,SIGEL1,SIGEL2,
35794 & SS,PL,PLL,E1,XP,YP,YM,PHR,PHP,X1,X2
35796 DOUBLE PRECISION TPDG92(7,2,6),TPDG96(9,6),BURQ83(3,6),XMA(6)
35799 & 3.D0, 2100.D0, 48.D0, 0.D0, 1.D0, 0.522D0, -4.51D0,
35800 & 3.D0, 2100.D0, 11.9D0, 26.9D0, -1.21D0, 0.169D0, -1.85D0,
35801 & 5.D0, 2100.D0, 38.4D0, 77.6D0, -0.64D0, 0.26D0, -1.2D0,
35802 & 5.D0, 2100.D0, 10.2D0, 52.7D0, -1.16D0, 0.125D0, -1.28D0,
35803 & 4.D0, 340.D0, 16.4D0, 19.3D0, -0.42D0, 0.19D0, 0.D0,
35804 & 4.D0, 340.D0, 0.D0, 11.4D0, -0.4D0, 0.079D0, 0.D0,
35805 & 2.5D0, 370.D0, 33.D0, 14.D0, -1.36D0, 0.456D0, -4.03D0,
35806 & 2.5D0, 370.D0, 1.76D0, 11.2D0, -0.64D0, 0.043D0, 0.D0,
35807 & 2.D0, 310.D0, 18.1D0, 0.D0, 1.D0, 0.26D0, -1.D0,
35808 & 2.D0, 310.D0, 5.D0, 8.1D0, -1.8D0, 0.16D0, -1.3D0,
35809 & 3.D0, 310.D0, 32.1D0, 0.D0, 1.D0, 0.66D0, -5.6D0,
35810 & 3.D0, 310.D0, 7.3D0, 0.D0, 1.D0, 0.29D0, -2.4D0 /
35813 & 50.D0, 22.D0,0.079D0,0.25D0,0.D0,
35814 & 77.15D0,-21.05D0,0.46D0,0.9D0,
35815 & 50.D0, 22.D0,0.079D0,0.25D0,0.D0,
35816 & 77.15D0,21.05D0,0.46D0,0.9D0,
35817 & 10.D0, 13.70,0.079D0,0.25D0,0.D0,
35818 & 31.85D0,-4.05D0,0.45D0,0.9D0,
35819 & 10.D0, 13.70,0.079D0,0.25D0,0.D0,
35820 & 31.85D0,4.05D0,0.45D0,0.9D0,
35821 & 10.D0, 12.20,0.079D0,0.25D0,0.D0,
35822 & 17.35D0,-9.05D0,0.50D0,0.9D0,
35823 & 10.D0, 12.20,0.079D0,0.25D0,0.D0,
35824 & 17.35D0,9.05D0,0.50D0,0.9D0 /
35827 & 11.13D0, -6.21D0, 0.30D0,
35828 & 11.13D0, 7.23D0, 0.30D0,
35829 & 9.11D0, -0.73D0, 0.28D0,
35830 & 9.11D0, 0.65D0, 0.28D0,
35831 & 8.55D0, -5.98D0, 0.28D0,
35832 & 8.55D0, 1.60D0, 0.28D0 /
35835 & 2*0.93956563D0, 2*0.13956995D0, 2*0.493677D0 /
35838 IF(ID2.NE.2212) THEN
35840 ELSE IF(ID1.EQ.2212) THEN
35842 ELSE IF(ID1.EQ.-2212) THEN
35844 ELSE IF(ID1.EQ.211) THEN
35846 ELSE IF(ID1.EQ.-211) THEN
35848 ELSE IF(ID1.EQ.321) THEN
35850 ELSE IF(ID1.EQ.-321) THEN
35856 C calculate lab momentum
35857 IF(IMODE.EQ.1) THEN
35859 E1 = 0.5D0/XMA(1)*(SS-XMA(1)**2-XMA(K)**2)
35860 PL = SQRT(E1*E1-XMA(K)**2)
35861 ELSE IF(IMODE.EQ.2) THEN
35863 SS = XMA(1)**2+XMA(K)**2+2.D0*XMA(1)*SQRT(PL**2+XMA(K)**2)
35866 WRITE(LO,'(1X,A,I5)') 'PHO_HADCSL:ERROR: invalid IMODE: ',IMODE
35871 C check against lower limit
35872 IF(ECM.LE.XMA(1)+XMA(K)) GOTO 200
35874 XP = TPDG96(2,K)*SS**TPDG96(3,K)
35875 YP = TPDG96(6,K)/SS**TPDG96(8,K)
35876 YM = TPDG96(7,K)/SS**TPDG96(8,K)
35878 PHR = TAN(PI/2.D0*(1.-TPDG96(8,K)))
35879 PHP = TAN(PI/2.D0*(1.+TPDG96(3,K)))
35880 RHO = (-YP/PHR + YM*PHR - XP/PHP)/(YP+YM+XP)
35881 SLOPE = BURQ83(1,K)+BURQ83(2,K)/SQRT(PL)+BURQ83(3,K)*PLL
35883 C select energy range and interpolation method
35884 IF(PL.LT.TPDG96(1,K)) THEN
35885 SIGTOT = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
35886 & + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
35887 SIGEL = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
35888 & + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
35889 ELSE IF(PL.LT.TPDG92(2,1,K)) THEN
35890 SIGTO1 = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
35891 & + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
35892 SIGEL1 = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
35893 & + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
35895 SIGEL2 = SIGTO2**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
35896 X2 = LOG(PL/TPDG96(1,K))/LOG(TPDG92(2,1,K)/TPDG96(1,K))
35898 SIGTOT = SIGTO2*X2 + SIGTO1*X1
35899 SIGEL = SIGEL2*X2 + SIGEL1*X1
35902 SIGEL = SIGTOT**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
35905 C no parametrization of diffraction implemented
35913 WRITE(LO,'(1X,2A,2I7)') 'PHO_HADCSL:ERROR: ',
35914 & 'invalid particle combination: ',ID1,ID2
35918 WRITE(LO,'(1X,2A,1P,2E12.4)') 'PHO_HADCSL:ERROR: ',
35919 & 'energy too small (Ecm,Plab): ',ECM,PLAB
35923 *$ CREATE PHO_CSDIFF.FOR
35925 CDECK ID>, PHO_CSDIFF
35926 SUBROUTINE PHO_CSDIFF(Id1,Id2,SS,Xi_min,Xi_max,
35927 & sig_sd1,sig_sd2,sig_dd)
35928 C***********************************************************************
35930 C cross section for diffraction dissociation according to
35931 C Goulianos' parametrization (Ref: PL B358 (1995) 379)
35933 C in addition rescaling for different particles is applied using
35934 C internal rescaling tables (not implemented yet)
35936 C input: Id1/2 PDG ID's of incoming particles
35937 C SS squared c.m. energy (GeV**2)
35938 C Xi_min min. diff mass (squared) = Xi_min*SS
35939 C Xi_max max. diff mass (squared) = Xi_max*SS
35941 C output: sig_sd1 cross section for diss. of particle 1 (mb)
35942 C sig_sd2 cross section for diss. of particle 2 (mb)
35943 C sig_dd cross section for diss. of both particles
35945 C***********************************************************************
35952 DOUBLE PRECISION SS,Xi_min,Xi_max,sig_sd1,sig_sd2,sig_dd
35954 C input/output channels
35956 COMMON /POINOU/ LI,LO
35958 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
35959 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
35960 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
35962 DOUBLE PRECISION xpos1(96),xwgh1(96),xpos2(96),xwgh2(96)
35963 DOUBLE PRECISION delta,alphap,beta0,gpom0,xm_p,x_rad2,xm4_p2,
35964 & fac,tt,t1,t2,tl,tu,Xnorm,xi,xil,xiu,w_xi,alpha_t,f2_t,
35965 & xms_1,xms_2,CSdiff
35967 INTEGER Ngau1,Ngau2,i1,i2
35971 DATA delta / 0.104d0 /
35972 DATA alphap / 0.25d0 /
35973 DATA beta0 / 6.56d0 /
35974 DATA gpom0 / 1.21d0 /
35975 DATA xm_p / 0.938d0 /
35976 DATA x_rad2 / 0.71d0 /
35978 C integration precision
35987 IF ((ABS(id1).EQ.2212).AND.(ABS(id2).EQ.2212)) THEN
35989 xm4_p2 = 4.D0*xm_p**2
35990 fac = beta0**2/(16.D0*PI)
35994 tl = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
35995 tu = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
35997 C flux renormalization and cross section
36001 xil = log(1.5d0/SS)
36004 IF(xiu.LE.xil) goto 1000
36006 CALL PHO_GAUSET(xil,xiu,Ngau1,xpos1,xwgh1)
36007 CALL PHO_GAUSET(tl,tu,Ngau2,xpos2,xwgh2)
36011 xi = exp(xpos1(i1))
36016 tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
36018 alpha_t = 1.D0+delta+alphap*tt
36019 f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
36022 & + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
36037 TL = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
36038 TU = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
36040 C single diffraction diss. cross section
36044 IF(XIU.LE.XIL) goto 2000
36046 CALL PHO_GAUSET(XIL,XIU,NGAU1,XPOS1,XWGH1)
36047 CALL PHO_GAUSET(TL,TU,NGAU2,XPOS2,XWGH2)
36051 xi = exp(xpos1(i1))
36052 w_xi = Xwgh1(i1)*beta0*gpom0*(xi*ss)**delta
36056 tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
36058 alpha_t = 1.D0+delta+alphap*tt
36059 f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
36062 & + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
36067 CSdiff = CSdiff*fac*GEV2MB/MAX(1.d0,Xnorm)
36069 * WRITE(LO,'(1x,1p,4e14.3)')
36070 * & sqrt(SS),Xnorm,2.*CSdiff*MAX(1.d0,Xnorm),2.*CSdiff
36077 C double diffraction dissociation cross section
36081 xil = log(1.5d0/SS)
36082 xiu = log(Xi_max/1.5d0)
36084 IF(xiu.LE.xil) goto 3000
36086 fac = (beta0*gpom0*SS**delta
36087 & /(4.d0*sqrt(PI)*MAX(1.d0,Xnorm)))**2
36090 CALL PHO_GAUSET(xil,xiu,ngau1,xpos1,xwgh1)
36094 xi = exp(xpos1(i1))
36097 xiu = log(Xi_max/(xi*SS))
36099 if(xil.lt.xiu) then
36101 CALL PHO_GAUSET(xil,xiu,Ngau2,xpos2,xwgh2)
36105 xms_2 = exp(xpos2(i2))*SS
36107 & + 1.d0/((xms_1*xms_2)**delta*log(SS/(xms_1*xms_2)))
36108 & *xwgh1(i1)*xwgh2(i2)
36116 sig_dd = CSdiff*fac*GEV2MB
36122 WRITE(LO,'(1x,2a,2I8)') 'PHO_CSDIFF: ',
36123 & 'invalid particle combination (Id1/2)',Id1,Id2
36129 *$ CREATE PHO_ALLM97.FOR
36131 CDECK ID>, PHO_ALLM97
36132 DOUBLE PRECISION FUNCTION PHO_ALLM97(Q2,W)
36133 C**********************************************************************
36135 C ALLM97 parametrization for gamma*-p cross section
36136 C (for F2 see comments, code adapted from V. Shekelyan, H1)
36138 C**********************************************************************
36144 C input/output channels
36146 COMMON /POINOU/ LI,LO
36148 DOUBLE PRECISION Q2,W
36149 DOUBLE PRECISION M02,M12,LAM2,M22
36150 DOUBLE PRECISION S11,S12,S13,A11,A12,A13,B11,B12,B13
36151 DOUBLE PRECISION S21,S22,S23,A21,A22,A23,B21,B22,B23
36152 DOUBLE PRECISION ALFA,XMP2,W2,Q02,S,T,T0,Z,CIN,
36153 & AP,BP,AR,BR,XP,XR,SR,SP,F2P,F2R
36154 DATA ALFA,XMP2 /112.2D0 , .8802D0 /
36185 Q02 = 0.46017D0 +LAM2
36189 T=LOG((Q2+Q02)/LAM2)
36191 IF(Q2.GT.0.D0) S=LOG(T/T0)
36194 IF(Q2.GT.0.D0) Z=(W2-XMP2)/(Q2+W2-XMP2)
36196 IF(S.LT.0.01D0) THEN
36200 XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
36206 F2P=SP*XP**AP*Z**BP
36210 XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
36216 F2R=SR*XR**AR*Z**BR
36222 XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
36224 AP=A11+(A11-A12)*(1.D0 /(1.D0 +S**A13)-1.D0 )
36226 BP=B11**2+B12**2*S**B13
36228 SP=S11+(S11-S12)*(1.D0 /(1.D0 +S**S13)-1.D0 )
36230 F2P=SP*XP**AP*Z**BP
36234 XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
36237 BR=B21**2+B22**2*S**B23
36240 F2R=SR*XR**AR*Z**BR
36244 * F2 = (F2P+F2R)*Q2/(Q2+M02)
36246 CIN=ALFA/(Q2+M02)*(1.D0 +4.D0*XMP2*Q2/(Q2+W2-XMP2)**2)/Z
36247 PHO_ALLM97 = CIN*(F2P+F2R)
36251 *$ CREATE PHO_DOR98LO.FOR
36253 CDECK ID>, PHO_DOR98LO
36254 SUBROUTINE PHO_DOR98LO (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
36255 C***********************************************************************
36257 C GRV98 parton densities, leading order set
36259 C For a detailed explanation see
36260 C M. Glueck, E. Reya, A. Vogt :
36261 C hep-ph/9806404 = DO-TH 98/07 = WUE-ITP-98-019
36262 C (To appear in Eur. Phys. J. C)
36264 C interpolation routine based on the original GRV98PA routine,
36265 C adapted to define interpolation table as DATA statements
36270 C INPUT: X = Bjorken-x (between 1.E-9 and 1.)
36271 C Q2 = scale in GeV**2 (between 0.8 and 1.E6)
36273 C OUTPUT: UV = u - u(bar), DV = d - d(bar), US = u(bar),
36274 C DS = d(bar), SS = s = s(bar), GL = gluon.
36275 C Always x times the distribution is returned.
36277 C******************************************************i****************
36278 IMPLICIT DOUBLE PRECISION (A-H, O-Z)
36281 C input/output channels
36283 COMMON /POINOU/ LI,LO
36285 PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
36286 DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
36287 1 XSF(NX,NQ), XGF(NX,NQ),
36288 2 XT(NARG), NA(NARG), ARRF(NX+NQ)
36290 DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
36291 & XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
36293 EQUIVALENCE (XUVF(1,1),XUVF_L(1))
36294 EQUIVALENCE (XDVF(1,1),XDVF_L(1))
36295 EQUIVALENCE (XDEF(1,1),XDEF_L(1))
36296 EQUIVALENCE (XUDF(1,1),XUDF_L(1))
36297 EQUIVALENCE (XSF(1,1),XSF_L(1))
36298 EQUIVALENCE (XGF(1,1),XGF_L(1))
36300 DATA (ARRF(K),K= 1, 95) /
36301 & -2.0723E+01,-2.0135E+01,-1.9560E+01,-1.8983E+01,-1.8421E+01,
36302 & -1.7833E+01,-1.7258E+01,-1.6680E+01,-1.6118E+01,-1.5530E+01,
36303 & -1.4955E+01,-1.4378E+01,-1.3816E+01,-1.3479E+01,-1.3122E+01,
36304 & -1.2717E+01,-1.2311E+01,-1.1913E+01,-1.1513E+01,-1.1176E+01,
36305 & -1.0820E+01,-1.0414E+01,-1.0009E+01,-9.6108E+00,-9.2103E+00,
36306 & -8.8739E+00,-8.5172E+00,-8.1117E+00,-7.7063E+00,-7.3082E+00,
36307 & -6.9078E+00,-6.5713E+00,-6.2146E+00,-5.8091E+00,-5.4037E+00,
36308 & -5.0056E+00,-4.6052E+00,-4.2687E+00,-3.9120E+00,-3.5066E+00,
36309 & -3.1011E+00,-2.8134E+00,-2.5257E+00,-2.3026E+00,-2.0794E+00,
36310 & -1.8971E+00,-1.7430E+00,-1.6094E+00,-1.4917E+00,-1.3863E+00,
36311 & -1.2910E+00,-1.2040E+00,-1.1239E+00,-1.0498E+00,-9.8083E-01,
36312 & -9.1629E-01,-7.9851E-01,-6.9315E-01,-5.9784E-01,-5.1083E-01,
36313 & -4.3078E-01,-3.5667E-01,-2.8768E-01,-2.2314E-01,-1.6252E-01,
36314 & -1.0536E-01,-5.1293E-02, 0.0000E+00,-2.2314E-01, 0.0000E+00,
36315 & 2.6236E-01, 5.8779E-01, 9.9325E-01, 1.3863E+00, 1.8563E+00,
36316 & 2.3026E+00, 2.7726E+00, 3.2189E+00, 3.6889E+00, 4.1589E+00,
36317 & 4.6052E+00, 5.1930E+00, 5.7683E+00, 6.3456E+00, 6.9078E+00,
36318 & 7.4955E+00, 8.0709E+00, 8.6482E+00, 9.2103E+00, 9.9988E+00,
36319 & 1.0736E+01, 1.1513E+01, 1.2301E+01, 1.3039E+01, 1.3816E+01/
36320 DATA (XUVF_L(K),K= 1, 114) /
36321 &2.3186E+00,2.2915E+00,2.2645E+00,2.2385E+00,2.2140E+00,2.1876E+00,
36322 &2.1623E+00,2.1366E+00,2.1121E+00,2.0862E+00,2.0612E+00,2.0358E+00,
36323 &2.0110E+00,1.9963E+00,1.9806E+00,1.9624E+00,1.9446E+00,1.9263E+00,
36324 &1.9072E+00,1.8904E+00,1.8724E+00,1.8515E+00,1.8294E+00,1.8085E+00,
36325 &1.7865E+00,1.7680E+00,1.7483E+00,1.7249E+00,1.6993E+00,1.6715E+00,
36326 &1.6385E+00,1.6141E+00,1.5884E+00,1.5597E+00,1.5337E+00,1.5121E+00,
36327 &1.4985E+00,1.4980E+00,1.5116E+00,1.5555E+00,1.6432E+00,1.7434E+00,
36328 &1.8861E+00,2.0327E+00,2.2174E+00,2.4015E+00,2.5849E+00,2.7671E+00,
36329 &2.9488E+00,3.1308E+00,3.3142E+00,3.4998E+00,3.6885E+00,3.8826E+00,
36330 &4.0815E+00,4.2069E+00,4.5481E+00,4.8830E+00,5.2116E+00,5.5351E+00,
36331 &5.8553E+00,6.1665E+00,6.4745E+00,6.7767E+00,7.0735E+00,7.3628E+00,
36332 &7.6283E+00,0.0000E+00,2.3948E+00,2.3665E+00,2.3388E+00,2.3126E+00,
36333 &2.2860E+00,2.2592E+00,2.2327E+00,2.2065E+00,2.1810E+00,2.1541E+00,
36334 &2.1284E+00,2.1020E+00,2.0760E+00,2.0605E+00,2.0443E+00,2.0259E+00,
36335 &2.0068E+00,1.9873E+00,1.9676E+00,1.9500E+00,1.9312E+00,1.9081E+00,
36336 &1.8860E+00,1.8635E+00,1.8406E+00,1.8221E+00,1.8007E+00,1.7764E+00,
36337 &1.7489E+00,1.7195E+00,1.6855E+00,1.6600E+00,1.6332E+00,1.6031E+00,
36338 &1.5760E+00,1.5532E+00,1.5397E+00,1.5376E+00,1.5507E+00,1.5929E+00,
36339 &1.6784E+00,1.7759E+00,1.9129E+00,2.0531E+00,2.2292E+00,2.4032E+00/
36340 DATA (XUVF_L(K),K= 115, 228) /
36341 &2.5752E+00,2.7449E+00,2.9135E+00,3.0810E+00,3.2491E+00,3.4183E+00,
36342 &3.5898E+00,3.7650E+00,3.9437E+00,4.0443E+00,4.3402E+00,4.6262E+00,
36343 &4.9009E+00,5.1640E+00,5.4156E+00,5.6530E+00,5.8759E+00,6.0779E+00,
36344 &6.2540E+00,6.3836E+00,6.4062E+00,0.0000E+00,2.4808E+00,2.4513E+00,
36345 &2.4236E+00,2.3948E+00,2.3680E+00,2.3397E+00,2.3127E+00,2.2853E+00,
36346 &2.2585E+00,2.2307E+00,2.2026E+00,2.1762E+00,2.1490E+00,2.1332E+00,
36347 &2.1164E+00,2.0964E+00,2.0766E+00,2.0565E+00,2.0353E+00,2.0171E+00,
36348 &1.9969E+00,1.9738E+00,1.9501E+00,1.9258E+00,1.9026E+00,1.8821E+00,
36349 &1.8594E+00,1.8330E+00,1.8046E+00,1.7734E+00,1.7378E+00,1.7112E+00,
36350 &1.6829E+00,1.6514E+00,1.6228E+00,1.5994E+00,1.5840E+00,1.5808E+00,
36351 &1.5927E+00,1.6334E+00,1.7157E+00,1.8093E+00,1.9406E+00,2.0735E+00,
36352 &2.2394E+00,2.4019E+00,2.5615E+00,2.7178E+00,2.8718E+00,3.0246E+00,
36353 &3.1766E+00,3.3284E+00,3.4820E+00,3.6370E+00,3.7952E+00,3.8716E+00,
36354 &4.1225E+00,4.3580E+00,4.5798E+00,4.7847E+00,4.9730E+00,5.1395E+00,
36355 &5.2832E+00,5.3945E+00,5.4634E+00,5.4612E+00,5.2940E+00,0.0000E+00,
36356 &2.5823E+00,2.5527E+00,2.5226E+00,2.4928E+00,2.4650E+00,2.4358E+00,
36357 &2.4071E+00,2.3783E+00,2.3505E+00,2.3212E+00,2.2928E+00,2.2636E+00,
36358 &2.2360E+00,2.2185E+00,2.2005E+00,2.1801E+00,2.1591E+00,2.1376E+00,
36359 &2.1153E+00,2.0960E+00,2.0747E+00,2.0505E+00,2.0247E+00,1.9991E+00/
36360 DATA (XUVF_L(K),K= 229, 342) /
36361 &1.9746E+00,1.9523E+00,1.9287E+00,1.9000E+00,1.8693E+00,1.8361E+00,
36362 &1.7994E+00,1.7711E+00,1.7409E+00,1.7076E+00,1.6772E+00,1.6517E+00,
36363 &1.6345E+00,1.6302E+00,1.6408E+00,1.6789E+00,1.7574E+00,1.8457E+00,
36364 &1.9692E+00,2.0939E+00,2.2474E+00,2.3969E+00,2.5419E+00,2.6837E+00,
36365 &2.8216E+00,2.9573E+00,3.0915E+00,3.2246E+00,3.3583E+00,3.4917E+00,
36366 &3.6273E+00,3.6791E+00,3.8823E+00,4.0673E+00,4.2350E+00,4.3813E+00,
36367 &4.5072E+00,4.6083E+00,4.6757E+00,4.7055E+00,4.6825E+00,4.5674E+00,
36368 &4.2566E+00,0.0000E+00,2.7025E+00,2.6705E+00,2.6393E+00,2.6093E+00,
36369 &2.5790E+00,2.5484E+00,2.5184E+00,2.4880E+00,2.4590E+00,2.4277E+00,
36370 &2.3971E+00,2.3669E+00,2.3380E+00,2.3200E+00,2.3002E+00,2.2782E+00,
36371 &2.2557E+00,2.2331E+00,2.2092E+00,2.1887E+00,2.1660E+00,2.1400E+00,
36372 &2.1126E+00,2.0859E+00,2.0586E+00,2.0351E+00,2.0094E+00,1.9786E+00,
36373 &1.9453E+00,1.9096E+00,1.8707E+00,1.8406E+00,1.8084E+00,1.7728E+00,
36374 &1.7392E+00,1.7128E+00,1.6933E+00,1.6875E+00,1.6949E+00,1.7295E+00,
36375 &1.8023E+00,1.8845E+00,1.9991E+00,2.1134E+00,2.2525E+00,2.3868E+00,
36376 &2.5160E+00,2.6405E+00,2.7609E+00,2.8781E+00,2.9929E+00,3.1059E+00,
36377 &3.2180E+00,3.3292E+00,3.4407E+00,3.4675E+00,3.6225E+00,3.7573E+00,
36378 &3.8710E+00,3.9617E+00,4.0270E+00,4.0642E+00,4.0675E+00,4.0263E+00,
36379 &3.9240E+00,3.7262E+00,3.3217E+00,0.0000E+00,2.8135E+00,2.7813E+00/
36380 DATA (XUVF_L(K),K= 343, 456) /
36381 &2.7489E+00,2.7166E+00,2.6850E+00,2.6527E+00,2.6212E+00,2.5898E+00,
36382 &2.5592E+00,2.5267E+00,2.4943E+00,2.4636E+00,2.4320E+00,2.4129E+00,
36383 &2.3929E+00,2.3695E+00,2.3453E+00,2.3211E+00,2.2959E+00,2.2740E+00,
36384 &2.2496E+00,2.2221E+00,2.1931E+00,2.1653E+00,2.1356E+00,2.1112E+00,
36385 &2.0830E+00,2.0503E+00,2.0147E+00,1.9766E+00,1.9361E+00,1.9037E+00,
36386 &1.8696E+00,1.8318E+00,1.7966E+00,1.7677E+00,1.7459E+00,1.7378E+00,
36387 &1.7430E+00,1.7738E+00,1.8407E+00,1.9169E+00,2.0223E+00,2.1273E+00,
36388 &2.2537E+00,2.3742E+00,2.4892E+00,2.5990E+00,2.7043E+00,2.8056E+00,
36389 &2.9038E+00,3.0000E+00,3.0936E+00,3.1864E+00,3.2782E+00,3.2867E+00,
36390 &3.4021E+00,3.4971E+00,3.5691E+00,3.6188E+00,3.6422E+00,3.6335E+00,
36391 &3.5908E+00,3.5036E+00,3.3552E+00,3.1085E+00,2.6634E+00,0.0000E+00,
36392 &2.9406E+00,2.9062E+00,2.8726E+00,2.8385E+00,2.8060E+00,2.7720E+00,
36393 &2.7392E+00,2.7058E+00,2.6734E+00,2.6399E+00,2.6057E+00,2.5722E+00,
36394 &2.5390E+00,2.5194E+00,2.4975E+00,2.4728E+00,2.4471E+00,2.4216E+00,
36395 &2.3945E+00,2.3712E+00,2.3458E+00,2.3152E+00,2.2856E+00,2.2545E+00,
36396 &2.2237E+00,2.1966E+00,2.1672E+00,2.1312E+00,2.0926E+00,2.0521E+00,
36397 &2.0093E+00,1.9748E+00,1.9384E+00,1.8975E+00,1.8601E+00,1.8275E+00,
36398 &1.8036E+00,1.7924E+00,1.7948E+00,1.8206E+00,1.8808E+00,1.9499E+00,
36399 &2.0450E+00,2.1390E+00,2.2512E+00,2.3570E+00,2.4564E+00,2.5501E+00/
36400 DATA (XUVF_L(K),K= 457, 570) /
36401 &2.6391E+00,2.7240E+00,2.8053E+00,2.8834E+00,2.9590E+00,3.0326E+00,
36402 &3.1042E+00,3.0942E+00,3.1727E+00,3.2289E+00,3.2628E+00,3.2739E+00,
36403 &3.2574E+00,3.2103E+00,3.1297E+00,3.0047E+00,2.8211E+00,2.5467E+00,
36404 &2.0897E+00,0.0000E+00,3.0557E+00,3.0193E+00,2.9840E+00,2.9497E+00,
36405 &2.9150E+00,2.8801E+00,2.8454E+00,2.8109E+00,2.7771E+00,2.7412E+00,
36406 &2.7065E+00,2.6716E+00,2.6360E+00,2.6149E+00,2.5923E+00,2.5663E+00,
36407 &2.5395E+00,2.5120E+00,2.4834E+00,2.4589E+00,2.4330E+00,2.4011E+00,
36408 &2.3676E+00,2.3363E+00,2.3027E+00,2.2736E+00,2.2422E+00,2.2040E+00,
36409 &2.1629E+00,2.1194E+00,2.0750E+00,2.0384E+00,1.9996E+00,1.9565E+00,
36410 &1.9160E+00,1.8811E+00,1.8541E+00,1.8409E+00,1.8399E+00,1.8611E+00,
36411 &1.9143E+00,1.9764E+00,2.0622E+00,2.1459E+00,2.2457E+00,2.3385E+00,
36412 &2.4249E+00,2.5051E+00,2.5806E+00,2.6515E+00,2.7182E+00,2.7823E+00,
36413 &2.8427E+00,2.9008E+00,2.9564E+00,2.9332E+00,2.9828E+00,3.0094E+00,
36414 &3.0142E+00,2.9955E+00,2.9537E+00,2.8796E+00,2.7735E+00,2.6260E+00,
36415 &2.4242E+00,2.1388E+00,1.6900E+00,0.0000E+00,3.1718E+00,3.1348E+00,
36416 &3.0971E+00,3.0610E+00,3.0260E+00,2.9896E+00,2.9533E+00,2.9173E+00,
36417 &2.8818E+00,2.8449E+00,2.8072E+00,2.7709E+00,2.7340E+00,2.7121E+00,
36418 &2.6877E+00,2.6605E+00,2.6319E+00,2.6032E+00,2.5732E+00,2.5471E+00,
36419 &2.5180E+00,2.4851E+00,2.4511E+00,2.4170E+00,2.3817E+00,2.3505E+00/
36420 DATA (XUVF_L(K),K= 571, 684) /
36421 &2.3172E+00,2.2762E+00,2.2328E+00,2.1868E+00,2.1400E+00,2.1012E+00,
36422 &2.0601E+00,2.0136E+00,1.9704E+00,1.9335E+00,1.9035E+00,1.8868E+00,
36423 &1.8827E+00,1.8990E+00,1.9452E+00,2.0005E+00,2.0763E+00,2.1507E+00,
36424 &2.2377E+00,2.3179E+00,2.3917E+00,2.4592E+00,2.5218E+00,2.5799E+00,
36425 &2.6336E+00,2.6843E+00,2.7314E+00,2.7753E+00,2.8166E+00,2.7824E+00,
36426 &2.8054E+00,2.8081E+00,2.7893E+00,2.7474E+00,2.6818E+00,2.5888E+00,
36427 &2.4646E+00,2.3032E+00,2.0902E+00,1.8025E+00,1.3740E+00,0.0000E+00,
36428 &3.2793E+00,3.2385E+00,3.2014E+00,3.1643E+00,3.1270E+00,3.0888E+00,
36429 &3.0517E+00,3.0141E+00,2.9773E+00,2.9392E+00,2.9009E+00,2.8610E+00,
36430 &2.8230E+00,2.8000E+00,2.7754E+00,2.7459E+00,2.7163E+00,2.6858E+00,
36431 &2.6545E+00,2.6270E+00,2.5962E+00,2.5617E+00,2.5271E+00,2.4903E+00,
36432 &2.4527E+00,2.4207E+00,2.3851E+00,2.3421E+00,2.2960E+00,2.2476E+00,
36433 &2.1987E+00,2.1578E+00,2.1146E+00,2.0670E+00,2.0202E+00,1.9796E+00,
36434 &1.9468E+00,1.9282E+00,1.9203E+00,1.9319E+00,1.9712E+00,2.0197E+00,
36435 &2.0872E+00,2.1524E+00,2.2288E+00,2.2981E+00,2.3606E+00,2.4177E+00,
36436 &2.4692E+00,2.5159E+00,2.5591E+00,2.5981E+00,2.6339E+00,2.6669E+00,
36437 &2.6962E+00,2.6528E+00,2.6566E+00,2.6395E+00,2.6028E+00,2.5437E+00,
36438 &2.4622E+00,2.3555E+00,2.2200E+00,2.0488E+00,1.8335E+00,1.5506E+00,
36439 &1.1442E+00,0.0000E+00,3.3868E+00,3.3470E+00,3.3075E+00,3.2689E+00/
36440 DATA (XUVF_L(K),K= 685, 798) /
36441 &3.2300E+00,3.1909E+00,3.1517E+00,3.1129E+00,3.0747E+00,3.0335E+00,
36442 &2.9946E+00,2.9537E+00,2.9140E+00,2.8896E+00,2.8638E+00,2.8337E+00,
36443 &2.8021E+00,2.7705E+00,2.7373E+00,2.7075E+00,2.6767E+00,2.6403E+00,
36444 &2.6031E+00,2.5649E+00,2.5258E+00,2.4917E+00,2.4537E+00,2.4080E+00,
36445 &2.3597E+00,2.3091E+00,2.2580E+00,2.2150E+00,2.1692E+00,2.1186E+00,
36446 &2.0701E+00,2.0257E+00,1.9901E+00,1.9679E+00,1.9571E+00,1.9629E+00,
36447 &1.9955E+00,2.0378E+00,2.0963E+00,2.1529E+00,2.2178E+00,2.2766E+00,
36448 &2.3287E+00,2.3749E+00,2.4162E+00,2.4529E+00,2.4850E+00,2.5140E+00,
36449 &2.5392E+00,2.5617E+00,2.5798E+00,2.5298E+00,2.5151E+00,2.4811E+00,
36450 &2.4282E+00,2.3561E+00,2.2611E+00,2.1439E+00,2.0005E+00,1.8252E+00,
36451 &1.6091E+00,1.3345E+00,9.5375E-01,0.0000E+00,3.4912E+00,3.4507E+00,
36452 &3.4100E+00,3.3696E+00,3.3310E+00,3.2893E+00,3.2496E+00,3.2088E+00,
36453 &3.1686E+00,3.1278E+00,3.0865E+00,3.0438E+00,3.0020E+00,2.9766E+00,
36454 &2.9494E+00,2.9180E+00,2.8850E+00,2.8520E+00,2.8174E+00,2.7877E+00,
36455 &2.7550E+00,2.7169E+00,2.6762E+00,2.6369E+00,2.5958E+00,2.5594E+00,
36456 &2.5195E+00,2.4721E+00,2.4211E+00,2.3680E+00,2.3145E+00,2.2695E+00,
36457 &2.2214E+00,2.1684E+00,2.1154E+00,2.0706E+00,2.0303E+00,2.0058E+00,
36458 &1.9909E+00,1.9920E+00,2.0177E+00,2.0531E+00,2.1031E+00,2.1511E+00,
36459 &2.2060E+00,2.2548E+00,2.2972E+00,2.3339E+00,2.3655E+00,2.3927E+00/
36460 DATA (XUVF_L(K),K= 799, 912) /
36461 &2.4159E+00,2.4357E+00,2.4520E+00,2.4644E+00,2.4735E+00,2.4171E+00,
36462 &2.3878E+00,2.3397E+00,2.2743E+00,2.1907E+00,2.0861E+00,1.9611E+00,
36463 &1.8128E+00,1.6351E+00,1.4227E+00,1.1584E+00,8.0371E-01,0.0000E+00,
36464 &3.5892E+00,3.5473E+00,3.5055E+00,3.4637E+00,3.4230E+00,3.3809E+00,
36465 &3.3396E+00,3.2976E+00,3.2571E+00,3.2126E+00,3.1696E+00,3.1272E+00,
36466 &3.0840E+00,3.0569E+00,3.0286E+00,2.9959E+00,2.9619E+00,2.9273E+00,
36467 &2.8910E+00,2.8598E+00,2.8266E+00,2.7863E+00,2.7448E+00,2.7029E+00,
36468 &2.6598E+00,2.6219E+00,2.5804E+00,2.5305E+00,2.4773E+00,2.4214E+00,
36469 &2.3662E+00,2.3191E+00,2.2698E+00,2.2126E+00,2.1577E+00,2.1092E+00,
36470 &2.0674E+00,2.0393E+00,2.0210E+00,2.0173E+00,2.0367E+00,2.0654E+00,
36471 &2.1076E+00,2.1485E+00,2.1942E+00,2.2338E+00,2.2678E+00,2.2959E+00,
36472 &2.3193E+00,2.3386E+00,2.3539E+00,2.3660E+00,2.3738E+00,2.3789E+00,
36473 &2.3799E+00,2.3197E+00,2.2776E+00,2.2186E+00,2.1426E+00,2.0495E+00,
36474 &1.9397E+00,1.8097E+00,1.6583E+00,1.4814E+00,1.2736E+00,1.0200E+00,
36475 &6.8880E-01,0.0000E+00,3.7157E+00,3.6699E+00,3.6275E+00,3.5842E+00,
36476 &3.5420E+00,3.4972E+00,3.4542E+00,3.4107E+00,3.3678E+00,3.3234E+00,
36477 &3.2774E+00,3.2332E+00,3.1870E+00,3.1600E+00,3.1297E+00,3.0952E+00,
36478 &3.0595E+00,3.0231E+00,2.9850E+00,2.9534E+00,2.9160E+00,2.8740E+00,
36479 &2.8312E+00,2.7872E+00,2.7408E+00,2.7014E+00,2.6568E+00,2.6045E+00/
36480 DATA (XUVF_L(K),K= 913, 1026) /
36481 &2.5481E+00,2.4895E+00,2.4315E+00,2.3817E+00,2.3283E+00,2.2697E+00,
36482 &2.2106E+00,2.1591E+00,2.1128E+00,2.0807E+00,2.0578E+00,2.0477E+00,
36483 &2.0583E+00,2.0796E+00,2.1122E+00,2.1433E+00,2.1777E+00,2.2069E+00,
36484 &2.2299E+00,2.2483E+00,2.2618E+00,2.2718E+00,2.2778E+00,2.2803E+00,
36485 &2.2797E+00,2.2749E+00,2.2668E+00,2.2019E+00,2.1468E+00,2.0761E+00,
36486 &1.9902E+00,1.8883E+00,1.7711E+00,1.6370E+00,1.4847E+00,1.3103E+00,
36487 &1.1091E+00,8.7047E-01,5.6856E-01,0.0000E+00,3.8327E+00,3.7877E+00,
36488 &3.7424E+00,3.6981E+00,3.6540E+00,3.6083E+00,3.5637E+00,3.5184E+00,
36489 &3.4753E+00,3.4271E+00,3.3800E+00,3.3325E+00,3.2860E+00,3.2564E+00,
36490 &3.2258E+00,3.1893E+00,3.1519E+00,3.1135E+00,3.0738E+00,3.0389E+00,
36491 &3.0010E+00,2.9580E+00,2.9118E+00,2.8654E+00,2.8178E+00,2.7758E+00,
36492 &2.7289E+00,2.6738E+00,2.6146E+00,2.5530E+00,2.4924E+00,2.4399E+00,
36493 &2.3845E+00,2.3213E+00,2.2605E+00,2.2040E+00,2.1540E+00,2.1186E+00,
36494 &2.0908E+00,2.0749E+00,2.0772E+00,2.0914E+00,2.1145E+00,2.1368E+00,
36495 &2.1613E+00,2.1804E+00,2.1941E+00,2.2037E+00,2.2088E+00,2.2101E+00,
36496 &2.2083E+00,2.2031E+00,2.1942E+00,2.1826E+00,2.1665E+00,2.0987E+00,
36497 &2.0321E+00,1.9516E+00,1.8571E+00,1.7497E+00,1.6281E+00,1.4923E+00,
36498 &1.3406E+00,1.1697E+00,9.7635E-01,7.5209E-01,4.7638E-01,0.0000E+00,
36499 &3.9497E+00,3.9009E+00,3.8555E+00,3.8080E+00,3.7630E+00,3.7163E+00/
36500 DATA (XUVF_L(K),K= 1027, 1140) /
36501 &3.6699E+00,3.6231E+00,3.5765E+00,3.5285E+00,3.4807E+00,3.4305E+00,
36502 &3.3810E+00,3.3511E+00,3.3185E+00,3.2805E+00,3.2414E+00,3.2016E+00,
36503 &3.1598E+00,3.1244E+00,3.0837E+00,3.0383E+00,2.9908E+00,2.9424E+00,
36504 &2.8919E+00,2.8477E+00,2.7990E+00,2.7403E+00,2.6784E+00,2.6142E+00,
36505 &2.5507E+00,2.4960E+00,2.4362E+00,2.3710E+00,2.3058E+00,2.2463E+00,
36506 &2.1931E+00,2.1539E+00,2.1216E+00,2.0996E+00,2.0940E+00,2.1012E+00,
36507 &2.1154E+00,2.1294E+00,2.1444E+00,2.1543E+00,2.1597E+00,2.1610E+00,
36508 &2.1585E+00,2.1523E+00,2.1432E+00,2.1307E+00,2.1155E+00,2.0964E+00,
36509 &2.0742E+00,2.0035E+00,1.9273E+00,1.8396E+00,1.7387E+00,1.6273E+00,
36510 &1.5032E+00,1.3665E+00,1.2164E+00,1.0501E+00,8.6515E-01,6.5470E-01,
36511 &4.0284E-01,0.0000E+00,4.0572E+00,4.0093E+00,3.9616E+00,3.9140E+00,
36512 &3.8670E+00,3.8185E+00,3.7706E+00,3.7224E+00,3.6746E+00,3.6251E+00,
36513 &3.5744E+00,3.5233E+00,3.4720E+00,3.4406E+00,3.4062E+00,3.3671E+00,
36514 &3.3263E+00,3.2847E+00,3.2414E+00,3.2046E+00,3.1620E+00,3.1150E+00,
36515 &3.0653E+00,3.0145E+00,2.9619E+00,2.9153E+00,2.8641E+00,2.8032E+00,
36516 &2.7388E+00,2.6715E+00,2.6056E+00,2.5481E+00,2.4880E+00,2.4171E+00,
36517 &2.3496E+00,2.2862E+00,2.2282E+00,2.1865E+00,2.1502E+00,2.1217E+00,
36518 &2.1086E+00,2.1086E+00,2.1149E+00,2.1216E+00,2.1275E+00,2.1295E+00,
36519 &2.1273E+00,2.1212E+00,2.1119E+00,2.0992E+00,2.0837E+00,2.0653E+00/
36520 DATA (XUVF_L(K),K= 1141, 1254) /
36521 &2.0442E+00,2.0194E+00,1.9912E+00,1.9193E+00,1.8359E+00,1.7412E+00,
36522 &1.6366E+00,1.5214E+00,1.3956E+00,1.2594E+00,1.1115E+00,9.5033E-01,
36523 &7.7356E-01,5.7585E-01,3.4506E-01,0.0000E+00,4.1710E+00,4.1201E+00,
36524 &4.0712E+00,4.0213E+00,3.9730E+00,3.9228E+00,3.8734E+00,3.8233E+00,
36525 &3.7726E+00,3.7217E+00,3.6699E+00,3.6160E+00,3.5640E+00,3.5311E+00,
36526 &3.4960E+00,3.4549E+00,3.4121E+00,3.3689E+00,3.3237E+00,3.2848E+00,
36527 &3.2425E+00,3.1917E+00,3.1399E+00,3.0866E+00,3.0319E+00,2.9838E+00,
36528 &2.9306E+00,2.8668E+00,2.7992E+00,2.7291E+00,2.6605E+00,2.6007E+00,
36529 &2.5375E+00,2.4631E+00,2.3919E+00,2.3261E+00,2.2643E+00,2.2183E+00,
36530 &2.1772E+00,2.1426E+00,2.1222E+00,2.1155E+00,2.1135E+00,2.1130E+00,
36531 &2.1102E+00,2.1039E+00,2.0941E+00,2.0815E+00,2.0652E+00,2.0466E+00,
36532 &2.0251E+00,2.0014E+00,1.9746E+00,1.9450E+00,1.9116E+00,1.8381E+00,
36533 &1.7481E+00,1.6484E+00,1.5404E+00,1.4225E+00,1.2963E+00,1.1611E+00,
36534 &1.0161E+00,8.6047E-01,6.9193E-01,5.0691E-01,2.9581E-01,0.0000E+00,
36535 &4.2754E+00,4.2238E+00,4.1737E+00,4.1233E+00,4.0740E+00,4.0219E+00,
36536 &3.9713E+00,3.9196E+00,3.8675E+00,3.8160E+00,3.7618E+00,3.7060E+00,
36537 &3.6510E+00,3.6173E+00,3.5808E+00,3.5380E+00,3.4941E+00,3.4493E+00,
36538 &3.4027E+00,3.3623E+00,3.3163E+00,3.2647E+00,3.2114E+00,3.1563E+00,
36539 &3.0989E+00,3.0489E+00,2.9929E+00,2.9263E+00,2.8563E+00,2.7837E+00/
36540 DATA (XUVF_L(K),K= 1255, 1368) /
36541 &2.7122E+00,2.6501E+00,2.5825E+00,2.5073E+00,2.4327E+00,2.3623E+00,
36542 &2.2962E+00,2.2474E+00,2.2020E+00,2.1616E+00,2.1335E+00,2.1209E+00,
36543 &2.1113E+00,2.1034E+00,2.0929E+00,2.0795E+00,2.0634E+00,2.0439E+00,
36544 &2.0222E+00,1.9982E+00,1.9716E+00,1.9428E+00,1.9113E+00,1.8773E+00,
36545 &1.8394E+00,1.7649E+00,1.6692E+00,1.5658E+00,1.4547E+00,1.3360E+00,
36546 &1.2095E+00,1.0761E+00,9.3485E-01,7.8430E-01,6.2380E-01,4.5010E-01,
36547 &2.5625E-01,0.0000E+00,4.3798E+00,4.3275E+00,4.2762E+00,4.2239E+00,
36548 &4.1730E+00,4.1196E+00,4.0674E+00,4.0143E+00,3.9623E+00,3.9056E+00,
36549 &3.8502E+00,3.7935E+00,3.7370E+00,3.7018E+00,3.6642E+00,3.6200E+00,
36550 &3.5742E+00,3.5277E+00,3.4786E+00,3.4371E+00,3.3901E+00,3.3359E+00,
36551 &3.2800E+00,3.2235E+00,3.1639E+00,3.1115E+00,3.0537E+00,2.9847E+00,
36552 &2.9116E+00,2.8364E+00,2.7623E+00,2.6973E+00,2.6275E+00,2.5497E+00,
36553 &2.4705E+00,2.3972E+00,2.3281E+00,2.2747E+00,2.2253E+00,2.1793E+00,
36554 &2.1444E+00,2.1253E+00,2.1081E+00,2.0939E+00,2.0755E+00,2.0555E+00,
36555 &2.0332E+00,2.0081E+00,1.9814E+00,1.9522E+00,1.9205E+00,1.8875E+00,
36556 &1.8520E+00,1.8139E+00,1.7725E+00,1.6968E+00,1.5976E+00,1.4911E+00,
36557 &1.3772E+00,1.2577E+00,1.1320E+00,1.0005E+00,8.6242E-01,7.1750E-01,
36558 &5.6466E-01,4.0150E-01,2.2333E-01,0.0000E+00,4.4809E+00,4.4265E+00,
36559 &4.3735E+00,4.3193E+00,4.2670E+00,4.2128E+00,4.1585E+00,4.1039E+00/
36560 DATA (XUVF_L(K),K= 1369, 1482) /
36561 &4.0509E+00,3.9928E+00,3.9351E+00,3.8769E+00,3.8180E+00,3.7821E+00,
36562 &3.7434E+00,3.6974E+00,3.6501E+00,3.6019E+00,3.5513E+00,3.5093E+00,
36563 &3.4594E+00,3.4035E+00,3.3456E+00,3.2870E+00,3.2250E+00,3.1715E+00,
36564 &3.1110E+00,3.0396E+00,2.9639E+00,2.8863E+00,2.8096E+00,2.7429E+00,
36565 &2.6702E+00,2.5884E+00,2.5068E+00,2.4296E+00,2.3560E+00,2.3003E+00,
36566 &2.2464E+00,2.1951E+00,2.1530E+00,2.1283E+00,2.1045E+00,2.0843E+00,
36567 &2.0591E+00,2.0328E+00,2.0047E+00,1.9749E+00,1.9429E+00,1.9096E+00,
36568 &1.8740E+00,1.8369E+00,1.7978E+00,1.7560E+00,1.7116E+00,1.6360E+00,
36569 &1.5322E+00,1.4233E+00,1.3084E+00,1.1885E+00,1.0637E+00,9.3449E-01,
36570 &7.9961E-01,6.6020E-01,5.1453E-01,3.6103E-01,1.9641E-01,0.0000E+00,
36571 &4.6169E+00,4.5608E+00,4.5060E+00,4.4504E+00,4.3960E+00,4.3395E+00,
36572 &4.2837E+00,4.2262E+00,4.1710E+00,4.1106E+00,4.0517E+00,3.9908E+00,
36573 &3.9300E+00,3.8920E+00,3.8509E+00,3.8030E+00,3.7538E+00,3.7035E+00,
36574 &3.6494E+00,3.6055E+00,3.5556E+00,3.4966E+00,3.4351E+00,3.3738E+00,
36575 &3.3090E+00,3.2518E+00,3.1888E+00,3.1141E+00,3.0348E+00,2.9533E+00,
36576 &2.8730E+00,2.8020E+00,2.7264E+00,2.6400E+00,2.5551E+00,2.4732E+00,
36577 &2.3941E+00,2.3329E+00,2.2742E+00,2.2147E+00,2.1644E+00,2.1317E+00,
36578 &2.0986E+00,2.0700E+00,2.0363E+00,2.0021E+00,1.9668E+00,1.9299E+00,
36579 &1.8922E+00,1.8532E+00,1.8125E+00,1.7704E+00,1.7270E+00,1.6809E+00/
36580 DATA (XUVF_L(K),K= 1483, 1596) /
36581 &1.6327E+00,1.5570E+00,1.4497E+00,1.3373E+00,1.2215E+00,1.1020E+00,
36582 &9.7897E-01,8.5304E-01,7.2349E-01,5.9074E-01,4.5411E-01,3.1307E-01,
36583 &1.6547E-01,0.0000E+00,4.7403E+00,4.6834E+00,4.6262E+00,4.5696E+00,
36584 &4.5140E+00,4.4557E+00,4.3978E+00,4.3393E+00,4.2817E+00,4.2191E+00,
36585 &4.1578E+00,4.0941E+00,4.0310E+00,3.9917E+00,3.9492E+00,3.8995E+00,
36586 &3.8481E+00,3.7958E+00,3.7411E+00,3.6937E+00,3.6405E+00,3.5806E+00,
36587 &3.5171E+00,3.4520E+00,3.3840E+00,3.3254E+00,3.2596E+00,3.1812E+00,
36588 &3.0985E+00,3.0137E+00,2.9301E+00,2.8556E+00,2.7782E+00,2.6879E+00,
36589 &2.5974E+00,2.5119E+00,2.4281E+00,2.3629E+00,2.2982E+00,2.2324E+00,
36590 &2.1730E+00,2.1332E+00,2.0922E+00,2.0570E+00,2.0152E+00,1.9739E+00,
36591 &1.9323E+00,1.8902E+00,1.8474E+00,1.8039E+00,1.7589E+00,1.7129E+00,
36592 &1.6654E+00,1.6163E+00,1.5652E+00,1.4896E+00,1.3789E+00,1.2649E+00,
36593 &1.1487E+00,1.0300E+00,9.0896E-01,7.8619E-01,6.6149E-01,5.3498E-01,
36594 &4.0654E-01,2.7586E-01,1.4208E-01,0.0000E+00,4.8699E+00,4.8107E+00,
36595 &4.7518E+00,4.6928E+00,4.6350E+00,4.5750E+00,4.5152E+00,4.4524E+00,
36596 &4.3956E+00,4.3299E+00,4.2674E+00,4.2014E+00,4.1350E+00,4.0939E+00,
36597 &4.0503E+00,3.9982E+00,3.9448E+00,3.8905E+00,3.8328E+00,3.7846E+00,
36598 &3.7300E+00,3.6664E+00,3.5991E+00,3.5326E+00,3.4620E+00,3.3998E+00,
36599 &3.3311E+00,3.2494E+00,3.1632E+00,3.0752E+00,2.9881E+00,2.9120E+00/
36600 DATA (XUVF_L(K),K= 1597, 1710) /
36601 &2.8299E+00,2.7339E+00,2.6398E+00,2.5493E+00,2.4611E+00,2.3911E+00,
36602 &2.3215E+00,2.2482E+00,2.1812E+00,2.1342E+00,2.0854E+00,2.0427E+00,
36603 &1.9932E+00,1.9453E+00,1.8978E+00,1.8504E+00,1.8030E+00,1.7545E+00,
36604 &1.7059E+00,1.6565E+00,1.6056E+00,1.5535E+00,1.4989E+00,1.4245E+00,
36605 &1.3108E+00,1.1959E+00,1.0798E+00,9.6219E-01,8.4358E-01,7.2422E-01,
36606 &6.0451E-01,4.8425E-01,3.6380E-01,2.4286E-01,1.2189E-01,0.0000E+00,
36607 &4.9964E+00,4.9356E+00,4.8755E+00,4.8147E+00,4.7550E+00,4.6935E+00,
36608 &4.6315E+00,4.5697E+00,4.5062E+00,4.4406E+00,4.3752E+00,4.3061E+00,
36609 &4.2380E+00,4.1962E+00,4.1500E+00,4.0963E+00,4.0405E+00,3.9832E+00,
36610 &3.9245E+00,3.8728E+00,3.8172E+00,3.7504E+00,3.6811E+00,3.6108E+00,
36611 &3.5381E+00,3.4734E+00,3.4018E+00,3.3164E+00,3.2269E+00,3.1352E+00,
36612 &3.0446E+00,2.9657E+00,2.8794E+00,2.7800E+00,2.6821E+00,2.5867E+00,
36613 &2.4930E+00,2.4184E+00,2.3433E+00,2.2634E+00,2.1877E+00,2.1342E+00,
36614 &2.0772E+00,2.0279E+00,1.9713E+00,1.9172E+00,1.8642E+00,1.8120E+00,
36615 &1.7600E+00,1.7076E+00,1.6553E+00,1.6027E+00,1.5491E+00,1.4938E+00,
36616 &1.4374E+00,1.3637E+00,1.2481E+00,1.1325E+00,1.0166E+00,9.0047E-01,
36617 &7.8428E-01,6.6889E-01,5.5381E-01,4.3953E-01,3.2652E-01,2.1461E-01,
36618 &1.0498E-01,0.0000E+00,5.1134E+00,5.0511E+00,4.9886E+00,4.9273E+00,
36619 &4.8660E+00,4.8016E+00,4.7382E+00,4.6744E+00,4.6106E+00,4.5420E+00/
36620 DATA (XUVF_L(K),K= 1711, 1824) /
36621 &4.4742E+00,4.4028E+00,4.3320E+00,4.2892E+00,4.2413E+00,4.1858E+00,
36622 &4.1281E+00,4.0682E+00,4.0067E+00,3.9556E+00,3.8955E+00,3.8271E+00,
36623 &3.7556E+00,3.6829E+00,3.6071E+00,3.5401E+00,3.4662E+00,3.3777E+00,
36624 &3.2849E+00,3.1898E+00,3.0960E+00,3.0140E+00,2.9244E+00,2.8224E+00,
36625 &2.7183E+00,2.6191E+00,2.5219E+00,2.4431E+00,2.3628E+00,2.2767E+00,
36626 &2.1931E+00,2.1332E+00,2.0695E+00,2.0145E+00,1.9514E+00,1.8920E+00,
36627 &1.8340E+00,1.7775E+00,1.7215E+00,1.6664E+00,1.6108E+00,1.5553E+00,
36628 &1.4995E+00,1.4421E+00,1.3839E+00,1.3103E+00,1.1944E+00,1.0782E+00,
36629 &9.6271E-01,8.4822E-01,7.3481E-01,6.2240E-01,5.1184E-01,4.0291E-01,
36630 &2.9618E-01,1.9206E-01,9.1846E-02,0.0000E+00,5.2367E+00,5.1713E+00,
36631 &5.1071E+00,5.0425E+00,4.9800E+00,4.9141E+00,4.8489E+00,4.7833E+00,
36632 &4.7181E+00,4.6457E+00,4.5768E+00,4.5034E+00,4.4300E+00,4.3847E+00,
36633 &4.3353E+00,4.2782E+00,4.2182E+00,4.1570E+00,4.0921E+00,4.0385E+00,
36634 &3.9782E+00,3.9074E+00,3.8331E+00,3.7575E+00,3.6781E+00,3.6086E+00,
36635 &3.5313E+00,3.4401E+00,3.3439E+00,3.2455E+00,3.1483E+00,3.0623E+00,
36636 &2.9694E+00,2.8629E+00,2.7561E+00,2.6527E+00,2.5508E+00,2.4669E+00,
36637 &2.3816E+00,2.2887E+00,2.1979E+00,2.1317E+00,2.0613E+00,2.0002E+00,
36638 &1.9307E+00,1.8659E+00,1.8033E+00,1.7426E+00,1.6834E+00,1.6247E+00,
36639 &1.5668E+00,1.5085E+00,1.4504E+00,1.3916E+00,1.3311E+00,1.2591E+00/
36640 DATA (XUVF_L(K),K= 1825, 1836) /
36641 &1.1415E+00,1.0256E+00,9.1107E-01,7.9840E-01,6.8736E-01,5.7902E-01,
36642 &4.7260E-01,3.6895E-01,2.6838E-01,1.7161E-01,8.0264E-02,0.0000E+00/
36643 DATA (XDVF_L(K),K= 1, 114) /
36644 &1.4230E+00,1.4064E+00,1.3903E+00,1.3749E+00,1.3590E+00,1.3424E+00,
36645 &1.3271E+00,1.3114E+00,1.2962E+00,1.2803E+00,1.2647E+00,1.2492E+00,
36646 &1.2340E+00,1.2246E+00,1.2155E+00,1.2044E+00,1.1927E+00,1.1814E+00,
36647 &1.1695E+00,1.1589E+00,1.1479E+00,1.1347E+00,1.1214E+00,1.1080E+00,
36648 &1.0944E+00,1.0824E+00,1.0700E+00,1.0544E+00,1.0371E+00,1.0188E+00,
36649 &9.9884E-01,9.8287E-01,9.6563E-01,9.4645E-01,9.2847E-01,9.1313E-01,
36650 &9.0246E-01,8.9955E-01,9.0461E-01,9.2737E-01,9.7648E-01,1.0343E+00,
36651 &1.1168E+00,1.2030E+00,1.3129E+00,1.4240E+00,1.5357E+00,1.6492E+00,
36652 &1.7643E+00,1.8818E+00,2.0016E+00,2.1253E+00,2.2535E+00,2.3853E+00,
36653 &2.5225E+00,2.5620E+00,2.7906E+00,3.0230E+00,3.2574E+00,3.4983E+00,
36654 &3.7459E+00,4.0062E+00,4.2803E+00,4.5790E+00,4.9150E+00,5.3263E+00,
36655 &5.9228E+00,0.0000E+00,1.4698E+00,1.4526E+00,1.4360E+00,1.4199E+00,
36656 &1.4030E+00,1.3864E+00,1.3702E+00,1.3542E+00,1.3386E+00,1.3221E+00,
36657 &1.3059E+00,1.2896E+00,1.2740E+00,1.2644E+00,1.2544E+00,1.2425E+00,
36658 &1.2309E+00,1.2185E+00,1.2061E+00,1.1953E+00,1.1836E+00,1.1697E+00,
36659 &1.1558E+00,1.1417E+00,1.1275E+00,1.1154E+00,1.1011E+00,1.0844E+00,
36660 &1.0663E+00,1.0471E+00,1.0261E+00,1.0092E+00,9.9133E-01,9.7103E-01,
36661 &9.5184E-01,9.3560E-01,9.2380E-01,9.1922E-01,9.2378E-01,9.4563E-01,
36662 &9.9235E-01,1.0474E+00,1.1262E+00,1.2078E+00,1.3110E+00,1.4146E+00/
36663 DATA (XDVF_L(K),K= 115, 228) /
36664 &1.5192E+00,1.6241E+00,1.7298E+00,1.8375E+00,1.9471E+00,2.0592E+00,
36665 &2.1741E+00,2.2925E+00,2.4144E+00,2.4425E+00,2.6407E+00,2.8375E+00,
36666 &3.0361E+00,3.2345E+00,3.4343E+00,3.6388E+00,3.8488E+00,4.0682E+00,
36667 &4.3043E+00,4.5737E+00,4.9280E+00,0.0000E+00,1.5226E+00,1.5047E+00,
36668 &1.4874E+00,1.4702E+00,1.4530E+00,1.4363E+00,1.4193E+00,1.4023E+00,
36669 &1.3860E+00,1.3690E+00,1.3520E+00,1.3351E+00,1.3190E+00,1.3083E+00,
36670 &1.2983E+00,1.2858E+00,1.2733E+00,1.2606E+00,1.2476E+00,1.2362E+00,
36671 &1.2237E+00,1.2092E+00,1.1943E+00,1.1795E+00,1.1645E+00,1.1509E+00,
36672 &1.1365E+00,1.1185E+00,1.0994E+00,1.0784E+00,1.0566E+00,1.0388E+00,
36673 &1.0195E+00,9.9801E-01,9.7765E-01,9.6019E-01,9.4712E-01,9.4158E-01,
36674 &9.4524E-01,9.6454E-01,1.0088E+00,1.0604E+00,1.1346E+00,1.2112E+00,
36675 &1.3076E+00,1.4038E+00,1.4995E+00,1.5957E+00,1.6918E+00,1.7888E+00,
36676 &1.8877E+00,1.9877E+00,2.0896E+00,2.1940E+00,2.2999E+00,2.3168E+00,
36677 &2.4844E+00,2.6497E+00,2.8098E+00,2.9678E+00,3.1219E+00,3.2743E+00,
36678 &3.4260E+00,3.5742E+00,3.7237E+00,3.8717E+00,4.0300E+00,0.0000E+00,
36679 &1.5849E+00,1.5662E+00,1.5482E+00,1.5298E+00,1.5130E+00,1.4944E+00,
36680 &1.4769E+00,1.4593E+00,1.4423E+00,1.4243E+00,1.4066E+00,1.3894E+00,
36681 &1.3720E+00,1.3607E+00,1.3499E+00,1.3366E+00,1.3237E+00,1.3101E+00,
36682 &1.2963E+00,1.2840E+00,1.2709E+00,1.2553E+00,1.2396E+00,1.2232E+00/
36683 DATA (XDVF_L(K),K= 229, 342) /
36684 &1.2075E+00,1.1932E+00,1.1776E+00,1.1584E+00,1.1377E+00,1.1152E+00,
36685 &1.0922E+00,1.0729E+00,1.0524E+00,1.0294E+00,1.0074E+00,9.8843E-01,
36686 &9.7377E-01,9.6751E-01,9.6901E-01,9.8606E-01,1.0264E+00,1.0745E+00,
36687 &1.1435E+00,1.2136E+00,1.3018E+00,1.3894E+00,1.4758E+00,1.5619E+00,
36688 &1.6474E+00,1.7332E+00,1.8194E+00,1.9063E+00,1.9941E+00,2.0832E+00,
36689 &2.1725E+00,2.1789E+00,2.3166E+00,2.4460E+00,2.5708E+00,2.6884E+00,
36690 &2.7987E+00,2.9025E+00,2.9974E+00,3.0823E+00,3.1538E+00,3.2013E+00,
36691 &3.2043E+00,0.0000E+00,1.6586E+00,1.6391E+00,1.6202E+00,1.6014E+00,
36692 &1.5830E+00,1.5638E+00,1.5457E+00,1.5267E+00,1.5087E+00,1.4899E+00,
36693 &1.4711E+00,1.4517E+00,1.4340E+00,1.4224E+00,1.4107E+00,1.3972E+00,
36694 &1.3827E+00,1.3684E+00,1.3535E+00,1.3404E+00,1.3263E+00,1.3096E+00,
36695 &1.2927E+00,1.2758E+00,1.2575E+00,1.2422E+00,1.2250E+00,1.2046E+00,
36696 &1.1821E+00,1.1579E+00,1.1331E+00,1.1127E+00,1.0905E+00,1.0655E+00,
36697 &1.0415E+00,1.0207E+00,1.0042E+00,9.9612E-01,9.9507E-01,1.0089E+00,
36698 &1.0451E+00,1.0887E+00,1.1514E+00,1.2146E+00,1.2936E+00,1.3711E+00,
36699 &1.4469E+00,1.5220E+00,1.5960E+00,1.6694E+00,1.7428E+00,1.8159E+00,
36700 &1.8894E+00,1.9620E+00,2.0344E+00,2.0313E+00,2.1357E+00,2.2333E+00,
36701 &2.3215E+00,2.4009E+00,2.4706E+00,2.5292E+00,2.5750E+00,2.6036E+00,
36702 &2.6096E+00,2.5783E+00,2.4673E+00,0.0000E+00,1.7269E+00,1.7065E+00/
36703 DATA (XDVF_L(K),K= 343, 456) /
36704 &1.6866E+00,1.6676E+00,1.6480E+00,1.6279E+00,1.6089E+00,1.5891E+00,
36705 &1.5701E+00,1.5502E+00,1.5307E+00,1.5113E+00,1.4910E+00,1.4799E+00,
36706 &1.4673E+00,1.4526E+00,1.4373E+00,1.4221E+00,1.4060E+00,1.3922E+00,
36707 &1.3771E+00,1.3596E+00,1.3414E+00,1.3234E+00,1.3045E+00,1.2879E+00,
36708 &1.2689E+00,1.2468E+00,1.2227E+00,1.1966E+00,1.1706E+00,1.1487E+00,
36709 &1.1248E+00,1.0980E+00,1.0724E+00,1.0495E+00,1.0310E+00,1.0212E+00,
36710 &1.0181E+00,1.0291E+00,1.0609E+00,1.1002E+00,1.1563E+00,1.2136E+00,
36711 &1.2840E+00,1.3528E+00,1.4201E+00,1.4854E+00,1.5492E+00,1.6125E+00,
36712 &1.6751E+00,1.7368E+00,1.7981E+00,1.8579E+00,1.9157E+00,1.9057E+00,
36713 &1.9875E+00,2.0577E+00,2.1190E+00,2.1700E+00,2.2094E+00,2.2370E+00,
36714 &2.2484E+00,2.2403E+00,2.2047E+00,2.1261E+00,1.9567E+00,0.0000E+00,
36715 &1.8047E+00,1.7833E+00,1.7626E+00,1.7418E+00,1.7220E+00,1.7009E+00,
36716 &1.6810E+00,1.6603E+00,1.6403E+00,1.6193E+00,1.5986E+00,1.5775E+00,
36717 &1.5570E+00,1.5441E+00,1.5309E+00,1.5156E+00,1.4991E+00,1.4828E+00,
36718 &1.4658E+00,1.4510E+00,1.4350E+00,1.4160E+00,1.3966E+00,1.3772E+00,
36719 &1.3565E+00,1.3386E+00,1.3184E+00,1.2942E+00,1.2680E+00,1.2404E+00,
36720 &1.2125E+00,1.1887E+00,1.1631E+00,1.1342E+00,1.1064E+00,1.0813E+00,
36721 &1.0608E+00,1.0480E+00,1.0426E+00,1.0500E+00,1.0774E+00,1.1111E+00,
36722 &1.1608E+00,1.2107E+00,1.2719E+00,1.3315E+00,1.3886E+00,1.4445E+00/
36723 DATA (XDVF_L(K),K= 457, 570) /
36724 &1.4984E+00,1.5505E+00,1.6020E+00,1.6524E+00,1.7009E+00,1.7480E+00,
36725 &1.7926E+00,1.7763E+00,1.8327E+00,1.8794E+00,1.9154E+00,1.9405E+00,
36726 &1.9531E+00,1.9537E+00,1.9362E+00,1.8986E+00,1.8325E+00,1.7203E+00,
36727 &1.5163E+00,0.0000E+00,1.8755E+00,1.8533E+00,1.8314E+00,1.8106E+00,
36728 &1.7890E+00,1.7672E+00,1.7464E+00,1.7248E+00,1.7038E+00,1.6817E+00,
36729 &1.6601E+00,1.6385E+00,1.6160E+00,1.6033E+00,1.5889E+00,1.5721E+00,
36730 &1.5552E+00,1.5380E+00,1.5199E+00,1.5042E+00,1.4871E+00,1.4670E+00,
36731 &1.4463E+00,1.4249E+00,1.4036E+00,1.3843E+00,1.3630E+00,1.3364E+00,
36732 &1.3086E+00,1.2791E+00,1.2500E+00,1.2245E+00,1.1971E+00,1.1662E+00,
36733 &1.1361E+00,1.1090E+00,1.0858E+00,1.0721E+00,1.0641E+00,1.0676E+00,
36734 &1.0898E+00,1.1195E+00,1.1627E+00,1.2069E+00,1.2603E+00,1.3118E+00,
36735 &1.3607E+00,1.4079E+00,1.4534E+00,1.4968E+00,1.5392E+00,1.5794E+00,
36736 &1.6181E+00,1.6552E+00,1.6888E+00,1.6690E+00,1.7073E+00,1.7353E+00,
36737 &1.7530E+00,1.7595E+00,1.7531E+00,1.7338E+00,1.6988E+00,1.6428E+00,
36738 &1.5583E+00,1.4293E+00,1.2136E+00,0.0000E+00,1.9470E+00,1.9238E+00,
36739 &1.9021E+00,1.8782E+00,1.8570E+00,1.8343E+00,1.8123E+00,1.7898E+00,
36740 &1.7680E+00,1.7449E+00,1.7222E+00,1.6994E+00,1.6760E+00,1.6624E+00,
36741 &1.6469E+00,1.6299E+00,1.6118E+00,1.5933E+00,1.5742E+00,1.5574E+00,
36742 &1.5392E+00,1.5179E+00,1.4955E+00,1.4738E+00,1.4506E+00,1.4300E+00/
36743 DATA (XDVF_L(K),K= 571, 684) /
36744 &1.4069E+00,1.3792E+00,1.3492E+00,1.3178E+00,1.2868E+00,1.2597E+00,
36745 &1.2307E+00,1.1976E+00,1.1654E+00,1.1363E+00,1.1108E+00,1.0945E+00,
36746 &1.0840E+00,1.0845E+00,1.1017E+00,1.1268E+00,1.1637E+00,1.2016E+00,
36747 &1.2473E+00,1.2910E+00,1.3324E+00,1.3719E+00,1.4090E+00,1.4450E+00,
36748 &1.4784E+00,1.5109E+00,1.5404E+00,1.5681E+00,1.5925E+00,1.5689E+00,
36749 &1.5916E+00,1.6043E+00,1.6067E+00,1.5981E+00,1.5779E+00,1.5449E+00,
36750 &1.4949E+00,1.4262E+00,1.3303E+00,1.1932E+00,9.7657E-01,0.0000E+00,
36751 &2.0122E+00,1.9881E+00,1.9640E+00,1.9418E+00,1.9190E+00,1.8954E+00,
36752 &1.8721E+00,1.8492E+00,1.8262E+00,1.8024E+00,1.7784E+00,1.7550E+00,
36753 &1.7300E+00,1.7157E+00,1.6999E+00,1.6818E+00,1.6627E+00,1.6435E+00,
36754 &1.6233E+00,1.6058E+00,1.5866E+00,1.5643E+00,1.5417E+00,1.5178E+00,
36755 &1.4926E+00,1.4705E+00,1.4465E+00,1.4174E+00,1.3856E+00,1.3527E+00,
36756 &1.3198E+00,1.2914E+00,1.2605E+00,1.2257E+00,1.1915E+00,1.1601E+00,
36757 &1.1326E+00,1.1142E+00,1.1016E+00,1.0982E+00,1.1114E+00,1.1321E+00,
36758 &1.1637E+00,1.1958E+00,1.2352E+00,1.2722E+00,1.3071E+00,1.3397E+00,
36759 &1.3704E+00,1.3995E+00,1.4267E+00,1.4516E+00,1.4736E+00,1.4942E+00,
36760 &1.5100E+00,1.4848E+00,1.4955E+00,1.4964E+00,1.4873E+00,1.4675E+00,
36761 &1.4366E+00,1.3933E+00,1.3349E+00,1.2585E+00,1.1565E+00,1.0171E+00,
36762 &8.0601E-01,0.0000E+00,2.0789E+00,2.0539E+00,2.0294E+00,2.0053E+00/
36763 DATA (XDVF_L(K),K= 685, 798) /
36764 &1.9820E+00,1.9581E+00,1.9336E+00,1.9096E+00,1.8860E+00,1.8609E+00,
36765 &1.8367E+00,1.8106E+00,1.7860E+00,1.7706E+00,1.7543E+00,1.7350E+00,
36766 &1.7150E+00,1.6945E+00,1.6735E+00,1.6550E+00,1.6349E+00,1.6112E+00,
36767 &1.5864E+00,1.5617E+00,1.5356E+00,1.5128E+00,1.4868E+00,1.4555E+00,
36768 &1.4224E+00,1.3876E+00,1.3532E+00,1.3231E+00,1.2904E+00,1.2536E+00,
36769 &1.2173E+00,1.1838E+00,1.1545E+00,1.1338E+00,1.1185E+00,1.1113E+00,
36770 &1.1199E+00,1.1362E+00,1.1627E+00,1.1895E+00,1.2222E+00,1.2529E+00,
36771 &1.2813E+00,1.3080E+00,1.3324E+00,1.3546E+00,1.3756E+00,1.3938E+00,
36772 &1.4103E+00,1.4232E+00,1.4319E+00,1.4055E+00,1.4052E+00,1.3959E+00,
36773 &1.3768E+00,1.3480E+00,1.3084E+00,1.2576E+00,1.1928E+00,1.1110E+00,
36774 &1.0066E+00,8.6804E-01,6.6615E-01,0.0000E+00,2.1434E+00,2.1178E+00,
36775 &2.0930E+00,2.0676E+00,2.0440E+00,2.0184E+00,1.9935E+00,1.9686E+00,
36776 &1.9439E+00,1.9179E+00,1.8915E+00,1.8663E+00,1.8400E+00,1.8239E+00,
36777 &1.8067E+00,1.7863E+00,1.7654E+00,1.7440E+00,1.7219E+00,1.7025E+00,
36778 &1.6814E+00,1.6565E+00,1.6311E+00,1.6045E+00,1.5766E+00,1.5526E+00,
36779 &1.5250E+00,1.4925E+00,1.4574E+00,1.4213E+00,1.3849E+00,1.3532E+00,
36780 &1.3191E+00,1.2800E+00,1.2418E+00,1.2062E+00,1.1743E+00,1.1517E+00,
36781 &1.1338E+00,1.1237E+00,1.1272E+00,1.1399E+00,1.1608E+00,1.1828E+00,
36782 &1.2092E+00,1.2341E+00,1.2570E+00,1.2774E+00,1.2962E+00,1.3135E+00/
36783 DATA (XDVF_L(K),K= 799, 912) /
36784 &1.3280E+00,1.3406E+00,1.3511E+00,1.3588E+00,1.3613E+00,1.3335E+00,
36785 &1.3246E+00,1.3067E+00,1.2801E+00,1.2441E+00,1.1985E+00,1.1418E+00,
36786 &1.0724E+00,9.8806E-01,8.8293E-01,7.4746E-01,5.5665E-01,0.0000E+00,
36787 &2.2035E+00,2.1769E+00,2.1514E+00,2.1259E+00,2.1000E+00,2.0743E+00,
36788 &2.0488E+00,2.0226E+00,1.9973E+00,1.9702E+00,1.9428E+00,1.9166E+00,
36789 &1.8890E+00,1.8729E+00,1.8548E+00,1.8337E+00,1.8116E+00,1.7895E+00,
36790 &1.7662E+00,1.7461E+00,1.7239E+00,1.6980E+00,1.6714E+00,1.6436E+00,
36791 &1.6146E+00,1.5889E+00,1.5604E+00,1.5266E+00,1.4895E+00,1.4515E+00,
36792 &1.4138E+00,1.3806E+00,1.3448E+00,1.3040E+00,1.2638E+00,1.2261E+00,
36793 &1.1920E+00,1.1669E+00,1.1469E+00,1.1341E+00,1.1335E+00,1.1420E+00,
36794 &1.1583E+00,1.1760E+00,1.1971E+00,1.2168E+00,1.2343E+00,1.2501E+00,
36795 &1.2640E+00,1.2762E+00,1.2866E+00,1.2942E+00,1.2996E+00,1.3020E+00,
36796 &1.3003E+00,1.2725E+00,1.2557E+00,1.2312E+00,1.1982E+00,1.1569E+00,
36797 &1.1068E+00,1.0465E+00,9.7460E-01,8.8884E-01,7.8459E-01,6.5333E-01,
36798 &4.7359E-01,0.0000E+00,2.2800E+00,2.2524E+00,2.2256E+00,2.1987E+00,
36799 &2.1730E+00,2.1459E+00,2.1192E+00,2.0922E+00,2.0656E+00,2.0374E+00,
36800 &2.0100E+00,1.9802E+00,1.9520E+00,1.9346E+00,1.9156E+00,1.8937E+00,
36801 &1.8706E+00,1.8475E+00,1.8228E+00,1.8017E+00,1.7783E+00,1.7509E+00,
36802 &1.7221E+00,1.6937E+00,1.6627E+00,1.6354E+00,1.6050E+00,1.5688E+00/
36803 DATA (XDVF_L(K),K= 913, 1026) /
36804 &1.5301E+00,1.4898E+00,1.4503E+00,1.4150E+00,1.3772E+00,1.3339E+00,
36805 &1.2911E+00,1.2510E+00,1.2138E+00,1.1866E+00,1.1637E+00,1.1458E+00,
36806 &1.1403E+00,1.1441E+00,1.1548E+00,1.1669E+00,1.1817E+00,1.1950E+00,
36807 &1.2065E+00,1.2163E+00,1.2249E+00,1.2313E+00,1.2355E+00,1.2379E+00,
36808 &1.2379E+00,1.2348E+00,1.2275E+00,1.1987E+00,1.1744E+00,1.1427E+00,
36809 &1.1035E+00,1.0570E+00,1.0018E+00,9.3862E-01,8.6494E-01,7.7913E-01,
36810 &6.7747E-01,5.5266E-01,3.8741E-01,0.0000E+00,2.3524E+00,2.3243E+00,
36811 &2.2963E+00,2.2689E+00,2.2420E+00,2.2137E+00,2.1858E+00,2.1579E+00,
36812 &2.1301E+00,2.1011E+00,2.0718E+00,2.0424E+00,2.0120E+00,1.9937E+00,
36813 &1.9743E+00,1.9509E+00,1.9267E+00,1.9020E+00,1.8763E+00,1.8541E+00,
36814 &1.8295E+00,1.8006E+00,1.7713E+00,1.7402E+00,1.7077E+00,1.6794E+00,
36815 &1.6475E+00,1.6087E+00,1.5679E+00,1.5259E+00,1.4840E+00,1.4470E+00,
36816 &1.4072E+00,1.3615E+00,1.3163E+00,1.2738E+00,1.2336E+00,1.2045E+00,
36817 &1.1783E+00,1.1563E+00,1.1459E+00,1.1457E+00,1.1504E+00,1.1577E+00,
36818 &1.1662E+00,1.1742E+00,1.1807E+00,1.1857E+00,1.1886E+00,1.1902E+00,
36819 &1.1899E+00,1.1878E+00,1.1830E+00,1.1751E+00,1.1633E+00,1.1345E+00,
36820 &1.1039E+00,1.0667E+00,1.0230E+00,9.7228E-01,9.1417E-01,8.4905E-01,
36821 &7.7478E-01,6.9004E-01,5.9155E-01,4.7371E-01,3.2191E-01,0.0000E+00,
36822 &2.4233E+00,2.3947E+00,2.3653E+00,2.3365E+00,2.3090E+00,2.2800E+00/
36823 DATA (XDVF_L(K),K= 1027, 1140) /
36824 &2.2512E+00,2.2220E+00,2.1934E+00,2.1628E+00,2.1319E+00,2.1007E+00,
36825 &2.0700E+00,2.0512E+00,2.0301E+00,2.0057E+00,1.9809E+00,1.9549E+00,
36826 &1.9281E+00,1.9049E+00,1.8791E+00,1.8497E+00,1.8175E+00,1.7854E+00,
36827 &1.7507E+00,1.7209E+00,1.6878E+00,1.6474E+00,1.6047E+00,1.5603E+00,
36828 &1.5164E+00,1.4777E+00,1.4358E+00,1.3879E+00,1.3403E+00,1.2952E+00,
36829 &1.2523E+00,1.2206E+00,1.1913E+00,1.1661E+00,1.1505E+00,1.1462E+00,
36830 &1.1460E+00,1.1481E+00,1.1518E+00,1.1545E+00,1.1559E+00,1.1562E+00,
36831 &1.1548E+00,1.1523E+00,1.1478E+00,1.1414E+00,1.1331E+00,1.1212E+00,
36832 &1.1055E+00,1.0763E+00,1.0405E+00,9.9877E-01,9.5130E-01,8.9815E-01,
36833 &8.3813E-01,7.7188E-01,6.9792E-01,6.1492E-01,5.2020E-01,4.0920E-01,
36834 &2.7020E-01,0.0000E+00,2.4906E+00,2.4607E+00,2.4307E+00,2.4014E+00,
36835 &2.3730E+00,2.3427E+00,2.3127E+00,2.2828E+00,2.2528E+00,2.2213E+00,
36836 &2.1903E+00,2.1577E+00,2.1250E+00,2.1053E+00,2.0839E+00,2.0583E+00,
36837 &2.0318E+00,2.0051E+00,1.9771E+00,1.9527E+00,1.9259E+00,1.8935E+00,
36838 &1.8607E+00,1.8269E+00,1.7917E+00,1.7606E+00,1.7253E+00,1.6833E+00,
36839 &1.6387E+00,1.5925E+00,1.5465E+00,1.5061E+00,1.4624E+00,1.4121E+00,
36840 &1.3623E+00,1.3152E+00,1.2700E+00,1.2349E+00,1.2036E+00,1.1745E+00,
36841 &1.1544E+00,1.1457E+00,1.1410E+00,1.1389E+00,1.1378E+00,1.1357E+00,
36842 &1.1332E+00,1.1290E+00,1.1244E+00,1.1176E+00,1.1099E+00,1.0996E+00/
36843 DATA (XDVF_L(K),K= 1141, 1254) /
36844 &1.0875E+00,1.0729E+00,1.0538E+00,1.0249E+00,9.8511E-01,9.3994E-01,
36845 &8.8948E-01,8.3410E-01,7.7332E-01,7.0681E-01,6.3377E-01,5.5280E-01,
36846 &4.6214E-01,3.5755E-01,2.2965E-01,0.0000E+00,2.5589E+00,2.5291E+00,
36847 &2.4979E+00,2.4676E+00,2.4370E+00,2.4060E+00,2.3753E+00,2.3443E+00,
36848 &2.3135E+00,2.2809E+00,2.2486E+00,2.2146E+00,2.1810E+00,2.1602E+00,
36849 &2.1376E+00,2.1114E+00,2.0841E+00,2.0557E+00,2.0265E+00,2.0011E+00,
36850 &1.9730E+00,1.9392E+00,1.9055E+00,1.8697E+00,1.8327E+00,1.8003E+00,
36851 &1.7635E+00,1.7197E+00,1.6727E+00,1.6246E+00,1.5770E+00,1.5346E+00,
36852 &1.4890E+00,1.4363E+00,1.3841E+00,1.3341E+00,1.2867E+00,1.2492E+00,
36853 &1.2151E+00,1.1824E+00,1.1578E+00,1.1451E+00,1.1356E+00,1.1298E+00,
36854 &1.1233E+00,1.1169E+00,1.1105E+00,1.1027E+00,1.0940E+00,1.0840E+00,
36855 &1.0726E+00,1.0592E+00,1.0444E+00,1.0265E+00,1.0045E+00,9.7613E-01,
36856 &9.3249E-01,8.8451E-01,8.3193E-01,7.7510E-01,7.1373E-01,6.4749E-01,
36857 &5.7554E-01,4.9725E-01,4.1072E-01,3.1254E-01,1.9551E-01,0.0000E+00,
36858 &2.6244E+00,2.5927E+00,2.5615E+00,2.5299E+00,2.4990E+00,2.4671E+00,
36859 &2.4356E+00,2.4034E+00,2.3717E+00,2.3377E+00,2.3034E+00,2.2689E+00,
36860 &2.2340E+00,2.2126E+00,2.1892E+00,2.1616E+00,2.1331E+00,2.1040E+00,
36861 &2.0736E+00,2.0471E+00,2.0180E+00,1.9830E+00,1.9472E+00,1.9112E+00,
36862 &1.8717E+00,1.8375E+00,1.7996E+00,1.7538E+00,1.7053E+00,1.6548E+00/
36863 DATA (XDVF_L(K),K= 1255, 1368) /
36864 &1.6053E+00,1.5612E+00,1.5138E+00,1.4590E+00,1.4045E+00,1.3516E+00,
36865 &1.3023E+00,1.2626E+00,1.2251E+00,1.1889E+00,1.1601E+00,1.1441E+00,
36866 &1.1302E+00,1.1201E+00,1.1098E+00,1.0996E+00,1.0888E+00,1.0782E+00,
36867 &1.0659E+00,1.0531E+00,1.0388E+00,1.0228E+00,1.0047E+00,9.8480E-01,
36868 &9.6040E-01,9.3234E-01,8.8589E-01,8.3563E-01,7.8162E-01,7.2366E-01,
36869 &6.6215E-01,5.9658E-01,5.2617E-01,4.5043E-01,3.6787E-01,2.7575E-01,
36870 &1.6826E-01,0.0000E+00,2.6886E+00,2.6564E+00,2.6234E+00,2.5908E+00,
36871 &2.5600E+00,2.5268E+00,2.4943E+00,2.4612E+00,2.4283E+00,2.3924E+00,
36872 &2.3582E+00,2.3219E+00,2.2860E+00,2.2642E+00,2.2394E+00,2.2113E+00,
36873 &2.1817E+00,2.1512E+00,2.1198E+00,2.0920E+00,2.0618E+00,2.0268E+00,
36874 &1.9890E+00,1.9503E+00,1.9098E+00,1.8739E+00,1.8343E+00,1.7867E+00,
36875 &1.7365E+00,1.6843E+00,1.6329E+00,1.5870E+00,1.5377E+00,1.4807E+00,
36876 &1.4239E+00,1.3692E+00,1.3169E+00,1.2751E+00,1.2350E+00,1.1954E+00,
36877 &1.1624E+00,1.1425E+00,1.1247E+00,1.1110E+00,1.0963E+00,1.0827E+00,
36878 &1.0687E+00,1.0547E+00,1.0396E+00,1.0240E+00,1.0070E+00,9.8853E-01,
36879 &9.6834E-01,9.4569E-01,9.1962E-01,8.9220E-01,8.4321E-01,7.9105E-01,
36880 &7.3592E-01,6.7777E-01,6.1620E-01,5.5143E-01,4.8272E-01,4.0962E-01,
36881 &3.3102E-01,2.4455E-01,1.4574E-01,0.0000E+00,2.7496E+00,2.7153E+00,
36882 &2.6835E+00,2.6504E+00,2.6180E+00,2.5834E+00,2.5502E+00,2.5161E+00/
36883 DATA (XDVF_L(K),K= 1369, 1482) /
36884 &2.4824E+00,2.4466E+00,2.4095E+00,2.3736E+00,2.3360E+00,2.3124E+00,
36885 &2.2875E+00,2.2580E+00,2.2274E+00,2.1960E+00,2.1631E+00,2.1347E+00,
36886 &2.1032E+00,2.0670E+00,2.0277E+00,1.9882E+00,1.9458E+00,1.9086E+00,
36887 &1.8675E+00,1.8179E+00,1.7658E+00,1.7122E+00,1.6586E+00,1.6112E+00,
36888 &1.5600E+00,1.5010E+00,1.4420E+00,1.3855E+00,1.3294E+00,1.2858E+00,
36889 &1.2435E+00,1.2006E+00,1.1641E+00,1.1410E+00,1.1193E+00,1.1023E+00,
36890 &1.0837E+00,1.0664E+00,1.0496E+00,1.0329E+00,1.0157E+00,9.9745E-01,
36891 &9.7803E-01,9.5735E-01,9.3539E-01,9.1075E-01,8.8302E-01,8.5608E-01,
36892 &8.0509E-01,7.5168E-01,6.9580E-01,6.3743E-01,5.7619E-01,5.1233E-01,
36893 &4.4547E-01,3.7496E-01,2.9995E-01,2.1862E-01,1.2745E-01,0.0000E+00,
36894 &2.8331E+00,2.7978E+00,2.7648E+00,2.7299E+00,2.6960E+00,2.6609E+00,
36895 &2.6263E+00,2.5910E+00,2.5561E+00,2.5197E+00,2.4802E+00,2.4424E+00,
36896 &2.4030E+00,2.3791E+00,2.3526E+00,2.3216E+00,2.2897E+00,2.2570E+00,
36897 &2.2225E+00,2.1925E+00,2.1595E+00,2.1199E+00,2.0799E+00,2.0383E+00,
36898 &1.9938E+00,1.9551E+00,1.9121E+00,1.8601E+00,1.8054E+00,1.7494E+00,
36899 &1.6932E+00,1.6435E+00,1.5898E+00,1.5280E+00,1.4659E+00,1.4056E+00,
36900 &1.3471E+00,1.3010E+00,1.2550E+00,1.2078E+00,1.1652E+00,1.1383E+00,
36901 &1.1114E+00,1.0902E+00,1.0668E+00,1.0451E+00,1.0248E+00,1.0039E+00,
36902 &9.8353E-01,9.6205E-01,9.4076E-01,9.1705E-01,8.9229E-01,8.6577E-01/
36903 DATA (XDVF_L(K),K= 1483, 1596) /
36904 &8.3604E-01,8.0985E-01,7.5687E-01,7.0190E-01,6.4516E-01,5.8700E-01,
36905 &5.2660E-01,4.6452E-01,3.9995E-01,3.3310E-01,2.6289E-01,1.8826E-01,
36906 &1.0655E-01,0.0000E+00,2.9096E+00,2.8732E+00,2.8390E+00,2.8027E+00,
36907 &2.7690E+00,2.7325E+00,2.6961E+00,2.6597E+00,2.6231E+00,2.5833E+00,
36908 &2.5456E+00,2.5047E+00,2.4650E+00,2.4391E+00,2.4120E+00,2.3799E+00,
36909 &2.3462E+00,2.3123E+00,2.2763E+00,2.2451E+00,2.2108E+00,2.1692E+00,
36910 &2.1276E+00,2.0835E+00,2.0378E+00,1.9974E+00,1.9525E+00,1.8983E+00,
36911 &1.8413E+00,1.7827E+00,1.7243E+00,1.6725E+00,1.6166E+00,1.5520E+00,
36912 &1.4872E+00,1.4244E+00,1.3627E+00,1.3136E+00,1.2649E+00,1.2130E+00,
36913 &1.1663E+00,1.1352E+00,1.1040E+00,1.0787E+00,1.0514E+00,1.0264E+00,
36914 &1.0021E+00,9.7883E-01,9.5548E-01,9.3171E-01,9.0763E-01,8.8283E-01,
36915 &8.5596E-01,8.2732E-01,7.9601E-01,7.7056E-01,7.1598E-01,6.6027E-01,
36916 &6.0340E-01,5.4514E-01,4.8601E-01,4.2556E-01,3.6359E-01,2.9984E-01,
36917 &2.3396E-01,1.6486E-01,9.0844E-02,0.0000E+00,2.9880E+00,2.9510E+00,
36918 &2.9150E+00,2.8782E+00,2.8430E+00,2.8048E+00,2.7677E+00,2.7301E+00,
36919 &2.6924E+00,2.6517E+00,2.6110E+00,2.5696E+00,2.5280E+00,2.5017E+00,
36920 &2.4728E+00,2.4393E+00,2.4042E+00,2.3687E+00,2.3313E+00,2.2988E+00,
36921 &2.2631E+00,2.2204E+00,2.1768E+00,2.1312E+00,2.0828E+00,2.0405E+00,
36922 &1.9928E+00,1.9364E+00,1.8772E+00,1.8164E+00,1.7558E+00,1.7018E+00/
36923 DATA (XDVF_L(K),K= 1597, 1710) /
36924 &1.6434E+00,1.5762E+00,1.5084E+00,1.4432E+00,1.3783E+00,1.3261E+00,
36925 &1.2741E+00,1.2182E+00,1.1669E+00,1.1315E+00,1.0961E+00,1.0671E+00,
36926 &1.0360E+00,1.0071E+00,9.7992E-01,9.5371E-01,9.2801E-01,9.0200E-01,
36927 &8.7588E-01,8.4862E-01,8.2038E-01,7.9020E-01,7.5770E-01,7.3298E-01,
36928 &6.7721E-01,6.2090E-01,5.6394E-01,5.0631E-01,4.4841E-01,3.8970E-01,
36929 &3.3019E-01,2.6973E-01,2.0791E-01,1.4420E-01,7.7416E-02,0.0000E+00,
36930 &3.0661E+00,3.0288E+00,2.9911E+00,2.9537E+00,2.9160E+00,2.8778E+00,
36931 &2.8392E+00,2.8000E+00,2.7610E+00,2.7200E+00,2.6782E+00,2.6345E+00,
36932 &2.5900E+00,2.5625E+00,2.5329E+00,2.4982E+00,2.4617E+00,2.4247E+00,
36933 &2.3857E+00,2.3518E+00,2.3145E+00,2.2697E+00,2.2245E+00,2.1764E+00,
36934 &2.1269E+00,2.0819E+00,2.0331E+00,1.9746E+00,1.9126E+00,1.8497E+00,
36935 &1.7862E+00,1.7303E+00,1.6696E+00,1.5995E+00,1.5285E+00,1.4608E+00,
36936 &1.3929E+00,1.3377E+00,1.2826E+00,1.2228E+00,1.1669E+00,1.1279E+00,
36937 &1.0882E+00,1.0555E+00,1.0205E+00,9.8876E-01,9.5876E-01,9.2969E-01,
36938 &9.0171E-01,8.7356E-01,8.4551E-01,8.1668E-01,7.8701E-01,7.5564E-01,
36939 &7.2196E-01,6.9797E-01,6.4121E-01,5.8469E-01,5.2810E-01,4.7131E-01,
36940 &4.1460E-01,3.5783E-01,3.0063E-01,2.4338E-01,1.8544E-01,1.2660E-01,
36941 &6.6270E-02,0.0000E+00,3.1379E+00,3.0995E+00,3.0600E+00,3.0213E+00,
36942 &2.9840E+00,2.9442E+00,2.9047E+00,2.8641E+00,2.8239E+00,2.7813E+00/
36943 DATA (XDVF_L(K),K= 1711, 1824) /
36944 &2.7383E+00,2.6928E+00,2.6470E+00,2.6191E+00,2.5880E+00,2.5519E+00,
36945 &2.5145E+00,2.4761E+00,2.4357E+00,2.4004E+00,2.3615E+00,2.3153E+00,
36946 &2.2678E+00,2.2180E+00,2.1669E+00,2.1208E+00,2.0699E+00,2.0087E+00,
36947 &1.9447E+00,1.8795E+00,1.8139E+00,1.7558E+00,1.6930E+00,1.6205E+00,
36948 &1.5467E+00,1.4759E+00,1.4054E+00,1.3484E+00,1.2895E+00,1.2267E+00,
36949 &1.1663E+00,1.1242E+00,1.0808E+00,1.0449E+00,1.0065E+00,9.7194E-01,
36950 &9.3967E-01,9.0840E-01,8.7834E-01,8.4891E-01,8.1928E-01,7.8930E-01,
36951 &7.5803E-01,7.2562E-01,6.9124E-01,6.6796E-01,6.1058E-01,5.5392E-01,
36952 &4.9752E-01,4.4176E-01,3.8633E-01,3.3127E-01,2.7648E-01,2.2186E-01,
36953 &1.6735E-01,1.1268E-01,5.7652E-02,0.0000E+00,3.2129E+00,3.1726E+00,
36954 &3.1325E+00,3.0928E+00,3.0540E+00,3.0127E+00,2.9717E+00,2.9303E+00,
36955 &2.8887E+00,2.8449E+00,2.8001E+00,2.7537E+00,2.7060E+00,2.6766E+00,
36956 &2.6453E+00,2.6073E+00,2.5683E+00,2.5286E+00,2.4866E+00,2.4501E+00,
36957 &2.4107E+00,2.3628E+00,2.3125E+00,2.2620E+00,2.2079E+00,2.1597E+00,
36958 &2.1067E+00,2.0440E+00,1.9778E+00,1.9097E+00,1.8421E+00,1.7819E+00,
36959 &1.7169E+00,1.6416E+00,1.5664E+00,1.4922E+00,1.4189E+00,1.3583E+00,
36960 &1.2971E+00,1.2300E+00,1.1652E+00,1.1200E+00,1.0729E+00,1.0343E+00,
36961 &9.9254E-01,9.5513E-01,9.2006E-01,8.8711E-01,8.5555E-01,8.2426E-01,
36962 &7.9305E-01,7.6193E-01,7.2963E-01,6.9636E-01,6.6128E-01,6.3868E-01/
36963 DATA (XDVF_L(K),K= 1825, 1836) /
36964 &5.8093E-01,5.2428E-01,4.6858E-01,4.1372E-01,3.5972E-01,3.0648E-01,
36965 &2.5392E-01,2.0208E-01,1.5083E-01,1.0018E-01,5.0068E-02,0.0000E+00/
36966 DATA (XDEF_L(K),K= 1, 114) /
36967 &4.3007E-01,4.2474E-01,4.1967E-01,4.1458E-01,4.0970E-01,4.0443E-01,
36968 &3.9925E-01,3.9397E-01,3.8864E-01,3.8302E-01,3.7707E-01,3.7100E-01,
36969 &3.6470E-01,3.6080E-01,3.5639E-01,3.5109E-01,3.4531E-01,3.3914E-01,
36970 &3.3238E-01,3.2609E-01,3.1913E-01,3.1062E-01,3.0152E-01,2.9176E-01,
36971 &2.8100E-01,2.7114E-01,2.5952E-01,2.4467E-01,2.2784E-01,2.0937E-01,
36972 &1.9117E-01,1.7470E-01,1.5685E-01,1.3678E-01,1.1825E-01,1.0349E-01,
36973 &9.4854E-02,9.5054E-02,1.0589E-01,1.3527E-01,1.8584E-01,2.3426E-01,
36974 &2.9021E-01,3.3527E-01,3.7670E-01,4.0255E-01,4.1326E-01,4.0880E-01,
36975 &3.8831E-01,3.5045E-01,2.9287E-01,2.1298E-01,1.0773E-01,0.0000E+00,
36976 &0.0000E+00,2.0644E-01,1.5422E-01,1.0950E-01,7.3614E-02,4.6726E-02,
36977 &2.7433E-02,1.4144E-02,6.5080E-03,2.4719E-03,0.0000E+00,0.0000E+00,
36978 &0.0000E+00,0.0000E+00,4.4398E-01,4.3864E-01,4.3346E-01,4.2809E-01,
36979 &4.2290E-01,4.1747E-01,4.1205E-01,4.0650E-01,4.0098E-01,3.9480E-01,
36980 &3.8873E-01,3.8226E-01,3.7560E-01,3.7145E-01,3.6678E-01,3.6108E-01,
36981 &3.5488E-01,3.4833E-01,3.4123E-01,3.3464E-01,3.2718E-01,3.1811E-01,
36982 &3.0838E-01,2.9811E-01,2.8670E-01,2.7630E-01,2.6412E-01,2.4861E-01,
36983 &2.3110E-01,2.1209E-01,1.9355E-01,1.7681E-01,1.5878E-01,1.3870E-01,
36984 &1.2044E-01,1.0620E-01,9.8341E-02,9.9345E-02,1.1086E-01,1.4055E-01,
36985 &1.9033E-01,2.3696E-01,2.8983E-01,3.3137E-01,3.6834E-01,3.8982E-01/
36986 DATA (XDEF_L(K),K= 115, 228) /
36987 &3.9672E-01,3.8896E-01,3.6609E-01,3.2678E-01,2.6933E-01,1.9181E-01,
36988 &9.1683E-02,0.0000E+00,0.0000E+00,1.8955E-01,1.4041E-01,9.8873E-02,
36989 &6.5928E-02,4.1462E-02,2.3905E-02,1.2324E-02,5.6113E-03,2.1050E-03,
36990 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,4.5980E-01,4.5420E-01,
36991 &4.4884E-01,4.4319E-01,4.3780E-01,4.3208E-01,4.2642E-01,4.2053E-01,
36992 &4.1457E-01,4.0824E-01,4.0181E-01,3.9484E-01,3.8780E-01,3.8328E-01,
36993 &3.7831E-01,3.7223E-01,3.6559E-01,3.5853E-01,3.5072E-01,3.4400E-01,
36994 &3.3590E-01,3.2633E-01,3.1598E-01,3.0508E-01,2.9301E-01,2.8197E-01,
36995 &2.6915E-01,2.5289E-01,2.3470E-01,2.1511E-01,1.9623E-01,1.7918E-01,
36996 &1.6098E-01,1.4092E-01,1.2294E-01,1.0928E-01,1.0224E-01,1.0401E-01,
36997 &1.1623E-01,1.4620E-01,1.9488E-01,2.3948E-01,2.8894E-01,3.2681E-01,
36998 &3.5905E-01,3.7613E-01,3.7908E-01,3.6817E-01,3.4299E-01,3.0266E-01,
36999 &2.4596E-01,1.7115E-01,7.6792E-02,0.0000E+00,0.0000E+00,1.7267E-01,
37000 &1.2670E-01,8.8446E-02,5.8458E-02,3.6380E-02,2.0551E-02,1.0608E-02,
37001 &4.7732E-03,1.7670E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
37002 &4.7845E-01,4.7258E-01,4.6687E-01,4.6107E-01,4.5540E-01,4.4938E-01,
37003 &4.4336E-01,4.3728E-01,4.3070E-01,4.2403E-01,4.1702E-01,4.0968E-01,
37004 &4.0210E-01,3.9723E-01,3.9181E-01,3.8522E-01,3.7808E-01,3.7047E-01,
37005 &3.6211E-01,3.5469E-01,3.4619E-01,3.3582E-01,3.2478E-01,3.1314E-01/
37006 DATA (XDEF_L(K),K= 229, 342) /
37007 &3.0021E-01,2.8848E-01,2.7488E-01,2.5781E-01,2.3886E-01,2.1865E-01,
37008 &1.9932E-01,1.8196E-01,1.6359E-01,1.4359E-01,1.2596E-01,1.1295E-01,
37009 &1.0678E-01,1.0933E-01,1.2234E-01,1.5242E-01,1.9969E-01,2.4187E-01,
37010 &2.8742E-01,3.2112E-01,3.4825E-01,3.6067E-01,3.5959E-01,3.4546E-01,
37011 &3.1813E-01,2.7719E-01,2.2151E-01,1.5037E-01,6.2862E-02,0.0000E+00,
37012 &0.0000E+00,1.5516E-01,1.1270E-01,7.7856E-02,5.0916E-02,3.1337E-02,
37013 &1.7279E-02,8.9355E-03,3.9672E-03,1.4465E-03,0.0000E+00,0.0000E+00,
37014 &0.0000E+00,0.0000E+00,5.0059E-01,4.9450E-01,4.8826E-01,4.8213E-01,
37015 &4.7610E-01,4.6972E-01,4.6326E-01,4.5655E-01,4.4999E-01,4.4265E-01,
37016 &4.3505E-01,4.2703E-01,4.1870E-01,4.1345E-01,4.0758E-01,4.0034E-01,
37017 &3.9260E-01,3.8434E-01,3.7539E-01,3.6725E-01,3.5804E-01,3.4696E-01,
37018 &3.3492E-01,3.2231E-01,3.0852E-01,2.9601E-01,2.8154E-01,2.6348E-01,
37019 &2.4363E-01,2.2272E-01,2.0295E-01,1.8526E-01,1.6669E-01,1.4678E-01,
37020 &1.2956E-01,1.1726E-01,1.1212E-01,1.1548E-01,1.2910E-01,1.5906E-01,
37021 &2.0458E-01,2.4395E-01,2.8508E-01,3.1418E-01,3.3593E-01,3.4343E-01,
37022 &3.3827E-01,3.2104E-01,2.9189E-01,2.5067E-01,1.9688E-01,1.3016E-01,
37023 &5.0498E-02,0.0000E+00,0.0000E+00,1.3742E-01,9.8602E-02,6.7357E-02,
37024 &4.3555E-02,2.6444E-02,1.4175E-02,7.3561E-03,3.2181E-03,1.1530E-03,
37025 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.2114E-01,5.1454E-01/
37026 DATA (XDEF_L(K),K= 343, 456) /
37027 &5.0806E-01,5.0160E-01,4.9520E-01,4.8843E-01,4.8165E-01,4.7456E-01,
37028 &4.6738E-01,4.5962E-01,4.5149E-01,4.4293E-01,4.3400E-01,4.2833E-01,
37029 &4.2194E-01,4.1420E-01,4.0580E-01,3.9678E-01,3.8741E-01,3.7848E-01,
37030 &3.6878E-01,3.5682E-01,3.4416E-01,3.3062E-01,3.1602E-01,3.0269E-01,
37031 &2.8749E-01,2.6857E-01,2.4798E-01,2.2641E-01,2.0626E-01,1.8828E-01,
37032 &1.6960E-01,1.4976E-01,1.3293E-01,1.2126E-01,1.1684E-01,1.2099E-01,
37033 &1.3505E-01,1.6471E-01,2.0841E-01,2.4521E-01,2.8248E-01,3.0770E-01,
37034 &3.2484E-01,3.2845E-01,3.1999E-01,3.0047E-01,2.7030E-01,2.2924E-01,
37035 &1.7739E-01,1.1482E-01,4.2174E-02,0.0000E+00,0.0000E+00,1.2330E-01,
37036 &8.7586E-02,5.9211E-02,3.7890E-02,2.2733E-02,1.1877E-02,6.1865E-03,
37037 &2.6713E-03,9.4247E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
37038 &5.4423E-01,5.3740E-01,5.3068E-01,5.2385E-01,5.1700E-01,5.0982E-01,
37039 &5.0256E-01,4.9509E-01,4.8731E-01,4.7895E-01,4.7023E-01,4.6094E-01,
37040 &4.5130E-01,4.4506E-01,4.3820E-01,4.2973E-01,4.2069E-01,4.1108E-01,
37041 &4.0069E-01,3.9131E-01,3.8063E-01,3.6796E-01,3.5430E-01,3.3991E-01,
37042 &3.2433E-01,3.1014E-01,2.9407E-01,2.7418E-01,2.5281E-01,2.3056E-01,
37043 &2.0999E-01,1.9171E-01,1.7291E-01,1.5321E-01,1.3677E-01,1.2578E-01,
37044 &1.2220E-01,1.2696E-01,1.4132E-01,1.7056E-01,2.1212E-01,2.4603E-01,
37045 &2.7912E-01,3.0023E-01,3.1274E-01,3.1234E-01,3.0087E-01,2.7925E-01/
37046 DATA (XDEF_L(K),K= 457, 570) /
37047 &2.4820E-01,2.0782E-01,1.5841E-01,1.0056E-01,3.5470E-02,0.0000E+00,
37048 &0.0000E+00,1.0941E-01,7.6864E-02,5.1391E-02,3.2506E-02,1.9250E-02,
37049 &9.7741E-03,5.1192E-03,2.1775E-03,0.0000E+00,0.0000E+00,0.0000E+00,
37050 &0.0000E+00,0.0000E+00,5.6542E-01,5.5814E-01,5.5101E-01,5.4385E-01,
37051 &5.3670E-01,5.2913E-01,5.2140E-01,5.1352E-01,5.0533E-01,4.9639E-01,
37052 &4.8702E-01,4.7710E-01,4.6670E-01,4.6011E-01,4.5270E-01,4.4365E-01,
37053 &4.3394E-01,4.2383E-01,4.1271E-01,4.0253E-01,3.9137E-01,3.7783E-01,
37054 &3.6325E-01,3.4810E-01,3.3163E-01,3.1674E-01,2.9988E-01,2.7922E-01,
37055 &2.5706E-01,2.3429E-01,2.1333E-01,1.9484E-01,1.7592E-01,1.5634E-01,
37056 &1.4028E-01,1.2985E-01,1.2692E-01,1.3218E-01,1.4678E-01,1.7535E-01,
37057 &2.1492E-01,2.4628E-01,2.7582E-01,2.9349E-01,3.0215E-01,2.9865E-01,
37058 &2.8479E-01,2.6176E-01,2.3025E-01,1.9073E-01,1.4372E-01,9.0030E-02,
37059 &3.1431E-02,0.0000E+00,0.0000E+00,9.8561E-02,6.8571E-02,4.5400E-02,
37060 &2.8439E-02,1.6650E-02,8.2414E-03,4.3377E-03,1.8226E-03,0.0000E+00,
37061 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.8660E-01,5.7912E-01,
37062 &5.7170E-01,5.6412E-01,5.5660E-01,5.4858E-01,5.4040E-01,5.3194E-01,
37063 &5.2336E-01,5.1383E-01,5.0381E-01,4.9326E-01,4.8220E-01,4.7515E-01,
37064 &4.6719E-01,4.5756E-01,4.4719E-01,4.3619E-01,4.2441E-01,4.1376E-01,
37065 &4.0188E-01,3.8750E-01,3.7220E-01,3.5617E-01,3.3884E-01,3.2317E-01/
37066 DATA (XDEF_L(K),K= 571, 684) /
37067 &3.0561E-01,2.8413E-01,2.6132E-01,2.3801E-01,2.1667E-01,1.9794E-01,
37068 &1.7898E-01,1.5951E-01,1.4381E-01,1.3395E-01,1.3154E-01,1.3722E-01,
37069 &1.5183E-01,1.7978E-01,2.1726E-01,2.4615E-01,2.7227E-01,2.8668E-01,
37070 &2.9185E-01,2.8560E-01,2.6981E-01,2.4566E-01,2.1405E-01,1.7560E-01,
37071 &1.3093E-01,8.1317E-02,2.8821E-02,0.0000E+00,0.0000E+00,8.9016E-02,
37072 &6.1335E-02,4.0241E-02,2.4960E-02,1.4451E-02,6.9787E-03,3.6912E-03,
37073 &1.5320E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
37074 &6.0621E-01,5.9821E-01,5.9043E-01,5.8253E-01,5.7470E-01,5.6625E-01,
37075 &5.5768E-01,5.4870E-01,5.3948E-01,5.2962E-01,5.1919E-01,5.0796E-01,
37076 &4.9620E-01,4.8867E-01,4.8027E-01,4.7003E-01,4.5907E-01,4.4740E-01,
37077 &4.3484E-01,4.2392E-01,4.1127E-01,3.9627E-01,3.8010E-01,3.6326E-01,
37078 &3.4524E-01,3.2900E-01,3.1064E-01,2.8853E-01,2.6510E-01,2.4135E-01,
37079 &2.1970E-01,2.0080E-01,1.8175E-01,1.6242E-01,1.4701E-01,1.3753E-01,
37080 &1.3572E-01,1.4160E-01,1.5623E-01,1.8343E-01,2.1902E-01,2.4571E-01,
37081 &2.6885E-01,2.8059E-01,2.8292E-01,2.7441E-01,2.5704E-01,2.3223E-01,
37082 &2.0062E-01,1.6317E-01,1.2079E-01,7.4733E-02,2.7461E-02,0.0000E+00,
37083 &0.0000E+00,8.1334E-02,5.5577E-02,3.6150E-02,2.2243E-02,1.2749E-02,
37084 &6.0264E-03,3.2009E-03,1.3143E-03,0.0000E+00,0.0000E+00,0.0000E+00,
37085 &0.0000E+00,0.0000E+00,6.2581E-01,6.1778E-01,6.0953E-01,6.0134E-01/
37086 DATA (XDEF_L(K),K= 685, 798) /
37087 &5.9310E-01,5.8428E-01,5.7523E-01,5.6587E-01,5.5625E-01,5.4565E-01,
37088 &5.3457E-01,5.2280E-01,5.1030E-01,5.0236E-01,4.9350E-01,4.8267E-01,
37089 &4.7104E-01,4.5899E-01,4.4560E-01,4.3381E-01,4.2066E-01,4.0485E-01,
37090 &3.8801E-01,3.7047E-01,3.5165E-01,3.3476E-01,3.1574E-01,2.9293E-01,
37091 &2.6889E-01,2.4469E-01,2.2279E-01,2.0369E-01,1.8458E-01,1.6537E-01,
37092 &1.5025E-01,1.4125E-01,1.3980E-01,1.4589E-01,1.6046E-01,1.8686E-01,
37093 &2.2052E-01,2.4502E-01,2.6530E-01,2.7444E-01,2.7406E-01,2.6361E-01,
37094 &2.4491E-01,2.1954E-01,1.8819E-01,1.5193E-01,1.1170E-01,6.9146E-02,
37095 &2.6829E-02,0.0000E+00,0.0000E+00,7.4387E-02,5.0398E-02,3.2529E-02,
37096 &1.9840E-02,1.1260E-02,5.2109E-03,2.7796E-03,1.1291E-03,0.0000E+00,
37097 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,6.4510E-01,6.3663E-01,
37098 &6.2809E-01,6.1948E-01,6.1090E-01,6.0165E-01,5.9256E-01,5.8263E-01,
37099 &5.7237E-01,5.6121E-01,5.4960E-01,5.3710E-01,5.2390E-01,5.1555E-01,
37100 &5.0615E-01,4.9474E-01,4.8273E-01,4.6980E-01,4.5603E-01,4.4343E-01,
37101 &4.2983E-01,4.1325E-01,3.9561E-01,3.7731E-01,3.5765E-01,3.4017E-01,
37102 &3.2063E-01,2.9709E-01,2.7258E-01,2.4795E-01,2.2572E-01,2.0647E-01,
37103 &1.8735E-01,1.6824E-01,1.5339E-01,1.4470E-01,1.4366E-01,1.4990E-01,
37104 &1.6437E-01,1.8986E-01,2.2169E-01,2.4408E-01,2.6175E-01,2.6863E-01,
37105 &2.6585E-01,2.5363E-01,2.3397E-01,2.0813E-01,1.7714E-01,1.4205E-01/
37106 DATA (XDEF_L(K),K= 799, 912) /
37107 &1.0396E-01,6.4602E-02,2.6785E-02,0.0000E+00,0.0000E+00,6.8343E-02,
37108 &4.5962E-02,2.9434E-02,1.7812E-02,1.0015E-02,4.5458E-03,2.4331E-03,
37109 &9.7866E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
37110 &6.6281E-01,6.5407E-01,6.4523E-01,6.3631E-01,6.2740E-01,6.1775E-01,
37111 &6.0821E-01,5.9770E-01,5.8724E-01,5.7535E-01,5.6321E-01,5.5021E-01,
37112 &5.3640E-01,5.2763E-01,5.1775E-01,5.0583E-01,4.9310E-01,4.7946E-01,
37113 &4.6520E-01,4.5225E-01,4.3811E-01,4.2074E-01,4.0247E-01,3.8355E-01,
37114 &3.6315E-01,3.4516E-01,3.2502E-01,3.0091E-01,2.7589E-01,2.5090E-01,
37115 &2.2842E-01,2.0903E-01,1.8987E-01,1.7087E-01,1.5631E-01,1.4790E-01,
37116 &1.4709E-01,1.5345E-01,1.6771E-01,1.9243E-01,2.2253E-01,2.4307E-01,
37117 &2.5846E-01,2.6327E-01,2.5857E-01,2.4493E-01,2.2441E-01,1.9832E-01,
37118 &1.6773E-01,1.3380E-01,9.7606E-02,6.1077E-02,2.7123E-02,4.1687E-04,
37119 &0.0000E+00,6.3316E-02,4.2290E-02,2.6899E-02,1.6166E-02,9.0143E-03,
37120 &4.0214E-03,2.1587E-03,8.6042E-04,0.0000E+00,0.0000E+00,0.0000E+00,
37121 &0.0000E+00,0.0000E+00,6.8558E-01,6.7623E-01,6.6716E-01,6.5776E-01,
37122 &6.4840E-01,6.3825E-01,6.2778E-01,6.1697E-01,6.0589E-01,5.9350E-01,
37123 &5.8071E-01,5.6677E-01,5.5220E-01,5.4293E-01,5.3246E-01,5.1980E-01,
37124 &5.0630E-01,4.9221E-01,4.7690E-01,4.6348E-01,4.4839E-01,4.3024E-01,
37125 &4.1112E-01,3.9125E-01,3.7016E-01,3.5134E-01,3.3054E-01,3.0571E-01/
37126 DATA (XDEF_L(K),K= 913, 1026) /
37127 &2.8005E-01,2.5463E-01,2.3186E-01,2.1230E-01,1.9311E-01,1.7422E-01,
37128 &1.5985E-01,1.5187E-01,1.5138E-01,1.5783E-01,1.7178E-01,1.9543E-01,
37129 &2.2331E-01,2.4162E-01,2.5415E-01,2.5666E-01,2.4964E-01,2.3438E-01,
37130 &2.1293E-01,1.8681E-01,1.5680E-01,1.2430E-01,9.0488E-02,5.7352E-02,
37131 &2.7942E-02,7.0995E-03,2.4780E-03,5.7612E-02,3.8138E-02,2.4057E-02,
37132 &1.4329E-02,7.9111E-03,3.4566E-03,1.8603E-03,7.3347E-04,0.0000E+00,
37133 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.0709E-01,6.9744E-01,
37134 &6.8784E-01,6.7803E-01,6.6830E-01,6.5763E-01,6.4678E-01,6.3540E-01,
37135 &6.2360E-01,6.1071E-01,5.9715E-01,5.8240E-01,5.6710E-01,5.5722E-01,
37136 &5.4625E-01,5.3291E-01,5.1856E-01,5.0380E-01,4.8797E-01,4.7363E-01,
37137 &4.5801E-01,4.3900E-01,4.1917E-01,3.9846E-01,3.7656E-01,3.5717E-01,
37138 &3.3564E-01,3.1017E-01,2.8397E-01,2.5816E-01,2.3508E-01,2.1538E-01,
37139 &1.9615E-01,1.7737E-01,1.6324E-01,1.5559E-01,1.5535E-01,1.6175E-01,
37140 &1.7537E-01,1.9793E-01,2.2384E-01,2.4005E-01,2.5009E-01,2.5051E-01,
37141 &2.4150E-01,2.2495E-01,2.0291E-01,1.7668E-01,1.4739E-01,1.1625E-01,
37142 &8.4583E-02,5.4470E-02,2.9013E-02,1.3147E-02,1.4553E-02,5.2777E-02,
37143 &3.4672E-02,2.1686E-02,1.2821E-02,7.0105E-03,3.0093E-03,1.6226E-03,
37144 &6.3321E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
37145 &7.2796E-01,7.1795E-01,7.0799E-01,6.9776E-01,6.8760E-01,6.7649E-01/
37146 DATA (XDEF_L(K),K= 1027, 1140) /
37147 &6.6523E-01,6.5299E-01,6.4099E-01,6.2720E-01,6.1289E-01,5.9763E-01,
37148 &5.8140E-01,5.7108E-01,5.5954E-01,5.4555E-01,5.3082E-01,5.1501E-01,
37149 &4.9841E-01,4.8352E-01,4.6718E-01,4.4758E-01,4.2678E-01,4.0543E-01,
37150 &3.8267E-01,3.6267E-01,3.4052E-01,3.1445E-01,2.8771E-01,2.6154E-01,
37151 &2.3817E-01,2.1835E-01,1.9910E-01,1.8043E-01,1.6662E-01,1.5905E-01,
37152 &1.5900E-01,1.6548E-01,1.7871E-01,2.0015E-01,2.2403E-01,2.3835E-01,
37153 &2.4610E-01,2.4469E-01,2.3394E-01,2.1634E-01,1.9372E-01,1.6761E-01,
37154 &1.3910E-01,1.0920E-01,7.9530E-02,5.2165E-02,3.0250E-02,1.8723E-02,
37155 &2.5275E-02,4.8575E-02,3.1676E-02,1.9677E-02,1.1540E-02,6.2533E-03,
37156 &2.6411E-03,1.4253E-03,5.5072E-04,0.0000E+00,0.0000E+00,0.0000E+00,
37157 &0.0000E+00,0.0000E+00,7.4788E-01,7.3751E-01,7.2708E-01,7.1644E-01,
37158 &7.0580E-01,6.9430E-01,6.8256E-01,6.6975E-01,6.5712E-01,6.4276E-01,
37159 &6.2791E-01,6.1180E-01,5.9490E-01,5.8409E-01,5.7199E-01,5.5739E-01,
37160 &5.4166E-01,5.2544E-01,5.0821E-01,4.9288E-01,4.7590E-01,4.5544E-01,
37161 &4.3393E-01,4.1178E-01,3.8837E-01,3.6775E-01,3.4513E-01,3.1844E-01,
37162 &2.9125E-01,2.6472E-01,2.4110E-01,2.2115E-01,2.0189E-01,1.8330E-01,
37163 &1.6955E-01,1.6237E-01,1.6243E-01,1.6875E-01,1.8164E-01,2.0201E-01,
37164 &2.2410E-01,2.3665E-01,2.4236E-01,2.3927E-01,2.2710E-01,2.0852E-01,
37165 &1.8563E-01,1.5962E-01,1.3170E-01,1.0314E-01,7.5292E-02,5.0347E-02/
37166 DATA (XDEF_L(K),K= 1141, 1254) /
37167 &3.1513E-02,2.3688E-02,3.4520E-02,4.4988E-02,2.9140E-02,1.7975E-02,
37168 &1.0472E-02,5.6268E-03,2.3442E-03,1.2646E-03,4.8432E-04,0.0000E+00,
37169 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.6812E-01,7.5731E-01,
37170 &7.4653E-01,7.3551E-01,7.2440E-01,7.1234E-01,6.9989E-01,6.8692E-01,
37171 &6.7357E-01,6.5855E-01,6.4312E-01,6.2624E-01,6.0850E-01,5.9719E-01,
37172 &5.8457E-01,5.6934E-01,5.5297E-01,5.3626E-01,5.1802E-01,5.0223E-01,
37173 &4.8440E-01,4.6329E-01,4.4109E-01,4.1826E-01,3.9408E-01,3.7291E-01,
37174 &3.4966E-01,3.2243E-01,2.9475E-01,2.6790E-01,2.4406E-01,2.2399E-01,
37175 &2.0470E-01,1.8621E-01,1.7262E-01,1.6558E-01,1.6576E-01,1.7201E-01,
37176 &1.8441E-01,2.0372E-01,2.2403E-01,2.3482E-01,2.3856E-01,2.3398E-01,
37177 &2.2040E-01,2.0103E-01,1.7782E-01,1.5205E-01,1.2492E-01,9.7540E-02,
37178 &7.1452E-02,4.8817E-02,3.2832E-02,2.8412E-02,4.3068E-02,4.1684E-02,
37179 &2.6819E-02,1.6431E-02,9.5049E-03,5.0674E-03,2.0840E-03,1.1231E-03,
37180 &4.2643E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
37181 &7.8709E-01,7.7617E-01,7.6509E-01,7.5353E-01,7.4210E-01,7.2955E-01,
37182 &7.1666E-01,7.0326E-01,6.8906E-01,6.7364E-01,6.5743E-01,6.3988E-01,
37183 &6.2140E-01,6.0962E-01,5.9645E-01,5.8083E-01,5.6382E-01,5.4630E-01,
37184 &5.2750E-01,5.1079E-01,4.9267E-01,4.7078E-01,4.4780E-01,4.2425E-01,
37185 &3.9948E-01,3.7773E-01,3.5398E-01,3.2619E-01,2.9811E-01,2.7093E-01/
37186 DATA (XDEF_L(K),K= 1255, 1368) /
37187 &2.4686E-01,2.2668E-01,2.0735E-01,1.8888E-01,1.7555E-01,1.6865E-01,
37188 &1.6887E-01,1.7500E-01,1.8693E-01,2.0522E-01,2.2377E-01,2.3300E-01,
37189 &2.3501E-01,2.2902E-01,2.1428E-01,1.9427E-01,1.7084E-01,1.4533E-01,
37190 &1.1889E-01,9.2655E-02,6.8174E-02,4.7575E-02,3.4123E-02,3.2605E-02,
37191 &5.0454E-02,3.8820E-02,2.4822E-02,1.5113E-02,8.6857E-03,4.5962E-03,
37192 &1.8704E-03,1.0050E-03,3.7856E-04,0.0000E+00,0.0000E+00,0.0000E+00,
37193 &0.0000E+00,0.0000E+00,8.0606E-01,7.9455E-01,7.8312E-01,7.7128E-01,
37194 &7.5940E-01,7.4610E-01,7.3287E-01,7.1917E-01,7.0456E-01,6.8825E-01,
37195 &6.7140E-01,6.5313E-01,6.3390E-01,6.2170E-01,6.0798E-01,5.9180E-01,
37196 &5.7419E-01,5.5596E-01,5.3636E-01,5.1934E-01,5.0050E-01,4.7790E-01,
37197 &4.5436E-01,4.3012E-01,4.0458E-01,3.8238E-01,3.5808E-01,3.2984E-01,
37198 &3.0133E-01,2.7388E-01,2.4957E-01,2.2930E-01,2.0996E-01,1.9168E-01,
37199 &1.7832E-01,1.7159E-01,1.7177E-01,1.7770E-01,1.8921E-01,2.0651E-01,
37200 &2.2344E-01,2.3117E-01,2.3152E-01,2.2426E-01,2.0844E-01,1.8790E-01,
37201 &1.6440E-01,1.3914E-01,1.1342E-01,8.8280E-02,6.5276E-02,4.6578E-02,
37202 &3.5360E-02,3.6411E-02,5.6986E-02,3.6256E-02,2.3040E-02,1.3948E-02,
37203 &7.9676E-03,4.1856E-03,1.6876E-03,9.0394E-04,3.3789E-04,0.0000E+00,
37204 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.2409E-01,8.1223E-01,
37205 &8.0027E-01,7.8810E-01,7.7580E-01,7.6250E-01,7.4852E-01,7.3383E-01/
37206 DATA (XDEF_L(K),K= 1369, 1482) /
37207 &7.1879E-01,7.0216E-01,6.8466E-01,6.6571E-01,6.4580E-01,6.3303E-01,
37208 &6.1887E-01,6.0161E-01,5.8362E-01,5.6485E-01,5.4490E-01,5.2736E-01,
37209 &5.0788E-01,4.8465E-01,4.6048E-01,4.3549E-01,4.0949E-01,3.8678E-01,
37210 &3.6198E-01,3.3325E-01,3.0435E-01,2.7667E-01,2.5212E-01,2.3179E-01,
37211 &2.1241E-01,1.9410E-01,1.8093E-01,1.7428E-01,1.7445E-01,1.8022E-01,
37212 &1.9133E-01,2.0758E-01,2.2299E-01,2.2941E-01,2.2823E-01,2.1990E-01,
37213 &2.0319E-01,1.8211E-01,1.5852E-01,1.3371E-01,1.0856E-01,8.4430E-02,
37214 &6.2776E-02,4.5758E-02,3.6514E-02,3.9756E-02,6.2597E-02,3.4019E-02,
37215 &2.1502E-02,1.2943E-02,7.3506E-03,3.8366E-03,1.5351E-03,8.1923E-04,
37216 &3.0383E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
37217 &8.4844E-01,8.3627E-01,8.2378E-01,8.1114E-01,7.9820E-01,7.8411E-01,
37218 &7.6977E-01,7.5436E-01,7.3871E-01,7.2101E-01,7.0269E-01,6.8280E-01,
37219 &6.6180E-01,6.4849E-01,6.3365E-01,6.1605E-01,5.9682E-01,5.7721E-01,
37220 &5.5628E-01,5.3805E-01,5.1772E-01,4.9378E-01,4.6868E-01,4.4295E-01,
37221 &4.1599E-01,3.9262E-01,3.6722E-01,3.3788E-01,3.0847E-01,2.8040E-01,
37222 &2.5562E-01,2.3513E-01,2.1572E-01,1.9746E-01,1.8447E-01,1.7787E-01,
37223 &1.7810E-01,1.8358E-01,1.9394E-01,2.0894E-01,2.2227E-01,2.2689E-01,
37224 &2.2385E-01,2.1408E-01,1.9620E-01,1.7461E-01,1.5108E-01,1.2667E-01,
37225 &1.0243E-01,7.9635E-02,5.9715E-02,4.4804E-02,3.7997E-02,4.3894E-02/
37226 DATA (XDEF_L(K),K= 1483, 1596) /
37227 &6.9391E-02,3.1240E-02,1.9603E-02,1.1712E-02,6.6036E-03,3.4150E-03,
37228 &1.3549E-03,7.1812E-04,2.6373E-04,0.0000E+00,0.0000E+00,0.0000E+00,
37229 &0.0000E+00,0.0000E+00,8.7089E-01,8.5819E-01,8.4535E-01,8.3207E-01,
37230 &8.1860E-01,8.0424E-01,7.8877E-01,7.7320E-01,7.5642E-01,7.3822E-01,
37231 &7.1895E-01,6.9816E-01,6.7640E-01,6.6244E-01,6.4701E-01,6.2817E-01,
37232 &6.0860E-01,5.8841E-01,5.6672E-01,5.4767E-01,5.2667E-01,5.0182E-01,
37233 &4.7599E-01,4.4955E-01,4.2190E-01,3.9787E-01,3.7196E-01,3.4199E-01,
37234 &3.1220E-01,2.8382E-01,2.5874E-01,2.3816E-01,2.1874E-01,2.0063E-01,
37235 &1.8770E-01,1.8107E-01,1.8121E-01,1.8638E-01,1.9622E-01,2.0994E-01,
37236 &2.2156E-01,2.2456E-01,2.1986E-01,2.0892E-01,1.9015E-01,1.6817E-01,
37237 &1.4465E-01,1.2070E-01,9.7309E-02,7.5665E-02,5.7234E-02,4.4095E-02,
37238 &3.9289E-02,4.7307E-02,7.4739E-02,2.8958E-02,1.8046E-02,1.0716E-02,
37239 &6.0010E-03,3.0801E-03,1.2145E-03,6.3833E-04,2.3251E-04,0.0000E+00,
37240 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.9366E-01,8.8058E-01,
37241 &8.6727E-01,8.5353E-01,8.3950E-01,8.2436E-01,8.0890E-01,7.9205E-01,
37242 &7.7476E-01,7.5566E-01,7.3557E-01,7.1393E-01,6.9120E-01,6.7672E-01,
37243 &6.6059E-01,6.4145E-01,6.2086E-01,5.9962E-01,5.7716E-01,5.5756E-01,
37244 &5.3584E-01,5.1022E-01,4.8344E-01,4.5615E-01,4.2780E-01,4.0320E-01,
37245 &3.7671E-01,3.4621E-01,3.1594E-01,2.8727E-01,2.6196E-01,2.4126E-01/
37246 DATA (XDEF_L(K),K= 1597, 1710) /
37247 &2.2177E-01,2.0361E-01,1.9078E-01,1.8427E-01,1.8432E-01,1.8918E-01,
37248 &1.9834E-01,2.1079E-01,2.2065E-01,2.2210E-01,2.1587E-01,2.0383E-01,
37249 &1.8424E-01,1.6197E-01,1.3849E-01,1.1505E-01,9.2463E-02,7.1949E-02,
37250 &5.4952E-02,4.3474E-02,4.0525E-02,5.0376E-02,7.9517E-02,2.6835E-02,
37251 &1.6616E-02,9.8004E-03,5.4489E-03,2.7768E-03,1.0900E-03,5.6728E-04,
37252 &2.0489E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
37253 &9.1643E-01,9.0298E-01,8.8901E-01,8.7472E-01,8.6030E-01,8.4449E-01,
37254 &8.2790E-01,8.1090E-01,7.9278E-01,7.7287E-01,7.5201E-01,7.2942E-01,
37255 &7.0580E-01,6.9067E-01,6.7395E-01,6.5357E-01,6.3264E-01,6.1082E-01,
37256 &5.8728E-01,5.6718E-01,5.4478E-01,5.1825E-01,4.9075E-01,4.6263E-01,
37257 &4.3360E-01,4.0844E-01,3.8138E-01,3.5032E-01,3.1963E-01,2.9065E-01,
37258 &2.6511E-01,2.4428E-01,2.2479E-01,2.0678E-01,1.9385E-01,1.8735E-01,
37259 &1.8722E-01,1.9179E-01,2.0029E-01,2.1158E-01,2.1961E-01,2.1971E-01,
37260 &2.1194E-01,1.9894E-01,1.7862E-01,1.5609E-01,1.3279E-01,1.0972E-01,
37261 &8.8007E-02,6.8578E-02,5.2905E-02,4.2942E-02,4.1624E-02,5.3065E-02,
37262 &8.3506E-02,2.4920E-02,1.5334E-02,8.9876E-03,4.9653E-03,2.5112E-03,
37263 &9.8300E-04,5.0629E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
37264 &0.0000E+00,0.0000E+00,9.3762E-01,9.2325E-01,9.0916E-01,8.9432E-01,
37265 &8.7930E-01,8.6312E-01,8.4579E-01,8.2807E-01,8.0954E-01,7.8866E-01/
37266 DATA (XDEF_L(K),K= 1711, 1824) /
37267 &7.6704E-01,7.4360E-01,7.1911E-01,7.0343E-01,6.8612E-01,6.6512E-01,
37268 &6.4349E-01,6.2048E-01,5.9676E-01,5.7574E-01,5.5261E-01,5.2556E-01,
37269 &4.9731E-01,4.6862E-01,4.3881E-01,4.1318E-01,3.8556E-01,3.5408E-01,
37270 &3.2299E-01,2.9375E-01,2.6794E-01,2.4706E-01,2.2744E-01,2.0939E-01,
37271 &1.9662E-01,1.9016E-01,1.8990E-01,1.9412E-01,2.0192E-01,2.1208E-01,
37272 &2.1863E-01,2.1745E-01,2.0845E-01,1.9458E-01,1.7365E-01,1.5094E-01,
37273 &1.2783E-01,1.0526E-01,8.4228E-02,6.5746E-02,5.1203E-02,4.2521E-02,
37274 &4.2531E-02,5.5238E-02,8.6619E-02,2.3321E-02,1.4266E-02,8.3142E-03,
37275 &4.5684E-03,2.2945E-03,8.9721E-04,4.5700E-04,0.0000E+00,0.0000E+00,
37276 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,9.5912E-01,9.4446E-01,
37277 &9.2967E-01,9.1446E-01,8.9890E-01,8.8176E-01,8.6424E-01,8.4567E-01,
37278 &8.2630E-01,8.0492E-01,7.8242E-01,7.5817E-01,7.3271E-01,7.1653E-01,
37279 &6.9849E-01,6.7725E-01,6.5433E-01,6.3091E-01,6.0625E-01,5.8456E-01,
37280 &5.6088E-01,5.3305E-01,5.0402E-01,4.7461E-01,4.4411E-01,4.1800E-01,
37281 &3.8988E-01,3.5790E-01,3.2644E-01,2.9690E-01,2.7087E-01,2.4987E-01,
37282 &2.3039E-01,2.1219E-01,1.9955E-01,1.9298E-01,1.9248E-01,1.9636E-01,
37283 &2.0355E-01,2.1258E-01,2.1752E-01,2.1512E-01,2.0490E-01,1.9021E-01,
37284 &1.6876E-01,1.4586E-01,1.2296E-01,1.0090E-01,8.0587E-02,6.3034E-02,
37285 &4.9591E-02,4.2122E-02,4.3355E-02,5.7203E-02,8.9336E-02,2.1802E-02/
37286 DATA (XDEF_L(K),K= 1825, 1836) /
37287 &1.3258E-02,7.6843E-03,4.1967E-03,2.0952E-03,8.1932E-04,4.1202E-04,
37288 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00/
37289 DATA (XUDF_L(K),K= 1, 114) /
37290 &1.8987E-02,1.9947E-02,2.0980E-02,2.2068E-02,2.3225E-02,2.4540E-02,
37291 &2.5957E-02,2.7526E-02,2.9229E-02,3.1232E-02,3.3453E-02,3.6003E-02,
37292 &3.8855E-02,4.0763E-02,4.2980E-02,4.5778E-02,4.8895E-02,5.2320E-02,
37293 &5.6174E-02,5.9765E-02,6.3980E-02,6.9315E-02,7.5299E-02,8.1888E-02,
37294 &8.9292E-02,9.6162E-02,1.0414E-01,1.1410E-01,1.2505E-01,1.3674E-01,
37295 &1.4937E-01,1.6060E-01,1.7296E-01,1.8730E-01,2.0166E-01,2.1531E-01,
37296 &2.2821E-01,2.3833E-01,2.4848E-01,2.6049E-01,2.7586E-01,2.9166E-01,
37297 &3.1456E-01,3.3942E-01,3.7230E-01,4.0597E-01,4.3921E-01,4.7071E-01,
37298 &4.9846E-01,5.2057E-01,5.3433E-01,5.3610E-01,5.2141E-01,4.8433E-01,
37299 &4.1719E-01,6.3794E-01,6.7411E-01,7.2040E-01,7.8812E-01,8.9495E-01,
37300 &1.0702E+00,1.3629E+00,1.8763E+00,2.8399E+00,4.8968E+00,1.0506E+01,
37301 &3.7793E+01,0.0000E+00,3.1111E-02,3.2336E-02,3.3580E-02,3.4906E-02,
37302 &3.6247E-02,3.7773E-02,3.9337E-02,4.1056E-02,4.2876E-02,4.5001E-02,
37303 &4.7299E-02,4.9897E-02,5.2761E-02,5.4666E-02,5.6867E-02,5.9620E-02,
37304 &6.2679E-02,6.6018E-02,6.9775E-02,7.3275E-02,7.7353E-02,8.2522E-02,
37305 &8.8327E-02,9.4694E-02,1.0184E-01,1.0846E-01,1.1615E-01,1.2575E-01,
37306 &1.3628E-01,1.4752E-01,1.5964E-01,1.7036E-01,1.8215E-01,1.9580E-01,
37307 &2.0933E-01,2.2213E-01,2.3411E-01,2.4341E-01,2.5275E-01,2.6387E-01,
37308 &2.7831E-01,2.9333E-01,3.1510E-01,3.3876E-01,3.6995E-01,4.0170E-01/
37309 DATA (XUDF_L(K),K= 115, 228) /
37310 &4.3298E-01,4.6172E-01,4.8742E-01,5.0700E-01,5.1856E-01,5.1873E-01,
37311 &5.0352E-01,4.6746E-01,4.0418E-01,6.1801E-01,6.5339E-01,6.9923E-01,
37312 &7.6627E-01,8.7125E-01,1.0408E+00,1.3199E+00,1.8020E+00,2.6920E+00,
37313 &4.5574E+00,9.5310E+00,3.2877E+01,0.0000E+00,5.1176E-02,5.2640E-02,
37314 &5.4100E-02,5.5603E-02,5.7095E-02,5.8737E-02,6.0416E-02,6.2154E-02,
37315 &6.4016E-02,6.6046E-02,6.8273E-02,7.0765E-02,7.3444E-02,7.5182E-02,
37316 &7.7263E-02,7.9781E-02,8.2626E-02,8.5707E-02,8.9176E-02,9.2402E-02,
37317 &9.6182E-02,1.0098E-01,1.0635E-01,1.1227E-01,1.1893E-01,1.2513E-01,
37318 &1.3230E-01,1.4128E-01,1.5115E-01,1.6164E-01,1.7300E-01,1.8301E-01,
37319 &1.9397E-01,2.0660E-01,2.1907E-01,2.3072E-01,2.4154E-01,2.4985E-01,
37320 &2.5817E-01,2.6810E-01,2.8136E-01,2.9535E-01,3.1585E-01,3.3824E-01,
37321 &3.6743E-01,3.9701E-01,4.2565E-01,4.5205E-01,4.7460E-01,4.9184E-01,
37322 &5.0110E-01,4.9954E-01,4.8363E-01,4.4878E-01,3.8940E-01,5.9452E-01,
37323 &6.2820E-01,6.7181E-01,7.3612E-01,8.3598E-01,9.9560E-01,1.2543E+00,
37324 &1.6953E+00,2.4947E+00,4.1415E+00,8.4275E+00,2.7797E+01,0.0000E+00,
37325 &8.6266E-02,8.7847E-02,8.9380E-02,9.0869E-02,9.2337E-02,9.3826E-02,
37326 &9.5315E-02,9.6842E-02,9.8333E-02,1.0003E-01,1.0178E-01,1.0370E-01,
37327 &1.0575E-01,1.0710E-01,1.0872E-01,1.1075E-01,1.1295E-01,1.1538E-01,
37328 &1.1821E-01,1.2088E-01,1.2396E-01,1.2796E-01,1.3252E-01,1.3756E-01/
37329 DATA (XUDF_L(K),K= 229, 342) /
37330 &1.4331E-01,1.4870E-01,1.5500E-01,1.6291E-01,1.7166E-01,1.8100E-01,
37331 &1.9111E-01,2.0002E-01,2.0977E-01,2.2095E-01,2.3189E-01,2.4200E-01,
37332 &2.5123E-01,2.5821E-01,2.6512E-01,2.7351E-01,2.8514E-01,2.9789E-01,
37333 &3.1683E-01,3.3731E-01,3.6424E-01,3.9124E-01,4.1697E-01,4.4030E-01,
37334 &4.6002E-01,4.7419E-01,4.8085E-01,4.7740E-01,4.6086E-01,4.2728E-01,
37335 &3.7241E-01,5.6656E-01,5.9684E-01,6.3694E-01,6.9622E-01,7.8804E-01,
37336 &9.3343E-01,1.1653E+00,1.5545E+00,2.2504E+00,3.6537E+00,7.2124E+00,
37337 &2.2653E+01,0.0000E+00,1.4838E-01,1.4960E-01,1.5068E-01,1.5161E-01,
37338 &1.5242E-01,1.5316E-01,1.5373E-01,1.5426E-01,1.5470E-01,1.5511E-01,
37339 &1.5554E-01,1.5602E-01,1.5660E-01,1.5698E-01,1.5750E-01,1.5830E-01,
37340 &1.5923E-01,1.6034E-01,1.6181E-01,1.6324E-01,1.6509E-01,1.6746E-01,
37341 &1.7054E-01,1.7402E-01,1.7811E-01,1.8208E-01,1.8687E-01,1.9296E-01,
37342 &1.9986E-01,2.0734E-01,2.1554E-01,2.2281E-01,2.3075E-01,2.3983E-01,
37343 &2.4863E-01,2.5660E-01,2.6366E-01,2.6883E-01,2.7387E-01,2.8026E-01,
37344 &2.8982E-01,3.0088E-01,3.1780E-01,3.3626E-01,3.6021E-01,3.8399E-01,
37345 &4.0666E-01,4.2682E-01,4.4278E-01,4.5386E-01,4.5774E-01,4.5230E-01,
37346 &4.3509E-01,4.0314E-01,3.5321E-01,5.3325E-01,5.5916E-01,5.9448E-01,
37347 &6.4707E-01,7.2797E-01,8.5557E-01,1.0563E+00,1.3882E+00,1.9717E+00,
37348 &3.1223E+00,5.9601E+00,1.7750E+01,0.0000E+00,2.3139E-01,2.3138E-01/
37349 DATA (XUDF_L(K),K= 343, 456) /
37350 &2.3120E-01,2.3076E-01,2.3006E-01,2.2907E-01,2.2788E-01,2.2645E-01,
37351 &2.2489E-01,2.2308E-01,2.2120E-01,2.1929E-01,2.1743E-01,2.1630E-01,
37352 &2.1526E-01,2.1411E-01,2.1311E-01,2.1231E-01,2.1171E-01,2.1148E-01,
37353 &2.1150E-01,2.1182E-01,2.1271E-01,2.1412E-01,2.1601E-01,2.1822E-01,
37354 &2.2096E-01,2.2496E-01,2.2961E-01,2.3481E-01,2.4086E-01,2.4622E-01,
37355 &2.5214E-01,2.5891E-01,2.6537E-01,2.7104E-01,2.7588E-01,2.7922E-01,
37356 &2.8235E-01,2.8664E-01,2.9413E-01,3.0352E-01,3.1845E-01,3.3481E-01,
37357 &3.5617E-01,3.7737E-01,3.9689E-01,4.1403E-01,4.2736E-01,4.3558E-01,
37358 &4.3712E-01,4.3016E-01,4.1245E-01,3.8197E-01,3.3645E-01,5.0322E-01,
37359 &5.2507E-01,5.5559E-01,6.0172E-01,6.7286E-01,7.8413E-01,9.5797E-01,
37360 &1.2422E+00,1.7341E+00,2.6883E+00,4.9868E+00,1.4177E+01,0.0000E+00,
37361 &3.6389E-01,3.6098E-01,3.5780E-01,3.5400E-01,3.5016E-01,3.4553E-01,
37362 &3.4044E-01,3.3521E-01,3.2971E-01,3.2369E-01,3.1755E-01,3.1120E-01,
37363 &3.0494E-01,3.0120E-01,2.9724E-01,2.9287E-01,2.8855E-01,2.8449E-01,
37364 &2.8072E-01,2.7770E-01,2.7469E-01,2.7175E-01,2.6933E-01,2.6740E-01,
37365 &2.6613E-01,2.6556E-01,2.6563E-01,2.6631E-01,2.6763E-01,2.6975E-01,
37366 &2.7268E-01,2.7539E-01,2.7857E-01,2.8224E-01,2.8565E-01,2.8841E-01,
37367 &2.9040E-01,2.9139E-01,2.9220E-01,2.9395E-01,2.9888E-01,3.0633E-01,
37368 &3.1877E-01,3.3296E-01,3.5147E-01,3.6947E-01,3.8604E-01,3.9986E-01/
37369 DATA (XUDF_L(K),K= 457, 570) /
37370 &4.1008E-01,4.1548E-01,4.1467E-01,4.0620E-01,3.8830E-01,3.5965E-01,
37371 &3.1902E-01,4.7020E-01,4.8772E-01,5.1303E-01,5.5185E-01,6.1224E-01,
37372 &7.0699E-01,8.5323E-01,1.0903E+00,1.4950E+00,2.2640E+00,4.0723E+00,
37373 &0.0000E+00,0.0000E+00,5.2666E-01,5.1909E-01,5.1100E-01,5.0238E-01,
37374 &4.9333E-01,4.8312E-01,4.7293E-01,4.6180E-01,4.5066E-01,4.3890E-01,
37375 &4.2692E-01,4.1467E-01,4.0262E-01,3.9542E-01,3.8784E-01,3.7925E-01,
37376 &3.7080E-01,3.6267E-01,3.5482E-01,3.4841E-01,3.4190E-01,3.3492E-01,
37377 &3.2852E-01,3.2287E-01,3.1768E-01,3.1409E-01,3.1066E-01,3.0785E-01,
37378 &3.0564E-01,3.0446E-01,3.0380E-01,3.0388E-01,3.0402E-01,3.0458E-01,
37379 &3.0488E-01,3.0475E-01,3.0386E-01,3.0263E-01,3.0116E-01,3.0045E-01,
37380 &3.0296E-01,3.0852E-01,3.1888E-01,3.3085E-01,3.4677E-01,3.6222E-01,
37381 &3.7600E-01,3.8707E-01,3.9488E-01,3.9799E-01,3.9530E-01,3.8568E-01,
37382 &3.6791E-01,3.4080E-01,3.0424E-01,4.4195E-01,4.5570E-01,4.7648E-01,
37383 &5.0935E-01,5.6099E-01,6.4225E-01,7.6680E-01,9.6736E-01,1.3053E+00,
37384 &1.9393E+00,3.3976E+00,0.0000E+00,0.0000E+00,7.4015E-01,7.2498E-01,
37385 &7.0940E-01,6.9297E-01,6.7620E-01,6.5800E-01,6.3935E-01,6.2047E-01,
37386 &6.0114E-01,5.8076E-01,5.6065E-01,5.4030E-01,5.2035E-01,5.0839E-01,
37387 &4.9583E-01,4.8167E-01,4.6773E-01,4.5434E-01,4.4113E-01,4.3035E-01,
37388 &4.1922E-01,4.0719E-01,3.9582E-01,3.8536E-01,3.7557E-01,3.6805E-01/
37389 DATA (XUDF_L(K),K= 571, 684) /
37390 &3.6079E-01,3.5336E-01,3.4710E-01,3.4173E-01,3.3719E-01,3.3400E-01,
37391 &3.3124E-01,3.2819E-01,3.2494E-01,3.2158E-01,3.1765E-01,3.1400E-01,
37392 &3.1011E-01,3.0684E-01,3.0682E-01,3.1046E-01,3.1856E-01,3.2861E-01,
37393 &3.4189E-01,3.5475E-01,3.6597E-01,3.7463E-01,3.8003E-01,3.8108E-01,
37394 &3.7681E-01,3.6631E-01,3.4865E-01,3.2327E-01,2.9078E-01,4.1488E-01,
37395 &4.2529E-01,4.4193E-01,4.6945E-01,5.1322E-01,5.8236E-01,6.8846E-01,
37396 &8.5739E-01,1.1394E+00,1.6617E+00,2.8395E+00,0.0000E+00,0.0000E+00,
37397 &9.8501E-01,9.5975E-01,9.3420E-01,9.0757E-01,8.8092E-01,8.5237E-01,
37398 &8.2383E-01,7.9445E-01,7.6556E-01,7.3524E-01,7.0484E-01,6.7495E-01,
37399 &6.4547E-01,6.2798E-01,6.0969E-01,5.8904E-01,5.6882E-01,5.4932E-01,
37400 &5.3014E-01,5.1443E-01,4.9826E-01,4.8058E-01,4.6380E-01,4.4815E-01,
37401 &4.3330E-01,4.2167E-01,4.1020E-01,3.9827E-01,3.8748E-01,3.7784E-01,
37402 &3.6931E-01,3.6303E-01,3.5669E-01,3.4992E-01,3.4358E-01,3.3710E-01,
37403 &3.3025E-01,3.2429E-01,3.1817E-01,3.1242E-01,3.1001E-01,3.1195E-01,
37404 &3.1802E-01,3.2610E-01,3.3719E-01,3.4770E-01,3.5674E-01,3.6357E-01,
37405 &3.6695E-01,3.6631E-01,3.6075E-01,3.4960E-01,3.3214E-01,3.0855E-01,
37406 &2.7931E-01,3.9198E-01,3.9931E-01,4.1263E-01,4.3550E-01,4.7310E-01,
37407 &5.3259E-01,6.2375E-01,7.6876E-01,1.0087E+00,1.4464E+00,2.4185E+00,
37408 &0.0000E+00,0.0000E+00,1.2917E+00,1.2523E+00,1.2128E+00,1.1722E+00/
37409 DATA (XUDF_L(K),K= 685, 798) /
37410 &1.1321E+00,1.0894E+00,1.0473E+00,1.0044E+00,9.6262E-01,9.1838E-01,
37411 &8.7565E-01,8.3283E-01,7.9186E-01,7.6734E-01,7.4146E-01,7.1300E-01,
37412 &6.8484E-01,6.5787E-01,6.3134E-01,6.0963E-01,5.8730E-01,5.6294E-01,
37413 &5.3947E-01,5.1767E-01,4.9689E-01,4.8039E-01,4.6398E-01,4.4675E-01,
37414 &4.3087E-01,4.1650E-01,4.0371E-01,3.9342E-01,3.8361E-01,3.7293E-01,
37415 &3.6284E-01,3.5305E-01,3.4307E-01,3.3468E-01,3.2613E-01,3.1788E-01,
37416 &3.1306E-01,3.1309E-01,3.1715E-01,3.2346E-01,3.3232E-01,3.4066E-01,
37417 &3.4779E-01,3.5251E-01,3.5401E-01,3.5184E-01,3.4519E-01,3.3347E-01,
37418 &3.1650E-01,2.9433E-01,2.6872E-01,3.6968E-01,3.7446E-01,3.8477E-01,
37419 &4.0368E-01,4.3551E-01,4.8654E-01,5.6457E-01,6.8832E-01,8.9135E-01,
37420 &1.2583E+00,2.0601E+00,0.0000E+00,0.0000E+00,1.6499E+00,1.5928E+00,
37421 &1.5356E+00,1.4773E+00,1.4202E+00,1.3601E+00,1.3009E+00,1.2413E+00,
37422 &1.1836E+00,1.1235E+00,1.0650E+00,1.0076E+00,9.5212E-01,9.1919E-01,
37423 &8.8569E-01,8.4733E-01,8.1006E-01,7.7436E-01,7.3955E-01,7.1104E-01,
37424 &6.8173E-01,6.4966E-01,6.1893E-01,5.9026E-01,5.6287E-01,5.4114E-01,
37425 &5.1941E-01,4.9621E-01,4.7490E-01,4.5564E-01,4.3786E-01,4.2408E-01,
37426 &4.1024E-01,3.9562E-01,3.8175E-01,3.6853E-01,3.5541E-01,3.4455E-01,
37427 &3.3366E-01,3.2286E-01,3.1565E-01,3.1397E-01,3.1618E-01,3.2069E-01,
37428 &3.2744E-01,3.3383E-01,3.3911E-01,3.4194E-01,3.4194E-01,3.3844E-01/
37429 DATA (XUDF_L(K),K= 799, 912) /
37430 &3.3088E-01,3.1887E-01,3.0224E-01,2.8177E-01,2.5901E-01,3.4945E-01,
37431 &3.5200E-01,3.5959E-01,3.7518E-01,4.0212E-01,4.4590E-01,5.1305E-01,
37432 &6.1934E-01,7.9273E-01,1.1025E+00,1.7693E+00,0.0000E+00,0.0000E+00,
37433 &2.0413E+00,1.9626E+00,1.8840E+00,1.8053E+00,1.7284E+00,1.6480E+00,
37434 &1.5697E+00,1.4911E+00,1.4157E+00,1.3375E+00,1.2620E+00,1.1875E+00,
37435 &1.1168E+00,1.0751E+00,1.0321E+00,9.8410E-01,9.3682E-01,8.9196E-01,
37436 &8.4816E-01,8.1245E-01,7.7582E-01,7.3576E-01,6.9745E-01,6.6154E-01,
37437 &6.2742E-01,6.0036E-01,5.7319E-01,5.4409E-01,5.1721E-01,4.9291E-01,
37438 &4.7049E-01,4.5284E-01,4.3541E-01,4.1671E-01,3.9926E-01,3.8274E-01,
37439 &3.6660E-01,3.5348E-01,3.4035E-01,3.2727E-01,3.1788E-01,3.1459E-01,
37440 &3.1499E-01,3.1792E-01,3.2291E-01,3.2764E-01,3.3124E-01,3.3250E-01,
37441 &3.3120E-01,3.2663E-01,3.1834E-01,3.0608E-01,2.8998E-01,2.7085E-01,
37442 &2.5085E-01,3.3191E-01,3.3258E-01,3.3808E-01,3.5072E-01,3.7379E-01,
37443 &4.1182E-01,4.7005E-01,5.6257E-01,7.1233E-01,9.7788E-01,1.5412E+00,
37444 &0.0000E+00,0.0000E+00,2.6325E+00,2.5188E+00,2.4060E+00,2.2942E+00,
37445 &2.1863E+00,2.0740E+00,1.9650E+00,1.8571E+00,1.7537E+00,1.6473E+00,
37446 &1.5453E+00,1.4458E+00,1.3515E+00,1.2965E+00,1.2394E+00,1.1767E+00,
37447 &1.1150E+00,1.0560E+00,9.9927E-01,9.5301E-01,9.0565E-01,8.5400E-01,
37448 &8.0462E-01,7.5858E-01,7.1481E-01,6.7994E-01,6.4502E-01,6.0799E-01/
37449 DATA (XUDF_L(K),K= 913, 1026) /
37450 &5.7349E-01,5.4206E-01,5.1299E-01,4.9028E-01,4.6789E-01,4.4387E-01,
37451 &4.2168E-01,4.0096E-01,3.8070E-01,3.6457E-01,3.4857E-01,3.3249E-01,
37452 &3.2026E-01,3.1503E-01,3.1326E-01,3.1423E-01,3.1703E-01,3.1974E-01,
37453 &3.2120E-01,3.2086E-01,3.1799E-01,3.1221E-01,3.0315E-01,2.9072E-01,
37454 &2.7522E-01,2.5796E-01,2.4114E-01,3.1079E-01,3.0956E-01,3.1267E-01,
37455 &3.2223E-01,3.4089E-01,3.7246E-01,4.2134E-01,4.9853E-01,6.2305E-01,
37456 &8.4191E-01,1.2983E+00,0.0000E+00,0.0000E+00,3.2997E+00,3.1427E+00,
37457 &2.9900E+00,2.8374E+00,2.6927E+00,2.5421E+00,2.3973E+00,2.2549E+00,
37458 &2.1191E+00,1.9809E+00,1.8488E+00,1.7209E+00,1.6001E+00,1.5300E+00,
37459 &1.4576E+00,1.3771E+00,1.2999E+00,1.2268E+00,1.1551E+00,1.0975E+00,
37460 &1.0385E+00,9.7437E-01,9.1327E-01,8.5649E-01,8.0236E-01,7.5952E-01,
37461 &7.1667E-01,6.7091E-01,6.2847E-01,5.9005E-01,5.5422E-01,5.2636E-01,
37462 &4.9890E-01,4.6976E-01,4.4269E-01,4.1752E-01,3.9377E-01,3.7477E-01,
37463 &3.5594E-01,3.3710E-01,3.2226E-01,3.1511E-01,3.1131E-01,3.1067E-01,
37464 &3.1132E-01,3.1227E-01,3.1198E-01,3.1021E-01,3.0606E-01,2.9926E-01,
37465 &2.8958E-01,2.7716E-01,2.6233E-01,2.4655E-01,2.3275E-01,2.9229E-01,
37466 &2.8941E-01,2.9061E-01,2.9753E-01,3.1273E-01,3.3909E-01,3.8034E-01,
37467 &4.4548E-01,5.5028E-01,7.3256E-01,1.1074E+00,0.0000E+00,0.0000E+00,
37468 &4.0557E+00,3.8486E+00,3.6460E+00,3.4480E+00,3.2579E+00,3.0626E+00/
37469 DATA (XUDF_L(K),K= 1027, 1140) /
37470 &2.8756E+00,2.6929E+00,2.5196E+00,2.3441E+00,2.1778E+00,2.0170E+00,
37471 &1.8670E+00,1.7797E+00,1.6902E+00,1.5909E+00,1.4960E+00,1.4058E+00,
37472 &1.3191E+00,1.2484E+00,1.1764E+00,1.0991E+00,1.0253E+00,9.5689E-01,
37473 &8.9197E-01,8.4046E-01,7.8904E-01,7.3442E-01,6.8367E-01,6.3780E-01,
37474 &5.9520E-01,5.6218E-01,5.2934E-01,4.9500E-01,4.6300E-01,4.3370E-01,
37475 &4.0611E-01,3.8431E-01,3.6284E-01,3.4121E-01,3.2389E-01,3.1494E-01,
37476 &3.0926E-01,3.0697E-01,3.0594E-01,3.0501E-01,3.0330E-01,3.0019E-01,
37477 &2.9492E-01,2.8734E-01,2.7718E-01,2.6476E-01,2.5057E-01,2.3646E-01,
37478 &2.2503E-01,2.7558E-01,2.7132E-01,2.7089E-01,2.7569E-01,2.8794E-01,
37479 &3.1000E-01,3.4491E-01,4.0016E-01,4.8886E-01,6.4191E-01,9.5232E-01,
37480 &0.0000E+00,0.0000E+00,4.8799E+00,4.6116E+00,4.3560E+00,4.1035E+00,
37481 &3.8608E+00,3.6163E+00,3.3822E+00,3.1557E+00,2.9412E+00,2.7247E+00,
37482 &2.5209E+00,2.3248E+00,2.1421E+00,2.0368E+00,1.9287E+00,1.8094E+00,
37483 &1.6955E+00,1.5877E+00,1.4841E+00,1.4003E+00,1.3154E+00,1.2237E+00,
37484 &1.1368E+00,1.0563E+00,9.8015E-01,9.2005E-01,8.5978E-01,7.9615E-01,
37485 &7.3715E-01,6.8369E-01,6.3441E-01,5.9609E-01,5.5830E-01,5.1865E-01,
37486 &4.8192E-01,4.4872E-01,4.1747E-01,3.9300E-01,3.6895E-01,3.4483E-01,
37487 &3.2508E-01,3.1459E-01,3.0709E-01,3.0328E-01,3.0056E-01,2.9840E-01,
37488 &2.9543E-01,2.9107E-01,2.8485E-01,2.7655E-01,2.6610E-01,2.5368E-01/
37489 DATA (XUDF_L(K),K= 1141, 1254) /
37490 &2.4019E-01,2.2736E-01,2.1837E-01,2.6080E-01,2.5542E-01,2.5362E-01,
37491 &2.5693E-01,2.6661E-01,2.8505E-01,3.1490E-01,3.6226E-01,4.3798E-01,
37492 &5.6769E-01,8.2836E-01,0.0000E+00,0.0000E+00,5.8340E+00,5.4940E+00,
37493 &5.1700E+00,4.8532E+00,4.5515E+00,4.2463E+00,3.9559E+00,3.6752E+00,
37494 &3.4138E+00,3.1496E+00,2.9022E+00,2.6648E+00,2.4450E+00,2.3189E+00,
37495 &2.1896E+00,2.0476E+00,1.9120E+00,1.7843E+00,1.6621E+00,1.5639E+00,
37496 &1.4648E+00,1.3569E+00,1.2556E+00,1.1618E+00,1.0734E+00,1.0037E+00,
37497 &9.3416E-01,8.6065E-01,7.9257E-01,7.3145E-01,6.7463E-01,6.3082E-01,
37498 &5.8786E-01,5.4262E-01,5.0118E-01,4.6374E-01,4.2883E-01,4.0146E-01,
37499 &3.7490E-01,3.4814E-01,3.2612E-01,3.1397E-01,3.0482E-01,2.9958E-01,
37500 &2.9536E-01,2.9178E-01,2.8756E-01,2.8208E-01,2.7504E-01,2.6611E-01,
37501 &2.5539E-01,2.4319E-01,2.3031E-01,2.1877E-01,2.1195E-01,2.4673E-01,
37502 &2.4036E-01,2.3746E-01,2.3912E-01,2.4677E-01,2.6223E-01,2.8748E-01,
37503 &3.2792E-01,3.9255E-01,5.0271E-01,7.2095E-01,0.0000E+00,0.0000E+00,
37504 &6.8578E+00,6.4388E+00,6.0380E+00,5.6501E+00,5.2825E+00,4.9103E+00,
37505 &4.5613E+00,4.2230E+00,3.9070E+00,3.5911E+00,3.2966E+00,3.0156E+00,
37506 &2.7567E+00,2.6078E+00,2.4563E+00,2.2905E+00,2.1319E+00,1.9837E+00,
37507 &1.8421E+00,1.7287E+00,1.6141E+00,1.4902E+00,1.3730E+00,1.2663E+00,
37508 &1.1652E+00,1.0858E+00,1.0067E+00,9.2337E-01,8.4648E-01,7.7710E-01/
37509 DATA (XUDF_L(K),K= 1255, 1368) /
37510 &7.1333E-01,6.6392E-01,6.1566E-01,5.6531E-01,5.1904E-01,4.7761E-01,
37511 &4.3908E-01,4.0927E-01,3.8022E-01,3.5109E-01,3.2686E-01,3.1318E-01,
37512 &3.0244E-01,2.9602E-01,2.9031E-01,2.8538E-01,2.8024E-01,2.7382E-01,
37513 &2.6607E-01,2.5668E-01,2.4571E-01,2.3364E-01,2.2155E-01,2.1116E-01,
37514 &2.0617E-01,2.3421E-01,2.2704E-01,2.2320E-01,2.2366E-01,2.2952E-01,
37515 &2.4241E-01,2.6402E-01,2.9884E-01,3.5437E-01,4.4860E-01,6.3331E-01,
37516 &0.0000E+00,0.0000E+00,7.9784E+00,7.4673E+00,6.9820E+00,6.5121E+00,
37517 &6.0712E+00,5.6250E+00,5.2080E+00,4.8065E+00,4.4309E+00,4.0590E+00,
37518 &3.7131E+00,3.3843E+00,3.0816E+00,2.9094E+00,2.7332E+00,2.5420E+00,
37519 &2.3595E+00,2.1895E+00,2.0271E+00,1.8966E+00,1.7658E+00,1.6248E+00,
37520 &1.4933E+00,1.3718E+00,1.2579E+00,1.1683E+00,1.0795E+00,9.8589E-01,
37521 &8.9996E-01,8.2253E-01,7.5153E-01,6.9648E-01,6.4287E-01,5.8736E-01,
37522 &5.3655E-01,4.9109E-01,4.4891E-01,4.1655E-01,3.8518E-01,3.5367E-01,
37523 &3.2738E-01,3.1221E-01,3.0006E-01,2.9246E-01,2.8544E-01,2.7940E-01,
37524 &2.7319E-01,2.6601E-01,2.5763E-01,2.4782E-01,2.3676E-01,2.2486E-01,
37525 &2.1329E-01,2.0405E-01,2.0083E-01,2.2267E-01,2.1489E-01,2.1027E-01,
37526 &2.0967E-01,2.1409E-01,2.2473E-01,2.4320E-01,2.7316E-01,3.2113E-01,
37527 &4.0209E-01,5.5899E-01,0.0000E+00,0.0000E+00,9.1575E+00,8.5458E+00,
37528 &7.9700E+00,7.4123E+00,6.8876E+00,6.3653E+00,5.8736E+00,5.4042E+00/
37529 DATA (XUDF_L(K),K= 1369, 1482) /
37530 &4.9684E+00,4.5359E+00,4.1366E+00,3.7576E+00,3.4110E+00,3.2138E+00,
37531 &3.0122E+00,2.7943E+00,2.5871E+00,2.3944E+00,2.2102E+00,2.0646E+00,
37532 &1.9163E+00,1.7581E+00,1.6109E+00,1.4753E+00,1.3483E+00,1.2486E+00,
37533 &1.1500E+00,1.0462E+00,9.5130E-01,8.6585E-01,7.8770E-01,7.2741E-01,
37534 &6.6891E-01,6.0781E-01,5.5266E-01,5.0342E-01,4.5788E-01,4.2322E-01,
37535 &3.8960E-01,3.5594E-01,3.2768E-01,3.1125E-01,2.9779E-01,2.8890E-01,
37536 &2.8091E-01,2.7385E-01,2.6670E-01,2.5886E-01,2.4989E-01,2.3976E-01,
37537 &2.2861E-01,2.1703E-01,2.0604E-01,1.9777E-01,1.9598E-01,2.1238E-01,
37538 &2.0408E-01,1.9879E-01,1.9735E-01,2.0048E-01,2.0933E-01,2.2523E-01,
37539 &2.5120E-01,2.9296E-01,3.6305E-01,4.9711E-01,0.0000E+00,0.0000E+00,
37540 &1.0956E+01,1.0188E+01,9.4660E+00,8.7704E+00,8.1209E+00,7.4727E+00,
37541 &6.8721E+00,6.2972E+00,5.7646E+00,5.2434E+00,4.7595E+00,4.3051E+00,
37542 &3.8911E+00,3.6559E+00,3.4174E+00,3.1598E+00,2.9153E+00,2.6889E+00,
37543 &2.4732E+00,2.3031E+00,2.1311E+00,1.9475E+00,1.7771E+00,1.6202E+00,
37544 &1.4748E+00,1.3609E+00,1.2481E+00,1.1301E+00,1.0222E+00,9.2549E-01,
37545 &8.3728E-01,7.6947E-01,7.0373E-01,6.3561E-01,5.7438E-01,5.1959E-01,
37546 &4.6984E-01,4.3187E-01,3.9529E-01,3.5864E-01,3.2783E-01,3.0967E-01,
37547 &2.9444E-01,2.8428E-01,2.7469E-01,2.6638E-01,2.5813E-01,2.4942E-01,
37548 &2.3986E-01,2.2937E-01,2.1819E-01,2.0682E-01,1.9665E-01,1.8966E-01/
37549 DATA (XUDF_L(K),K= 1483, 1596) /
37550 &1.8971E-01,1.9926E-01,1.9036E-01,1.8442E-01,1.8192E-01,1.8362E-01,
37551 &1.9037E-01,2.0318E-01,2.2459E-01,2.5904E-01,3.1665E-01,4.2407E-01,
37552 &0.0000E+00,0.0000E+00,1.2798E+01,1.1861E+01,1.0986E+01,1.0144E+01,
37553 &9.3643E+00,8.5887E+00,7.8706E+00,7.1866E+00,6.5568E+00,5.9419E+00,
37554 &5.3754E+00,4.8419E+00,4.3593E+00,4.0864E+00,3.8109E+00,3.5127E+00,
37555 &3.2315E+00,2.9714E+00,2.7252E+00,2.5309E+00,2.3356E+00,2.1269E+00,
37556 &1.9338E+00,1.7578E+00,1.5939E+00,1.4656E+00,1.3394E+00,1.2075E+00,
37557 &1.0875E+00,9.8023E-01,8.8256E-01,8.0772E-01,7.3533E-01,6.6054E-01,
37558 &5.9364E-01,5.3423E-01,4.8009E-01,4.3930E-01,4.0003E-01,3.6079E-01,
37559 &3.2768E-01,3.0809E-01,2.9130E-01,2.7993E-01,2.6898E-01,2.5976E-01,
37560 &2.5062E-01,2.4123E-01,2.3116E-01,2.2040E-01,2.0917E-01,1.9814E-01,
37561 &1.8865E-01,1.8272E-01,1.8428E-01,1.8820E-01,1.7883E-01,1.7238E-01,
37562 &1.6914E-01,1.6979E-01,1.7482E-01,1.8534E-01,2.0325E-01,2.3214E-01,
37563 &2.8022E-01,3.6659E-01,0.0000E+00,0.0000E+00,1.4900E+01,1.3767E+01,
37564 &1.2708E+01,1.1700E+01,1.0766E+01,9.8403E+00,8.9832E+00,8.1757E+00,
37565 &7.4366E+00,6.7121E+00,6.0486E+00,5.4300E+00,4.8704E+00,4.5555E+00,
37566 &4.2371E+00,3.8955E+00,3.5734E+00,3.2760E+00,2.9952E+00,2.7738E+00,
37567 &2.5528E+00,2.3175E+00,2.1001E+00,1.9012E+00,1.7176E+00,1.5750E+00,
37568 &1.4344E+00,1.2880E+00,1.1547E+00,1.0364E+00,9.2859E-01,8.4652E-01/
37569 DATA (XUDF_L(K),K= 1597, 1710) /
37570 &7.6723E-01,6.8578E-01,6.1255E-01,5.4848E-01,4.9034E-01,4.4649E-01,
37571 &4.0456E-01,3.6275E-01,3.2738E-01,3.0624E-01,2.8805E-01,2.7544E-01,
37572 &2.6343E-01,2.5315E-01,2.4318E-01,2.3314E-01,2.2263E-01,2.1166E-01,
37573 &2.0051E-01,1.8983E-01,1.8102E-01,1.7610E-01,1.7901E-01,1.7764E-01,
37574 &1.6791E-01,1.6102E-01,1.5715E-01,1.5684E-01,1.6056E-01,1.6899E-01,
37575 &1.8376E-01,2.0786E-01,2.4776E-01,3.1470E-01,0.0000E+00,0.0000E+00,
37576 &1.7212E+01,1.5853E+01,1.4590E+01,1.3390E+01,1.2283E+01,1.1191E+01,
37577 &1.0185E+01,9.2395E+00,8.3762E+00,7.5315E+00,6.7670E+00,6.0503E+00,
37578 &5.4086E+00,5.0481E+00,4.6843E+00,4.2940E+00,3.9280E+00,3.5917E+00,
37579 &3.2752E+00,3.0252E+00,2.7768E+00,2.5132E+00,2.2690E+00,2.0490E+00,
37580 &1.8445E+00,1.6857E+00,1.5301E+00,1.3685E+00,1.2219E+00,1.0920E+00,
37581 &9.7438E-01,8.8478E-01,7.9825E-01,7.1007E-01,6.3111E-01,5.6196E-01,
37582 &5.0016E-01,4.5321E-01,4.0867E-01,3.6435E-01,3.2686E-01,3.0431E-01,
37583 &2.8470E-01,2.7109E-01,2.5789E-01,2.4674E-01,2.3605E-01,2.2547E-01,
37584 &2.1459E-01,2.0348E-01,1.9237E-01,1.8201E-01,1.7376E-01,1.6982E-01,
37585 &1.7398E-01,1.6789E-01,1.5795E-01,1.5065E-01,1.4630E-01,1.4521E-01,
37586 &1.4773E-01,1.5443E-01,1.6659E-01,1.8664E-01,2.1966E-01,2.6878E-01,
37587 &0.0000E+00,0.0000E+00,1.9526E+01,1.7951E+01,1.6470E+01,1.5074E+01,
37588 &1.3790E+01,1.2527E+01,1.1370E+01,1.0282E+01,9.2958E+00,8.3330E+00/
37589 DATA (XUDF_L(K),K= 1711, 1824) /
37590 &7.4603E+00,6.6536E+00,5.9285E+00,5.5219E+00,5.1141E+00,4.6768E+00,
37591 &4.2681E+00,3.8926E+00,3.5402E+00,3.2626E+00,2.9882E+00,2.6963E+00,
37592 &2.4284E+00,2.1851E+00,1.9619E+00,1.7885E+00,1.6187E+00,1.4429E+00,
37593 &1.2838E+00,1.1431E+00,1.0159E+00,9.1924E-01,8.2663E-01,7.3180E-01,
37594 &6.4793E-01,5.7429E-01,5.0828E-01,4.5904E-01,4.1215E-01,3.6558E-01,
37595 &3.2620E-01,3.0238E-01,2.8167E-01,2.6700E-01,2.5302E-01,2.4098E-01,
37596 &2.2975E-01,2.1873E-01,2.0756E-01,1.9633E-01,1.8532E-01,1.7533E-01,
37597 &1.6763E-01,1.6450E-01,1.6959E-01,1.5953E-01,1.4943E-01,1.4185E-01,
37598 &1.3716E-01,1.3545E-01,1.3705E-01,1.4238E-01,1.5258E-01,1.6945E-01,
37599 &1.9705E-01,2.3049E-01,0.0000E+00,0.0000E+00,2.2141E+01,2.0286E+01,
37600 &1.8570E+01,1.6948E+01,1.5466E+01,1.4010E+01,1.2679E+01,1.1431E+01,
37601 &1.0303E+01,9.2106E+00,8.2239E+00,7.3077E+00,6.4926E+00,6.0348E+00,
37602 &5.5765E+00,5.0879E+00,4.6321E+00,4.2138E+00,3.8233E+00,3.5162E+00,
37603 &3.2122E+00,2.8907E+00,2.5960E+00,2.3300E+00,2.0856E+00,1.8954E+00,
37604 &1.7110E+00,1.5199E+00,1.3476E+00,1.1955E+00,1.0584E+00,9.5478E-01,
37605 &8.5531E-01,7.5417E-01,6.6439E-01,5.8623E-01,5.1682E-01,4.6468E-01,
37606 &4.1541E-01,3.6662E-01,3.2538E-01,3.0035E-01,2.7843E-01,2.6291E-01,
37607 &2.4798E-01,2.3522E-01,2.2346E-01,2.1203E-01,2.0062E-01,1.8935E-01,
37608 &1.7843E-01,1.6874E-01,1.6163E-01,1.5920E-01,1.6520E-01,1.5147E-01/
37609 DATA (XUDF_L(K),K= 1825, 1836) /
37610 &1.4120E-01,1.3349E-01,1.2844E-01,1.2620E-01,1.2701E-01,1.3118E-01,
37611 &1.3954E-01,1.5369E-01,1.7631E-01,1.9416E-01,0.0000E+00,0.0000E+00/
37612 DATA (XSF_L(K),K= 1, 114) /
37613 &8.9277E-03,9.2838E-03,9.6380E-03,9.9960E-03,1.0349E-02,1.0719E-02,
37614 &1.1082E-02,1.1442E-02,1.1792E-02,1.2148E-02,1.2489E-02,1.2817E-02,
37615 &1.3124E-02,1.3295E-02,1.3474E-02,1.3661E-02,1.3835E-02,1.3985E-02,
37616 &1.4121E-02,1.4217E-02,1.4303E-02,1.4379E-02,1.4419E-02,1.4434E-02,
37617 &1.4412E-02,1.4366E-02,1.4286E-02,1.4158E-02,1.3991E-02,1.3790E-02,
37618 &1.3553E-02,1.3335E-02,1.3094E-02,1.2821E-02,1.2580E-02,1.2410E-02,
37619 &1.2357E-02,1.2459E-02,1.2790E-02,1.3571E-02,1.5018E-02,1.6665E-02,
37620 &1.9113E-02,2.1832E-02,2.5587E-02,2.9818E-02,3.4535E-02,3.9813E-02,
37621 &4.5737E-02,5.2358E-02,5.9765E-02,6.8021E-02,7.7185E-02,8.7258E-02,
37622 &9.8198E-02,1.1073E-01,1.4216E-01,1.8364E-01,2.3959E-01,3.1758E-01,
37623 &4.3050E-01,6.0203E-01,8.8214E-01,1.3845E+00,2.4294E+00,5.2463E+00,
37624 &1.8903E+01,0.0000E+00,1.4987E-02,1.5468E-02,1.5936E-02,1.6403E-02,
37625 &1.6855E-02,1.7319E-02,1.7760E-02,1.8194E-02,1.8600E-02,1.9008E-02,
37626 &1.9382E-02,1.9730E-02,2.0033E-02,2.0199E-02,2.0359E-02,2.0523E-02,
37627 &2.0654E-02,2.0760E-02,2.0831E-02,2.0870E-02,2.0886E-02,2.0858E-02,
37628 &2.0798E-02,2.0680E-02,2.0523E-02,2.0363E-02,2.0127E-02,1.9825E-02,
37629 &1.9464E-02,1.9060E-02,1.8607E-02,1.8200E-02,1.7750E-02,1.7240E-02,
37630 &1.6759E-02,1.6362E-02,1.6103E-02,1.6050E-02,1.6240E-02,1.6916E-02,
37631 &1.8336E-02,2.0030E-02,2.2586E-02,2.5447E-02,2.9418E-02,3.3874E-02/
37632 DATA (XSF_L(K),K= 115, 228) /
37633 &3.8821E-02,4.4375E-02,5.0509E-02,5.7343E-02,6.4974E-02,7.3385E-02,
37634 &8.2640E-02,9.2732E-02,1.0354E-01,1.1667E-01,1.4809E-01,1.8910E-01,
37635 &2.4387E-01,3.1940E-01,4.2764E-01,5.9054E-01,8.5228E-01,1.3150E+00,
37636 &2.2623E+00,4.7596E+00,1.6445E+01,0.0000E+00,2.5010E-02,2.5616E-02,
37637 &2.6180E-02,2.6758E-02,2.7279E-02,2.7792E-02,2.8274E-02,2.8729E-02,
37638 &2.9134E-02,2.9513E-02,2.9836E-02,3.0110E-02,3.0324E-02,3.0417E-02,
37639 &3.0492E-02,3.0537E-02,3.0551E-02,3.0517E-02,3.0432E-02,3.0326E-02,
37640 &3.0181E-02,2.9954E-02,2.9663E-02,2.9316E-02,2.8913E-02,2.8508E-02,
37641 &2.8021E-02,2.7422E-02,2.6741E-02,2.5997E-02,2.5204E-02,2.4500E-02,
37642 &2.3734E-02,2.2858E-02,2.2019E-02,2.1281E-02,2.0698E-02,2.0402E-02,
37643 &2.0365E-02,2.0844E-02,2.2137E-02,2.3807E-02,2.6404E-02,2.9338E-02,
37644 &3.3433E-02,3.8036E-02,4.3135E-02,4.8799E-02,5.5061E-02,6.1999E-02,
37645 &6.9633E-02,7.8024E-02,8.7156E-02,9.6998E-02,1.0742E-01,1.2099E-01,
37646 &1.5162E-01,1.9121E-01,2.4363E-01,3.1510E-01,4.1638E-01,5.6669E-01,
37647 &8.0557E-01,1.2216E+00,2.0572E+00,4.2084E+00,1.3911E+01,0.0000E+00,
37648 &4.2554E-02,4.3210E-02,4.3820E-02,4.4379E-02,4.4862E-02,4.5317E-02,
37649 &4.5708E-02,4.6037E-02,4.6300E-02,4.6434E-02,4.6540E-02,4.6530E-02,
37650 &4.6426E-02,4.6317E-02,4.6155E-02,4.5919E-02,4.5622E-02,4.5267E-02,
37651 &4.4833E-02,4.4425E-02,4.3932E-02,4.3298E-02,4.2582E-02,4.1785E-02/
37652 DATA (XSF_L(K),K= 229, 342) /
37653 &4.0903E-02,4.0097E-02,3.9179E-02,3.8047E-02,3.6815E-02,3.5547E-02,
37654 &3.4199E-02,3.3020E-02,3.1748E-02,3.0298E-02,2.8905E-02,2.7644E-02,
37655 &2.6563E-02,2.5882E-02,2.5485E-02,2.5614E-02,2.6651E-02,2.8199E-02,
37656 &3.0731E-02,3.3652E-02,3.7768E-02,4.2390E-02,4.7530E-02,5.3188E-02,
37657 &5.9436E-02,6.6257E-02,7.3734E-02,8.1918E-02,9.0696E-02,1.0004E-01,
37658 &1.0978E-01,1.2357E-01,1.5274E-01,1.8999E-01,2.3888E-01,3.0452E-01,
37659 &3.9656E-01,5.3136E-01,7.4246E-01,1.1043E+00,1.8158E+00,3.6023E+00,
37660 &0.0000E+00,0.0000E+00,7.3602E-02,7.4085E-02,7.4460E-02,7.4729E-02,
37661 &7.4904E-02,7.4982E-02,7.4902E-02,7.4713E-02,7.4446E-02,7.3972E-02,
37662 &7.3397E-02,7.2626E-02,7.1803E-02,7.1200E-02,7.0479E-02,6.9610E-02,
37663 &6.8654E-02,6.7624E-02,6.6495E-02,6.5467E-02,6.4313E-02,6.2898E-02,
37664 &6.1380E-02,5.9788E-02,5.8079E-02,5.6557E-02,5.4876E-02,5.2866E-02,
37665 &5.0733E-02,4.8592E-02,4.6341E-02,4.4415E-02,4.2370E-02,4.0073E-02,
37666 &3.7825E-02,3.5778E-02,3.3956E-02,3.2702E-02,3.1749E-02,3.1334E-02,
37667 &3.1922E-02,3.3216E-02,3.5534E-02,3.8322E-02,4.2321E-02,4.6830E-02,
37668 &5.1816E-02,5.7335E-02,6.3369E-02,6.9947E-02,7.7109E-02,8.4752E-02,
37669 &9.2948E-02,1.0153E-01,1.1031E-01,1.2405E-01,1.5100E-01,1.8509E-01,
37670 &2.2905E-01,2.8761E-01,3.6847E-01,4.8537E-01,6.6543E-01,9.6831E-01,
37671 &1.5524E+00,2.9766E+00,0.0000E+00,0.0000E+00,1.1509E-01,1.1500E-01/
37672 DATA (XSF_L(K),K= 343, 456) /
37673 &1.1474E-01,1.1430E-01,1.1371E-01,1.1292E-01,1.1196E-01,1.1079E-01,
37674 &1.0948E-01,1.0791E-01,1.0620E-01,1.0426E-01,1.0215E-01,1.0076E-01,
37675 &9.9224E-02,9.7466E-02,9.5472E-02,9.3507E-02,9.1346E-02,8.9460E-02,
37676 &8.7382E-02,8.4914E-02,8.2326E-02,7.9663E-02,7.6874E-02,7.4459E-02,
37677 &7.1794E-02,6.8694E-02,6.5489E-02,6.2266E-02,5.8964E-02,5.6164E-02,
37678 &5.3226E-02,4.9916E-02,4.6721E-02,4.3794E-02,4.1128E-02,3.9225E-02,
37679 &3.7654E-02,3.6613E-02,3.6666E-02,3.7626E-02,3.9655E-02,4.2227E-02,
37680 &4.6000E-02,5.0288E-02,5.5044E-02,6.0308E-02,6.6020E-02,7.2218E-02,
37681 &7.8943E-02,8.6079E-02,9.3611E-02,1.0141E-01,1.0925E-01,1.2274E-01,
37682 &1.4748E-01,1.7840E-01,2.1791E-01,2.6997E-01,3.4109E-01,4.4280E-01,
37683 &5.9706E-01,8.5325E-01,1.3371E+00,2.4909E+00,0.0000E+00,0.0000E+00,
37684 &1.8131E-01,1.7986E-01,1.7802E-01,1.7597E-01,1.7372E-01,1.7110E-01,
37685 &1.6825E-01,1.6515E-01,1.6187E-01,1.5820E-01,1.5428E-01,1.5016E-01,
37686 &1.4582E-01,1.4314E-01,1.4017E-01,1.3677E-01,1.3315E-01,1.2951E-01,
37687 &1.2571E-01,1.2248E-01,1.1891E-01,1.1472E-01,1.1045E-01,1.0615E-01,
37688 &1.0173E-01,9.7944E-02,9.3854E-02,8.9131E-02,8.4347E-02,7.9597E-02,
37689 &7.4799E-02,7.0788E-02,6.6599E-02,6.1932E-02,5.7438E-02,5.3307E-02,
37690 &4.9546E-02,4.6816E-02,4.4417E-02,4.2536E-02,4.1862E-02,4.2361E-02,
37691 &4.3960E-02,4.6198E-02,4.9612E-02,5.3553E-02,5.7974E-02,6.2830E-02/
37692 DATA (XSF_L(K),K= 457, 570) /
37693 &6.8141E-02,7.3865E-02,7.9970E-02,8.6422E-02,9.3160E-02,1.0006E-01,
37694 &1.0685E-01,1.1989E-01,1.4199E-01,1.6937E-01,2.0407E-01,2.4925E-01,
37695 &3.1029E-01,3.9635E-01,5.2529E-01,7.3579E-01,1.1263E+00,2.0347E+00,
37696 &0.0000E+00,0.0000E+00,2.6278E-01,2.5883E-01,2.5460E-01,2.5007E-01,
37697 &2.4526E-01,2.3995E-01,2.3437E-01,2.2848E-01,2.2242E-01,2.1578E-01,
37698 &2.0894E-01,2.0181E-01,1.9465E-01,1.9018E-01,1.8540E-01,1.7984E-01,
37699 &1.7415E-01,1.6846E-01,1.6261E-01,1.5768E-01,1.5234E-01,1.4615E-01,
37700 &1.3987E-01,1.3368E-01,1.2736E-01,1.2199E-01,1.1628E-01,1.0975E-01,
37701 &1.0321E-01,9.6788E-02,9.0380E-02,8.5059E-02,7.9532E-02,7.3436E-02,
37702 &6.7594E-02,6.2243E-02,5.7363E-02,5.3720E-02,5.0502E-02,4.7772E-02,
37703 &4.6346E-02,4.6358E-02,4.7497E-02,4.9377E-02,5.2401E-02,5.5965E-02,
37704 &6.0009E-02,6.4489E-02,6.9334E-02,7.4546E-02,8.0117E-02,8.5936E-02,
37705 &9.1972E-02,9.8056E-02,1.0398E-01,1.1644E-01,1.3628E-01,1.6068E-01,
37706 &1.9127E-01,2.3085E-01,2.8377E-01,3.5756E-01,4.6698E-01,6.4315E-01,
37707 &9.6485E-01,1.6969E+00,0.0000E+00,0.0000E+00,3.6944E-01,3.6187E-01,
37708 &3.5380E-01,3.4525E-01,3.3659E-01,3.2716E-01,3.1761E-01,3.0767E-01,
37709 &2.9759E-01,2.8675E-01,2.7586E-01,2.6462E-01,2.5339E-01,2.4660E-01,
37710 &2.3933E-01,2.3101E-01,2.2257E-01,2.1415E-01,2.0571E-01,1.9854E-01,
37711 &1.9083E-01,1.8216E-01,1.7338E-01,1.6480E-01,1.5613E-01,1.4885E-01/
37712 DATA (XSF_L(K),K= 571, 684) /
37713 &1.4115E-01,1.3244E-01,1.2380E-01,1.1542E-01,1.0713E-01,1.0031E-01,
37714 &9.3226E-02,8.5515E-02,7.8171E-02,7.1449E-02,6.5307E-02,6.0723E-02,
37715 &5.6523E-02,5.2878E-02,5.0622E-02,5.0109E-02,5.0720E-02,5.2187E-02,
37716 &5.4770E-02,5.7950E-02,6.1582E-02,6.5595E-02,6.9997E-02,7.4716E-02,
37717 &7.9677E-02,8.4886E-02,9.0221E-02,9.5543E-02,1.0065E-01,1.1245E-01,
37718 &1.3012E-01,1.5166E-01,1.7859E-01,2.1305E-01,2.5881E-01,3.2188E-01,
37719 &4.1454E-01,5.6186E-01,8.2718E-01,1.4188E+00,0.0000E+00,0.0000E+00,
37720 &4.9195E-01,4.7916E-01,4.6620E-01,4.5277E-01,4.3908E-01,4.2463E-01,
37721 &4.0985E-01,3.9491E-01,3.7975E-01,3.6377E-01,3.4790E-01,3.3178E-01,
37722 &3.1592E-01,3.0640E-01,2.9622E-01,2.8462E-01,2.7303E-01,2.6160E-01,
37723 &2.5012E-01,2.4047E-01,2.3023E-01,2.1867E-01,2.0717E-01,1.9597E-01,
37724 &1.8477E-01,1.7546E-01,1.6568E-01,1.5468E-01,1.4387E-01,1.3343E-01,
37725 &1.2319E-01,1.1482E-01,1.0622E-01,9.6828E-02,8.7978E-02,7.9884E-02,
37726 &7.2526E-02,6.6973E-02,6.1948E-02,5.7359E-02,5.4304E-02,5.3263E-02,
37727 &5.3381E-02,5.4456E-02,5.6601E-02,5.9380E-02,6.2613E-02,6.6252E-02,
37728 &7.0174E-02,7.4432E-02,7.8943E-02,8.3559E-02,8.8282E-02,9.2963E-02,
37729 &9.7382E-02,1.0858E-01,1.2441E-01,1.4363E-01,1.6745E-01,1.9778E-01,
37730 &2.3771E-01,2.9246E-01,3.7200E-01,4.9738E-01,7.2010E-01,1.2083E+00,
37731 &0.0000E+00,0.0000E+00,6.4521E-01,6.2534E-01,6.0540E-01,5.8499E-01/
37732 DATA (XSF_L(K),K= 685, 798) /
37733 &5.6467E-01,5.4301E-01,5.2143E-01,4.9951E-01,4.7813E-01,4.5538E-01,
37734 &4.3325E-01,4.1083E-01,3.8899E-01,3.7591E-01,3.6210E-01,3.4648E-01,
37735 &3.3091E-01,3.1578E-01,3.0062E-01,2.8797E-01,2.7469E-01,2.5979E-01,
37736 &2.4501E-01,2.3066E-01,2.1649E-01,2.0481E-01,1.9252E-01,1.7884E-01,
37737 &1.6549E-01,1.5274E-01,1.4029E-01,1.3018E-01,1.1985E-01,1.0865E-01,
37738 &9.8135E-02,8.8550E-02,7.9829E-02,7.3318E-02,6.7269E-02,6.1748E-02,
37739 &5.7838E-02,5.6250E-02,5.5826E-02,5.6474E-02,5.8181E-02,6.0533E-02,
37740 &6.3373E-02,6.6563E-02,7.0085E-02,7.3865E-02,7.7842E-02,8.1937E-02,
37741 &8.6092E-02,9.0169E-02,9.3962E-02,1.0448E-01,1.1858E-01,1.3561E-01,
37742 &1.5663E-01,1.8318E-01,2.1803E-01,2.6529E-01,3.3349E-01,4.3985E-01,
37743 &6.2661E-01,1.0291E+00,0.0000E+00,0.0000E+00,8.2462E-01,7.9558E-01,
37744 &7.6680E-01,7.3764E-01,7.0860E-01,6.7834E-01,6.4822E-01,6.1798E-01,
37745 &5.8880E-01,5.5792E-01,5.2800E-01,4.9801E-01,4.6912E-01,4.5197E-01,
37746 &4.3393E-01,4.1360E-01,3.9348E-01,3.7394E-01,3.5462E-01,3.3856E-01,
37747 &3.2180E-01,3.0303E-01,2.8460E-01,2.6681E-01,2.4932E-01,2.3502E-01,
37748 &2.2005E-01,2.0359E-01,1.8747E-01,1.7224E-01,1.5746E-01,1.4551E-01,
37749 &1.3337E-01,1.2028E-01,1.0805E-01,9.6986E-02,8.6877E-02,7.9334E-02,
37750 &7.2326E-02,6.5799E-02,6.1060E-02,5.8911E-02,5.7957E-02,5.8189E-02,
37751 &5.9441E-02,6.1387E-02,6.3834E-02,6.6632E-02,6.9732E-02,7.3070E-02/
37752 DATA (XSF_L(K),K= 799, 912) /
37753 &7.6595E-02,8.0190E-02,8.3816E-02,8.7358E-02,9.0631E-02,1.0046E-01,
37754 &1.1304E-01,1.2815E-01,1.4670E-01,1.7006E-01,2.0049E-01,2.4154E-01,
37755 &3.0039E-01,3.9121E-01,5.4894E-01,8.8378E-01,0.0000E+00,0.0000E+00,
37756 &1.0199E+00,9.8025E-01,9.4100E-01,9.0151E-01,8.6283E-01,8.2243E-01,
37757 &7.8262E-01,7.4321E-01,7.0465E-01,6.6494E-01,6.2647E-01,5.8811E-01,
37758 &5.5152E-01,5.2985E-01,5.0721E-01,4.8183E-01,4.5681E-01,4.3274E-01,
37759 &4.0883E-01,3.8916E-01,3.6878E-01,3.4589E-01,3.2366E-01,3.0238E-01,
37760 &2.8152E-01,2.6437E-01,2.4685E-01,2.2733E-01,2.0858E-01,1.9085E-01,
37761 &1.7375E-01,1.6000E-01,1.4607E-01,1.3115E-01,1.1722E-01,1.0469E-01,
37762 &9.3284E-02,8.4739E-02,7.6803E-02,6.9420E-02,6.3844E-02,6.1178E-02,
37763 &5.9720E-02,5.9561E-02,6.0398E-02,6.1984E-02,6.4051E-02,6.6494E-02,
37764 &6.9202E-02,7.2161E-02,7.5274E-02,7.8453E-02,8.1651E-02,8.4728E-02,
37765 &8.7564E-02,9.6777E-02,1.0806E-01,1.2157E-01,1.3806E-01,1.5882E-01,
37766 &1.8566E-01,2.2170E-01,2.7301E-01,3.5168E-01,4.8696E-01,7.7010E-01,
37767 &0.0000E+00,0.0000E+00,1.3158E+00,1.2585E+00,1.2024E+00,1.1462E+00,
37768 &1.0919E+00,1.0352E+00,9.8042E-01,9.2608E-01,8.7345E-01,8.1987E-01,
37769 &7.6814E-01,7.1724E-01,6.6882E-01,6.4053E-01,6.1093E-01,5.7796E-01,
37770 &5.4572E-01,5.1470E-01,4.8433E-01,4.5934E-01,4.3358E-01,4.0495E-01,
37771 &3.7717E-01,3.5082E-01,3.2513E-01,3.0408E-01,2.8258E-01,2.5918E-01/
37772 DATA (XSF_L(K),K= 913, 1026) /
37773 &2.3648E-01,2.1538E-01,1.9510E-01,1.7888E-01,1.6255E-01,1.4508E-01,
37774 &1.2895E-01,1.1443E-01,1.0131E-01,9.1507E-02,8.2387E-02,7.3778E-02,
37775 &6.7147E-02,6.3813E-02,6.1721E-02,6.1065E-02,6.1373E-02,6.2475E-02,
37776 &6.4105E-02,6.6079E-02,6.8362E-02,7.0856E-02,7.3440E-02,7.6143E-02,
37777 &7.8812E-02,8.1388E-02,8.3726E-02,9.2167E-02,1.0190E-01,1.1355E-01,
37778 &1.2780E-01,1.4554E-01,1.6841E-01,1.9900E-01,2.4223E-01,3.0775E-01,
37779 &4.1920E-01,6.4849E-01,0.0000E+00,0.0000E+00,1.6483E+00,1.5703E+00,
37780 &1.4940E+00,1.4180E+00,1.3449E+00,1.2694E+00,1.1966E+00,1.1250E+00,
37781 &1.0566E+00,9.8644E-01,9.1985E-01,8.5482E-01,7.9312E-01,7.5722E-01,
37782 &7.1986E-01,6.7849E-01,6.3821E-01,5.9972E-01,5.6214E-01,5.3143E-01,
37783 &4.9987E-01,4.6500E-01,4.3136E-01,3.9956E-01,3.6875E-01,3.4379E-01,
37784 &3.1832E-01,2.9044E-01,2.6397E-01,2.3923E-01,2.1580E-01,1.9706E-01,
37785 &1.7829E-01,1.5838E-01,1.3999E-01,1.2356E-01,1.0875E-01,9.7664E-02,
37786 &8.7392E-02,7.7645E-02,7.0035E-02,6.6062E-02,6.3365E-02,6.2239E-02,
37787 &6.2062E-02,6.2731E-02,6.3942E-02,6.5526E-02,6.7390E-02,6.9436E-02,
37788 &7.1635E-02,7.3891E-02,7.6122E-02,7.8246E-02,8.0196E-02,8.7884E-02,
37789 &9.6357E-02,1.0648E-01,1.1880E-01,1.3413E-01,1.5386E-01,1.7993E-01,
37790 &2.1655E-01,2.7189E-01,3.6486E-01,5.5332E-01,0.0000E+00,0.0000E+00,
37791 &2.0271E+00,1.9234E+00,1.8224E+00,1.7226E+00,1.6272E+00,1.5293E+00/
37792 DATA (XSF_L(K),K= 1027, 1140) /
37793 &1.4356E+00,1.3438E+00,1.2568E+00,1.1682E+00,1.0841E+00,1.0026E+00,
37794 &9.2625E-01,8.8207E-01,8.3568E-01,7.8523E-01,7.3607E-01,6.8926E-01,
37795 &6.4385E-01,6.0685E-01,5.6892E-01,5.2730E-01,4.8731E-01,4.4961E-01,
37796 &4.1331E-01,3.8417E-01,3.5441E-01,3.2210E-01,2.9168E-01,2.6323E-01,
37797 &2.3631E-01,2.1500E-01,1.9374E-01,1.7129E-01,1.5067E-01,1.3231E-01,
37798 &1.1579E-01,1.0349E-01,9.2080E-02,8.1205E-02,7.2626E-02,6.8039E-02,
37799 &6.4761E-02,6.3188E-02,6.2549E-02,6.2795E-02,6.3617E-02,6.4835E-02,
37800 &6.6329E-02,6.8017E-02,6.9809E-02,7.1667E-02,7.3520E-02,7.5270E-02,
37801 &7.6864E-02,8.3899E-02,9.1206E-02,1.0002E-01,1.1070E-01,1.2399E-01,
37802 &1.4094E-01,1.6341E-01,1.9474E-01,2.4163E-01,3.1971E-01,4.7587E-01,
37803 &0.0000E+00,0.0000E+00,2.4392E+00,2.3049E+00,2.1760E+00,2.0502E+00,
37804 &1.9296E+00,1.8065E+00,1.6895E+00,1.5750E+00,1.4674E+00,1.3585E+00,
37805 &1.2554E+00,1.1565E+00,1.0638E+00,1.0103E+00,9.5527E-01,8.9449E-01,
37806 &8.3572E-01,7.8018E-01,7.2635E-01,6.8280E-01,6.3819E-01,5.8948E-01,
37807 &5.4299E-01,4.9923E-01,4.5740E-01,4.2371E-01,3.8978E-01,3.5296E-01,
37808 &3.1832E-01,2.8629E-01,2.5599E-01,2.3212E-01,2.0840E-01,1.8346E-01,
37809 &1.6065E-01,1.4043E-01,1.2229E-01,1.0880E-01,9.6294E-02,8.4335E-02,
37810 &7.4905E-02,6.9717E-02,6.5897E-02,6.3914E-02,6.2851E-02,6.2731E-02,
37811 &6.3183E-02,6.4075E-02,6.5225E-02,6.6597E-02,6.8048E-02,6.9577E-02/
37812 DATA (XSF_L(K),K= 1141, 1254) /
37813 &7.1093E-02,7.2525E-02,7.3842E-02,8.0241E-02,8.6615E-02,9.4292E-02,
37814 &1.0360E-01,1.1517E-01,1.2992E-01,1.4936E-01,1.7633E-01,2.1652E-01,
37815 &2.8294E-01,4.1389E-01,0.0000E+00,0.0000E+00,2.9162E+00,2.7470E+00,
37816 &2.5840E+00,2.4244E+00,2.2743E+00,2.1215E+00,1.9764E+00,1.8358E+00,
37817 &1.7035E+00,1.5708E+00,1.4463E+00,1.3268E+00,1.2152E+00,1.1514E+00,
37818 &1.0857E+00,1.0132E+00,9.4449E-01,8.7867E-01,8.1556E-01,7.6453E-01,
37819 &7.1252E-01,6.5602E-01,6.0218E-01,5.5192E-01,5.0387E-01,4.6545E-01,
37820 &4.2679E-01,3.8521E-01,3.4602E-01,3.1005E-01,2.7623E-01,2.4962E-01,
37821 &2.2332E-01,1.9577E-01,1.7070E-01,1.4856E-01,1.2874E-01,1.1402E-01,
37822 &1.0040E-01,8.7343E-02,7.6984E-02,7.1254E-02,6.6892E-02,6.4508E-02,
37823 &6.3019E-02,6.2518E-02,6.2667E-02,6.3211E-02,6.4031E-02,6.5064E-02,
37824 &6.6243E-02,6.7458E-02,6.8679E-02,6.9830E-02,7.0885E-02,7.6672E-02,
37825 &8.2192E-02,8.8844E-02,9.6930E-02,1.0696E-01,1.1972E-01,1.3654E-01,
37826 &1.5978E-01,1.9411E-01,2.5048E-01,3.6023E-01,0.0000E+00,0.0000E+00,
37827 &3.4281E+00,3.2194E+00,3.0180E+00,2.8239E+00,2.6400E+00,2.4537E+00,
37828 &2.2781E+00,2.1087E+00,1.9503E+00,1.7915E+00,1.6433E+00,1.5021E+00,
37829 &1.3711E+00,1.2958E+00,1.2191E+00,1.1350E+00,1.0536E+00,9.7846E-01,
37830 &9.0526E-01,8.4668E-01,7.8697E-01,7.2243E-01,6.6110E-01,6.0402E-01,
37831 &5.4971E-01,5.0652E-01,4.6307E-01,4.1647E-01,3.7287E-01,3.3288E-01/
37832 DATA (XSF_L(K),K= 1255, 1368) /
37833 &2.9545E-01,2.6636E-01,2.3751E-01,2.0740E-01,1.8012E-01,1.5611E-01,
37834 &1.3467E-01,1.1881E-01,1.0414E-01,9.0105E-02,7.8839E-02,7.2563E-02,
37835 &6.7703E-02,6.4930E-02,6.3070E-02,6.2241E-02,6.2071E-02,6.2347E-02,
37836 &6.2882E-02,6.3645E-02,6.4526E-02,6.5473E-02,6.6427E-02,6.7333E-02,
37837 &6.8194E-02,7.3430E-02,7.8217E-02,8.3974E-02,9.1017E-02,9.9745E-02,
37838 &1.1088E-01,1.2552E-01,1.4563E-01,1.7528E-01,2.2351E-01,3.1636E-01,
37839 &0.0000E+00,0.0000E+00,3.9892E+00,3.7328E+00,3.4900E+00,3.2549E+00,
37840 &3.0344E+00,2.8108E+00,2.6014E+00,2.4001E+00,2.2123E+00,2.0253E+00,
37841 &1.8518E+00,1.6860E+00,1.5339E+00,1.4463E+00,1.3575E+00,1.2608E+00,
37842 &1.1678E+00,1.0809E+00,9.9767E-01,9.3087E-01,8.6314E-01,7.8996E-01,
37843 &7.2083E-01,6.5671E-01,5.9602E-01,5.4775E-01,4.9935E-01,4.4773E-01,
37844 &3.9951E-01,3.5571E-01,3.1467E-01,2.8272E-01,2.5135E-01,2.1871E-01,
37845 &1.8923E-01,1.6331E-01,1.4031E-01,1.2332E-01,1.0762E-01,9.2560E-02,
37846 &8.0473E-02,7.3714E-02,6.8385E-02,6.5246E-02,6.3019E-02,6.1878E-02,
37847 &6.1420E-02,6.1413E-02,6.1734E-02,6.2226E-02,6.2861E-02,6.3564E-02,
37848 &6.4288E-02,6.4985E-02,6.5657E-02,7.0367E-02,7.4522E-02,7.9506E-02,
37849 &8.5651E-02,9.3297E-02,1.0298E-01,1.1572E-01,1.3323E-01,1.5884E-01,
37850 &2.0039E-01,2.7925E-01,0.0000E+00,0.0000E+00,4.5788E+00,4.2729E+00,
37851 &3.9840E+00,3.7039E+00,3.4438E+00,3.1812E+00,2.9349E+00,2.6996E+00/
37852 DATA (XSF_L(K),K= 1369, 1482) /
37853 &2.4810E+00,2.2644E+00,2.0633E+00,1.8732E+00,1.6979E+00,1.5988E+00,
37854 &1.4974E+00,1.3865E+00,1.2812E+00,1.1834E+00,1.0891E+00,1.0143E+00,
37855 &9.3839E-01,8.5662E-01,7.7948E-01,7.0838E-01,6.4106E-01,5.8780E-01,
37856 &5.3454E-01,4.7781E-01,4.2528E-01,3.7737E-01,3.3289E-01,2.9818E-01,
37857 &2.6446E-01,2.2932E-01,1.9770E-01,1.7005E-01,1.4552E-01,1.2746E-01,
37858 &1.1078E-01,9.4770E-02,8.1957E-02,7.4689E-02,6.8915E-02,6.5457E-02,
37859 &6.2902E-02,6.1493E-02,6.0768E-02,6.0515E-02,6.0585E-02,6.0863E-02,
37860 &6.1298E-02,6.1789E-02,6.2311E-02,6.2835E-02,6.3340E-02,6.7601E-02,
37861 &7.1162E-02,7.5516E-02,8.0878E-02,8.7566E-02,9.6095E-02,1.0725E-01,
37862 &1.2258E-01,1.4495E-01,1.8090E-01,2.4841E-01,0.0000E+00,0.0000E+00,
37863 &5.4774E+00,5.0929E+00,4.7320E+00,4.3841E+00,4.0592E+00,3.7350E+00,
37864 &3.4329E+00,3.1454E+00,2.8799E+00,2.6172E+00,2.3747E+00,2.1466E+00,
37865 &1.9383E+00,1.8195E+00,1.6996E+00,1.5689E+00,1.4457E+00,1.3301E+00,
37866 &1.2211E+00,1.1339E+00,1.0456E+00,9.5119E-01,8.6259E-01,7.8097E-01,
37867 &7.0419E-01,6.4380E-01,5.8358E-01,5.1955E-01,4.6051E-01,4.0719E-01,
37868 &3.5768E-01,3.1962E-01,2.8220E-01,2.4360E-01,2.0909E-01,1.7895E-01,
37869 &1.5240E-01,1.3282E-01,1.1484E-01,9.7655E-02,8.3739E-02,7.5857E-02,
37870 &6.9509E-02,6.5616E-02,6.2633E-02,6.0853E-02,5.9819E-02,5.9271E-02,
37871 &5.9038E-02,5.9046E-02,5.9192E-02,5.9432E-02,5.9709E-02,6.0008E-02/
37872 DATA (XSF_L(K),K= 1483, 1596) /
37873 &6.0340E-02,6.4032E-02,6.6851E-02,7.0446E-02,7.4870E-02,8.0457E-02,
37874 &8.7554E-02,9.6862E-02,1.0964E-01,1.2821E-01,1.5779E-01,2.1189E-01,
37875 &0.0000E+00,0.0000E+00,6.3982E+00,5.9307E+00,5.4920E+00,5.0710E+00,
37876 &4.6822E+00,4.2915E+00,3.9337E+00,3.5898E+00,3.2756E+00,2.9660E+00,
37877 &2.6817E+00,2.4150E+00,2.1724E+00,2.0348E+00,1.8961E+00,1.7457E+00,
37878 &1.6034E+00,1.4714E+00,1.3471E+00,1.2473E+00,1.1476E+00,1.0408E+00,
37879 &9.4083E-01,8.4932E-01,7.6350E-01,6.9606E-01,6.2897E-01,5.5833E-01,
37880 &4.9315E-01,4.3444E-01,3.8044E-01,3.3861E-01,2.9817E-01,2.5642E-01,
37881 &2.1917E-01,1.8685E-01,1.5838E-01,1.3752E-01,1.1831E-01,9.9987E-02,
37882 &8.5224E-02,7.6762E-02,6.9910E-02,6.5655E-02,6.2297E-02,6.0213E-02,
37883 &5.8897E-02,5.8096E-02,5.7624E-02,5.7400E-02,5.7322E-02,5.7351E-02,
37884 &5.7432E-02,5.7560E-02,5.7758E-02,6.0939E-02,6.3212E-02,6.6167E-02,
37885 &6.9884E-02,7.4560E-02,8.0552E-02,8.8432E-02,9.9242E-02,1.1491E-01,
37886 &1.3966E-01,1.8320E-01,0.0000E+00,0.0000E+00,7.4490E+00,6.8826E+00,
37887 &6.3540E+00,5.8477E+00,5.3805E+00,4.9187E+00,4.4884E+00,4.0843E+00,
37888 &3.7147E+00,3.3516E+00,3.0193E+00,2.7088E+00,2.4279E+00,2.2696E+00,
37889 &2.1091E+00,1.9368E+00,1.7739E+00,1.6237E+00,1.4821E+00,1.3692E+00,
37890 &1.2557E+00,1.1358E+00,1.0238E+00,9.2133E-01,8.2567E-01,7.5070E-01,
37891 &6.7656E-01,5.9850E-01,5.2688E-01,4.6263E-01,4.0371E-01,3.5842E-01/
37892 DATA (XSF_L(K),K= 1597, 1710) /
37893 &3.1427E-01,2.6933E-01,2.2930E-01,1.9466E-01,1.6427E-01,1.4208E-01,
37894 &1.2168E-01,1.0226E-01,8.6560E-02,7.7553E-02,7.0202E-02,6.5576E-02,
37895 &6.1860E-02,5.9487E-02,5.7920E-02,5.6852E-02,5.6166E-02,5.5736E-02,
37896 &5.5458E-02,5.5289E-02,5.5193E-02,5.5163E-02,5.5243E-02,5.7935E-02,
37897 &5.9740E-02,6.2111E-02,6.5158E-02,6.9050E-02,7.4078E-02,8.0683E-02,
37898 &8.9776E-02,1.0288E-01,1.2351E-01,1.5725E-01,0.0000E+00,0.0000E+00,
37899 &8.6044E+00,7.9255E+00,7.2940E+00,6.6940E+00,6.1391E+00,5.5940E+00,
37900 &5.0907E+00,4.6180E+00,4.1841E+00,3.7622E+00,3.3775E+00,3.0195E+00,
37901 &2.6967E+00,2.5153E+00,2.3331E+00,2.1364E+00,1.9521E+00,1.7815E+00,
37902 &1.6211E+00,1.4944E+00,1.3683E+00,1.2334E+00,1.1084E+00,9.9465E-01,
37903 &8.8864E-01,8.0585E-01,7.2432E-01,6.3866E-01,5.6038E-01,4.9058E-01,
37904 &4.2648E-01,3.7768E-01,3.3036E-01,2.8189E-01,2.3907E-01,2.0214E-01,
37905 &1.6987E-01,1.4635E-01,1.2479E-01,1.0428E-01,8.7748E-02,7.8203E-02,
37906 &7.0386E-02,6.5431E-02,6.1373E-02,5.8719E-02,5.6916E-02,5.5642E-02,
37907 &5.4751E-02,5.4118E-02,5.3653E-02,5.3314E-02,5.3067E-02,5.2897E-02,
37908 &5.2861E-02,5.5140E-02,5.6493E-02,5.8378E-02,6.0860E-02,6.4090E-02,
37909 &6.8261E-02,7.3828E-02,8.1439E-02,9.2423E-02,1.0952E-01,1.3424E-01,
37910 &0.0000E+00,0.0000E+00,9.7645E+00,8.9701E+00,8.2340E+00,7.5357E+00,
37911 &6.8926E+00,6.2607E+00,5.6834E+00,5.1374E+00,4.6459E+00,4.1625E+00/
37912 DATA (XSF_L(K),K= 1711, 1824) /
37913 &3.7261E+00,3.3206E+00,2.9567E+00,2.7529E+00,2.5476E+00,2.3274E+00,
37914 &2.1217E+00,1.9320E+00,1.7541E+00,1.6131E+00,1.4740E+00,1.3257E+00,
37915 &1.1879E+00,1.0631E+00,9.4732E-01,8.5726E-01,7.6844E-01,6.7586E-01,
37916 &5.9131E-01,5.1597E-01,4.4748E-01,3.9504E-01,3.4470E-01,2.9317E-01,
37917 &2.4779E-01,2.0880E-01,1.7478E-01,1.5007E-01,1.2748E-01,1.0600E-01,
37918 &8.8713E-02,7.8704E-02,7.0472E-02,6.5220E-02,6.0885E-02,5.7993E-02,
37919 &5.5967E-02,5.4536E-02,5.3470E-02,5.2665E-02,5.2054E-02,5.1577E-02,
37920 &5.1203E-02,5.0930E-02,5.0809E-02,5.2731E-02,5.3716E-02,5.5192E-02,
37921 &5.7203E-02,5.9902E-02,6.3412E-02,6.8123E-02,7.4602E-02,8.3905E-02,
37922 &9.8185E-02,1.1515E-01,0.0000E+00,0.0000E+00,1.1069E+01,1.0141E+01,
37923 &9.2840E+00,8.4741E+00,7.7316E+00,7.0038E+00,6.3364E+00,5.7137E+00,
37924 &5.1475E+00,4.6031E+00,4.1059E+00,3.6477E+00,3.2381E+00,3.0086E+00,
37925 &2.7788E+00,2.5333E+00,2.3033E+00,2.0926E+00,1.8951E+00,1.7404E+00,
37926 &1.5854E+00,1.4229E+00,1.2715E+00,1.1352E+00,1.0089E+00,9.1089E-01,
37927 &8.1457E-01,7.1424E-01,6.2332E-01,5.4229E-01,4.6872E-01,4.1295E-01,
37928 &3.5903E-01,3.0454E-01,2.5654E-01,2.1539E-01,1.7965E-01,1.5373E-01,
37929 &1.3011E-01,1.0766E-01,8.9530E-02,7.9108E-02,7.0483E-02,6.4943E-02,
37930 &6.0331E-02,5.7203E-02,5.4990E-02,5.3395E-02,5.2144E-02,5.1206E-02,
37931 &5.0454E-02,4.9840E-02,4.9351E-02,4.8978E-02,4.8801E-02,5.0351E-02/
37932 DATA (XSF_L(K),K= 1825, 1836) /
37933 &5.1017E-02,5.2127E-02,5.3737E-02,5.5934E-02,5.8835E-02,6.2800E-02,
37934 &6.8260E-02,7.6135E-02,8.7873E-02,0.0000E+00,0.0000E+00,0.0000E+00/
37935 DATA (XGF_L(K),K= 1, 114) /
37936 &1.0646E+00,1.0934E+00,1.1214E+00,1.1484E+00,1.1741E+00,1.1999E+00,
37937 &1.2242E+00,1.2466E+00,1.2676E+00,1.2873E+00,1.3042E+00,1.3194E+00,
37938 &1.3313E+00,1.3376E+00,1.3430E+00,1.3472E+00,1.3502E+00,1.3504E+00,
37939 &1.3501E+00,1.3478E+00,1.3430E+00,1.3356E+00,1.3267E+00,1.3149E+00,
37940 &1.3003E+00,1.2857E+00,1.2680E+00,1.2451E+00,1.2189E+00,1.1899E+00,
37941 &1.1575E+00,1.1282E+00,1.0947E+00,1.0543E+00,1.0121E+00,9.6983E-01,
37942 &9.2809E-01,8.9556E-01,8.6663E-01,8.4606E-01,8.4971E-01,8.7714E-01,
37943 &9.3569E-01,1.0140E+00,1.1325E+00,1.2706E+00,1.4268E+00,1.6005E+00,
37944 &1.7918E+00,2.0014E+00,2.2301E+00,2.4791E+00,2.7490E+00,3.0404E+00,
37945 &3.3541E+00,3.5718E+00,4.2579E+00,5.0478E+00,5.9674E+00,7.0458E+00,
37946 &8.3375E+00,9.9284E+00,1.1949E+01,1.4650E+01,1.8560E+01,2.5096E+01,
37947 &4.0067E+01,0.0000E+00,1.6404E+00,1.6723E+00,1.7014E+00,1.7287E+00,
37948 &1.7533E+00,1.7768E+00,1.7973E+00,1.8152E+00,1.8297E+00,1.8417E+00,
37949 &1.8498E+00,1.8540E+00,1.8544E+00,1.8526E+00,1.8489E+00,1.8424E+00,
37950 &1.8335E+00,1.8221E+00,1.8091E+00,1.7949E+00,1.7784E+00,1.7555E+00,
37951 &1.7310E+00,1.7034E+00,1.6713E+00,1.6428E+00,1.6093E+00,1.5680E+00,
37952 &1.5230E+00,1.4754E+00,1.4241E+00,1.3785E+00,1.3278E+00,1.2681E+00,
37953 &1.2068E+00,1.1462E+00,1.0867E+00,1.0400E+00,9.9665E-01,9.6041E-01,
37954 &9.4923E-01,9.6563E-01,1.0117E+00,1.0781E+00,1.1816E+00,1.3028E+00/
37955 DATA (XGF_L(K),K= 115, 228) /
37956 &1.4397E+00,1.5912E+00,1.7573E+00,1.9376E+00,2.1326E+00,2.3425E+00,
37957 &2.5677E+00,2.8078E+00,3.0611E+00,3.2398E+00,3.7904E+00,4.4126E+00,
37958 &5.1162E+00,5.9322E+00,6.8841E+00,8.0278E+00,9.4403E+00,1.1276E+01,
37959 &1.3844E+01,1.7948E+01,2.6821E+01,0.0000E+00,2.5295E+00,2.5563E+00,
37960 &2.5800E+00,2.5995E+00,2.6174E+00,2.6286E+00,2.6363E+00,2.6395E+00,
37961 &2.6379E+00,2.6306E+00,2.6184E+00,2.6000E+00,2.5768E+00,2.5598E+00,
37962 &2.5397E+00,2.5137E+00,2.4839E+00,2.4516E+00,2.4161E+00,2.3833E+00,
37963 &2.3459E+00,2.3000E+00,2.2499E+00,2.1966E+00,2.1407E+00,2.0900E+00,
37964 &2.0320E+00,1.9647E+00,1.8929E+00,1.8190E+00,1.7411E+00,1.6734E+00,
37965 &1.5997E+00,1.5142E+00,1.4279E+00,1.3438E+00,1.2617E+00,1.1967E+00,
37966 &1.1353E+00,1.0800E+00,1.0501E+00,1.0526E+00,1.0849E+00,1.1369E+00,
37967 &1.2228E+00,1.3250E+00,1.4410E+00,1.5691E+00,1.7085E+00,1.8587E+00,
37968 &2.0200E+00,2.1915E+00,2.3728E+00,2.5633E+00,2.7603E+00,2.9047E+00,
37969 &3.3315E+00,3.8026E+00,4.3243E+00,4.9121E+00,5.5828E+00,6.3648E+00,
37970 &7.3038E+00,8.4817E+00,1.0068E+01,1.2484E+01,1.7398E+01,0.0000E+00,
37971 &3.9781E+00,3.9859E+00,3.9880E+00,3.9845E+00,3.9763E+00,3.9582E+00,
37972 &3.9337E+00,3.9028E+00,3.8636E+00,3.8159E+00,3.7613E+00,3.6984E+00,
37973 &3.6287E+00,3.5836E+00,3.5326E+00,3.4703E+00,3.4046E+00,3.3350E+00,
37974 &3.2612E+00,3.1962E+00,3.1248E+00,3.0388E+00,2.9485E+00,2.8565E+00/
37975 DATA (XGF_L(K),K= 229, 342) /
37976 &2.7591E+00,2.6752E+00,2.5823E+00,2.4756E+00,2.3627E+00,2.2510E+00,
37977 &2.1352E+00,2.0365E+00,1.9308E+00,1.8097E+00,1.6896E+00,1.5737E+00,
37978 &1.4618E+00,1.3735E+00,1.2886E+00,1.2087E+00,1.1551E+00,1.1411E+00,
37979 &1.1545E+00,1.1903E+00,1.2550E+00,1.3356E+00,1.4282E+00,1.5306E+00,
37980 &1.6419E+00,1.7606E+00,1.8869E+00,2.0194E+00,2.1574E+00,2.2992E+00,
37981 &2.4432E+00,2.5568E+00,2.8674E+00,3.2008E+00,3.5626E+00,3.9572E+00,
37982 &4.3932E+00,4.8857E+00,5.4544E+00,6.1386E+00,7.0188E+00,8.2895E+00,
37983 &1.0709E+01,0.0000E+00,6.3697E+00,6.3265E+00,6.2740E+00,6.2091E+00,
37984 &6.1391E+00,6.0517E+00,5.9560E+00,5.8525E+00,5.7367E+00,5.6106E+00,
37985 &5.4709E+00,5.3235E+00,5.1695E+00,5.0724E+00,4.9662E+00,4.8411E+00,
37986 &4.7105E+00,4.5784E+00,4.4412E+00,4.3226E+00,4.1943E+00,4.0442E+00,
37987 &3.8903E+00,3.7360E+00,3.5773E+00,3.4420E+00,3.2967E+00,3.1301E+00,
37988 &2.9593E+00,2.7916E+00,2.6229E+00,2.4802E+00,2.3301E+00,2.1613E+00,
37989 &1.9957E+00,1.8382E+00,1.6875E+00,1.5691E+00,1.4545E+00,1.3433E+00,
37990 &1.2614E+00,1.2264E+00,1.2177E+00,1.2342E+00,1.2749E+00,1.3313E+00,
37991 &1.3987E+00,1.4740E+00,1.5559E+00,1.6431E+00,1.7346E+00,1.8295E+00,
37992 &1.9260E+00,2.0232E+00,2.1174E+00,2.2034E+00,2.4118E+00,2.6289E+00,
37993 &2.8563E+00,3.0948E+00,3.3486E+00,3.6231E+00,3.9250E+00,4.2677E+00,
37994 &4.6847E+00,5.2492E+00,6.2650E+00,0.0000E+00,9.3778E+00,9.2428E+00/
37995 DATA (XGF_L(K),K= 343, 456) /
37996 &9.0960E+00,8.9365E+00,8.7665E+00,8.5746E+00,8.3714E+00,8.1544E+00,
37997 &7.9343E+00,7.6882E+00,7.4352E+00,7.1724E+00,6.9027E+00,6.7360E+00,
37998 &6.5571E+00,6.3494E+00,6.1374E+00,5.9260E+00,5.7093E+00,5.5249E+00,
37999 &5.3270E+00,5.0995E+00,4.8700E+00,4.6419E+00,4.4114E+00,4.2173E+00,
38000 &4.0129E+00,3.7786E+00,3.5451E+00,3.3173E+00,3.0900E+00,2.9004E+00,
38001 &2.7040E+00,2.4853E+00,2.2734E+00,2.0742E+00,1.8851E+00,1.7372E+00,
38002 &1.5941E+00,1.4536E+00,1.3433E+00,1.2893E+00,1.2607E+00,1.2587E+00,
38003 &1.2792E+00,1.3153E+00,1.3616E+00,1.4149E+00,1.4736E+00,1.5361E+00,
38004 &1.6012E+00,1.6677E+00,1.7344E+00,1.7990E+00,1.8589E+00,1.9261E+00,
38005 &2.0646E+00,2.2044E+00,2.3456E+00,2.4882E+00,2.6342E+00,2.7823E+00,
38006 &2.9370E+00,3.1022E+00,3.2902E+00,3.5288E+00,3.9528E+00,0.0000E+00,
38007 &1.3926E+01,1.3617E+01,1.3298E+01,1.2959E+01,1.2612E+01,1.2230E+01,
38008 &1.1845E+01,1.1442E+01,1.1036E+01,1.0599E+01,1.0158E+01,9.7041E+00,
38009 &9.2562E+00,8.9827E+00,8.6974E+00,8.3632E+00,8.0255E+00,7.6946E+00,
38010 &7.3614E+00,7.0802E+00,6.7814E+00,6.4439E+00,6.1064E+00,5.7775E+00,
38011 &5.4468E+00,5.1723E+00,4.8858E+00,4.5617E+00,4.2425E+00,3.9361E+00,
38012 &3.6353E+00,3.3874E+00,3.1301E+00,2.8506E+00,2.5816E+00,2.3318E+00,
38013 &2.0965E+00,1.9136E+00,1.7368E+00,1.5622E+00,1.4211E+00,1.3452E+00,
38014 &1.2937E+00,1.2737E+00,1.2719E+00,1.2868E+00,1.3119E+00,1.3437E+00/
38015 DATA (XGF_L(K),K= 457, 570) /
38016 &1.3799E+00,1.4189E+00,1.4596E+00,1.5003E+00,1.5401E+00,1.5761E+00,
38017 &1.6073E+00,1.6574E+00,1.7377E+00,1.8158E+00,1.8902E+00,1.9601E+00,
38018 &2.0263E+00,2.0884E+00,2.1452E+00,2.1990E+00,2.2512E+00,2.3118E+00,
38019 &2.4354E+00,0.0000E+00,1.9256E+01,1.8699E+01,1.8142E+01,1.7563E+01,
38020 &1.6980E+01,1.6355E+01,1.5725E+01,1.5081E+01,1.4443E+01,1.3769E+01,
38021 &1.3097E+01,1.2422E+01,1.1755E+01,1.1358E+01,1.0937E+01,1.0454E+01,
38022 &9.9818E+00,9.5167E+00,9.0465E+00,8.6570E+00,8.2473E+00,7.7870E+00,
38023 &7.3320E+00,6.8911E+00,6.4569E+00,6.0969E+00,5.7223E+00,5.3051E+00,
38024 &4.8992E+00,4.5131E+00,4.1351E+00,3.8285E+00,3.5148E+00,3.1749E+00,
38025 &2.8517E+00,2.5534E+00,2.2748E+00,2.0598E+00,1.8527E+00,1.6465E+00,
38026 &1.4780E+00,1.3832E+00,1.3129E+00,1.2758E+00,1.2566E+00,1.2544E+00,
38027 &1.2628E+00,1.2778E+00,1.2971E+00,1.3186E+00,1.3412E+00,1.3637E+00,
38028 &1.3845E+00,1.4021E+00,1.4142E+00,1.4518E+00,1.4945E+00,1.5327E+00,
38029 &1.5661E+00,1.5941E+00,1.6160E+00,1.6309E+00,1.6386E+00,1.6381E+00,
38030 &1.6291E+00,1.6176E+00,1.6271E+00,0.0000E+00,2.5945E+01,2.5063E+01,
38031 &2.4160E+01,2.3234E+01,2.2336E+01,2.1370E+01,2.0417E+01,1.9450E+01,
38032 &1.8508E+01,1.7517E+01,1.6548E+01,1.5580E+01,1.4645E+01,1.4085E+01,
38033 &1.3496E+01,1.2836E+01,1.2181E+01,1.1547E+01,1.0921E+01,1.0404E+01,
38034 &9.8614E+00,9.2547E+00,8.6616E+00,8.0926E+00,7.5352E+00,7.0774E+00/
38035 DATA (XGF_L(K),K= 571, 684) /
38036 &6.6043E+00,6.0842E+00,5.5816E+00,5.1040E+00,4.6450E+00,4.2749E+00,
38037 &3.8995E+00,3.4941E+00,3.1134E+00,2.7651E+00,2.4423E+00,2.1941E+00,
38038 &1.9564E+00,1.7198E+00,1.5241E+00,1.4112E+00,1.3220E+00,1.2705E+00,
38039 &1.2348E+00,1.2175E+00,1.2113E+00,1.2119E+00,1.2167E+00,1.2238E+00,
38040 &1.2321E+00,1.2398E+00,1.2460E+00,1.2491E+00,1.2470E+00,1.2752E+00,
38041 &1.2894E+00,1.2998E+00,1.3055E+00,1.3049E+00,1.2991E+00,1.2860E+00,
38042 &1.2655E+00,1.2370E+00,1.1998E+00,1.1564E+00,1.1181E+00,0.0000E+00,
38043 &3.3362E+01,3.2051E+01,3.0740E+01,2.9429E+01,2.8133E+01,2.6758E+01,
38044 &2.5422E+01,2.4082E+01,2.2784E+01,2.1435E+01,2.0130E+01,1.8839E+01,
38045 &1.7597E+01,1.6865E+01,1.6098E+01,1.5241E+01,1.4397E+01,1.3587E+01,
38046 &1.2791E+01,1.2130E+01,1.1444E+01,1.0687E+01,9.9507E+00,9.2501E+00,
38047 &8.5659E+00,8.0104E+00,7.4390E+00,6.8118E+00,6.2125E+00,5.6506E+00,
38048 &5.1096E+00,4.6780E+00,4.2434E+00,3.7769E+00,3.3424E+00,2.9475E+00,
38049 &2.5842E+00,2.3061E+00,2.0409E+00,1.7770E+00,1.5572E+00,1.4290E+00,
38050 &1.3248E+00,1.2609E+00,1.2112E+00,1.1814E+00,1.1636E+00,1.1530E+00,
38051 &1.1469E+00,1.1433E+00,1.1407E+00,1.1378E+00,1.1337E+00,1.1269E+00,
38052 &1.1152E+00,1.1360E+00,1.1320E+00,1.1243E+00,1.1127E+00,1.0960E+00,
38053 &1.0739E+00,1.0461E+00,1.0122E+00,9.7100E-01,9.2292E-01,8.6909E-01,
38054 &8.1432E-01,0.0000E+00,4.2364E+01,4.0483E+01,3.8640E+01,3.6792E+01/
38055 DATA (XGF_L(K),K= 685, 798) /
38056 &3.4991E+01,3.3112E+01,3.1295E+01,2.9487E+01,2.7748E+01,2.5953E+01,
38057 &2.4235E+01,2.2543E+01,2.0935E+01,1.9990E+01,1.9011E+01,1.7921E+01,
38058 &1.6852E+01,1.5830E+01,1.4831E+01,1.4013E+01,1.3165E+01,1.2236E+01,
38059 &1.1337E+01,1.0485E+01,9.6616E+00,8.9943E+00,8.3137E+00,7.5711E+00,
38060 &6.8670E+00,6.2090E+00,5.5842E+00,5.0866E+00,4.5873E+00,4.0564E+00,
38061 &3.5646E+00,3.1234E+00,2.7185E+00,2.4107E+00,2.1172E+00,1.8273E+00,
38062 &1.5836E+00,1.4407E+00,1.3211E+00,1.2459E+00,1.1839E+00,1.1433E+00,
38063 &1.1153E+00,1.0949E+00,1.0794E+00,1.0667E+00,1.0555E+00,1.0443E+00,
38064 &1.0317E+00,1.0172E+00,9.9883E-01,1.0131E+00,9.9503E-01,9.7446E-01,
38065 &9.5064E-01,9.2316E-01,8.9156E-01,8.5528E-01,8.1439E-01,7.6837E-01,
38066 &7.1718E-01,6.6210E-01,6.0243E-01,0.0000E+00,5.2603E+01,5.0038E+01,
38067 &4.7540E+01,4.5053E+01,4.2652E+01,4.0175E+01,3.7784E+01,3.5407E+01,
38068 &3.3154E+01,3.0851E+01,2.8651E+01,2.6507E+01,2.4488E+01,2.3310E+01,
38069 &2.2084E+01,2.0735E+01,1.9418E+01,1.8166E+01,1.6951E+01,1.5960E+01,
38070 &1.4935E+01,1.3817E+01,1.2742E+01,1.1732E+01,1.0759E+01,9.9749E+00,
38071 &9.1794E+00,8.3186E+00,7.5044E+00,6.7510E+00,6.0386E+00,5.4762E+00,
38072 &4.9137E+00,4.3200E+00,3.7728E+00,3.2842E+00,2.8391E+00,2.5026E+00,
38073 &2.1835E+00,1.8677E+00,1.6033E+00,1.4461E+00,1.3138E+00,1.2277E+00,
38074 &1.1557E+00,1.1057E+00,1.0689E+00,1.0407E+00,1.0176E+00,9.9768E-01/
38075 DATA (XGF_L(K),K= 799, 912) /
38076 &9.7951E-01,9.6199E-01,9.4331E-01,9.2359E-01,9.0058E-01,9.0921E-01,
38077 &8.8156E-01,8.5244E-01,8.2081E-01,7.8702E-01,7.5025E-01,7.1005E-01,
38078 &6.6667E-01,6.1984E-01,5.6969E-01,5.1748E-01,4.5895E-01,0.0000E+00,
38079 &6.3459E+01,6.0127E+01,5.6900E+01,5.3695E+01,5.0615E+01,4.7464E+01,
38080 &4.4440E+01,4.1483E+01,3.8684E+01,3.5826E+01,3.3122E+01,3.0500E+01,
38081 &2.8040E+01,2.6617E+01,2.5143E+01,2.3518E+01,2.1950E+01,2.0455E+01,
38082 &1.9011E+01,1.7842E+01,1.6646E+01,1.5337E+01,1.4094E+01,1.2920E+01,
38083 &1.1799E+01,1.0903E+01,9.9940E+00,9.0166E+00,8.0967E+00,7.2512E+00,
38084 &6.4551E+00,5.8279E+00,5.2081E+00,4.5519E+00,3.9568E+00,3.4237E+00,
38085 &2.9425E+00,2.5798E+00,2.2371E+00,1.8995E+00,1.6161E+00,1.4477E+00,
38086 &1.3046E+00,1.2096E+00,1.1285E+00,1.0709E+00,1.0274E+00,9.9290E-01,
38087 &9.6399E-01,9.3860E-01,9.1550E-01,8.9324E-01,8.7036E-01,8.4674E-01,
38088 &8.2129E-01,8.2506E-01,7.9094E-01,7.5633E-01,7.2031E-01,6.8307E-01,
38089 &6.4387E-01,6.0237E-01,5.5907E-01,5.1344E-01,4.6618E-01,4.1810E-01,
38090 &3.6329E-01,0.0000E+00,7.9498E+01,7.4941E+01,7.0580E+01,6.6266E+01,
38091 &6.2169E+01,5.8002E+01,5.4045E+01,5.0164E+01,4.6539E+01,4.2847E+01,
38092 &3.9386E+01,3.6065E+01,3.2968E+01,3.1180E+01,2.9347E+01,2.7330E+01,
38093 &2.5394E+01,2.3566E+01,2.1811E+01,2.0388E+01,1.8944E+01,1.7368E+01,
38094 &1.5877E+01,1.4488E+01,1.3164E+01,1.2111E+01,1.1051E+01,9.9162E+00/
38095 DATA (XGF_L(K),K= 913, 1026) /
38096 &8.8542E+00,7.8839E+00,6.9777E+00,6.2689E+00,5.5695E+00,4.8410E+00,
38097 &4.1789E+00,3.5909E+00,3.0635E+00,2.6689E+00,2.2973E+00,1.9324E+00,
38098 &1.6270E+00,1.4446E+00,1.2882E+00,1.1839E+00,1.0926E+00,1.0266E+00,
38099 &9.7585E-01,9.3473E-01,8.9976E-01,8.6898E-01,8.4068E-01,8.1374E-01,
38100 &7.8714E-01,7.6011E-01,7.3262E-01,7.3148E-01,6.9170E-01,6.5270E-01,
38101 &6.1357E-01,5.7426E-01,5.3417E-01,4.9316E-01,4.5166E-01,4.0914E-01,
38102 &3.6649E-01,3.2429E-01,2.7651E-01,0.0000E+00,9.7091E+01,9.1127E+01,
38103 &8.5440E+01,7.9869E+01,7.4603E+01,6.9275E+01,6.4220E+01,5.9343E+01,
38104 &5.4780E+01,5.0195E+01,4.5912E+01,4.1816E+01,3.8028E+01,3.5857E+01,
38105 &3.3637E+01,3.1205E+01,2.8880E+01,2.6695E+01,2.4601E+01,2.2923E+01,
38106 &2.1219E+01,1.9374E+01,1.7634E+01,1.6009E+01,1.4488E+01,1.3276E+01,
38107 &1.2064E+01,1.0772E+01,9.5709E+00,8.4795E+00,7.4649E+00,6.6775E+00,
38108 &5.9046E+00,5.1015E+00,4.3733E+00,3.7372E+00,3.1677E+00,2.7434E+00,
38109 &2.3459E+00,1.9566E+00,1.6317E+00,1.4368E+00,1.2699E+00,1.1572E+00,
38110 &1.0581E+00,9.8558E-01,9.2913E-01,8.8297E-01,8.4349E-01,8.0862E-01,
38111 &7.7667E-01,7.4686E-01,7.1760E-01,6.8906E-01,6.6005E-01,6.5493E-01,
38112 &6.1209E-01,5.7080E-01,5.3038E-01,4.9085E-01,4.5137E-01,4.1231E-01,
38113 &3.7316E-01,3.3442E-01,2.9613E-01,2.5928E-01,2.1912E-01,0.0000E+00,
38114 &1.1660E+02,1.0899E+02,1.0178E+02,9.4752E+01,8.8142E+01,8.1480E+01/
38115 DATA (XGF_L(K),K= 1027, 1140) /
38116 &7.5219E+01,6.9198E+01,6.3578E+01,5.7986E+01,5.2800E+01,4.7867E+01,
38117 &4.3328E+01,4.0736E+01,3.8088E+01,3.5213E+01,3.2469E+01,2.9907E+01,
38118 &2.7451E+01,2.5501E+01,2.3516E+01,2.1392E+01,1.9391E+01,1.7546E+01,
38119 &1.5800E+01,1.4426E+01,1.3057E+01,1.1607E+01,1.0266E+01,9.0517E+00,
38120 &7.9294E+00,7.0617E+00,6.2165E+00,5.3397E+00,4.5572E+00,3.8687E+00,
38121 &3.2598E+00,2.8078E+00,2.3859E+00,1.9745E+00,1.6317E+00,1.4267E+00,
38122 &1.2497E+00,1.1305E+00,1.0247E+00,9.4657E-01,8.8556E-01,8.3542E-01,
38123 &7.9253E-01,7.5465E-01,7.2037E-01,6.8840E-01,6.5775E-01,6.2793E-01,
38124 &5.9852E-01,5.9015E-01,5.4553E-01,5.0339E-01,4.6306E-01,4.2411E-01,
38125 &3.8622E-01,3.4909E-01,3.1294E-01,2.7773E-01,2.4373E-01,2.1150E-01,
38126 &1.7848E-01,0.0000E+00,1.3738E+02,1.2796E+02,1.1904E+02,1.1042E+02,
38127 &1.0233E+02,9.4222E+01,8.6662E+01,7.9409E+01,7.2655E+01,6.6001E+01,
38128 &5.9833E+01,5.4007E+01,4.8672E+01,4.5642E+01,4.2552E+01,3.9214E+01,
38129 &3.6040E+01,3.3082E+01,3.0272E+01,2.8026E+01,2.5779E+01,2.3361E+01,
38130 &2.1093E+01,1.9009E+01,1.7062E+01,1.5526E+01,1.4003E+01,1.2396E+01,
38131 &1.0916E+01,9.5845E+00,8.3611E+00,7.4188E+00,6.5021E+00,5.5589E+00,
38132 &4.7169E+00,3.9865E+00,3.3389E+00,2.8617E+00,2.4178E+00,1.9872E+00,
38133 &1.6283E+00,1.4143E+00,1.2296E+00,1.1049E+00,9.9315E-01,9.1079E-01,
38134 &8.4623E-01,7.9317E-01,7.4768E-01,7.0802E-01,6.7178E-01,6.3836E-01/
38135 DATA (XGF_L(K),K= 1141, 1254) /
38136 &6.0703E-01,5.7658E-01,5.4733E-01,5.3630E-01,4.9100E-01,4.4879E-01,
38137 &4.0920E-01,3.7138E-01,3.3521E-01,3.0054E-01,2.6721E-01,2.3523E-01,
38138 &2.0485E-01,1.7634E-01,1.4852E-01,0.0000E+00,1.6103E+02,1.4938E+02,
38139 &1.3848E+02,1.2798E+02,1.1818E+02,1.0840E+02,9.9309E+01,9.0651E+01,
38140 &8.2647E+01,7.4733E+01,6.7469E+01,6.0672E+01,5.4433E+01,5.0913E+01,
38141 &4.7343E+01,4.3482E+01,3.9833E+01,3.6452E+01,3.3242E+01,3.0689E+01,
38142 &2.8134E+01,2.5404E+01,2.2863E+01,2.0531E+01,1.8362E+01,1.6652E+01,
38143 &1.4967E+01,1.3197E+01,1.1573E+01,1.0120E+01,8.7877E+00,7.7679E+00,
38144 &6.7819E+00,5.7685E+00,4.8731E+00,4.0967E+00,3.4122E+00,2.9097E+00,
38145 &2.4451E+00,1.9953E+00,1.6222E+00,1.3995E+00,1.2076E+00,1.0771E+00,
38146 &9.6151E-01,8.7563E-01,8.0819E-01,7.5269E-01,7.0548E-01,6.6395E-01,
38147 &6.2666E-01,5.9253E-01,5.6034E-01,5.3005E-01,5.0122E-01,4.8790E-01,
38148 &4.4273E-01,4.0115E-01,3.6251E-01,3.2632E-01,2.9224E-01,2.5988E-01,
38149 &2.2931E-01,2.0039E-01,1.7324E-01,1.4805E-01,1.2201E-01,0.0000E+00,
38150 &1.8591E+02,1.7193E+02,1.5886E+02,1.4632E+02,1.3469E+02,1.2310E+02,
38151 &1.1237E+02,1.0218E+02,9.2839E+01,8.3643E+01,7.5256E+01,6.7382E+01,
38152 &6.0231E+01,5.6204E+01,5.2127E+01,4.7743E+01,4.3601E+01,3.9784E+01,
38153 &3.6172E+01,3.3310E+01,3.0455E+01,2.7410E+01,2.4579E+01,2.2009E+01,
38154 &1.9599E+01,1.7727E+01,1.5886E+01,1.3956E+01,1.2193E+01,1.0620E+01/
38155 DATA (XGF_L(K),K= 1255, 1368) /
38156 &9.1866E+00,8.0925E+00,7.0383E+00,5.9623E+00,5.0119E+00,4.1917E+00,
38157 &3.4750E+00,2.9503E+00,2.4663E+00,1.9999E+00,1.6141E+00,1.3840E+00,
38158 &1.1856E+00,1.0518E+00,9.3192E-01,8.4324E-01,7.7348E-01,7.1642E-01,
38159 &6.6779E-01,6.2531E-01,5.8732E-01,5.5231E-01,5.2039E-01,4.9037E-01,
38160 &4.6218E-01,4.4711E-01,4.0225E-01,3.6159E-01,3.2438E-01,2.8982E-01,
38161 &2.5765E-01,2.2765E-01,1.9954E-01,1.7331E-01,1.4889E-01,1.2621E-01,
38162 &9.6984E-02,0.0000E+00,2.1269E+02,1.9609E+02,1.8060E+02,1.6582E+02,
38163 &1.5214E+02,1.3863E+02,1.2613E+02,1.1431E+02,1.0351E+02,9.2957E+01,
38164 &8.3294E+01,7.4318E+01,6.6188E+01,6.1617E+01,5.7019E+01,5.2073E+01,
38165 &4.7428E+01,4.3153E+01,3.9122E+01,3.5941E+01,3.2764E+01,2.9404E+01,
38166 &2.6282E+01,2.3458E+01,2.0836E+01,1.8796E+01,1.6786E+01,1.4693E+01,
38167 &1.2792E+01,1.1101E+01,9.5678E+00,8.4010E+00,7.2773E+00,6.1402E+00,
38168 &5.1403E+00,4.2791E+00,3.5311E+00,2.9851E+00,2.4835E+00,2.0017E+00,
38169 &1.6039E+00,1.3677E+00,1.1646E+00,1.0265E+00,9.0375E-01,8.1271E-01,
38170 &7.4135E-01,6.8280E-01,6.3328E-01,5.9018E-01,5.5184E-01,5.1677E-01,
38171 &4.8494E-01,4.5537E-01,4.2797E-01,4.1146E-01,3.6736E-01,3.2788E-01,
38172 &2.9207E-01,2.5923E-01,2.2901E-01,2.0110E-01,1.7527E-01,1.5131E-01,
38173 &1.2926E-01,1.0839E-01,6.9776E-02,0.0000E+00,2.4043E+02,2.2104E+02,
38174 &2.0300E+02,1.8582E+02,1.7003E+02,1.5443E+02,1.4007E+02,1.2658E+02/
38175 DATA (XGF_L(K),K= 1369, 1482) /
38176 &1.1426E+02,1.0227E+02,9.1332E+01,8.1197E+01,7.2119E+01,6.6989E+01,
38177 &6.1846E+01,5.6342E+01,5.1188E+01,4.6448E+01,4.2002E+01,3.8498E+01,
38178 &3.5016E+01,3.1335E+01,2.7931E+01,2.4848E+01,2.2009E+01,1.9797E+01,
38179 &1.7637E+01,1.5389E+01,1.3354E+01,1.1550E+01,9.9187E+00,8.6824E+00,
38180 &7.4988E+00,6.3022E+00,5.2549E+00,4.3589E+00,3.5788E+00,3.0139E+00,
38181 &2.4962E+00,2.0005E+00,1.5931E+00,1.3514E+00,1.1435E+00,1.0028E+00,
38182 &8.7751E-01,7.8479E-01,7.1218E-01,6.5272E-01,6.0250E-01,5.5920E-01,
38183 &5.2061E-01,4.8590E-01,4.5422E-01,4.2519E-01,3.9858E-01,3.8094E-01,
38184 &3.3789E-01,2.9975E-01,2.6524E-01,2.3401E-01,2.0560E-01,1.7956E-01,
38185 &1.5565E-01,1.3374E-01,1.1354E-01,9.4096E-02,3.9275E-02,0.0000E+00,
38186 &2.8195E+02,2.5830E+02,2.3640E+02,2.1554E+02,1.9645E+02,1.7774E+02,
38187 &1.6058E+02,1.4448E+02,1.2990E+02,1.1575E+02,1.0299E+02,9.1121E+01,
38188 &8.0574E+01,7.4642E+01,6.8724E+01,6.2402E+01,5.6498E+01,5.1101E+01,
38189 &4.6042E+01,4.2081E+01,3.8152E+01,3.4014E+01,3.0201E+01,2.6780E+01,
38190 &2.3611E+01,2.1171E+01,1.8789E+01,1.6329E+01,1.4107E+01,1.2148E+01,
38191 &1.0386E+01,9.0557E+00,7.7874E+00,6.5118E+00,5.4006E+00,4.4539E+00,
38192 &3.6370E+00,3.0467E+00,2.5088E+00,1.9959E+00,1.5762E+00,1.3274E+00,
38193 &1.1142E+00,9.7065E-01,8.4265E-01,7.4825E-01,6.7451E-01,6.1445E-01,
38194 &5.6374E-01,5.2024E-01,4.8166E-01,4.4741E-01,4.1643E-01,3.8830E-01/
38195 DATA (XGF_L(K),K= 1483, 1596) /
38196 &3.6282E-01,3.4411E-01,3.0249E-01,2.6607E-01,2.3369E-01,2.0474E-01,
38197 &1.7852E-01,1.5489E-01,1.3341E-01,1.1384E-01,9.5862E-02,7.7509E-02,
38198 &0.0000E+00,0.0000E+00,3.2379E+02,2.9556E+02,2.6960E+02,2.4513E+02,
38199 &2.2265E+02,2.0073E+02,1.8071E+02,1.6202E+02,1.4515E+02,1.2887E+02,
38200 &1.1419E+02,1.0071E+02,8.8650E+01,8.1931E+01,7.5233E+01,6.8140E+01,
38201 &6.1510E+01,5.5467E+01,4.9832E+01,4.5419E+01,4.1070E+01,3.6493E+01,
38202 &3.2295E+01,2.8536E+01,2.5086E+01,2.2426E+01,1.9846E+01,1.7175E+01,
38203 &1.4781E+01,1.2681E+01,1.0797E+01,9.3831E+00,8.0380E+00,6.6897E+00,
38204 &5.5221E+00,4.5337E+00,3.6831E+00,3.0714E+00,2.5159E+00,1.9884E+00,
38205 &1.5586E+00,1.3048E+00,1.0886E+00,9.4191E-01,8.1217E-01,7.1679E-01,
38206 &6.4238E-01,5.8194E-01,5.3136E-01,4.8766E-01,4.4965E-01,4.1594E-01,
38207 &3.8570E-01,3.5847E-01,3.3403E-01,3.1456E-01,2.7454E-01,2.3977E-01,
38208 &2.0922E-01,1.8216E-01,1.5795E-01,1.3622E-01,1.1669E-01,9.9012E-02,
38209 &8.2668E-02,6.4604E-02,0.0000E+00,0.0000E+00,3.7071E+02,3.3727E+02,
38210 &3.0660E+02,2.7790E+02,2.5169E+02,2.2608E+02,2.0283E+02,1.8123E+02,
38211 &1.6179E+02,1.4311E+02,1.2635E+02,1.1097E+02,9.7357E+01,8.9759E+01,
38212 &8.2263E+01,7.4239E+01,6.6821E+01,6.0073E+01,5.3813E+01,4.8927E+01,
38213 &4.4114E+01,3.9072E+01,3.4471E+01,3.0351E+01,2.6592E+01,2.3699E+01,
38214 &2.0903E+01,1.8031E+01,1.5459E+01,1.3211E+01,1.1204E+01,9.7024E+00/
38215 DATA (XGF_L(K),K= 1597, 1710) /
38216 &8.2828E+00,6.8644E+00,5.6367E+00,4.6059E+00,3.7241E+00,3.0915E+00,
38217 &2.5189E+00,1.9786E+00,1.5396E+00,1.2816E+00,1.0611E+00,9.1306E-01,
38218 &7.8207E-01,6.8594E-01,6.1118E-01,5.5075E-01,5.0031E-01,4.5732E-01,
38219 &4.1996E-01,3.8671E-01,3.5732E-01,3.3101E-01,3.0775E-01,2.8769E-01,
38220 &2.4931E-01,2.1637E-01,1.8763E-01,1.6241E-01,1.4002E-01,1.2013E-01,
38221 &1.0238E-01,8.6311E-02,7.1348E-02,5.2982E-02,0.0000E+00,0.0000E+00,
38222 &4.2142E+02,3.8237E+02,3.4660E+02,3.1292E+02,2.8259E+02,2.5300E+02,
38223 &2.2626E+02,2.0148E+02,1.7927E+02,1.5797E+02,1.3896E+02,1.2163E+02,
38224 &1.0632E+02,9.7858E+01,8.9366E+01,8.0488E+01,7.2234E+01,6.4771E+01,
38225 &5.7843E+01,5.2468E+01,4.7182E+01,4.1663E+01,3.6633E+01,3.2165E+01,
38226 &2.8082E+01,2.4971E+01,2.1960E+01,1.8866E+01,1.6118E+01,1.3723E+01,
38227 &1.1595E+01,1.0008E+01,8.5101E+00,7.0232E+00,5.7443E+00,4.6705E+00,
38228 &3.7584E+00,3.1066E+00,2.5189E+00,1.9659E+00,1.5193E+00,1.2575E+00,
38229 &1.0346E+00,8.8517E-01,7.5338E-01,6.5695E-01,5.8219E-01,5.2200E-01,
38230 &4.7218E-01,4.2954E-01,3.9258E-01,3.6043E-01,3.3190E-01,3.0663E-01,
38231 &2.8431E-01,2.6413E-01,2.2746E-01,1.9612E-01,1.6912E-01,1.4557E-01,
38232 &1.2488E-01,1.0660E-01,9.0362E-02,7.5731E-02,6.1890E-02,4.2720E-02,
38233 &0.0000E+00,0.0000E+00,4.7166E+02,4.2676E+02,3.8580E+02,3.4749E+02,
38234 &3.1273E+02,2.7927E+02,2.4899E+02,2.2108E+02,1.9611E+02,1.7230E+02/
38235 DATA (XGF_L(K),K= 1711, 1824) /
38236 &1.5107E+02,1.3178E+02,1.1483E+02,1.0548E+02,9.6179E+01,8.6383E+01,
38237 &7.7331E+01,6.9156E+01,6.1613E+01,5.5763E+01,5.0019E+01,4.4056E+01,
38238 &3.8633E+01,3.3819E+01,2.9446E+01,2.6108E+01,2.2889E+01,1.9617E+01,
38239 &1.6706E+01,1.4179E+01,1.1938E+01,1.0276E+01,8.7112E+00,7.1630E+00,
38240 &5.8345E+00,4.7275E+00,3.7856E+00,3.1171E+00,2.5164E+00,1.9532E+00,
38241 &1.4997E+00,1.2350E+00,1.0108E+00,8.6027E-01,7.2804E-01,6.3166E-01,
38242 &5.5726E-01,4.9745E-01,4.4802E-01,4.0623E-01,3.7002E-01,3.3850E-01,
38243 &3.1081E-01,2.8644E-01,2.6509E-01,2.4476E-01,2.0951E-01,1.7979E-01,
38244 &1.5426E-01,1.3217E-01,1.1290E-01,9.5951E-02,8.0975E-02,6.7483E-02,
38245 &5.4483E-02,3.4309E-02,0.0000E+00,0.0000E+00,5.2745E+02,4.7595E+02,
38246 &4.2900E+02,3.8543E+02,3.4589E+02,3.0795E+02,2.7377E+02,2.4235E+02,
38247 &2.1434E+02,1.8771E+02,1.6408E+02,1.4266E+02,1.2392E+02,1.1358E+02,
38248 &1.0335E+02,9.2593E+01,8.2702E+01,7.3780E+01,6.5553E+01,5.9207E+01,
38249 &5.2983E+01,4.6535E+01,4.0700E+01,3.5531E+01,3.0842E+01,2.7278E+01,
38250 &2.3855E+01,2.0386E+01,1.7301E+01,1.4635E+01,1.2282E+01,1.0538E+01,
38251 &8.9065E+00,7.2932E+00,5.9178E+00,4.7769E+00,3.8086E+00,3.1240E+00,
38252 &2.5114E+00,1.9387E+00,1.4794E+00,1.2125E+00,9.8604E-01,8.3538E-01,
38253 &7.0309E-01,6.0683E-01,5.3289E-01,4.7378E-01,4.2493E-01,3.8387E-01,
38254 &3.4846E-01,3.1778E-01,2.9097E-01,2.6744E-01,2.4699E-01,2.2688E-01/
38255 DATA (XGF_L(K),K= 1825, 1836) /
38256 &1.9308E-01,1.6489E-01,1.4079E-01,1.2009E-01,1.0214E-01,8.6447E-02,
38257 &7.2603E-02,6.0131E-02,4.7893E-02,2.6613E-02,0.0000E+00,0.0000E+00/
38261 *...CHECK OF X AND Q2 VALUES :
38262 IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
38264 91 FORMAT (2X,'GRV98: x out of range',1p,E12.4)
38270 IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
38272 92 FORMAT (2X,'GRV98: Q2 out of range',1p,E12.4)
38278 *...INTERPOLATION :
38286 UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
38287 DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
38288 DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
38289 UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
38290 US = 0.5 * (UD - DE)
38291 DS = 0.5 * (UD + DE)
38292 SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF) * X1**7 * XS
38293 GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF) * X1**5 * XS
38297 *$ CREATE PHO_DOR98SC.FOR
38299 CDECK ID>, PHO_DOR98SC
38300 SUBROUTINE PHO_DOR98SC (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
38301 C***********************************************************************
38303 C GRV98 parton densities, leading order set
38305 C For a detailed explanation see
38306 C M. Glueck, E. Reya, A. Vogt :
38307 C hep-ph/9806404 = DO-TH 98/07 = WUE-ITP-98-019
38308 C (To appear in Eur. Phys. J. C)
38310 C interpolation routine based on the original GRV98PA routine,
38311 C adapted to define interpolation table as DATA statements
38315 C CAUTION: this is a version with gluon shadowing corrections
38319 C INPUT: X = Bjorken-x (between 1.E-9 and 1.)
38320 C Q2 = scale in GeV**2 (between 0.8 and 1.E6)
38322 C OUTPUT: UV = u - u(bar), DV = d - d(bar), US = u(bar),
38323 C DS = d(bar), SS = s = s(bar), GL = gluon.
38324 C Always x times the distribution is returned.
38326 C******************************************************i****************
38327 IMPLICIT DOUBLE PRECISION (A-H, O-Z)
38330 C input/output channels
38332 COMMON /POINOU/ LI,LO
38334 PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
38335 DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
38336 1 XSF(NX,NQ), XGF(NX,NQ),
38337 2 XT(NARG), NA(NARG), ARRF(NX+NQ)
38339 DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
38340 & XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
38342 EQUIVALENCE (XUVF(1,1),XUVF_L(1))
38343 EQUIVALENCE (XDVF(1,1),XDVF_L(1))
38344 EQUIVALENCE (XDEF(1,1),XDEF_L(1))
38345 EQUIVALENCE (XUDF(1,1),XUDF_L(1))
38346 EQUIVALENCE (XSF(1,1),XSF_L(1))
38347 EQUIVALENCE (XGF(1,1),XGF_L(1))
38349 *#################### data statements for shadowed LO PDF ##############
38351 *#######################################################################
38354 *...CHECK OF X AND Q2 VALUES :
38355 IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
38357 91 FORMAT (2X,'GRV98_SC: x out of range',1p,E12.4)
38363 IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
38365 92 FORMAT (2X,'GRV98_SC: Q2 out of range',1p,E12.4)
38371 *...INTERPOLATION :
38379 UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
38380 DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
38381 DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
38382 UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
38383 US = 0.5 * (UD - DE)
38384 DS = 0.5 * (UD + DE)
38385 SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF) * X1**7 * XS
38386 GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF) * X1**5 * XS
38390 *$ CREATE PHO_DOR94LO.FOR
38392 CDECK ID>, PHO_DOR94LO
38393 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38395 * 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 *
38399 * FOR A DETAILED EXPLANATION SEE *
38400 * M. GLUECK, E.REYA, A.VOGT : *
38401 * DO-TH 94/24 = DESY 94-206 *
38402 * (TO APPEAR IN Z. PHYS. C) *
38404 * THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR *
38405 * Q**2 / GEV**2 BETWEEN 0.4 AND 1.E6 *
38406 * X BETWEEN 1.E-5 AND 1. *
38407 * LARGE-X REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION *
38408 * IS NEGLIGIBLY SMALL, WERE EXCLUDED FROM THE FIT. *
38410 * HEAVY QUARK THRESHOLDS Q(H) = M(H) IN THE BETA FUNCTION : *
38411 * M(C) = 1.5, M(B) = 4.5 *
38412 * CORRESPONDING LAMBDA(F) VALUES IN GEV FOR Q**2 > M(H)**2 : *
38413 * LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
38414 * LAMBDA(5) = 0.153, *
38415 * NLO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
38416 * LAMBDA(5) = 0.131. *
38417 * THE NUMBER OF ACTIVE QUARK FLAVOURS IS NF = 3 EVERYWHERE *
38418 * EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,... *
38419 * ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION. *
38420 * IF NEEDED, HEAVY QUARK DENSITIES CAN BE TAKEN FROM THE 1991 *
38421 * GRV PARAMETRIZATION. *
38423 * NLO DISTRIBUTIONS ARE GIVEN IN MS-BAR FACTORIZATION SCHEME *
38424 * (SUBROUTINE GRV94HO) AS WELL AS IN THE DIS SCHEME (GRV94DI), *
38425 * THE LEADING ORDER PARAMETRIZATION IS PROVIDED BY "GRV94LO". *
38427 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38429 *...INPUT PARAMETERS :
38431 * X = MOMENTUM FRACTION
38432 * Q2 = SCALE Q**2 IN GEV**2
38434 *...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION) :
38436 * UV = U(VAL) = U - U(BAR)
38437 * DV = D(VAL) = D - D(BAR)
38438 * DEL = D(BAR) - U(BAR)
38439 * UDB = U(BAR) + D(BAR)
38443 *...LO PARAMETRIZATION :
38445 SUBROUTINE PHO_DOR94LO (X, Q2, UV, DV, DEL, UDB, SB, GL)
38446 IMPLICIT DOUBLE PRECISION (A - Z)
38450 LAM2 = 0.2322 * 0.2322
38451 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38456 NU = 2.284 + 0.802 * S + 0.055 * S2
38457 AKU = 0.590 - 0.024 * S
38458 BKU = 0.131 + 0.063 * S
38459 AU = -0.449 - 0.138 * S - 0.076 * S2
38460 BU = 0.213 + 2.669 * S - 0.728 * S2
38461 CU = 8.854 - 9.135 * S + 1.979 * S2
38462 DU = 2.997 + 0.753 * S - 0.076 * S2
38463 UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38465 ND = 0.371 + 0.083 * S + 0.039 * S2
38467 BKD = 0.486 + 0.062 * S
38468 AD = -0.509 + 3.310 * S - 1.248 * S2
38469 BD = 12.41 - 10.52 * S + 2.267 * S2
38470 CD = 6.373 - 6.208 * S + 1.418 * S2
38471 DD = 3.691 + 0.799 * S - 0.071 * S2
38472 DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38474 NE = 0.082 + 0.014 * S + 0.008 * S2
38475 AKE = 0.409 - 0.005 * S
38476 BKE = 0.799 + 0.071 * S
38477 AE = -38.07 + 36.13 * S - 0.656 * S2
38478 BE = 90.31 - 74.15 * S + 7.645 * S2
38480 DE = 7.486 + 1.217 * S - 0.159 * S2
38481 DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38485 AKX = 0.410 - 0.232 * S
38486 BKX = 0.534 - 0.457 * S
38487 AGX = 0.890 - 0.140 * S
38489 CX = 0.320 + 0.683 * S
38490 DX = 4.752 + 1.164 * S + 0.286 * S2
38491 EX = 4.119 + 1.713 * S
38492 ESX = 0.682 + 2.978 * S
38493 UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38497 AKS = 1.798 - 0.596 * S
38498 AS = -5.548 + 3.669 * DS - 0.616 * S
38499 BS = 18.92 - 16.73 * DS + 5.168 * S
38500 DST = 6.379 - 0.350 * S + 0.142 * S2
38501 EST = 3.981 + 1.638 * S
38503 SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38507 AKG = 1.742 - 0.930 * S
38509 AG = 7.486 - 2.185 * S
38510 BG = 16.69 - 22.74 * S + 5.779 * S2
38511 CG = -25.59 + 29.71 * S - 7.296 * S2
38512 DG = 2.792 + 2.215 * S + 0.422 * S2 - 0.104 * S3
38513 EG = 0.807 + 2.005 * S
38514 ESG = 3.841 + 0.316 * S
38515 GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38520 *...NLO PARAMETRIZATION (MS(BAR)) :
38522 *$ CREATE PHO_DOR94HO.FOR
38524 CDECK ID>, PHO_DOR94HO
38525 SUBROUTINE PHO_DOR94HO (X, Q2, UV, DV, DEL, UDB, SB, GL)
38526 IMPLICIT DOUBLE PRECISION (A - Z)
38530 LAM2 = 0.248 * 0.248
38531 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38536 NU = 1.304 + 0.863 * S
38537 AKU = 0.558 - 0.020 * S
38539 AU = -0.113 + 0.283 * S - 0.321 * S2
38540 BU = 6.843 - 5.089 * S + 2.647 * S2 - 0.527 * S3
38541 CU = 7.771 - 10.09 * S + 2.630 * S2
38542 DU = 3.315 + 1.145 * S - 0.583 * S2 + 0.154 * S3
38543 UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38545 ND = 0.102 - 0.017 * S + 0.005 * S2
38546 AKD = 0.270 - 0.019 * S
38548 AD = 2.393 + 6.228 * S - 0.881 * S2
38549 BD = 46.06 + 4.673 * S - 14.98 * S2 + 1.331 * S3
38550 CD = 17.83 - 53.47 * S + 21.24 * S2
38551 DD = 4.081 + 0.976 * S - 0.485 * S2 + 0.152 * S3
38552 DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38554 NE = 0.070 + 0.042 * S - 0.011 * S2 + 0.004 * S3
38555 AKE = 0.409 - 0.007 * S
38556 BKE = 0.782 + 0.082 * S
38557 AE = -29.65 + 26.49 * S + 5.429 * S2
38558 BE = 90.20 - 74.97 * S + 4.526 * S2
38560 DE = 8.122 + 2.120 * S - 1.088 * S2 + 0.231 * S3
38561 DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38568 BGX = 3.210 - 1.866 * S
38570 DX = 9.010 + 0.896 * DS + 0.222 * S2
38571 EX = 3.077 + 1.446 * S
38572 ESX = 3.173 - 2.445 * DS + 2.207 * S
38573 UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38577 AKS = 1.690 + 0.650 * DS - 0.922 * S
38578 AS = -4.329 + 1.131 * S
38579 BS = 9.568 - 1.744 * S
38580 DST = 9.377 + 1.088 * DS - 1.320 * S + 0.130 * S2
38581 EST = 3.031 + 1.639 * S
38582 ESS = 5.837 + 0.815 * S
38583 SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38587 AKG = 1.724 + 0.157 * S
38588 BKG = 0.800 + 1.016 * S
38589 AG = 7.517 - 2.547 * S
38590 BG = 34.09 - 52.21 * DS + 17.47 * S
38591 CG = 4.039 + 1.491 * S
38592 DG = 3.404 + 0.830 * S
38593 EG = -1.112 + 3.438 * S - 0.302 * S2
38594 ESG = 3.256 - 0.436 * S
38595 GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38599 *$ CREATE PHO_DOR94DI.FOR
38601 CDECK ID>, PHO_DOR94DI
38603 *...NLO PARAMETRIZATION (DIS) :
38605 SUBROUTINE PHO_DOR94DI (X, Q2, UV, DV, DEL, UDB, SB, GL)
38606 IMPLICIT DOUBLE PRECISION (A - Z)
38610 LAM2 = 0.248 * 0.248
38611 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38616 NU = 2.484 + 0.116 * S + 0.093 * S2
38617 AKU = 0.563 - 0.025 * S
38618 BKU = 0.054 + 0.154 * S
38619 AU = -0.326 - 0.058 * S - 0.135 * S2
38620 BU = -3.322 + 8.259 * S - 3.119 * S2 + 0.291 * S3
38621 CU = 11.52 - 12.99 * S + 3.161 * S2
38622 DU = 2.808 + 1.400 * S - 0.557 * S2 + 0.119 * S3
38623 UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38625 ND = 0.156 - 0.017 * S
38626 AKD = 0.299 - 0.022 * S
38627 BKD = 0.259 - 0.015 * S
38628 AD = 3.445 + 1.278 * S + 0.326 * S2
38629 BD = -6.934 + 37.45 * S - 18.95 * S2 + 1.463 * S3
38630 CD = 55.45 - 69.92 * S + 20.78 * S2
38631 DD = 3.577 + 1.441 * S - 0.683 * S2 + 0.179 * S3
38632 DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38634 NE = 0.099 + 0.019 * S + 0.002 * S2
38635 AKE = 0.419 - 0.013 * S
38636 BKE = 1.064 - 0.038 * S
38637 AE = -44.00 + 98.70 * S - 14.79 * S2
38638 BE = 28.59 - 40.94 * S - 13.66 * S2 + 2.523 * S3
38639 CE = 84.57 - 108.8 * S + 31.52 * S2
38640 DE = 7.469 + 2.480 * S - 0.866 * S2
38641 DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38645 AKX = 0.326 + 0.150 * S
38646 BKX = 0.956 + 0.405 * S
38648 BGX = 3.794 - 2.359 * DS
38650 DX = 7.941 + 0.534 * DS - 0.940 * S + 0.410 * S2
38651 EX = 3.049 + 1.597 * S
38652 ESX = 4.396 - 4.594 * DS + 3.268 * S
38653 UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38657 AKS = 1.415 - 0.641 * DS
38658 AS = 0.580 - 9.763 * DS + 6.795 * S - 0.558 * S2
38659 BS = 5.617 + 5.709 * DS - 3.972 * S
38660 DST = 13.78 - 9.581 * S + 5.370 * S2 - 0.996 * S3
38661 EST = 4.546 + 0.372 * S2
38662 ESS = 5.053 - 1.070 * S + 0.805 * S2
38663 SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38668 BKG = 2.427 + 1.311 * S - 0.153 * S2
38669 AG = 25.09 - 7.935 * S
38670 BG = -14.84 - 124.3 * DS + 72.18 * S
38671 CG = 590.3 - 173.8 * S
38672 DG = 5.196 + 1.857 * S
38673 EG = -1.648 + 3.988 * S - 0.432 * S2
38674 ESG = 3.232 - 0.542 * S
38675 GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38680 *...FUNCTIONAL FORMS OF THE PARAMETRIZATIONS :
38682 *$ CREATE PHO_DOR94FV.FOR
38684 CDECK ID>, PHO_DOR94FV
38685 DOUBLE PRECISION FUNCTION PHO_DOR94FV (X,N,AK,BK,A,B,C,D)
38686 IMPLICIT DOUBLE PRECISION (A - Z)
38690 PHO_DOR94FV = N*X**AK*(1.D0+A*X**BK+X*(B+C*DX))*(1.D0-X)**D
38694 *$ CREATE PHO_DOR94FW.FOR
38696 CDECK ID>, PHO_DOR94FW
38697 DOUBLE PRECISION FUNCTION PHO_DOR94FW(X,S,AL,BE,AK,BK,
38699 IMPLICIT DOUBLE PRECISION (A - Z)
38703 PHO_DOR94FW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
38704 1 * DEXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38708 *$ CREATE PHO_DOR94FS.FOR
38710 CDECK ID>, PHO_DOR94FS
38711 DOUBLE PRECISION FUNCTION PHO_DOR94FS (X,S,AL,BE,AK,AG,B,D,E,ES)
38712 IMPLICIT DOUBLE PRECISION (A - Z)
38717 PHO_DOR94FS = S**AL / LX**AK * (1.+ AG*DX + B*X) * (1.- X)**D
38718 1 * DEXP (-E + SQRT (ES * S**BE * LX))
38722 *$ CREATE PHO_DOR92LO.FOR
38724 CDECK ID>, PHO_DOR92LO
38727 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38729 * 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 *
38731 * FOR A DETAILED EXPLANATION SEE : *
38732 * M. GLUECK, E.REYA, A.VOGT: DO-TH 91/07 *
38734 * THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
38735 * FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
38736 * / HO) AND 1.E8 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
38737 * REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG- *
38738 * LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT. *
38740 * HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
38741 * M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
38743 * CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
38744 * LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
38745 * LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
38746 * HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
38747 * LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
38749 * HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL. *
38751 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38753 SUBROUTINE PHO_DOR92LO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
38754 IMPLICIT DOUBLE PRECISION (A - Z)
38758 LAM2 = 0.232 * 0.232
38759 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38762 C...X * (UV + DV) :
38763 NUD = 0.663 + 0.191 * S - 0.041 * S2 + 0.031 * S3
38765 AGUD = -1.97 + 6.74 * S - 1.96 * S2
38766 BUD = 24.4 - 20.7 * S + 4.08 * S2
38767 DUD = 2.86 + 0.70 * S - 0.02 * S2
38768 UDV = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
38770 ND = 0.579 + 0.283 * S + 0.047 * S2
38771 AKD = 0.523 - 0.015 * S
38772 AGD = 2.22 - 0.59 * S - 0.27 * S2
38773 BD = 5.95 - 6.19 * S + 1.55 * S2
38774 DD = 3.57 + 0.94 * S - 0.16 * S2
38775 DV = PHO_DOR92FV (X,ND,AKD,AGD,BD,DD)
38779 AKG = 1.00 - 0.17 * S
38781 AGG = 0.0 + 4.879 * S - 1.383 * S2
38782 BGG = 25.92 - 28.97 * S + 5.596 * S2
38783 CG = -25.69 + 23.68 * S - 1.975 * S2
38784 DG = 2.537 + 1.718 * S + 0.353 * S2
38785 EG = 0.595 + 2.138 * S
38787 GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38788 C...X * UBAR = X * DBAR :
38791 AKU = 0.412 - 0.171 * S
38792 BKU = 0.566 - 0.496 * S
38795 CU = 1.029 + 1.785 * S - 0.459 * S2
38796 DU = 4.696 + 2.109 * S
38797 EU = 3.838 + 1.944 * S
38799 UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
38800 C...X * SBAR = X * S :
38804 AKS = 2.082 - 0.577 * S
38805 AGS = -3.055 + 1.024 * S ** 0.67
38806 BS = 27.4 - 20.0 * S ** 0.154
38808 EST = 4.33 + 1.408 * S
38809 ESS = 8.27 - 0.437 * S
38810 SB = PHO_DOR92FS(X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38811 C...X * CBAR = X * C :
38817 BC = 4.24 - 0.804 * S
38818 DC = 3.46 + 1.076 * S
38819 EC = 4.61 + 1.490 * S
38820 ESC = 2.555 + 1.961 * S
38821 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38822 C...X * BBAR = X * B :
38829 DB = 2.929 + 1.396 * S
38830 EB = 4.71 + 1.514 * S
38831 ESB = 4.02 + 1.239 * S
38832 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38836 *$ CREATE PHO_DOR92HO.FOR
38838 CDECK ID>, PHO_DOR92HO
38839 SUBROUTINE PHO_DOR92HO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
38840 IMPLICIT DOUBLE PRECISION (A - Z)
38844 LAM2 = 0.248 * 0.248
38845 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38849 C...X * (UV + DV) :
38850 NUD = 0.330 + 0.151 * S - 0.059 * S2 + 0.027 * S3
38852 AGUD = -2.28 + 15.73 * S - 4.58 * S2
38853 BUD = 56.7 - 53.6 * S + 11.21 * S2
38854 DUD = 3.17 + 1.17 * S - 0.47 * S2 + 0.09 * S3
38855 UDV = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
38857 ND = 0.459 + 0.315 * DS + 0.515 * S
38858 AKD = 0.624 - 0.031 * S
38859 AGD = 8.13 - 6.77 * DS + 0.46 * S
38860 BD = 6.59 - 12.83 * DS + 5.65 * S
38861 DD = 3.98 + 1.04 * S - 0.34 * S2
38862 DV = PHO_DOR92FV (X, ND, AKD, AGD, BD, DD)
38866 AKG = 0.323 + 1.653 * S
38867 BKG = 0.811 + 2.044 * S
38868 AGG = 0.0 + 1.963 * S - 0.519 * S2
38869 BGG = 0.078 + 6.24 * S
38870 CG = 30.77 - 24.19 * S
38871 DG = 3.188 + 0.720 * S
38872 EG = -0.881 + 2.687 * S
38874 GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38875 C...X * UBAR = X * DBAR :
38878 AKU = 0.636 - 0.084 * S
38880 AGU = 1.121 - 0.193 * S
38881 BGU = 0.751 - 0.785 * S
38882 CU = 8.57 - 1.763 * S
38883 DU = 10.22 + 0.668 * S
38884 EU = 3.784 + 1.280 * S
38885 ESU = 1.808 + 0.980 * S
38886 UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
38887 C...X * SBAR = X * S :
38891 AKS = 2.942 - 1.016 * S
38892 AGS = -4.60 + 1.167 * S
38893 BS = 9.31 - 1.324 * S
38894 DS = 11.49 - 1.198 * S + 0.053 * S2
38895 EST = 2.630 + 1.729 * S
38897 SB = PHO_DOR92FS (X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38898 C...X * CBAR = X * C :
38902 AKC = -0.625 - 0.523 * S
38904 BC = 1.896 + 1.616 * S
38905 DC = 4.12 + 0.683 * S
38906 EC = 4.36 + 1.328 * S
38907 ESC = 0.677 + 0.679 * S
38908 CB = PHO_DOR92FS (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38909 C...X * BBAR = X * B :
38913 AKB = 0.0 - 0.193 * S
38916 DB = 3.447 + 0.927 * S
38917 EB = 4.68 + 1.259 * S
38918 ESB = 1.892 + 2.199 * S
38919 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38923 *$ CREATE PHO_DOR92FV.FOR
38925 CDECK ID>, PHO_DOR92FV
38926 DOUBLE PRECISION FUNCTION PHO_DOR92FV(X,N,AK,AG,B,D)
38927 IMPLICIT DOUBLE PRECISION (A - Z)
38930 PHO_DOR92FV = N * X**AK * (1.+ AG*DX + B*X) * (1.- X)**D
38934 *$ CREATE PHO_DOR92FW.FOR
38936 CDECK ID>, PHO_DOR92FW
38937 DOUBLE PRECISION FUNCTION PHO_DOR92FW(X,S,
38938 & AL,BE,AK,BK,AG,BG,C,D,E,ES)
38939 IMPLICIT DOUBLE PRECISION (A - Z)
38942 PHO_DOR92FW = (X**AK * (AG + X * (BG + X*C)) * LX**BK + S**AL
38943 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38947 *$ CREATE PHO_DOR92FS.FOR
38949 CDECK ID>, PHO_DOR92FS
38950 DOUBLE PRECISION FUNCTION PHO_DOR92FS(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
38951 IMPLICIT DOUBLE PRECISION (A - Z)
38956 IF (S .LE. ST) THEN
38959 PHO_DOR92FS = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
38960 1 * EXP (-E + SQRT (ES * S**BE * LX))
38965 *$ CREATE PHO_DORPLO.FOR
38967 CDECK ID>, PHO_DORPLO
38969 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38971 * G R V - P I O N - P A R A M E T R I Z A T I O N S *
38973 * FOR A DETAILED EXPLANATION SEE : *
38974 * M. GLUECK, E.REYA, A.VOGT: DO-TH 91/16 *
38976 * THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
38977 * FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
38978 * / HO) AND 1.E8 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
38979 * REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG- *
38980 * LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT. *
38982 * HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
38983 * M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
38985 * CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
38986 * LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
38987 * LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
38988 * HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
38989 * LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
38991 * HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL. *
38993 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38995 SUBROUTINE PHO_DORPLO (X, Q2, VAP, GLP, QBP, CBP, BBP)
38996 IMPLICIT DOUBLE PRECISION (A - Z)
39000 LAM2 = 0.232 * 0.232
39001 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39005 NV = 0.519 + 0.180 * S - 0.011 * S2
39006 AKV = 0.499 - 0.027 * S
39007 AGV = 0.381 - 0.419 * S
39008 DV = 0.367 + 0.563 * S
39009 VAP = PHO_DORFVP (X, NV, AKV, AGV, DV)
39013 AKG = 0.482 + 0.341 * DS
39015 AGG = 0.678 + 0.877 * S - 0.175 * S2
39016 BGG = 0.338 - 1.597 * S
39017 CG = 0.0 - 0.233 * S + 0.406 * S2
39018 DG = 0.390 + 1.053 * S
39019 EG = 0.618 + 2.070 * S
39021 GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
39022 C...X * QBAR (SU(3)-SYMMETRIC SEA) :
39026 AKS = 2.538 - 0.763 * S
39028 BS = 0.313 + 0.935 * S
39030 EST = 4.433 + 1.301 * S
39031 ESS = 9.30 - 0.887 * S
39032 QBP = PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
39033 C...X * CBAR = X * C :
39040 DC = 1.208 + 0.771 * S
39041 EC = 4.40 + 1.493 * S
39042 ESC = 2.032 + 1.901 * S
39043 CBP = PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
39044 C...X * BBAR = X * B :
39051 DB = 0.697 + 0.855 * S
39052 EB = 4.51 + 1.490 * S
39053 ESB = 3.056 + 1.694 * S
39054 BBP = PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
39058 *$ CREATE PHO_DORPHO.FOR
39060 CDECK ID>, PHO_DORPHO
39061 SUBROUTINE PHO_DORPHO (X, Q2, VAP, GLP, QBP, CBP, BBP)
39062 IMPLICIT DOUBLE PRECISION (A - Z)
39066 LAM2 = 0.248 * 0.248
39067 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39071 NV = 0.456 + 0.150 * DS + 0.112 * S - 0.019 * S2
39072 AKV = 0.505 - 0.033 * S
39073 AGV = 0.748 - 0.669 * DS - 0.133 * S
39074 DV = 0.365 + 0.197 * DS + 0.394 * S
39075 VAP = PHO_DORFVP (X, NV, AKV, AGV, DV)
39079 AKG = 0.437 - 0.689 * DS
39081 AGG = 1.324 - 0.441 * DS - 0.130 * S
39082 BGG = -0.955 + 0.259 * S
39083 CG = 1.075 - 0.302 * S
39084 DG = 1.158 + 1.229 * S
39085 EG = 0.0 + 2.510 * S
39086 ESG = 2.604 + 0.165 * S
39087 GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
39088 C...X * QBAR (SU(3)-SYMMETRIC SEA) :
39092 AKS = -0.350 + 0.806 * S
39095 DS = 2.273 + 1.438 * S
39096 EST = 3.214 + 1.545 * S
39097 ESS = 1.341 + 1.938 * S
39098 QBP = PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
39099 C...X * CBAR = X * C :
39103 AKC = 0.0 - 0.457 * S
39105 BC = -1.00 + 1.40 * S
39106 DC = 1.318 + 0.584 * S
39107 EC = 4.45 + 1.235 * S
39108 ESC = 1.496 + 1.010 * S
39109 CBP = PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
39110 C...X * BBAR = X * B :
39114 AKB = 0.0 - 0.172 * S
39117 DB = 1.447 + 0.485 * S
39118 EB = 4.79 + 1.164 * S
39119 ESB = 1.724 + 2.121 * S
39120 BBP = PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
39124 *$ CREATE PHO_DORFVP.FOR
39126 CDECK ID>, PHO_DORFVP
39127 DOUBLE PRECISION FUNCTION PHO_DORFVP(X,N,AK,AG,D)
39128 IMPLICIT DOUBLE PRECISION (A - Z)
39132 PHO_DORFVP = N * X**AK * (1.+ AG*DX) * (1.- X)**D
39136 *$ CREATE PHO_DORFGP.FOR
39138 CDECK ID>, PHO_DORFGP
39139 DOUBLE PRECISION FUNCTION PHO_DORFGP(X,S,AL,BE,AK,BK,AG,
39141 IMPLICIT DOUBLE PRECISION (A - Z)
39146 PHO_DORFGP = (X**AK * (AG + BG*DX + C*X) * LX**BK + S**AL
39147 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
39151 *$ CREATE PHO_DORFQP.FOR
39153 CDECK ID>, PHO_DORFQP
39154 DOUBLE PRECISION FUNCTION PHO_DORFQP(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
39155 IMPLICIT DOUBLE PRECISION (A - Z)
39160 IF (S .LE. ST) THEN
39163 PHO_DORFQP = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
39164 1 * EXP (-E + SQRT (ES * S**BE * LX))
39169 *$ CREATE PHO_DORGLO.FOR
39171 CDECK ID>, PHO_DORGLO
39172 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39174 * 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 *
39176 * FOR A DETAILED EXPLANATION SEE : *
39177 * M. GLUECK, E.REYA, A.VOGT: DO-TH 91/31 *
39179 * THE OUTPUT IS ALWAYS 1./ ALPHA(EM) * X * PARTON DENSITY *
39181 * THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
39182 * FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
39183 * / HO) AND 1.E6 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
39185 * HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
39186 * M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
39188 * CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
39189 * LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
39190 * LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
39191 * HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
39192 * LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
39194 * HO DISTRIBUTIONS REFER TO THE DIS(GAMMA) SCHEME, SEE : *
39195 * M. GLUECK, E.REYA, A.VOGT: DO-TH 91/26 *
39197 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39199 SUBROUTINE PHO_DORGLO (X, Q2, UL, DL, SL, CL, BL, GL)
39200 IMPLICIT DOUBLE PRECISION (A - Z)
39204 LAM2 = 0.232 * 0.232
39205 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39208 C...X * U = X * UBAR :
39211 AK = 0.500 - 0.176 * S
39212 BK = 15.00 - 5.687 * SS - 0.552 * S2
39213 AG = 0.235 + 0.046 * SS
39214 BG = 0.082 - 0.051 * S + 0.168 * S2
39215 C = 0.0 + 0.459 * S
39216 D = 0.354 - 0.061 * S
39217 E = 4.899 + 1.678 * S
39218 ES = 2.046 + 1.389 * S
39219 UL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39220 C...X * D = X * DBAR :
39223 AK = 0.496 + 0.026 * S
39224 BK = 0.685 - 0.580 * SS + 0.608 * S2
39225 AG = 0.233 + 0.302 * S
39226 BG = 0.0 - 0.818 * S + 0.198 * S2
39227 C = 0.114 + 0.154 * S
39228 D = 0.405 - 0.195 * S + 0.046 * S2
39229 E = 4.807 + 1.226 * S
39230 ES = 2.166 + 0.664 * S
39231 DL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39235 AK = 0.462 - 0.524 * SS
39236 BK = 5.451 - 0.804 * S2
39237 AG = 0.535 - 0.504 * SS + 0.288 * S2
39238 BG = 0.364 - 0.520 * S
39239 C = -0.323 + 0.115 * S2
39240 D = 0.233 + 0.790 * S - 0.139 * S2
39241 E = 0.893 + 1.968 * S
39242 ES = 3.432 + 0.392 * S
39243 GL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39244 C...X * S = X * SBAR :
39248 AK = 0.470 - 0.099 * S2
39250 AG = 0.121 - 0.068 * SS
39251 BG = -0.090 + 0.074 * S
39252 C = 0.062 + 0.034 * S
39253 D = 0.0 + 0.226 * S - 0.060 * S2
39254 E = 4.288 + 1.707 * S
39255 ES = 2.122 + 0.656 * S
39256 SL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39257 C...X * C = X * CBAR :
39261 AK = 1.254 - 0.251 * S
39262 BK = 3.932 - 0.327 * S2
39263 AG = 0.658 + 0.202 * S
39266 D = 0.0 + 0.141 * S - 0.027 * S2
39267 E = 4.911 + 0.969 * S
39268 ES = 2.796 + 0.952 * S
39269 CL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39270 C...X * B = X * BBAR :
39274 AK = 1.961 - 0.370 * S
39275 BK = 0.923 + 0.119 * S
39276 AG = 0.815 + 0.207 * S
39279 D = -0.223 + 0.173 * S
39280 E = 5.426 + 0.623 * S
39281 ES = 3.819 + 0.901 * S
39282 BL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39286 *$ CREATE PHO_DORGHO.FOR
39288 CDECK ID>, PHO_DORGHO
39289 SUBROUTINE PHO_DORGHO (X, Q2, UH, DH, SH, CH, BH, GH)
39290 IMPLICIT DOUBLE PRECISION (A - Z)
39294 LAM2 = 0.248 * 0.248
39295 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39298 C...X * U = X * UBAR :
39301 AK = 0.449 - 0.025 * S - 0.071 * S2
39302 BK = 5.060 - 1.116 * SS
39304 BG = 0.319 + 0.422 * S
39305 C = 1.508 + 4.792 * S - 1.963 * S2
39306 D = 1.075 + 0.222 * SS - 0.193 * S2
39307 E = 4.147 + 1.131 * S
39308 ES = 1.661 + 0.874 * S
39309 UH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39310 C...X * D = X * DBAR :
39313 AK = 0.442 - 0.132 * S - 0.058 * S2
39314 BK = 5.437 - 1.916 * SS
39316 BG = 0.311 - 0.059 * S
39317 C = 0.800 + 0.078 * S - 0.100 * S2
39318 D = 0.862 + 0.294 * SS - 0.184 * S2
39319 E = 4.202 + 1.352 * S
39320 ES = 1.841 + 0.990 * S
39321 DH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39325 AK = 0.530 - 0.742 * SS + 0.025 * S2
39327 AG = 0.533 - 0.281 * SS + 0.218 * S2
39328 BG = 0.025 - 0.518 * S + 0.156 * S2
39329 C = -0.282 + 0.209 * S2
39330 D = 0.107 + 1.058 * S - 0.218 * S2
39331 E = 0.0 + 2.704 * S
39332 ES = 3.071 - 0.378 * S
39333 GH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39334 C...X * S = X * SBAR :
39338 AK = 1.770 - 0.735 * SS - 0.079 * S2
39340 AG = 0.084 - 0.023 * S
39342 C = 2.119 - 0.942 * S + 0.063 * S2
39343 D = 1.271 + 0.076 * S - 0.190 * S2
39344 E = 4.604 + 0.737 * S
39345 ES = 1.641 + 0.976 * S
39346 SH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39347 C...X * C = X * CBAR :
39351 AK = 1.142 - 0.175 * S
39353 AG = 0.504 + 0.317 * S
39356 D = 0.398 + 0.326 * S - 0.107 * S2
39357 E = 5.493 + 0.408 * S
39358 ES = 2.426 + 1.277 * S
39359 CH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39360 C...X * B = X * BBAR :
39364 AK = 1.953 - 0.391 * S
39365 BK = 1.657 - 0.161 * S
39366 AG = 1.076 + 0.034 * S
39369 D = 0.353 + 0.016 * S
39370 E = 5.713 + 0.249 * S
39371 ES = 3.456 + 0.673 * S
39372 BH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39376 *$ CREATE PHO_DORGH0.FOR
39378 CDECK ID>, PHO_DORGH0
39379 SUBROUTINE PHO_DORGH0 (X, Q2, U0, D0, S0, C0, B0, G0)
39380 IMPLICIT DOUBLE PRECISION (A - Z)
39384 LAM2 = 0.248 * 0.248
39385 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39388 C...X * U = X * UBAR :
39391 AK = 0.527 + 0.200 * S - 0.107 * S2
39392 BK = 7.106 - 0.310 * SS - 0.786 * S2
39393 AG = 0.197 + 0.533 * S
39394 BG = 0.062 - 0.398 * S + 0.109 * S2
39395 C = 0.755 * S - 0.112 * S2
39396 D = 0.318 - 0.059 * S
39397 E = 4.225 + 1.708 * S
39398 ES = 1.752 + 0.866 * S
39399 U0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39400 C...X * D = X * DBAR :
39403 AK = 0.500 + 0.067 * SS - 0.055 * S2
39404 BK = 0.376 - 0.453 * SS + 0.405 * S2
39405 AG = 0.156 + 0.184 * S
39406 BG = 0.0 - 0.528 * S + 0.146 * S2
39407 C = 0.121 + 0.092 * S
39408 D = 0.379 - 0.301 * S + 0.081 * S2
39409 E = 4.346 + 1.638 * S
39410 ES = 1.645 + 1.016 * S
39411 D0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39415 AK = 0.537 - 0.600 * SS
39416 BK = 6.389 - 0.953 * S2
39417 AG = 0.558 - 0.383 * SS + 0.261 * S2
39418 BG = 0.0 - 0.305 * S
39419 C = -0.222 + 0.078 * S2
39420 D = 0.153 + 0.978 * S - 0.209 * S2
39421 E = 1.429 + 1.772 * S
39422 ES = 3.331 + 0.806 * S
39423 G0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39424 C...X * S = X * SBAR :
39428 AK = 0.622 + 0.332 * S - 0.300 * S2
39430 AG = 0.211 - 0.064 * SS - 0.018 * S2
39431 BG = -0.215 + 0.122 * S
39433 D = 0.0 + 0.253 * S - 0.081 * S2
39434 E = 3.990 + 2.014 * S
39435 ES = 1.720 + 0.986 * S
39436 S0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39437 C...X * C = X * CBAR :
39441 AK = 1.228 - 0.231 * S
39442 BK = 3.806 - 0.337 * S2
39443 AG = 0.932 + 0.150 * S
39446 D = 0.0 + 0.138 * S - 0.028 * S2
39447 E = 5.588 + 0.628 * S
39448 ES = 2.665 + 1.054 * S
39449 C0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39450 C...X * B = X * BBAR :
39454 AK = 1.719 - 0.292 * S
39455 BK = 0.928 + 0.096 * S
39456 AG = 0.845 + 0.178 * S
39459 D = -0.191 + 0.151 * S
39460 E = 6.089 + 0.282 * S
39461 ES = 3.379 + 1.062 * S
39462 B0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39466 *$ CREATE PHO_DORGF.FOR
39468 CDECK ID>, PHO_DORGF
39469 DOUBLE PRECISION FUNCTION PHO_DORGF(X,S,AL,BE,AK,BK,
39471 IMPLICIT DOUBLE PRECISION (A - Z)
39476 PHO_DORGF = (X**AK * (AG + BG * SX + C * X**BK) + S**AL
39477 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
39481 *$ CREATE PHO_DORGFS.FOR
39483 CDECK ID>, PHO_DORGFS
39484 DOUBLE PRECISION FUNCTION PHO_DORGFS(X,S,SF,AL,BE,AK,BK,AG,BG,
39486 IMPLICIT DOUBLE PRECISION (A - Z)
39489 IF (S .LE. SF) THEN
39495 PHO_DORGFS = (DS * X**AK * (AG + BG * SX + C * X**BK) + DS**AL
39496 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
39501 *$ CREATE PHO_DORGLV.FOR
39503 CDECK ID>, PHO_DORGLV
39504 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39506 * G R S - LO - VIRTUAL PHOTON PARAMETRIZATIONS *
39508 * FOR A DETAILED EXPLANATION SEE *
39509 * M. GLUECK, E.REYA, M. STRATMANN : *
39510 * PHYS. REV. D51 (1995) 3220 *
39512 * THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR *
39513 * Q**2 / GEV**2 BETWEEN 0.6 AND 5.E4 *
39514 * AND (!) Q**2 > 5 P**2 *
39515 * P**2 / GEV**2 BETWEEN 0.0 AND 10. *
39516 * P**2 = 0 <=> REAL PHOTON *
39517 * X BETWEEN 1.E-4 AND 1. *
39519 * HEAVY QUARK THRESHOLDS Q(H) = M(H) IN THE BETA FUNCTION : *
39520 * M(C) = 1.5, M(B) = 4.5 *
39521 * CORRESPONDING LAMBDA(F) VALUES IN GEV FOR Q**2 > M(H)**2 : *
39522 * LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
39523 * LAMBDA(5) = 0.153, *
39524 * THE NUMBER OF ACTIVE QUARK FLAVOURS IS NF = 3 EVERYWHERE *
39525 * EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,... *
39526 * ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION. *
39528 * PLEASE REPORT ANY STRANGE BEHAVIOUR TO : *
39529 * Marco.Stratmann@durham.ac.uk *
39530 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39532 *...INPUT PARAMETERS :
39534 * X = MOMENTUM FRACTION
39535 * Q2 = SCALE Q**2 IN GEV**2
39536 * P2 = VIRTUALITY OF THE PHOTON IN GEV**2
39538 *...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION DIVIDED BY ALPHA_EM) :
39540 ********************************************************
39541 * subroutine grspar(x,q2,p2,ugam,dgam,sgam,ggam)
39542 subroutine PHO_DORGLV(x,q2,p2,ugam,dgam,sgam,ggam)
39543 implicit double precision (a-z)
39546 C input/output channels
39548 COMMON /POINOU/ LI,LO
39555 if(x.lt.0.0001d0) check=1
39556 if((q2.lt.0.6d0).or.(q2.gt.50000.d0)) check=1
39557 if(q2.lt.5.d0*p2) check=1
39559 c calculate distributions
39561 if(check.eq.0) then
39562 call PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
39564 WRITE(LO,*) 'GRS PDF parametrization: x/q2/p2 limits exceeded'
39565 WRITE(LO,'(1X,A,1P,3E12.3)') 'current X, Q2, P2:',x,q2,p2
39570 *$ CREATE PHO_grscalc.FOR
39572 CDECK ID>, PHO_grscalc
39573 subroutine PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
39574 implicit double precision (a-z)
39577 dimension u1(40),ds1(40),g1(40)
39578 dimension ud2(20),s2(20),g2(20)
39579 dimension up0(20),dsp0(20),gp0(20)
39581 C save u1,ds1,g1,ud2,s2,g2,up0,dsp0,gp0
39584 data u1/-0.139d0,0.783d0,0.132d0,0.087d0,0.003d0,-0.0134d0,
39585 & 0.009d0,-0.017d0,0.092d0,-0.516d0,-0.085d0,0.439d0,
39586 & 0.013d0,0.108d0,-0.019d0,-0.272d0,-0.167d0,0.138d0,
39587 & 0.076d0,0.026d0,-0.013d0,0.27d0,0.107d0,-0.097d0,0.04d0,
39588 & 0.064d0,0.011d0,0.002d0,0.057d0,-0.057d0,0.162d0,
39589 & -0.172d0,0.124d0,-0.016d0,-0.065d0,0.044d0,-1.009d0,
39590 & 0.622d0,0.227d0,-0.184d0/
39591 data ds1/0.033d0,0.007d0,-0.0516d0,0.12d0,0.001d0,-0.013d0,
39592 & 0.018d0,-0.028d0,0.102d0,-0.595d0,-0.114d0,0.669d0,
39593 & 0.022d0,0.001d0,-0.003d0,-0.0583d0,-0.041d0,0.035d0,
39594 & 0.009d0,0.009d0,0.004d0,0.054d0,0.025d0,-0.02d0,
39595 & 0.007d0,0.021d0,0.01d0,0.004d0,-0.067d0,0.06d0,-0.148d0,
39596 & 0.13d0,0.032d0,-0.009d0,-0.06d0,0.036d0,-0.39d0,0.033d0,
39597 & 0.245d0,-0.171d0/
39598 data g1/0.025d0,0.d0,-0.018d0,0.112d0,-0.025d0,0.177d0,
39599 & -0.022d0,0.024d0,0.001d0,-0.0104d0,0.d0,0.d0,-1.082d0,
39600 & -1.666d0,0.d0,0.086d0,0.d0,0.053d0,0.005d0,-0.058d0,
39601 & 0.034d0,0.073d0,1.08d0,1.63d0,-0.0256d0,-0.088d0,0.d0,
39602 & 0.d0,-0.004d0,0.016d0,0.007d0,-0.012d0,0.01d0,-0.673d0,
39603 & 0.126d0,-0.167d0,0.032d0,-0.227d0,0.086d0,-0.159d0/
39604 data ud2/0.756d0,0.187d0,0.109d0,-0.163d0,0.002d0,0.004d0,
39605 & 0.054d0,-0.039d0,22.53d0,-21.02d0,5.608d0,0.332d0,
39606 & -0.008d0,-0.021d0,0.381d0,0.572d0,4.774d0,1.436d0,
39607 & -0.614d0,3.548d0/
39608 data s2/0.902d0,0.182d0,0.271d0,-0.346d0,0.017d0,-0.01d0,
39609 & -0.011d0,0.0065d0,17.1d0,-13.29d0,6.519d0,0.031d0,
39610 & -0.0176d0,0.003d0,1.243d0,0.804d0,4.709d0,1.499d0,
39612 data g2/0.364d0,1.31d0,0.86d0,-0.254d0,0.611d0,0.008d0,
39613 & -0.097d0,-2.412d0,-0.843d0,2.248d0,-0.201d0,1.33d0,
39614 & 0.572d0,0.44d0,1.233d0,0.009d0,0.954d0,1.862d0,3.791d0,
39616 data up0/1.551d0,0.105d0,1.089d0,-0.172d0,3.822d0,-2.162d0,
39617 & 0.533d0,-0.467d0,-0.412d0,0.2d0,0.377d0,0.299d0,0.487d0,
39618 & 0.0766d0,0.119d0,0.063d0,7.605d0,0.234d0,-0.567d0,
39620 data dsp0/2.484d0,1.214d0,1.088d0,-0.1735d0,4.293d0,
39621 & -2.802d0,0.5975d0,-0.1193d0,-0.0872d0,0.0418d0,0.128d0,
39622 & 0.0337d0,0.127d0,0.0135d0,0.14d0,0.0423d0,6.946d0,
39623 & 0.814d0,1.531d0,0.124d0/
39624 data gp0/1.682d0,1.1d0,0.5888d0,-0.4714d0,0.5362d0,0.0127d0,
39625 & -2.438d0,0.03399d0,0.07825d0,0.05842d0,0.08393d0,2.348d0,
39626 & -0.07182d0,1.084d0,0.3098d0,-0.07514d0,3.327d0,1.1d0,
39627 & 2.264d0,0.2675d0/
39630 lam2=0.232d0*0.232d0
39632 if(p2.le.0.25d0) then
39633 s=log(log(q2/lam2)/log(mu2/lam2))
39637 s=log(log(q2/lam2)/log(p2/lam2))
39638 lp1=log(p2/mu2)*log(p2/mu2)
39639 lp2=log(p2/mu2+log(p2/mu2))
39642 alp=up0(1)+lp1*u1(1)+lp2*u1(2)
39643 bet=up0(2)+lp1*u1(3)+lp2*u1(4)
39644 a=up0(3)+lp1*u1(5)+lp2*u1(6)+
39645 & (up0(4)+lp1*u1(7)+lp2*u1(8))*s
39646 b=up0(5)+lp1*u1(9)+lp2*u1(10)+
39647 & (up0(6)+lp1*u1(11)+lp2*u1(12))*s**0.5+
39648 & (up0(7)+lp1*u1(13)+lp2*u1(14))*s**2
39649 gb=up0(8)+lp1*u1(15)+lp2*u1(16)+
39650 & (up0(9)+lp1*u1(17)+lp2*u1(18))*s+
39651 & (up0(10)+lp1*u1(19)+lp2*u1(20))*s**2
39652 ga=up0(11)+lp1*u1(21)+lp2*u1(22)+
39653 & (up0(12)+lp1*u1(23)+lp2*u1(24))*s**0.5
39654 gc=up0(13)+lp1*u1(25)+lp2*u1(33)+
39655 & (up0(14)+lp1*u1(26)+lp2*u1(34))*s
39656 gd=up0(15)+lp1*u1(27)+lp2*u1(35)+
39657 & (up0(16)+lp1*u1(28)+lp2*u1(36))*s
39658 ge=up0(17)+lp1*u1(29)+lp2*u1(37)+
39659 & (up0(18)+lp1*u1(30)+lp2*u1(38))*s
39660 gep=up0(19)+lp1*u1(31)+lp2*u1(39)+
39661 & (up0(20)+lp1*u1(32)+lp2*u1(40))*s
39662 upart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39664 alp=dsp0(1)+lp1*ds1(1)+lp2*ds1(2)
39665 bet=dsp0(2)+lp1*ds1(3)+lp2*ds1(4)
39666 a=dsp0(3)+lp1*ds1(5)+lp2*ds1(6)+
39667 & (dsp0(4)+lp1*ds1(7)+lp2*ds1(8))*s
39668 b=dsp0(5)+lp1*ds1(9)+lp2*ds1(10)+
39669 & (dsp0(6)+lp1*ds1(11)+lp2*ds1(12))*s**0.5+
39670 & (dsp0(7)+lp1*ds1(13)+lp2*ds1(14))*s**2
39671 gb=dsp0(8)+lp1*ds1(15)+lp2*ds1(16)+
39672 & (dsp0(9)+lp1*ds1(17)+lp2*ds1(18))*s+
39673 & (dsp0(10)+lp1*ds1(19)+lp2*ds1(20))*s**2
39674 ga=dsp0(11)+lp1*ds1(21)+lp2*ds1(22)+
39675 & (dsp0(12)+lp1*ds1(23)+lp2*ds1(24))*s
39676 gc=dsp0(13)+lp1*ds1(25)+lp2*ds1(33)+
39677 & (dsp0(14)+lp1*ds1(26)+lp2*ds1(34))*s
39678 gd=dsp0(15)+lp1*ds1(27)+lp2*ds1(35)+
39679 & (dsp0(16)+lp1*ds1(28)+lp2*ds1(36))*s
39680 ge=dsp0(17)+lp1*ds1(29)+lp2*ds1(37)+
39681 & (dsp0(18)+lp1*ds1(30)+lp2*ds1(38))*s
39682 gep=dsp0(19)+lp1*ds1(31)+lp2*ds1(39)+
39683 & (dsp0(20)+lp1*ds1(32)+lp2*ds1(40))*s
39684 dspart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39686 alp=gp0(1)+lp1*g1(1)+lp2*g1(2)
39687 bet=gp0(2)+lp1*g1(3)+lp2*g1(4)
39688 a=gp0(3)+lp1*g1(5)+lp2*g1(6)+
39689 & (gp0(4)+lp1*g1(7)+lp2*g1(8))*s**0.5
39690 b=gp0(5)+lp1*g1(9)+lp2*g1(10)+
39691 & (gp0(6)+lp1*g1(11)+lp2*g1(12))*s**2
39692 gb=gp0(7)+lp1*g1(13)+lp2*g1(14)+
39693 & (gp0(8)+lp1*g1(15)+lp2*g1(16))*s
39694 ga=gp0(9)+lp1*g1(17)+lp2*g1(18)+
39695 & (gp0(10)+lp1*g1(19)+lp2*g1(20))*s**0.5+
39696 & (gp0(11)+lp1*g1(21)+lp2*g1(22))*s**2
39697 gc=gp0(12)+lp1*g1(23)+lp2*g1(24)+
39698 & (gp0(13)+lp1*g1(25)+lp2*g1(26))*s**2
39699 gd=gp0(14)+lp1*g1(27)+lp2*g1(28)+
39700 & (gp0(15)+lp1*g1(29)+lp2*g1(30))*s+
39701 & (gp0(16)+lp1*g1(31)+lp2*g1(32))*s**2
39702 ge=gp0(17)+lp1*g1(33)+lp2*g1(34)+
39703 & (gp0(18)+lp1*g1(35)+lp2*g1(36))*s
39704 gep=gp0(19)+lp1*g1(37)+lp2*g1(38)+
39705 & (gp0(20)+lp1*g1(39)+lp2*g1(40))*s
39706 gpart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39708 s=log(log(q2/lam2)/log(mu2/lam2))
39709 suppr=1.d0/(1.d0+p2/0.59d0)**2
39714 ga=ud2(5)+ud2(6)*s**0.5
39716 b=ud2(9)+ud2(10)*s+ud2(11)*s**2
39717 gb=ud2(12)+ud2(13)*s+ud2(14)*s**2
39718 gd=ud2(15)+ud2(16)*s
39719 ge=ud2(17)+ud2(18)*s
39720 gep=ud2(19)+ud2(20)*s
39721 udpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39726 ga=s2(5)+s2(6)*s**0.5
39728 b=s2(9)+s2(10)*s+s2(11)*s**2
39729 gb=s2(12)+s2(13)*s+s2(14)*s**2
39732 gep=s2(19)+s2(20)*s
39733 spart2=suppr*PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39737 a=g2(3)+g2(4)*s**0.5
39740 ga=g2(9)+g2(10)*s**0.5+g2(11)*s**2
39741 gc=g2(12)+g2(13)*s**2
39742 gd=g2(14)+g2(15)*s+g2(16)*s**2
39744 gep=g2(19)+g2(20)*s
39745 gpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39747 ugam=upart1+udpart2
39748 dgam=dspart1+udpart2
39749 sgam=dspart1+spart2
39754 *$ CREATE PHO_grsf1.FOR
39756 CDECK ID>, PHO_grsf1
39757 DOUBLE PRECISION FUNCTION PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,
39759 implicit double precision (a-z)
39762 PHO_grsf1=(x**a*(ga+gb*sqrt(x)+gc*x**b)+
39763 & s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
39768 *$ CREATE PHO_grsf2.FOR
39770 CDECK ID>, PHO_grsf2
39771 DOUBLE PRECISION FUNCTION PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,
39773 implicit double precision (a-z)
39776 PHO_grsf2=(s*x**a*(ga+gb*sqrt(x)+gc*x**b)+
39777 & s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
39782 *$ CREATE PHO_CKMTPA.FOR
39784 CDECK ID>, PHO_CKMTPA
39785 SUBROUTINE PHO_CKMTPA(IPA,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
39786 C**********************************************************************
39788 C PDF based on Regge theory, evolved with .... by ....
39790 C input: IPAR 2212 proton (not installed)
39793 C output: parameters of parametrization
39795 C**********************************************************************
39796 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39801 C input/output channels
39803 COMMON /POINOU/ LI,LO
39805 REAL PROP(40),POMP(40)
39807 & .230000E+00, .200000E+01, .150200E+00, .120000E+01, .263100E+00,
39808 & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
39809 & .100000E+00, .330000E-01, .352102E-01, .200000E+01, .200000E+01,
39810 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39811 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39812 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39813 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39814 & .000000E+00, .000000E+00, .100000E+00, .200000E+01, .100000E+09/
39816 & .230000E+00, .500000E+01, .150200E+00, .120000E+01, .263100E+00,
39817 & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
39818 & .700000E-01, .700000E-01, .137161E+00, .300000E+01, .200000E+01,
39819 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39820 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39821 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39822 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39823 & .000000E+00, .000000E+00, .100000E+00, .500000E+01, .100000E+09/
39825 IF(IPA.EQ.2212) THEN
39830 ELSE IF(IPA.EQ.990) THEN
39836 WRITE(LO,'(1X,A,I7)')
39837 & 'PHO_CKMTPA:ERROR: invalid particle code',IPA
39844 *$ CREATE PHO_CKMTPD.FOR
39846 CDECK ID>, PHO_CKMTPD
39847 SUBROUTINE PHO_CKMTPD(IPAR,X,SCALE2,PD)
39848 C**********************************************************************
39850 C PDF based on Regge theory, evolved with .... by ....
39852 C input: IPAR 2212 proton (not installed)
39855 C output: PD(-6:6) x*f(x) parton distribution functions
39856 C (PDFLIB convention: d = PD(1), u = PD(2) )
39858 C**********************************************************************
39861 C input/output channels
39863 COMMON /POINOU/ LI,LO
39865 DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP
39871 C QCD lambda for evolution
39874 C Q0**2 for evolution
39878 C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
39879 C q(6)=x*charm, q(7)=x*gluon
39883 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
39885 IF(IPAR.EQ.2212) THEN
39886 * CALL PHO_CKMTPR(XX,SB,QQ
39887 WRITE(LO,'(/1X,A,I6)') 'PHO_CKMTPD:ERROR: invalid particle',IPAR
39890 CALL PHO_CKMTPO(XX,SB,QQ)
39895 PD(-4) = DBLE(QQ(6))
39896 PD(-3) = DBLE(QQ(3))
39897 PD(-2) = DBLE(QQ(4))
39898 PD(-1) = DBLE(QQ(5))
39899 PD(0) = DBLE(QQ(7))
39900 PD(1) = DBLE(QQ(2))
39901 PD(2) = DBLE(QQ(1))
39902 PD(3) = DBLE(QQ(3))
39903 PD(4) = DBLE(QQ(6))
39906 IF(IPAR.EQ.990) THEN
39907 CDN = (PD(1)-PD(-1))/2.D0
39908 CUP = (PD(2)-PD(-2))/2.D0
39909 PD(-1) = PD(-1) + CDN
39910 PD(-2) = PD(-2) + CUP
39916 *$ CREATE PHO_CKMTPO.FOR
39918 CDECK ID>, PHO_CKMTPO
39919 SUBROUTINE PHO_CKMTPO(X,S,QQ)
39920 C**********************************************************************
39922 C calculation partons in Pomeron
39924 C**********************************************************************
39929 C input/output channels
39931 COMMON /POINOU/ LI,LO
39933 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
39934 EQUIVALENCE (GF(1,1,1),DL(1))
39938 C DEU.NORM. QUARKS,GLUONS,NEW NORM .6223E+00 .2754E+00 .1372E+01
39939 C POM.NORM. QUARKS,GLUONS,ALL .132E+00 .275E+00 .407E+00
39940 DATA (DL(K),K= 1, 85) /
39941 & .324159E-01, .324159E-01, .298895E-01, .298895E-01, .298895E-01,
39942 & .298895E-01, .486150E+00,-.867362E-18, .362035E-01, .362035E-01,
39943 & .335142E-01, .335151E-01, .335151E-01, .335142E-01, .745381E+00,
39944 & .399157E-02, .417146E-01, .417146E-01, .388545E-01, .388564E-01,
39945 & .388564E-01, .388545E-01, .107588E+01, .969559E-02, .493208E-01,
39946 & .493208E-01, .462819E-01, .462849E-01, .462849E-01, .462819E-01,
39947 & .148168E+01, .174837E-01, .593251E-01, .593251E-01, .560991E-01,
39948 & .561035E-01, .561035E-01, .560991E-01, .196422E+01, .276588E-01,
39949 & .720220E-01, .720220E-01, .686007E-01, .686065E-01, .686065E-01,
39950 & .686007E-01, .252331E+01, .405154E-01, .876695E-01, .876695E-01,
39951 & .840445E-01, .840520E-01, .840520E-01, .840445E-01, .315730E+01,
39952 & .563115E-01, .106489E+00, .106489E+00, .102652E+00, .102662E+00,
39953 & .102662E+00, .102652E+00, .386313E+01, .752690E-01, .128662E+00,
39954 & .128662E+00, .124605E+00, .124616E+00, .124616E+00, .124605E+00,
39955 & .463661E+01, .975686E-01, .154326E+00, .154326E+00, .150039E+00,
39956 & .150053E+00, .150053E+00, .150039E+00, .547247E+01, .123348E+00,
39957 & .183571E+00, .183571E+00, .179048E+00, .179063E+00, .179063E+00/
39958 DATA (DL(K),K= 86, 170) /
39959 & .179048E+00, .636464E+01, .152698E+00, .216445E+00, .216445E+00,
39960 & .211676E+00, .211694E+00, .211694E+00, .211676E+00, .730631E+01,
39961 & .185666E+00, .252948E+00, .252948E+00, .247925E+00, .247946E+00,
39962 & .247946E+00, .247925E+00, .829017E+01, .222252E+00, .293037E+00,
39963 & .293037E+00, .287752E+00, .287776E+00, .287776E+00, .287752E+00,
39964 & .930850E+01, .262414E+00, .336625E+00, .336625E+00, .331070E+00,
39965 & .331097E+00, .331097E+00, .331070E+00, .103534E+02, .306065E+00,
39966 & .383587E+00, .383587E+00, .377754E+00, .377785E+00, .377785E+00,
39967 & .377754E+00, .114166E+02, .353079E+00, .433760E+00, .433760E+00,
39968 & .427641E+00, .427675E+00, .427675E+00, .427641E+00, .124903E+02,
39969 & .403294E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39970 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39971 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39972 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39973 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39974 & .296507E-01, .296507E-01, .258624E-01, .258624E-01, .258624E-01,
39975 & .258624E-01, .422709E+00,-.173472E-17, .330029E-01, .330029E-01/
39976 DATA (DL(K),K= 171, 255) /
39977 & .289773E-01, .289787E-01, .289787E-01, .289773E-01, .642996E+00,
39978 & .344499E-02, .377610E-01, .377610E-01, .334880E-01, .334910E-01,
39979 & .334910E-01, .334880E-01, .914159E+00, .828363E-02, .441590E-01,
39980 & .441590E-01, .396285E-01, .396333E-01, .396333E-01, .396285E-01,
39981 & .123635E+01, .147501E-01, .523710E-01, .523710E-01, .475730E-01,
39982 & .475798E-01, .475798E-01, .475730E-01, .160820E+01, .230185E-01,
39983 & .625514E-01, .625514E-01, .574758E-01, .574848E-01, .574848E-01,
39984 & .574758E-01, .202705E+01, .332433E-01, .748195E-01, .748195E-01,
39985 & .694563E-01, .694678E-01, .694678E-01, .694563E-01, .248945E+01,
39986 & .455440E-01, .892611E-01, .892611E-01, .836006E-01, .836147E-01,
39987 & .836147E-01, .836006E-01, .299114E+01, .600067E-01, .105928E+00,
39988 & .105928E+00, .999607E-01, .999776E-01, .999776E-01, .999607E-01,
39989 & .352735E+01, .766833E-01, .124839E+00, .124839E+00, .118555E+00,
39990 & .118575E+00, .118575E+00, .118555E+00, .409288E+01, .955921E-01,
39991 & .145978E+00, .145978E+00, .139368E+00, .139391E+00, .139391E+00,
39992 & .139368E+00, .468226E+01, .116719E+00, .169300E+00, .169300E+00,
39993 & .162355E+00, .162382E+00, .162382E+00, .162355E+00, .528987E+01/
39994 DATA (DL(K),K= 256, 340) /
39995 & .140017E+00, .194730E+00, .194730E+00, .187441E+00, .187471E+00,
39996 & .187471E+00, .187441E+00, .591007E+01, .165413E+00, .222167E+00,
39997 & .222167E+00, .214525E+00, .214559E+00, .214559E+00, .214525E+00,
39998 & .653724E+01, .192806E+00, .251486E+00, .251486E+00, .243482E+00,
39999 & .243521E+00, .243521E+00, .243482E+00, .716591E+01, .222070E+00,
40000 & .282539E+00, .282539E+00, .274165E+00, .274208E+00, .274208E+00,
40001 & .274165E+00, .779082E+01, .253058E+00, .315161E+00, .315161E+00,
40002 & .306410E+00, .306458E+00, .306458E+00, .306410E+00, .840695E+01,
40003 & .285608E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40004 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40005 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40006 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40007 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40008 & .279581E-01, .279581E-01, .222797E-01, .222797E-01, .222797E-01,
40009 & .222797E-01, .367732E+00, .867362E-18, .309604E-01, .309604E-01,
40010 & .249419E-01, .249441E-01, .249441E-01, .249419E-01, .552053E+00,
40011 & .296633E-02, .350831E-01, .350831E-01, .287126E-01, .287173E-01/
40012 DATA (DL(K),K= 341, 425) /
40013 & .287173E-01, .287126E-01, .770476E+00, .704001E-02, .404554E-01,
40014 & .404554E-01, .337212E-01, .337286E-01, .337286E-01, .337212E-01,
40015 & .102096E+01, .123504E-01, .471588E-01, .471588E-01, .400495E-01,
40016 & .400599E-01, .400599E-01, .400495E-01, .130079E+01, .189795E-01,
40017 & .552518E-01, .552518E-01, .477564E-01, .477700E-01, .477700E-01,
40018 & .477564E-01, .160637E+01, .269860E-01, .647649E-01, .647649E-01,
40019 & .568725E-01, .568897E-01, .568897E-01, .568725E-01, .193388E+01,
40020 & .364007E-01, .757021E-01, .757021E-01, .674022E-01, .674232E-01,
40021 & .674232E-01, .674022E-01, .227916E+01, .472280E-01, .880430E-01,
40022 & .880430E-01, .793257E-01, .793507E-01, .793507E-01, .793257E-01,
40023 & .263802E+01, .594481E-01, .101745E+00, .101745E+00, .926005E-01,
40024 & .926297E-01, .926297E-01, .926005E-01, .300628E+01, .730184E-01,
40025 & .116745E+00, .116745E+00, .107164E+00, .107198E+00, .107198E+00,
40026 & .107164E+00, .337982E+01, .878765E-01, .132961E+00, .132961E+00,
40027 & .122936E+00, .122974E+00, .122974E+00, .122936E+00, .375469E+01,
40028 & .103942E+00, .150298E+00, .150298E+00, .139820E+00, .139863E+00,
40029 & .139863E+00, .139820E+00, .412714E+01, .121118E+00, .168645E+00/
40030 DATA (DL(K),K= 426, 510) /
40031 & .168645E+00, .157706E+00, .157754E+00, .157754E+00, .157706E+00,
40032 & .449366E+01, .139296E+00, .187883E+00, .187883E+00, .176476E+00,
40033 & .176529E+00, .176529E+00, .176476E+00, .485100E+01, .158356E+00,
40034 & .207882E+00, .207882E+00, .196000E+00, .196059E+00, .196059E+00,
40035 & .196000E+00, .519622E+01, .178170E+00, .228506E+00, .228506E+00,
40036 & .216145E+00, .216209E+00, .216209E+00, .216145E+00, .552665E+01,
40037 & .198603E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40038 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40039 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40040 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40041 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40042 & .275294E-01, .275294E-01, .190245E-01, .190245E-01, .190245E-01,
40043 & .190245E-01, .320228E+00, .000000E+00, .302671E-01, .302671E-01,
40044 & .212851E-01, .212884E-01, .212884E-01, .212851E-01, .470861E+00,
40045 & .255059E-02, .338703E-01, .338703E-01, .243988E-01, .244059E-01,
40046 & .244059E-01, .243988E-01, .642452E+00, .595399E-02, .383922E-01,
40047 & .383922E-01, .284195E-01, .284305E-01, .284305E-01, .284195E-01/
40048 DATA (DL(K),K= 511, 595) /
40049 & .831913E+00, .102638E-01, .438519E-01, .438519E-01, .333669E-01,
40050 & .333821E-01, .333821E-01, .333669E-01, .103618E+01, .155000E-01,
40051 & .502475E-01, .502475E-01, .392399E-01, .392595E-01, .392595E-01,
40052 & .392399E-01, .125172E+01, .216612E-01, .575580E-01, .575580E-01,
40053 & .460181E-01, .460425E-01, .460425E-01, .460181E-01, .147519E+01,
40054 & .287272E-01, .657445E-01, .657445E-01, .536635E-01, .536929E-01,
40055 & .536929E-01, .536635E-01, .170330E+01, .366597E-01, .747539E-01,
40056 & .747539E-01, .621238E-01, .621582E-01, .621582E-01, .621238E-01,
40057 & .193297E+01, .454066E-01, .845205E-01, .845205E-01, .713340E-01,
40058 & .713738E-01, .713738E-01, .713340E-01, .216133E+01, .549027E-01,
40059 & .949687E-01, .949687E-01, .812194E-01, .812646E-01, .812646E-01,
40060 & .812194E-01, .238578E+01, .650733E-01, .106015E+00, .106015E+00,
40061 & .916972E-01, .917480E-01, .917480E-01, .916972E-01, .260395E+01,
40062 & .758355E-01, .117569E+00, .117569E+00, .102678E+00, .102735E+00,
40063 & .102735E+00, .102678E+00, .281373E+01, .871004E-01, .129537E+00,
40064 & .129537E+00, .114070E+00, .114133E+00, .114133E+00, .114070E+00,
40065 & .301327E+01, .987750E-01, .141824E+00, .141824E+00, .125777E+00/
40066 DATA (DL(K),K= 596, 680) /
40067 & .125846E+00, .125846E+00, .125777E+00, .320098E+01, .110764E+00,
40068 & .154331E+00, .154331E+00, .137703E+00, .137778E+00, .137778E+00,
40069 & .137703E+00, .337553E+01, .122970E+00, .166962E+00, .166962E+00,
40070 & .149753E+00, .149833E+00, .149833E+00, .149753E+00, .353582E+01,
40071 & .135299E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40072 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40073 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40074 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40075 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40076 & .286766E-01, .286766E-01, .159579E-01, .159579E-01, .159579E-01,
40077 & .159579E-01, .279430E+00,-.867362E-18, .312327E-01, .312327E-01,
40078 & .178644E-01, .178691E-01, .178691E-01, .178644E-01, .399186E+00,
40079 & .219459E-02, .344289E-01, .344289E-01, .204015E-01, .204111E-01,
40080 & .204111E-01, .204015E-01, .529978E+00, .501953E-02, .382657E-01,
40081 & .382657E-01, .235713E-01, .235860E-01, .235860E-01, .235713E-01,
40082 & .668515E+00, .847682E-02, .427243E-01, .427243E-01, .273559E-01,
40083 & .273758E-01, .273758E-01, .273559E-01, .812075E+00, .125486E-01/
40084 DATA (DL(K),K= 681, 765) /
40085 & .477691E-01, .477691E-01, .317212E-01, .317465E-01, .317465E-01,
40086 & .317212E-01, .957801E+00, .172006E-01, .533547E-01, .533547E-01,
40087 & .366231E-01, .366539E-01, .366539E-01, .366231E-01, .110327E+01,
40088 & .223886E-01, .594259E-01, .594259E-01, .420076E-01, .420441E-01,
40089 & .420441E-01, .420076E-01, .124628E+01, .280584E-01, .659213E-01,
40090 & .659213E-01, .478149E-01, .478570E-01, .478570E-01, .478149E-01,
40091 & .138496E+01, .341502E-01, .727749E-01, .727749E-01, .539803E-01,
40092 & .540280E-01, .540280E-01, .539803E-01, .151767E+01, .405990E-01,
40093 & .799178E-01, .799178E-01, .604361E-01, .604895E-01, .604895E-01,
40094 & .604361E-01, .164304E+01, .473372E-01, .872796E-01, .872796E-01,
40095 & .671134E-01, .671724E-01, .671724E-01, .671134E-01, .175992E+01,
40096 & .542955E-01, .947896E-01, .947896E-01, .739429E-01, .740075E-01,
40097 & .740075E-01, .739429E-01, .186739E+01, .614047E-01, .102378E+00,
40098 & .102378E+00, .808565E-01, .809266E-01, .809266E-01, .808565E-01,
40099 & .196473E+01, .685965E-01, .109978E+00, .109978E+00, .877881E-01,
40100 & .878637E-01, .878637E-01, .877881E-01, .205141E+01, .758045E-01,
40101 & .117525E+00, .117525E+00, .946745E-01, .947553E-01, .947553E-01/
40102 DATA (DL(K),K= 766, 850) /
40103 & .946745E-01, .212709E+01, .829655E-01, .124958E+00, .124958E+00,
40104 & .101456E+00, .101542E+00, .101542E+00, .101456E+00, .219159E+01,
40105 & .900196E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40106 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40107 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40108 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40109 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40110 & .318691E-01, .318691E-01, .129081E-01, .129081E-01, .129081E-01,
40111 & .129081E-01, .244842E+00,-.867362E-18, .343104E-01, .343104E-01,
40112 & .145076E-01, .145124E-01, .145124E-01, .145076E-01, .337040E+00,
40113 & .189443E-02, .371900E-01, .371900E-01, .165461E-01, .165557E-01,
40114 & .165557E-01, .165461E-01, .433081E+00, .422691E-02, .404763E-01,
40115 & .404763E-01, .189941E-01, .190085E-01, .190085E-01, .189941E-01,
40116 & .530109E+00, .696769E-02, .441304E-01, .441304E-01, .218150E-01,
40117 & .218342E-01, .218342E-01, .218150E-01, .626129E+00, .100799E-01,
40118 & .481031E-01, .481031E-01, .249615E-01, .249853E-01, .249853E-01,
40119 & .249615E-01, .719221E+00, .135159E-01, .523426E-01, .523426E-01/
40120 DATA (DL(K),K= 851, 935) /
40121 & .283837E-01, .284122E-01, .284122E-01, .283837E-01, .807951E+00,
40122 & .172259E-01, .567940E-01, .567940E-01, .320288E-01, .320619E-01,
40123 & .320619E-01, .320288E-01, .891154E+00, .211568E-01, .614022E-01,
40124 & .614022E-01, .358436E-01, .358811E-01, .358811E-01, .358436E-01,
40125 & .967928E+00, .252549E-01, .661122E-01, .661122E-01, .397750E-01,
40126 & .398169E-01, .398169E-01, .397750E-01, .103759E+01, .294673E-01,
40127 & .708708E-01, .708708E-01, .437716E-01, .438176E-01, .438176E-01,
40128 & .437716E-01, .109966E+01, .337422E-01, .756269E-01, .756269E-01,
40129 & .477840E-01, .478342E-01, .478342E-01, .477840E-01, .115380E+01,
40130 & .380302E-01, .803322E-01, .803322E-01, .517659E-01, .518200E-01,
40131 & .518200E-01, .517659E-01, .119986E+01, .422846E-01, .849423E-01,
40132 & .849423E-01, .556743E-01, .557322E-01, .557322E-01, .556743E-01,
40133 & .123782E+01, .464624E-01, .894164E-01, .894164E-01, .594701E-01,
40134 & .595315E-01, .595315E-01, .594701E-01, .126777E+01, .505242E-01,
40135 & .937178E-01, .937178E-01, .631181E-01, .631829E-01, .631829E-01,
40136 & .631181E-01, .128993E+01, .544348E-01, .978144E-01, .978144E-01,
40137 & .665876E-01, .666556E-01, .666556E-01, .665876E-01, .130457E+01/
40138 DATA (DL(K),K= 936, 1020) /
40139 & .581632E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40140 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40141 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40142 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40143 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40144 & .377668E-01, .377668E-01, .968304E-02, .968304E-02, .968304E-02,
40145 & .968304E-02, .216392E+00,-.130104E-17, .401066E-01, .401066E-01,
40146 & .110266E-01, .110291E-01, .110291E-01, .110266E-01, .284113E+00,
40147 & .164283E-02, .426983E-01, .426983E-01, .126461E-01, .126510E-01,
40148 & .126510E-01, .126461E-01, .350879E+00, .355790E-02, .454940E-01,
40149 & .454940E-01, .144965E-01, .145039E-01, .145039E-01, .144965E-01,
40150 & .414611E+00, .570002E-02, .484493E-01, .484493E-01, .165364E-01,
40151 & .165462E-01, .165462E-01, .165364E-01, .474149E+00, .802739E-02,
40152 & .515153E-01, .515153E-01, .187191E-01, .187313E-01, .187313E-01,
40153 & .187191E-01, .528511E+00, .104932E-01, .546458E-01, .546458E-01,
40154 & .210009E-01, .210154E-01, .210154E-01, .210009E-01, .577107E+00,
40155 & .130535E-01, .577962E-01, .577962E-01, .233395E-01, .233563E-01/
40156 DATA (DL(K),K= 1021, 1105) /
40157 & .233563E-01, .233395E-01, .619574E+00, .156658E-01, .609249E-01,
40158 & .609249E-01, .256954E-01, .257143E-01, .257143E-01, .256954E-01,
40159 & .655725E+00, .182905E-01, .639938E-01, .639938E-01, .280322E-01,
40160 & .280532E-01, .280532E-01, .280322E-01, .685523E+00, .208909E-01,
40161 & .669681E-01, .669681E-01, .303170E-01, .303399E-01, .303399E-01,
40162 & .303170E-01, .709053E+00, .234341E-01, .698172E-01, .698172E-01,
40163 & .325206E-01, .325454E-01, .325454E-01, .325206E-01, .726501E+00,
40164 & .258907E-01, .725141E-01, .725141E-01, .346176E-01, .346442E-01,
40165 & .346442E-01, .346176E-01, .738139E+00, .282352E-01, .750364E-01,
40166 & .750364E-01, .365866E-01, .366148E-01, .366148E-01, .365866E-01,
40167 & .744304E+00, .304461E-01, .773653E-01, .773653E-01, .384099E-01,
40168 & .384396E-01, .384396E-01, .384099E-01, .745388E+00, .325056E-01,
40169 & .794860E-01, .794860E-01, .400736E-01, .401046E-01, .401046E-01,
40170 & .400736E-01, .741819E+00, .343996E-01, .813873E-01, .813873E-01,
40171 & .415670E-01, .415993E-01, .415993E-01, .415670E-01, .734051E+00,
40172 & .361177E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40173 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40174 DATA (DL(K),K= 1106, 1190) /
40175 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40176 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40177 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40178 & .433773E-01, .433773E-01, .745094E-02, .745094E-02, .745094E-02,
40179 & .745094E-02, .201612E+00,-.130104E-17, .455998E-01, .455998E-01,
40180 & .866239E-02, .866443E-02, .866443E-02, .866239E-02, .255046E+00,
40181 & .149977E-02, .479569E-01, .479569E-01, .100584E-01, .100624E-01,
40182 & .100624E-01, .100584E-01, .305549E+00, .317779E-02, .503976E-01,
40183 & .503976E-01, .115911E-01, .115970E-01, .115970E-01, .115911E-01,
40184 & .351606E+00, .498612E-02, .528804E-01, .528804E-01, .132216E-01,
40185 & .132293E-01, .132293E-01, .132216E-01, .392560E+00, .688553E-02,
40186 & .553621E-01, .553621E-01, .149087E-01, .149181E-01, .149181E-01,
40187 & .149087E-01, .427948E+00, .883486E-02, .578049E-01, .578049E-01,
40188 & .166165E-01, .166276E-01, .166276E-01, .166165E-01, .457612E+00,
40189 & .107980E-01, .601739E-01, .601739E-01, .183120E-01, .183246E-01,
40190 & .183246E-01, .183120E-01, .481565E+00, .127419E-01, .624390E-01,
40191 & .624390E-01, .199661E-01, .199801E-01, .199801E-01, .199661E-01/
40192 DATA (DL(K),K= 1191, 1275) /
40193 & .499943E+00, .146375E-01, .645736E-01, .645736E-01, .215535E-01,
40194 & .215688E-01, .215688E-01, .215535E-01, .512983E+00, .164593E-01,
40195 & .665556E-01, .665556E-01, .230528E-01, .230693E-01, .230693E-01,
40196 & .230528E-01, .520995E+00, .181859E-01, .683669E-01, .683669E-01,
40197 & .244463E-01, .244639E-01, .244639E-01, .244463E-01, .524347E+00,
40198 & .197998E-01, .699932E-01, .699932E-01, .257201E-01, .257387E-01,
40199 & .257387E-01, .257201E-01, .523447E+00, .212869E-01, .714240E-01,
40200 & .714240E-01, .268637E-01, .268832E-01, .268832E-01, .268637E-01,
40201 & .518729E+00, .226367E-01, .726523E-01, .726523E-01, .278697E-01,
40202 & .278900E-01, .278900E-01, .278697E-01, .510641E+00, .238420E-01,
40203 & .736741E-01, .736741E-01, .287338E-01, .287547E-01, .287547E-01,
40204 & .287338E-01, .499630E+00, .248984E-01, .744886E-01, .744886E-01,
40205 & .294542E-01, .294757E-01, .294757E-01, .294542E-01, .486140E+00,
40206 & .258043E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40207 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40208 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40209 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40210 DATA (DL(K),K= 1276, 1360) /
40211 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40212 & .499162E-01, .499162E-01, .534441E-02, .534441E-02, .534441E-02,
40213 & .534441E-02, .191108E+00,-.151788E-17, .519197E-01, .519197E-01,
40214 & .646285E-02, .646402E-02, .646402E-02, .646285E-02, .232539E+00,
40215 & .137669E-02, .539504E-01, .539504E-01, .769150E-02, .769377E-02,
40216 & .769377E-02, .769150E-02, .269907E+00, .285489E-02, .559598E-01,
40217 & .559598E-01, .898389E-02, .898721E-02, .898721E-02, .898389E-02,
40218 & .302186E+00, .438814E-02, .579130E-01, .579130E-01, .103061E-01,
40219 & .103104E-01, .103104E-01, .103061E-01, .329124E+00, .594258E-02,
40220 & .597754E-01, .597754E-01, .116245E-01, .116297E-01, .116297E-01,
40221 & .116245E-01, .350643E+00, .748452E-02, .615191E-01, .615191E-01,
40222 & .129113E-01, .129174E-01, .129174E-01, .129113E-01, .366890E+00,
40223 & .898645E-02, .631204E-01, .631204E-01, .141428E-01, .141497E-01,
40224 & .141497E-01, .141428E-01, .378134E+00, .104247E-01, .645601E-01,
40225 & .645601E-01, .152995E-01, .153071E-01, .153071E-01, .152995E-01,
40226 & .384719E+00, .117798E-01, .658236E-01, .658236E-01, .163657E-01,
40227 & .163739E-01, .163739E-01, .163657E-01, .387045E+00, .130362E-01/
40228 DATA (DL(K),K= 1361, 1445) /
40229 & .669000E-01, .669000E-01, .173294E-01, .173381E-01, .173381E-01,
40230 & .173294E-01, .385547E+00, .141821E-01, .677824E-01, .677824E-01,
40231 & .181820E-01, .181912E-01, .181912E-01, .181820E-01, .380677E+00,
40232 & .152091E-01, .684672E-01, .684672E-01, .189180E-01, .189277E-01,
40233 & .189277E-01, .189180E-01, .372894E+00, .161119E-01, .689539E-01,
40234 & .689539E-01, .195349E-01, .195449E-01, .195449E-01, .195349E-01,
40235 & .362650E+00, .168880E-01, .692447E-01, .692447E-01, .200324E-01,
40236 & .200427E-01, .200427E-01, .200324E-01, .350383E+00, .175374E-01,
40237 & .693442E-01, .693442E-01, .204123E-01, .204229E-01, .204229E-01,
40238 & .204123E-01, .336505E+00, .180622E-01, .692590E-01, .692590E-01,
40239 & .206783E-01, .206891E-01, .206891E-01, .206783E-01, .321403E+00,
40240 & .184661E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40241 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40242 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40243 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40244 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40245 & .554152E-01, .554152E-01, .386683E-02, .386683E-02, .386683E-02/
40246 DATA (DL(K),K= 1446, 1530) /
40247 & .386683E-02, .185844E+00,-.151788E-17, .571372E-01, .571372E-01,
40248 & .493623E-02, .493704E-02, .493704E-02, .493623E-02, .219342E+00,
40249 & .129037E-02, .588098E-01, .588098E-01, .606768E-02, .606924E-02,
40250 & .606924E-02, .606768E-02, .248288E+00, .263296E-02, .603896E-01,
40251 & .603896E-01, .721747E-02, .721973E-02, .721973E-02, .721747E-02,
40252 & .271974E+00, .398431E-02, .618484E-01, .618484E-01, .835658E-02,
40253 & .835949E-02, .835949E-02, .835658E-02, .290397E+00, .531560E-02,
40254 & .631600E-01, .631600E-01, .945726E-02, .946074E-02, .946074E-02,
40255 & .945726E-02, .303702E+00, .659930E-02, .643051E-01, .643051E-01,
40256 & .104983E-01, .105023E-01, .105023E-01, .104983E-01, .312209E+00,
40257 & .781443E-02, .652691E-01, .652691E-01, .114624E-01, .114669E-01,
40258 & .114669E-01, .114624E-01, .316328E+00, .894407E-02, .660416E-01,
40259 & .660416E-01, .123367E-01, .123416E-01, .123416E-01, .123367E-01,
40260 & .316509E+00, .997546E-02, .666169E-01, .666169E-01, .131119E-01,
40261 & .131171E-01, .131171E-01, .131119E-01, .313229E+00, .108996E-01,
40262 & .669925E-01, .669925E-01, .137818E-01, .137874E-01, .137874E-01,
40263 & .137818E-01, .306974E+00, .117107E-01, .671695E-01, .671695E-01/
40264 DATA (DL(K),K= 1531, 1615) /
40265 & .143437E-01, .143495E-01, .143495E-01, .143437E-01, .298224E+00,
40266 & .124061E-01, .671517E-01, .671517E-01, .147970E-01, .148031E-01,
40267 & .148031E-01, .147970E-01, .287441E+00, .129858E-01, .669454E-01,
40268 & .669454E-01, .151437E-01, .151499E-01, .151499E-01, .151437E-01,
40269 & .275064E+00, .134517E-01, .665590E-01, .665590E-01, .153872E-01,
40270 & .153935E-01, .153935E-01, .153872E-01, .261497E+00, .138078E-01,
40271 & .660023E-01, .660023E-01, .155327E-01, .155391E-01, .155391E-01,
40272 & .155327E-01, .247105E+00, .140595E-01, .652865E-01, .652865E-01,
40273 & .155864E-01, .155929E-01, .155929E-01, .155864E-01, .232218E+00,
40274 & .142131E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40275 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40276 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40277 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40278 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40279 & .601098E-01, .601098E-01, .278641E-02, .278641E-02, .278641E-02,
40280 & .278641E-02, .183460E+00, .130104E-17, .614949E-01, .614949E-01,
40281 & .382710E-02, .382771E-02, .382771E-02, .382710E-02, .211150E+00/
40282 DATA (DL(K),K= 1616, 1700) /
40283 & .122320E-02, .627722E-01, .627722E-01, .489465E-02, .489580E-02,
40284 & .489580E-02, .489465E-02, .234040E+00, .246333E-02, .639042E-01,
40285 & .639042E-01, .594825E-02, .594990E-02, .594990E-02, .594825E-02,
40286 & .251649E+00, .367998E-02, .648697E-01, .648697E-01, .696315E-02,
40287 & .696526E-02, .696526E-02, .696315E-02, .264143E+00, .484875E-02,
40288 & .656502E-01, .656502E-01, .791658E-02, .791907E-02, .791907E-02,
40289 & .791658E-02, .271822E+00, .594722E-02, .662343E-01, .662343E-01,
40290 & .879236E-02, .879520E-02, .879520E-02, .879236E-02, .275124E+00,
40291 & .695957E-02, .666152E-01, .666152E-01, .957846E-02, .958160E-02,
40292 & .958160E-02, .957846E-02, .274549E+00, .787413E-02, .667905E-01,
40293 & .667905E-01, .102668E-01, .102702E-01, .102702E-01, .102668E-01,
40294 & .270615E+00, .868318E-02, .667616E-01, .667616E-01, .108528E-01,
40295 & .108564E-01, .108564E-01, .108528E-01, .263847E+00, .938250E-02,
40296 & .665331E-01, .665331E-01, .113349E-01, .113387E-01, .113387E-01,
40297 & .113349E-01, .254756E+00, .997082E-02, .661123E-01, .661123E-01,
40298 & .117139E-01, .117179E-01, .117179E-01, .117139E-01, .243828E+00,
40299 & .104494E-01, .655090E-01, .655090E-01, .119931E-01, .119971E-01/
40300 DATA (DL(K),K= 1701, 1785) /
40301 & .119971E-01, .119931E-01, .231518E+00, .108217E-01, .647345E-01,
40302 & .647345E-01, .121770E-01, .121811E-01, .121811E-01, .121770E-01,
40303 & .218237E+00, .110927E-01, .638017E-01, .638017E-01, .122717E-01,
40304 & .122759E-01, .122759E-01, .122717E-01, .204353E+00, .112689E-01,
40305 & .627241E-01, .627241E-01, .122842E-01, .122884E-01, .122884E-01,
40306 & .122842E-01, .190187E+00, .113573E-01, .615161E-01, .615161E-01,
40307 & .122221E-01, .122262E-01, .122262E-01, .122221E-01, .176012E+00,
40308 & .113659E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40309 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40310 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40311 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40312 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40313 & .641221E-01, .641221E-01, .198544E-02, .198544E-02, .198544E-02,
40314 & .198544E-02, .183018E+00, .184314E-17, .651208E-01, .651208E-01,
40315 & .300778E-02, .300823E-02, .300823E-02, .300778E-02, .206180E+00,
40316 & .116844E-02, .659664E-01, .659664E-01, .402903E-02, .402989E-02,
40317 & .402989E-02, .402903E-02, .224390E+00, .232648E-02, .666277E-01/
40318 DATA (DL(K),K= 1786, 1870) /
40319 & .666277E-01, .501117E-02, .501238E-02, .501238E-02, .501117E-02,
40320 & .237332E+00, .343657E-02, .670904E-01, .670904E-01, .593321E-02,
40321 & .593473E-02, .593473E-02, .593321E-02, .245310E+00, .447818E-02,
40322 & .673435E-01, .673435E-01, .677663E-02, .677843E-02, .677843E-02,
40323 & .677663E-02, .248743E+00, .543320E-02, .673832E-01, .673832E-01,
40324 & .752958E-02, .753161E-02, .753161E-02, .752958E-02, .248162E+00,
40325 & .629021E-02, .672099E-01, .672099E-01, .818432E-02, .818655E-02,
40326 & .818655E-02, .818432E-02, .244140E+00, .704188E-02, .668281E-01,
40327 & .668281E-01, .873688E-02, .873927E-02, .873927E-02, .873688E-02,
40328 & .237247E+00, .768463E-02, .662457E-01, .662457E-01, .918650E-02,
40329 & .918903E-02, .918903E-02, .918650E-02, .228043E+00, .821808E-02,
40330 & .654734E-01, .654734E-01, .953502E-02, .953766E-02, .953766E-02,
40331 & .953502E-02, .217054E+00, .864446E-02, .645238E-01, .645238E-01,
40332 & .978645E-02, .978915E-02, .978915E-02, .978645E-02, .204766E+00,
40333 & .896811E-02, .634114E-01, .634114E-01, .994639E-02, .994915E-02,
40334 & .994915E-02, .994639E-02, .191614E+00, .919500E-02, .621515E-01,
40335 & .621515E-01, .100217E-01, .100245E-01, .100245E-01, .100217E-01/
40336 DATA (DL(K),K= 1871, 1955) /
40337 & .177983E+00, .933229E-02, .607602E-01, .607602E-01, .100200E-01,
40338 & .100228E-01, .100228E-01, .100200E-01, .164201E+00, .938793E-02,
40339 & .592539E-01, .592539E-01, .994938E-02, .995217E-02, .995217E-02,
40340 & .994938E-02, .150544E+00, .937032E-02, .576488E-01, .576488E-01,
40341 & .981814E-02, .982091E-02, .982091E-02, .981814E-02, .137234E+00,
40342 & .928803E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40343 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40344 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40345 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40346 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40347 & .675167E-01, .675167E-01, .139130E-02, .139130E-02, .139130E-02,
40348 & .139130E-02, .184090E+00, .113841E-17, .680840E-01, .680840E-01,
40349 & .240061E-02, .240097E-02, .240097E-02, .240061E-02, .203559E+00,
40350 & .112278E-02, .684634E-01, .684634E-01, .338513E-02, .338580E-02,
40351 & .338580E-02, .338513E-02, .217944E+00, .221249E-02, .686304E-01,
40352 & .686304E-01, .430938E-02, .431032E-02, .431032E-02, .430938E-02,
40353 & .227068E+00, .323420E-02, .685779E-01, .685779E-01, .515589E-02/
40354 DATA (DL(K),K= 1956, 2040) /
40355 & .515707E-02, .515707E-02, .515589E-02, .231353E+00, .417091E-02,
40356 & .683023E-01, .683023E-01, .591002E-02, .591140E-02, .591140E-02,
40357 & .591002E-02, .231327E+00, .500843E-02, .678068E-01, .678068E-01,
40358 & .656383E-02, .656537E-02, .656537E-02, .656383E-02, .227606E+00,
40359 & .573925E-02, .670989E-01, .670989E-01, .711344E-02, .711513E-02,
40360 & .711513E-02, .711344E-02, .220833E+00, .635992E-02, .661895E-01,
40361 & .661895E-01, .755852E-02, .756031E-02, .756031E-02, .755852E-02,
40362 & .211624E+00, .687048E-02, .650923E-01, .650923E-01, .790162E-02,
40363 & .790350E-02, .790350E-02, .790162E-02, .200567E+00, .727387E-02,
40364 & .638232E-01, .638232E-01, .814753E-02, .814946E-02, .814946E-02,
40365 & .814753E-02, .188197E+00, .757524E-02, .623994E-01, .623994E-01,
40366 & .830271E-02, .830469E-02, .830469E-02, .830271E-02, .174994E+00,
40367 & .778139E-02, .608390E-01, .608390E-01, .837482E-02, .837682E-02,
40368 & .837682E-02, .837482E-02, .161373E+00, .790029E-02, .591605E-01,
40369 & .591605E-01, .837226E-02, .837426E-02, .837426E-02, .837226E-02,
40370 & .147685E+00, .794065E-02, .573824E-01, .573824E-01, .830376E-02,
40371 & .830575E-02, .830575E-02, .830376E-02, .134218E+00, .791148E-02/
40372 DATA (DL(K),K= 2041, 2125) /
40373 & .555224E-01, .555224E-01, .817811E-02, .818008E-02, .818008E-02,
40374 & .817811E-02, .121200E+00, .782185E-02, .535980E-01, .535980E-01,
40375 & .800390E-02, .800584E-02, .800584E-02, .800390E-02, .108803E+00,
40376 & .768059E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40377 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40378 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40379 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40380 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40381 & .703249E-01, .703249E-01, .953926E-03, .953926E-03, .953926E-03,
40382 & .953926E-03, .186497E+00, .108420E-18, .704188E-01, .704188E-01,
40383 & .195267E-02, .195297E-02, .195297E-02, .195267E-02, .202831E+00,
40384 & .108414E-02, .702995E-01, .702995E-01, .290528E-02, .290582E-02,
40385 & .290582E-02, .290528E-02, .213933E+00, .211514E-02, .699499E-01,
40386 & .699499E-01, .377873E-02, .377950E-02, .377950E-02, .377873E-02,
40387 & .219748E+00, .306054E-02, .693699E-01, .693699E-01, .455903E-02,
40388 & .455997E-02, .455997E-02, .455903E-02, .220821E+00, .390679E-02,
40389 & .685634E-01, .685634E-01, .523531E-02, .523640E-02, .523640E-02/
40390 DATA (DL(K),K= 2126, 2210) /
40391 & .523531E-02, .217787E+00, .464347E-02, .675406E-01, .675406E-01,
40392 & .580340E-02, .580462E-02, .580462E-02, .580340E-02, .211353E+00,
40393 & .526681E-02, .663155E-01, .663155E-01, .626315E-02, .626446E-02,
40394 & .626446E-02, .626315E-02, .202230E+00, .577705E-02, .649052E-01,
40395 & .649052E-01, .661759E-02, .661897E-02, .661897E-02, .661759E-02,
40396 & .191081E+00, .617758E-02, .633285E-01, .633285E-01, .687230E-02,
40397 & .687373E-02, .687373E-02, .687230E-02, .178518E+00, .647434E-02,
40398 & .616058E-01, .616058E-01, .703464E-02, .703611E-02, .703611E-02,
40399 & .703464E-02, .165082E+00, .667499E-02, .597580E-01, .597580E-01,
40400 & .711320E-02, .711468E-02, .711468E-02, .711320E-02, .151241E+00,
40401 & .678842E-02, .578059E-01, .578059E-01, .711723E-02, .711872E-02,
40402 & .711872E-02, .711723E-02, .137382E+00, .682417E-02, .557702E-01,
40403 & .557702E-01, .705628E-02, .705776E-02, .705776E-02, .705628E-02,
40404 & .123821E+00, .679205E-02, .536704E-01, .536704E-01, .693979E-02,
40405 & .694125E-02, .694125E-02, .693979E-02, .110798E+00, .670173E-02,
40406 & .515252E-01, .515252E-01, .677689E-02, .677832E-02, .677832E-02,
40407 & .677689E-02, .984933E-01, .656256E-02, .493519E-01, .493519E-01/
40408 DATA (DL(K),K= 2211, 2295) /
40409 & .657614E-02, .657753E-02, .657753E-02, .657614E-02, .870270E-01,
40410 & .638332E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40411 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40412 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40413 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40414 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40415 & .725555E-01, .725555E-01, .636424E-03, .636424E-03, .636424E-03,
40416 & .636424E-03, .190200E+00,-.271051E-17, .721364E-01, .721364E-01,
40417 & .162522E-02, .162546E-02, .162546E-02, .162522E-02, .203770E+00,
40418 & .105090E-02, .714881E-01, .714881E-01, .254763E-02, .254807E-02,
40419 & .254807E-02, .254763E-02, .211914E+00, .202976E-02, .706012E-01,
40420 & .706012E-01, .337323E-02, .337384E-02, .337384E-02, .337323E-02,
40421 & .214704E+00, .290668E-02, .694832E-01, .694832E-01, .409164E-02,
40422 & .409240E-02, .409240E-02, .409164E-02, .212817E+00, .367169E-02,
40423 & .681454E-01, .681454E-01, .469593E-02, .469679E-02, .469679E-02,
40424 & .469593E-02, .207013E+00, .431823E-02, .666048E-01, .666048E-01,
40425 & .518578E-02, .518673E-02, .518673E-02, .518578E-02, .198095E+00/
40426 DATA (DL(K),K= 2296, 2380) /
40427 & .484637E-02, .648819E-01, .648819E-01, .556473E-02, .556575E-02,
40428 & .556575E-02, .556473E-02, .186850E+00, .525997E-02, .629989E-01,
40429 & .629989E-01, .583908E-02, .584014E-02, .584014E-02, .583908E-02,
40430 & .173986E+00, .556566E-02, .609795E-01, .609795E-01, .601725E-02,
40431 & .601834E-02, .601834E-02, .601725E-02, .160140E+00, .577215E-02,
40432 & .588474E-01, .588474E-01, .610889E-02, .611000E-02, .611000E-02,
40433 & .610889E-02, .145850E+00, .588934E-02, .566261E-01, .566261E-01,
40434 & .612435E-02, .612547E-02, .612547E-02, .612435E-02, .131564E+00,
40435 & .592785E-02, .543385E-01, .543385E-01, .607415E-02, .607526E-02,
40436 & .607526E-02, .607415E-02, .117636E+00, .589841E-02, .520060E-01,
40437 & .520060E-01, .596861E-02, .596970E-02, .596970E-02, .596861E-02,
40438 & .104336E+00, .581156E-02, .496485E-01, .496485E-01, .581753E-02,
40439 & .581860E-02, .581860E-02, .581753E-02, .918563E-01, .567728E-02,
40440 & .472842E-01, .472842E-01, .563002E-02, .563105E-02, .563105E-02,
40441 & .563002E-02, .803205E-01, .550487E-02, .449295E-01, .449295E-01,
40442 & .541435E-02, .541535E-02, .541535E-02, .541435E-02, .697975E-01,
40443 & .530276E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40444 DATA (DL(K),K= 2381, 2465) /
40445 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40446 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40447 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40448 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40449 & .742000E-01, .742000E-01, .410482E-03, .410482E-03, .410482E-03,
40450 & .410482E-03, .195273E+00,-.143657E-17, .732296E-01, .732296E-01,
40451 & .138854E-02, .138874E-02, .138874E-02, .138854E-02, .206298E+00,
40452 & .102151E-02, .720241E-01, .720241E-01, .228017E-02, .228054E-02,
40453 & .228054E-02, .228017E-02, .211639E+00, .195225E-02, .705820E-01,
40454 & .705820E-01, .305794E-02, .305844E-02, .305844E-02, .305794E-02,
40455 & .211509E+00, .276522E-02, .689187E-01, .689187E-01, .371549E-02,
40456 & .371609E-02, .371609E-02, .371549E-02, .206745E+00, .345441E-02,
40457 & .670527E-01, .670527E-01, .425016E-02, .425084E-02, .425084E-02,
40458 & .425016E-02, .198254E+00, .401749E-02, .650080E-01, .650080E-01,
40459 & .466572E-02, .466647E-02, .466647E-02, .466572E-02, .186950E+00,
40460 & .445856E-02, .628107E-01, .628107E-01, .496948E-02, .497027E-02,
40461 & .497027E-02, .496948E-02, .173701E+00, .478517E-02, .604878E-01/
40462 DATA (DL(K),K= 2466, 2550) /
40463 & .604878E-01, .517094E-02, .517175E-02, .517175E-02, .517094E-02,
40464 & .159263E+00, .500709E-02, .580665E-01, .580665E-01, .528116E-02,
40465 & .528199E-02, .528199E-02, .528116E-02, .144287E+00, .513562E-02,
40466 & .555730E-01, .555730E-01, .531181E-02, .531265E-02, .531265E-02,
40467 & .531181E-02, .129304E+00, .518264E-02, .530325E-01, .530325E-01,
40468 & .527468E-02, .527550E-02, .527550E-02, .527468E-02, .114731E+00,
40469 & .516012E-02, .504682E-01, .504682E-01, .518116E-02, .518198E-02,
40470 & .518198E-02, .518116E-02, .100877E+00, .507964E-02, .479014E-01,
40471 & .479014E-01, .504198E-02, .504278E-02, .504278E-02, .504198E-02,
40472 & .879578E-01, .495209E-02, .453511E-01, .453511E-01, .486695E-02,
40473 & .486772E-02, .486772E-02, .486695E-02, .761077E-01, .478741E-02,
40474 & .428340E-01, .428340E-01, .466486E-02, .466560E-02, .466560E-02,
40475 & .466486E-02, .653932E-01, .459453E-02, .403645E-01, .403645E-01,
40476 & .444342E-02, .444413E-02, .444413E-02, .444342E-02, .558281E-01,
40477 & .438128E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40478 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40479 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40480 DATA (DL(K),K= 2551, 2635) /
40481 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40482 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40483 & .752337E-01, .752337E-01, .253875E-03, .253875E-03, .253875E-03,
40484 & .253875E-03, .201902E+00,-.159920E-17, .736752E-01, .736752E-01,
40485 & .121909E-02, .121925E-02, .121925E-02, .121909E-02, .210465E+00,
40486 & .994282E-03, .718865E-01, .718865E-01, .207747E-02, .207776E-02,
40487 & .207776E-02, .207747E-02, .212997E+00, .187854E-02, .698746E-01,
40488 & .698746E-01, .280521E-02, .280560E-02, .280560E-02, .280521E-02,
40489 & .209895E+00, .262933E-02, .676629E-01, .676629E-01, .340063E-02,
40490 & .340109E-02, .340109E-02, .340063E-02, .202191E+00, .324527E-02,
40491 & .652775E-01, .652775E-01, .386588E-02, .386641E-02, .386641E-02,
40492 & .386588E-02, .190971E+00, .372876E-02, .627483E-01, .627483E-01,
40493 & .420910E-02, .420967E-02, .420967E-02, .420910E-02, .177278E+00,
40494 & .408818E-02, .601066E-01, .601066E-01, .444148E-02, .444208E-02,
40495 & .444208E-02, .444148E-02, .162071E+00, .433493E-02, .573831E-01,
40496 & .573831E-01, .457564E-02, .457625E-02, .457625E-02, .457564E-02,
40497 & .146148E+00, .448183E-02, .546072E-01, .546072E-01, .462506E-02/
40498 DATA (DL(K),K= 2636, 2720) /
40499 & .462567E-02, .462567E-02, .462506E-02, .130166E+00, .454252E-02,
40500 & .518065E-01, .518065E-01, .460307E-02, .460368E-02, .460368E-02,
40501 & .460307E-02, .114632E+00, .453052E-02, .490062E-01, .490062E-01,
40502 & .452252E-02, .452312E-02, .452312E-02, .452252E-02, .999175E-01,
40503 & .445880E-02, .462287E-01, .462287E-01, .439529E-02, .439588E-02,
40504 & .439588E-02, .439529E-02, .862750E-01, .433936E-02, .434937E-01,
40505 & .434937E-01, .423211E-02, .423268E-02, .423268E-02, .423211E-02,
40506 & .738542E-01, .418306E-02, .408180E-01, .408180E-01, .404245E-02,
40507 & .404299E-02, .404299E-02, .404245E-02, .627228E-01, .399946E-02,
40508 & .382157E-01, .382157E-01, .383446E-02, .383498E-02, .383498E-02,
40509 & .383446E-02, .528847E-01, .379682E-02, .356980E-01, .356980E-01,
40510 & .361508E-02, .361557E-02, .361557E-02, .361508E-02, .442963E-01,
40511 & .358213E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40512 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40513 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40514 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40515 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40516 DATA (DL(K),K= 2721, 2805) /
40517 & .756149E-01, .756149E-01, .148956E-03, .148956E-03, .148956E-03,
40518 & .148956E-03, .210410E+00,-.149078E-18, .734321E-01, .734321E-01,
40519 & .109779E-02, .109791E-02, .109791E-02, .109779E-02, .216444E+00,
40520 & .967243E-03, .710369E-01, .710369E-01, .191860E-02, .191882E-02,
40521 & .191882E-02, .191860E-02, .215992E+00, .180426E-02, .684452E-01,
40522 & .684452E-01, .259230E-02, .259259E-02, .259259E-02, .259230E-02,
40523 & .209697E+00, .249224E-02, .656884E-01, .656884E-01, .312270E-02,
40524 & .312305E-02, .312305E-02, .312270E-02, .198844E+00, .303522E-02,
40525 & .627994E-01, .627994E-01, .351747E-02, .351786E-02, .351786E-02,
40526 & .351747E-02, .184740E+00, .344105E-02, .598138E-01, .598138E-01,
40527 & .378940E-02, .378981E-02, .378981E-02, .378940E-02, .168578E+00,
40528 & .372269E-02, .567666E-01, .567666E-01, .395362E-02, .395405E-02,
40529 & .395405E-02, .395362E-02, .151409E+00, .389544E-02, .536907E-01,
40530 & .536907E-01, .402569E-02, .402613E-02, .402613E-02, .402569E-02,
40531 & .134065E+00, .397499E-02, .506163E-01, .506163E-01, .402117E-02,
40532 & .402161E-02, .402161E-02, .402117E-02, .117191E+00, .397702E-02,
40533 & .475706E-01, .475706E-01, .395467E-02, .395511E-02, .395511E-02/
40534 DATA (DL(K),K= 2806, 2890) /
40535 & .395467E-02, .101250E+00, .391626E-02, .445771E-01, .445771E-01,
40536 & .383961E-02, .384003E-02, .384003E-02, .383961E-02, .865500E-01,
40537 & .380621E-02, .416559E-01, .416559E-01, .368789E-02, .368830E-02,
40538 & .368830E-02, .368789E-02, .732657E-01, .365888E-02, .388235E-01,
40539 & .388235E-01, .350985E-02, .351025E-02, .351025E-02, .350985E-02,
40540 & .614686E-01, .348466E-02, .360931E-01, .360931E-01, .331425E-02,
40541 & .331462E-02, .331462E-02, .331425E-02, .511511E-01, .329240E-02,
40542 & .334751E-01, .334751E-01, .310835E-02, .310870E-02, .310870E-02,
40543 & .310835E-02, .422485E-01, .308941E-02, .309768E-01, .309768E-01,
40544 & .289805E-02, .289838E-02, .289838E-02, .289805E-02, .346590E-01,
40545 & .288164E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40546 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40547 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40548 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40549 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40550 & .752796E-01, .752796E-01, .816906E-04, .816906E-04, .816906E-04,
40551 & .816906E-04, .221322E+00, .298156E-18, .724376E-01, .724376E-01/
40552 DATA (DL(K),K= 2891, 2975) /
40553 & .100884E-02, .100894E-02, .100894E-02, .100884E-02, .224569E+00,
40554 & .938046E-03, .694166E-01, .694166E-01, .178592E-02, .178609E-02,
40555 & .178609E-02, .178592E-02, .220745E+00, .172460E-02, .662414E-01,
40556 & .662414E-01, .240001E-02, .240024E-02, .240024E-02, .240001E-02,
40557 & .210839E+00, .234694E-02, .629511E-01, .629511E-01, .286144E-02,
40558 & .286171E-02, .286171E-02, .286144E-02, .196463E+00, .281556E-02,
40559 & .595849E-01, .595849E-01, .318412E-02, .318441E-02, .318441E-02,
40560 & .318412E-02, .179204E+00, .314448E-02, .561822E-01, .561822E-01,
40561 & .338573E-02, .338605E-02, .338605E-02, .338573E-02, .160420E+00,
40562 & .335151E-02, .527801E-01, .527801E-01, .348530E-02, .348562E-02,
40563 & .348562E-02, .348530E-02, .141254E+00, .345578E-02, .494117E-01,
40564 & .494117E-01, .350098E-02, .350131E-02, .350131E-02, .350098E-02,
40565 & .122547E+00, .347555E-02, .461061E-01, .461061E-01, .344994E-02,
40566 & .345026E-02, .345026E-02, .344994E-02, .104908E+00, .342804E-02,
40567 & .428876E-01, .428876E-01, .334753E-02, .334784E-02, .334784E-02,
40568 & .334753E-02, .887264E-01, .332868E-02, .397764E-01, .397764E-01,
40569 & .320718E-02, .320748E-02, .320748E-02, .320718E-02, .742160E-01/
40570 DATA (DL(K),K= 2976, 3060) /
40571 & .319097E-02, .367882E-01, .367882E-01, .304033E-02, .304062E-02,
40572 & .304062E-02, .304033E-02, .614556E-01, .302641E-02, .339348E-01,
40573 & .339348E-01, .285650E-02, .285677E-02, .285677E-02, .285650E-02,
40574 & .504214E-01, .284454E-02, .312247E-01, .312247E-01, .266337E-02,
40575 & .266363E-02, .266363E-02, .266337E-02, .410205E-01, .265311E-02,
40576 & .286629E-01, .286629E-01, .246705E-02, .246730E-02, .246730E-02,
40577 & .246705E-02, .331166E-01, .245826E-02, .262521E-01, .262521E-01,
40578 & .227226E-02, .227248E-02, .227248E-02, .227226E-02, .265498E-01,
40579 & .226473E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40580 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40581 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40582 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40583 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40584 & .741335E-01, .741335E-01, .409835E-04, .409835E-04, .409835E-04,
40585 & .409835E-04, .235495E+00,-.158395E-17, .705990E-01, .705990E-01,
40586 & .938808E-03, .938883E-03, .938883E-03, .938808E-03, .235413E+00,
40587 & .903728E-03, .669383E-01, .669383E-01, .166382E-02, .166395E-02/
40588 DATA (DL(K),K= 3061, 3145) /
40589 & .166395E-02, .166382E-02, .227523E+00, .163381E-02, .631853E-01,
40590 & .631853E-01, .221128E-02, .221145E-02, .221145E-02, .221128E-02,
40591 & .213316E+00, .218562E-02, .593855E-01, .593855E-01, .259911E-02,
40592 & .259931E-02, .259931E-02, .259911E-02, .194833E+00, .257720E-02,
40593 & .555825E-01, .555825E-01, .284819E-02, .284841E-02, .284841E-02,
40594 & .284819E-02, .174012E+00, .282950E-02, .518174E-01, .518174E-01,
40595 & .298117E-02, .298140E-02, .298140E-02, .298117E-02, .152385E+00,
40596 & .296523E-02, .481268E-01, .481268E-01, .302067E-02, .302090E-02,
40597 & .302090E-02, .302067E-02, .131168E+00, .300708E-02, .445413E-01,
40598 & .445413E-01, .298689E-02, .298712E-02, .298712E-02, .298689E-02,
40599 & .111177E+00, .297532E-02, .410859E-01, .410859E-01, .289793E-02,
40600 & .289815E-02, .289815E-02, .289793E-02, .929352E-01, .288809E-02,
40601 & .377798E-01, .377798E-01, .276920E-02, .276941E-02, .276941E-02,
40602 & .276920E-02, .767178E-01, .276084E-02, .346372E-01, .346372E-01,
40603 & .261353E-02, .261373E-02, .261373E-02, .261353E-02, .626102E-01,
40604 & .260643E-02, .316676E-01, .316676E-01, .244134E-02, .244154E-02,
40605 & .244154E-02, .244134E-02, .505665E-01, .243531E-02, .288765E-01/
40606 DATA (DL(K),K= 3146, 3230) /
40607 & .288765E-01, .226087E-02, .226105E-02, .226105E-02, .226087E-02,
40608 & .404527E-01, .225576E-02, .262660E-01, .262660E-01, .207845E-02,
40609 & .207862E-02, .207862E-02, .207845E-02, .320820E-01, .207412E-02,
40610 & .238351E-01, .238351E-01, .189881E-02, .189897E-02, .189897E-02,
40611 & .189881E-02, .252422E-01, .189514E-02, .215808E-01, .215808E-01,
40612 & .172536E-02, .172551E-02, .172551E-02, .172536E-02, .197186E-01,
40613 & .172225E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40614 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40615 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40616 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40617 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40618 & .720339E-01, .720339E-01, .181946E-04, .181946E-04, .181946E-04,
40619 & .181946E-04, .254393E+00, .469256E-18, .677768E-01, .677768E-01,
40620 & .875835E-03, .875888E-03, .875888E-03, .875835E-03, .249966E+00,
40621 & .860480E-03, .634725E-01, .634725E-01, .153792E-02, .153801E-02,
40622 & .153801E-02, .153792E-02, .236824E+00, .152496E-02, .591619E-01,
40623 & .591619E-01, .201036E-02, .201048E-02, .201048E-02, .201036E-02/
40624 DATA (DL(K),K= 3231, 3315) /
40625 & .217211E+00, .199944E-02, .548948E-01, .548948E-01, .231978E-02,
40626 & .231992E-02, .231992E-02, .231978E-02, .193739E+00, .231058E-02,
40627 & .507162E-01, .507162E-01, .249460E-02, .249475E-02, .249475E-02,
40628 & .249460E-02, .168773E+00, .248686E-02, .466653E-01, .466653E-01,
40629 & .256217E-02, .256232E-02, .256232E-02, .256217E-02, .144012E+00,
40630 & .255566E-02, .427744E-01, .427744E-01, .254804E-02, .254820E-02,
40631 & .254820E-02, .254804E-02, .120695E+00, .254258E-02, .390676E-01,
40632 & .390676E-01, .247365E-02, .247380E-02, .247380E-02, .247365E-02,
40633 & .995452E-01, .246906E-02, .355626E-01, .355626E-01, .235710E-02,
40634 & .235725E-02, .235725E-02, .235710E-02, .809281E-01, .235325E-02,
40635 & .322703E-01, .322703E-01, .221303E-02, .221317E-02, .221317E-02,
40636 & .221303E-02, .649429E-01, .220980E-02, .291963E-01, .291963E-01,
40637 & .205294E-02, .205307E-02, .205307E-02, .205294E-02, .515039E-01,
40638 & .205024E-02, .263419E-01, .263419E-01, .188569E-02, .188581E-02,
40639 & .188581E-02, .188569E-02, .404102E-01, .188343E-02, .237044E-01,
40640 & .237044E-01, .171783E-02, .171795E-02, .171795E-02, .171783E-02,
40641 & .313959E-01, .171594E-02, .212782E-01, .212782E-01, .155409E-02/
40642 DATA (DL(K),K= 3316, 3400) /
40643 & .155419E-02, .155419E-02, .155409E-02, .241750E-01, .155251E-02,
40644 & .190555E-01, .190555E-01, .139767E-02, .139777E-02, .139777E-02,
40645 & .139767E-02, .184646E-01, .139635E-02, .170270E-01, .170270E-01,
40646 & .125065E-02, .125074E-02, .125074E-02, .125065E-02, .139996E-01,
40647 & .124955E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40648 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40649 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40650 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40651 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40652 & .687547E-01, .687547E-01, .676181E-05, .676181E-05, .676181E-05,
40653 & .676181E-05, .280728E+00,-.145838E-17, .637529E-01, .637529E-01,
40654 & .808781E-03, .808818E-03, .808818E-03, .808781E-03, .270033E+00,
40655 & .803169E-03, .588180E-01, .588180E-01, .139388E-02, .139394E-02,
40656 & .139394E-02, .139388E-02, .249568E+00, .138922E-02, .539945E-01,
40657 & .539945E-01, .178168E-02, .178176E-02, .178176E-02, .178168E-02,
40658 & .222743E+00, .177782E-02, .493317E-01, .493317E-01, .200838E-02,
40659 & .200848E-02, .200848E-02, .200838E-02, .192919E+00, .200519E-02/
40660 DATA (DL(K),K= 3401, 3485) /
40661 & .448709E-01, .448709E-01, .211009E-02, .211019E-02, .211019E-02,
40662 & .211009E-02, .162975E+00, .210745E-02, .406433E-01, .406433E-01,
40663 & .211805E-02, .211815E-02, .211815E-02, .211805E-02, .134716E+00,
40664 & .211586E-02, .366716E-01, .366716E-01, .205957E-02, .205968E-02,
40665 & .205968E-02, .205957E-02, .109289E+00, .205776E-02, .329687E-01,
40666 & .329687E-01, .195606E-02, .195616E-02, .195616E-02, .195606E-02,
40667 & .871955E-01, .195457E-02, .295400E-01, .295400E-01, .182447E-02,
40668 & .182456E-02, .182456E-02, .182447E-02, .685399E-01, .182323E-02,
40669 & .263849E-01, .263849E-01, .167765E-02, .167774E-02, .167774E-02,
40670 & .167765E-02, .531615E-01, .167663E-02, .234975E-01, .234975E-01,
40671 & .152505E-02, .152514E-02, .152514E-02, .152505E-02, .407334E-01,
40672 & .152421E-02, .208683E-01, .208683E-01, .137342E-02, .137350E-02,
40673 & .137350E-02, .137342E-02, .308674E-01, .137273E-02, .184852E-01,
40674 & .184852E-01, .122732E-02, .122739E-02, .122739E-02, .122732E-02,
40675 & .231578E-01, .122675E-02, .163340E-01, .163340E-01, .108968E-02,
40676 & .108975E-02, .108975E-02, .108968E-02, .172149E-01, .108921E-02,
40677 & .143996E-01, .143996E-01, .962198E-03, .962260E-03, .962260E-03/
40678 DATA (DL(K),K= 3486, 3570) /
40679 & .962198E-03, .126908E-01, .961815E-03, .126661E-01, .126661E-01,
40680 & .845675E-03, .845732E-03, .845732E-03, .845675E-03, .928555E-02,
40681 & .845361E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40682 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40683 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40684 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40685 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40686 & .639050E-01, .639050E-01, .189600E-05, .189600E-05, .189600E-05,
40687 & .189600E-05, .320203E+00, .545701E-18, .581555E-01, .581555E-01,
40688 & .725861E-03, .725886E-03, .725886E-03, .725861E-03, .299305E+00,
40689 & .724320E-03, .526376E-01, .526376E-01, .121568E-02, .121572E-02,
40690 & .121572E-02, .121568E-02, .267591E+00, .121442E-02, .473911E-01,
40691 & .473911E-01, .150820E-02, .150825E-02, .150825E-02, .150820E-02,
40692 & .230364E+00, .150718E-02, .424558E-01, .424558E-01, .164949E-02,
40693 & .164955E-02, .164955E-02, .164949E-02, .191972E+00, .164867E-02,
40694 & .378600E-01, .378600E-01, .168256E-02, .168262E-02, .168262E-02,
40695 & .168256E-02, .155818E+00, .168189E-02, .336181E-01, .336181E-01/
40696 DATA (DL(K),K= 3571, 3655) /
40697 & .164080E-02, .164086E-02, .164086E-02, .164080E-02, .123609E+00,
40698 & .164026E-02, .297349E-01, .297349E-01, .155136E-02, .155142E-02,
40699 & .155142E-02, .155136E-02, .961680E-01, .155092E-02, .262052E-01,
40700 & .262052E-01, .143382E-02, .143388E-02, .143388E-02, .143382E-02,
40701 & .735522E-01, .143346E-02, .230171E-01, .230171E-01, .130247E-02,
40702 & .130253E-02, .130253E-02, .130247E-02, .553916E-01, .130218E-02,
40703 & .201539E-01, .201539E-01, .116733E-02, .116739E-02, .116739E-02,
40704 & .116733E-02, .411453E-01, .116710E-02, .175955E-01, .175955E-01,
40705 & .103505E-02, .103510E-02, .103510E-02, .103505E-02, .301858E-01,
40706 & .103486E-02, .153199E-01, .153199E-01, .909828E-03, .909880E-03,
40707 & .909880E-03, .909828E-03, .218957E-01, .909677E-03, .133043E-01,
40708 & .133043E-01, .794097E-03, .794146E-03, .794146E-03, .794097E-03,
40709 & .157204E-01, .793976E-03, .115259E-01, .115259E-01, .689012E-03,
40710 & .689057E-03, .689057E-03, .689012E-03, .111816E-01, .688913E-03,
40711 & .996208E-02, .996208E-02, .594880E-03, .594922E-03, .594922E-03,
40712 & .594880E-03, .788559E-02, .594801E-03, .859151E-02, .859151E-02,
40713 & .511455E-03, .511493E-03, .511493E-03, .511455E-03, .551865E-02/
40714 DATA (DL(K),K= 3656, 3740) /
40715 & .511392E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40716 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40717 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40718 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40719 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40720 & .567030E-01, .567030E-01, .317692E-06, .317692E-06, .317692E-06,
40721 & .317692E-06, .387655E+00,-.196551E-18, .502560E-01, .502560E-01,
40722 & .611827E-03, .611838E-03, .611838E-03, .611827E-03, .346975E+00,
40723 & .611576E-03, .442838E-01, .442838E-01, .981907E-03, .981929E-03,
40724 & .981929E-03, .981907E-03, .295290E+00, .981708E-03, .388018E-01,
40725 & .388018E-01, .116826E-02, .116829E-02, .116829E-02, .116826E-02,
40726 & .241157E+00, .116810E-02, .338227E-01, .338227E-01, .122537E-02,
40727 & .122541E-02, .122541E-02, .122537E-02, .190062E+00, .122525E-02,
40728 & .293442E-01, .293442E-01, .120047E-02, .120052E-02, .120052E-02,
40729 & .120047E-02, .145706E+00, .120037E-02, .253494E-01, .253494E-01,
40730 & .112580E-02, .112585E-02, .112585E-02, .112580E-02, .109110E+00,
40731 & .112572E-02, .218132E-01, .218132E-01, .102498E-02, .102503E-02/
40732 DATA (DL(K),K= 3741, 3825) /
40733 & .102503E-02, .102498E-02, .800661E-01, .102492E-02, .187030E-01,
40734 & .187030E-01, .913395E-03, .913450E-03, .913450E-03, .913395E-03,
40735 & .577342E-01, .913348E-03, .159833E-01, .159833E-01, .800935E-03,
40736 & .800990E-03, .800990E-03, .800935E-03, .409782E-01, .800898E-03,
40737 & .136172E-01, .136172E-01, .693698E-03, .693751E-03, .693751E-03,
40738 & .693698E-03, .286780E-01, .693669E-03, .115681E-01, .115681E-01,
40739 & .595013E-03, .595064E-03, .595064E-03, .595013E-03, .198197E-01,
40740 & .594990E-03, .980105E-02, .980105E-02, .506423E-03, .506471E-03,
40741 & .506471E-03, .506423E-03, .135410E-01, .506405E-03, .828286E-02,
40742 & .828286E-02, .428323E-03, .428368E-03, .428368E-03, .428323E-03,
40743 & .915498E-02, .428309E-03, .698303E-02, .698303E-02, .360397E-03,
40744 & .360439E-03, .360439E-03, .360397E-03, .613133E-02, .360386E-03,
40745 & .587373E-02, .587373E-02, .301934E-03, .301973E-03, .301973E-03,
40746 & .301934E-03, .407092E-02, .301925E-03, .492985E-02, .492985E-02,
40747 & .252029E-03, .252064E-03, .252064E-03, .252029E-03, .268179E-02,
40748 & .252022E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40749 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40750 DATA (DL(K),K= 3826, 3910) /
40751 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40752 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40753 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40754 & .450567E-01, .450567E-01, .151200E-07, .151200E-07, .151200E-07,
40755 & .151200E-07, .542258E+00,-.767310E-18, .381624E-01, .381624E-01,
40756 & .438685E-03, .438751E-03, .438751E-03, .438685E-03, .447480E+00,
40757 & .438674E-03, .321250E-01, .321250E-01, .653465E-03, .653574E-03,
40758 & .653574E-03, .653465E-03, .347952E+00, .653456E-03, .268827E-01,
40759 & .268827E-01, .724735E-03, .724868E-03, .724868E-03, .724735E-03,
40760 & .258636E+00, .724728E-03, .223751E-01, .223751E-01, .709421E-03,
40761 & .709567E-03, .709567E-03, .709421E-03, .185088E+00, .709417E-03,
40762 & .185359E-01, .185359E-01, .650478E-03, .650626E-03, .650626E-03,
40763 & .650478E-03, .128686E+00, .650474E-03, .152906E-01, .152906E-01,
40764 & .572423E-03, .572567E-03, .572567E-03, .572423E-03, .873875E-01,
40765 & .572420E-03, .125654E-01, .125654E-01, .490165E-03, .490302E-03,
40766 & .490302E-03, .490165E-03, .581141E-01, .490163E-03, .102901E-01,
40767 & .102901E-01, .411740E-03, .411866E-03, .411866E-03, .411740E-03/
40768 DATA (DL(K),K= 3911, 3995) /
40769 & .379596E-01, .411738E-03, .839975E-02, .839975E-02, .340986E-03,
40770 & .341101E-03, .341101E-03, .340986E-03, .244073E-01, .340985E-03,
40771 & .683634E-02, .683634E-02, .279417E-03, .279520E-03, .279520E-03,
40772 & .279417E-03, .154717E-01, .279416E-03, .554846E-02, .554846E-02,
40773 & .227114E-03, .227204E-03, .227204E-03, .227114E-03, .968450E-02,
40774 & .227113E-03, .449143E-02, .449143E-02, .183425E-03, .183504E-03,
40775 & .183504E-03, .183425E-03, .599306E-02, .183425E-03, .362676E-02,
40776 & .362676E-02, .147387E-03, .147455E-03, .147455E-03, .147387E-03,
40777 & .366977E-02, .147387E-03, .292164E-02, .292164E-02, .117936E-03,
40778 & .117995E-03, .117995E-03, .117936E-03, .222583E-02, .117936E-03,
40779 & .234830E-02, .234830E-02, .940414E-04, .940914E-04, .940914E-04,
40780 & .940414E-04, .133844E-02, .940412E-04, .188339E-02, .188339E-02,
40781 & .747651E-04, .748074E-04, .748074E-04, .747651E-04, .798451E-03,
40782 & .747649E-04, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40783 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40784 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40785 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40786 DATA (DL(K),K= 3996, 4000) /
40787 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40792 IF(X.GT.0.9985) RETURN
40798 IF(I.EQ.3.AND.X.GT.0.95) GOTO 19
40799 IF(I.EQ.8.AND.X.GT.0.95) GOTO 19
40806 A1 = PHO_CKMTFV(X,F1)
40807 A2 = PHO_CKMTFV(X,F2)
40808 QQ(I)=A1*(S2-S)/DELTA+A2*(S-S1)/DELTA
40814 *$ CREATE PHO_CKMTFV.FOR
40816 CDECK ID>, PHO_CKMTFV
40817 REAL FUNCTION PHO_CKMTFV(X,FVL)
40818 C**********************************************************************
40820 C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
40821 C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
40822 C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
40825 C**********************************************************************
40828 DIMENSION FVL(25),XGRID(25)
40830 C input/output channels
40832 COMMON /POINOU/ LI,LO
40834 DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
40835 *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
40839 IF(X.LT.XGRID(I)) GO TO 2
40844 ELSE IF(I.GT.23) THEN
40850 BXI=LOG(1.-XGRID(I))
40852 BXJ=LOG(1.-XGRID(J))
40854 BXK=LOG(1.-XGRID(K))
40855 FI=LOG(ABS(FVL(I)) +1.E-15)
40856 FJ=LOG(ABS(FVL(J)) +1.E-16)
40857 FK=LOG(ABS(FVL(K)) +1.E-17)
40858 DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
40859 ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
40861 ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
40862 BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
40863 IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
40865 C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
40866 C WRITE(LO,2001) X,FVL
40867 C 2001 FORMAT(8E12.4)
40868 C WRITE(LO,2001) ALPHA,BETA,ALOGA,DET
40870 PHO_CKMTFV=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
40874 *$ CREATE PHO_SASGAM.FOR
40876 CDECK ID>, PHO_SASGAM
40877 C***********************************************************************
40878 C...SaSgam version 2 - parton distributions of the photon
40879 C...by Gerhard A. Schuler and Torbjorn Sjostrand
40880 C...For further information see Z. Phys. C68 (1995) 607
40881 C...and Phys. Lett. B376 (1996) 193.
40883 C...18 January 1996: original code.
40884 C...22 July 1996: calculation of BETA moved in SASBEH.
40886 C!!!Note that one further call parameter - IP2 - has been added
40887 C!!!to the SASGAM argument list compared with version 1.
40889 C...The user should only need to call the SASGAM routine,
40890 C...which in turn calls the auxiliary routines SASVMD, SASANO,
40891 C...SASBEH and SASDIR. The package is self-contained.
40893 C...One particular aspect of these parametrizations is that F2 for
40894 C...the photon is not obtained just as the charge-squared-weighted
40895 C...sum of quark distributions, but differ in the treatment of
40896 C...heavy flavours (in F2 the DIS relation W2 = Q2*(1-x)/x restricts
40897 C...the kinematics range of heavy-flavour production, but the same
40898 C...kinematics is not relevant e.g. for jet production) and, for the
40899 C...'MSbar' fits, in the addition of a Cgamma term related to the
40900 C...separation of direct processes. Schematically:
40901 C...PDF = VMD (rho, omega, phi) + anomalous (d, u, s, c, b).
40902 C...F2 = VMD (rho, omega, phi) + anomalous (d, u, s) +
40903 C... Bethe-Heitler (c, b) (+ Cgamma (d, u, s)).
40904 C...The J/psi and Upsilon states have not been included in the VMD sum,
40905 C...but low c and b masses in the other components should compensate
40906 C...for this in a duality sense.
40908 C...The calling sequence is the following:
40909 C CALL SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40910 C...with the following declaration statement:
40911 C DIMENSION XPDFGM(-6:6)
40912 C...and, optionally, further information in:
40913 C COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
40915 C COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
40916 C...Input: ISET = 1 : SaS set 1D ('DIS', Q0 = 0.6 GeV)
40917 C = 2 : SaS set 1M ('MSbar', Q0 = 0.6 GeV)
40918 C = 3 : SaS set 2D ('DIS', Q0 = 2 GeV)
40919 C = 4 : SaS set 2M ('MSbar', Q0 = 2 GeV)
40922 C P2 : P2 value; should be = 0. for an on-shell photon.
40923 C IP2 : scheme used to evaluate off-shell anomalous component.
40924 C = 0 : recommended default, see = 7.
40925 C = 1 : dipole dampening by integration; very time-consuming.
40926 C = 2 : P_0^2 = max( Q_0^2, P^2 )
40927 C = 3 : P_0^2 = Q_0^2 + P^2.
40928 C = 4 : P_{eff} that preserves momentum sum.
40929 C = 5 : P_{int} that preserves momentum and average
40931 C = 6 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
40932 C = 7 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
40933 C...Output: F2GM : F2 value of the photon (including factors of alpha_em).
40934 C XPFDGM : x times parton distribution functions of the photon,
40935 C with elements 0 = g, 1 = d, 2 = u, 3 = s, 4 = c, 5 = b,
40936 C 6 = t (always empty!), - for antiquarks (result is same).
40937 C...The breakdown by component is stored in the commonblock SASCOM,
40938 C with elements as above.
40939 C XPVMD : rho, omega, phi VMD part only of output.
40940 C XPANL : d, u, s anomalous part only of output.
40941 C XPANH : c, b anomalous part only of output.
40942 C XPBEH : c, b Bethe-Heitler part only of output.
40943 C XPDIR : Cgamma (direct contribution) part only of output.
40944 C...The above arrays do not distinguish valence and sea contributions,
40945 C...although this information is available internally. The additional
40946 C...commonblock SASVAL provides the valence part only of the above
40947 C...distributions. Array names VXPVMD, VXPANL and VXPANH correspond
40948 C...to XPVMD, XPANL and XPANH, while XPBEH and XPDIR are valence only
40949 C...and therefore not given doubly. VXPDGM gives the sum of valence
40950 C...parts, and so matches XPDFGM. The difference, i.e. XPVMD-VXPVMD
40951 C...and so on, gives the sea part only.
40952 C***********************************************************************
40954 SUBROUTINE PHO_SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40955 C...Purpose: to construct the F2 and parton distributions of the photon
40956 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
40957 C...For F2, c and b are included by the Bethe-Heitler formula;
40958 C...in the 'MSbar' scheme additionally a Cgamma term is added.
40960 DIMENSION XPDFGM(-6:6)
40962 C input/output channels
40964 COMMON /POINOU/ LI,LO
40966 COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
40968 COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
40970 C SAVE /SASCOM/,/SASVAL/
40973 C...Temporary array.
40974 DIMENSION XPGA(-6:6), VXPGA(-6:6)
40975 C...Charm and bottom masses (low to compensate for J/psi etc.).
40976 DATA PMC/1.3/, PMB/4.6/
40977 C...alpha_em and alpha_em/(2*pi).
40978 DATA AEM/0.007297/, AEM2PI/0.0011614/
40979 C...Lambda value for 4 flavours.
40981 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
40983 C...VMD couplings f_V**2/(4*pi).
40984 DATA FRHO/2.20/, FOMEGA/23.6/, FPHI/18.4/
40985 C...Masses for rho (=omega) and phi.
40986 DATA PMRHO/0.770/, PMPHI/1.020/
40987 C...Number of points in integration for IP2=1.
41005 C...Check that input sensible.
41006 IF(ISET.LE.0.OR.ISET.GE.5) THEN
41007 WRITE(LO,*) ' FATAL ERROR: SaSgam called for unknown set'
41008 WRITE(LO,*) ' ISET = ',ISET
41011 IF(X.LE.0..OR.X.GT.1.) THEN
41012 WRITE(LO,*) ' FATAL ERROR: SaSgam called for unphysical x'
41013 WRITE(LO,*) ' X = ',X
41017 C...Set Q0 cut-off parameter as function of set used.
41025 C...Scale choice for off-shell photon; common factors.
41030 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
41031 FACNOR=LOG(Q2/Q02)/NSTEP
41032 ELSEIF(IP2.EQ.2) THEN
41034 ELSEIF(IP2.EQ.3) THEN
41036 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
41037 ELSEIF(IP2.EQ.4) THEN
41038 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
41039 & ((Q2+P2)*(Q02+P2)))
41040 ELSEIF(IP2.EQ.5) THEN
41041 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
41042 & ((Q2+P2)*(Q02+P2)))
41043 P2MX=Q0*SQRT(P2MXA)
41044 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
41045 ELSEIF(IP2.EQ.6) THEN
41046 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
41047 & ((Q2+P2)*(Q02+P2)))
41048 P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
41050 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
41051 & ((Q2+P2)*(Q02+P2)))
41052 P2MX=Q0*SQRT(P2MXA)
41054 P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
41055 P2MXB=MAX(0.,1.-P2/Q2)*P2MXB+MIN(1.,P2/Q2)*P2MXA
41056 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
41059 C...Call VMD parametrization for d quark and use to give rho, omega,
41060 C...phi. Note dipole dampening for off-shell photon.
41061 CALL PHO_SASVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
41065 FACUD=AEM*(1./FRHO+1./FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
41066 FACS=AEM*(1./FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
41068 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
41070 XPVMD(1)=XPVMD(1)+(1.-FRACU)*FACUD*XFVAL
41071 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
41072 XPVMD(3)=XPVMD(3)+FACS*XFVAL
41073 XPVMD(-1)=XPVMD(-1)+(1.-FRACU)*FACUD*XFVAL
41074 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
41075 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
41076 VXPVMD(1)=(1.-FRACU)*FACUD*XFVAL
41077 VXPVMD(2)=FRACU*FACUD*XFVAL
41078 VXPVMD(3)=FACS*XFVAL
41079 VXPVMD(-1)=(1.-FRACU)*FACUD*XFVAL
41080 VXPVMD(-2)=FRACU*FACUD*XFVAL
41081 VXPVMD(-3)=FACS*XFVAL
41084 C...Anomalous parametrizations for different strategies
41085 C...for off-shell photons; except full integration.
41087 C...Call anomalous parametrization for d + u + s.
41088 CALL PHO_SASANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
41090 XPANL(KFL)=FACNOR*XPGA(KFL)
41091 VXPANL(KFL)=FACNOR*VXPGA(KFL)
41094 C...Call anomalous parametrization for c and b.
41095 CALL PHO_SASANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
41097 XPANH(KFL)=FACNOR*XPGA(KFL)
41098 VXPANH(KFL)=FACNOR*VXPGA(KFL)
41100 CALL PHO_SASANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
41102 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
41103 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
41107 C...Special option: loop over flavours and integrate over k2.
41109 DO 160 ISTEP=1,NSTEP
41110 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5)/NSTEP)
41111 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
41112 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
41113 CALL PHO_SASVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
41114 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
41115 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8./9.)
41116 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2./9.)
41118 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
41119 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
41120 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
41121 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
41127 C...Call Bethe-Heitler term expression for charm and bottom.
41128 CALL PHO_SASBEH(4,X,Q2,P2,PMC**2,XPBH)
41131 CALL PHO_SASBEH(5,X,Q2,P2,PMB**2,XPBH)
41135 C...For MSbar subtraction call C^gamma term expression for d, u, s.
41136 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
41137 CALL PHO_SASDIR(X,Q2,P2,Q02,XPGA)
41139 XPDIR(KFL)=XPGA(KFL)
41143 C...Store result in output array.
41146 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4./9.
41147 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
41148 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
41149 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
41150 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
41156 C*********************************************************************
41158 *$ CREATE PHO_SASVMD.FOR
41160 CDECK ID>, PHO_SASVMD
41161 SUBROUTINE PHO_SASVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
41162 C...Purpose: to evaluate the VMD parton distributions of a photon,
41163 C...evolved homogeneously from an initial scale P2 to Q2.
41164 C...Does not include dipole suppression factor.
41165 C...ISET is parton distribution set, see above;
41166 C...additionally ISET=0 is used for the evolution of an anomalous photon
41167 C...which branched at a scale P2 and then evolved homogeneously to Q2.
41168 C...ALAM is the 4-flavour Lambda, which is automatically converted
41169 C...to 3- and 5-flavour equivalents as needed.
41171 DIMENSION XPGA(-6:6), VXPGA(-6:6)
41173 C input/output channels
41175 COMMON /POINOU/ LI,LO
41177 DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
41186 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
41187 ALAM3=ALAM*(PMC/ALAM)**(2./27.)
41188 ALAM5=ALAM*(ALAM/PMB)**(2./23.)
41189 P2EFF=MAX(P2,1.2*ALAM3**2)
41190 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
41191 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
41192 Q2EFF=MAX(Q2,P2EFF)
41194 C...Find number of flavours at lower and upper scale.
41196 IF(P2EFF.LT.PMC**2) NFP=3
41197 IF(P2EFF.GT.PMB**2) NFP=5
41199 IF(Q2EFF.LT.PMC**2) NFQ=3
41200 IF(Q2EFF.GT.PMB**2) NFQ=5
41202 C...Find s as sum of 3-, 4- and 5-flavour parts.
41206 IF(NFQ.EQ.3) Q2DIV=Q2EFF
41207 S=S+(6./27.)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
41209 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
41211 IF(NFP.EQ.3) P2DIV=PMC**2
41213 IF(NFQ.EQ.5) Q2DIV=PMB**2
41214 S=S+(6./25.)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
41218 IF(NFP.EQ.5) P2DIV=P2EFF
41219 S=S+(6./23.)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
41222 C...Calculate frequent combinations of x and s.
41229 C...Evaluate homogeneous anomalous parton distributions below or
41230 C...above threshold.
41232 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
41233 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
41234 XVAL = X * 1.5 * (X**2+X1**2)
41238 XVAL = (1.5/(1.-0.197*S+4.33*S2)*X**2 + (1.5+2.10*S)/
41239 & (1.+3.29*S)*X1**2 + 5.23*S/(1.+1.17*S+19.9*S3)*X*X1) *
41240 & X**(1./(1.+1.5*S)) * (1.-X**2)**(2.667*S)
41241 XGLU = 4.*S/(1.+4.76*S+15.2*S2+29.3*S4) *
41242 & X**(-2.03*S/(1.+2.44*S)) * (X1*XL)**(1.333*S) *
41243 & ((4.*X**2+7.*X+4.)*X1/3. - 2.*X*(1.+X)*XL)
41244 XSEA = S2/(1.+4.54*S+8.19*S2+8.05*S3) *
41245 & X**(-1.54*S/(1.+1.29*S)) * X1**(2.667*S) *
41246 & ((8.-73.*X+62.*X**2)*X1/9. + (3.-8.*X**2/3.)*X*XL +
41247 & (2.*X-1.)*X*XL**2)
41250 C...Evaluate set 1D parton distributions below or above threshold.
41251 ELSEIF(ISET.EQ.1) THEN
41252 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
41253 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
41254 XVAL = 1.294 * X**0.80 * X1**0.76
41255 XGLU = 1.273 * X**0.40 * X1**1.76
41256 XSEA = 0.100 * X1**3.76
41258 XVAL = 1.294/(1.+0.252*S+3.079*S2) * X**(0.80-0.13*S) *
41259 & X1**(0.76+0.667*S) * XL**(2.*S)
41260 XGLU = 7.90*S/(1.+5.50*S) * EXP(-5.16*S) *
41261 & X**(-1.90*S/(1.+3.60*S)) * X1**1.30 * XL**(0.50+3.*S) +
41262 & 1.273 * EXP(-10.*S) * X**0.40 * X1**(1.76+3.*S)
41263 XSEA = (0.1-0.397*S2+1.121*S3)/(1.+5.61*S2+5.26*S3) *
41264 & X**(-7.32*S2/(1.+10.3*S2)) *
41265 & X1**((3.76+15.*S+12.*S2)/(1.+4.*S))
41266 XSEA0 = 0.100 * X1**3.76
41269 C...Evaluate set 1M parton distributions below or above threshold.
41270 ELSEIF(ISET.EQ.2) THEN
41271 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
41272 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
41273 XVAL = 0.8477 * X**0.51 * X1**1.37
41274 XGLU = 3.42 * X**0.255 * X1**2.37
41277 XVAL = 0.8477/(1.+1.37*S+2.18*S2+3.73*S3) * X**(0.51+0.21*S)
41278 & * X1**1.37 * XL**(2.667*S)
41279 XGLU = 24.*S/(1.+9.6*S+0.92*S2+14.34*S3) * EXP(-5.94*S) *
41280 & X**((-0.013-1.80*S)/(1.+3.14*S)) * X1**(2.37+0.4*S) *
41281 & XL**(0.32+3.6*S) + 3.42 * EXP(-12.*S) * X**0.255 *
41283 XSEA = 0.842*S/(1.+21.3*S-33.2*S2+229.*S3) *
41284 & X**((0.13-2.90*S)/(1.+5.44*S)) * X1**(3.45+0.5*S) *
41289 C...Evaluate set 2D parton distributions below or above threshold.
41290 ELSEIF(ISET.EQ.3) THEN
41291 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
41292 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
41293 XVAL = X**0.46 * X1**0.64 + 0.76 * X
41294 XGLU = 1.925 * X1**2
41295 XSEA = 0.242 * X1**4
41297 XVAL = (1.+0.186*S)/(1.-0.209*S+1.495*S2) * X**(0.46+0.25*S)
41298 & * X1**((0.64+0.14*S+5.*S2)/(1.+S)) * XL**(1.9*S) +
41299 & (0.76+0.4*S) * X * X1**(2.667*S)
41300 XGLU = (1.925+5.55*S+147.*S2)/(1.-3.59*S+3.32*S2) *
41301 & EXP(-18.67*S) * X**((-5.81*S-5.34*S2)/(1.+29.*S-4.26*S2))
41302 & * X1**((2.-5.9*S)/(1.+1.7*S)) * XL**(9.3*S/(1.+1.7*S))
41303 XSEA = (0.242-0.252*S+1.19*S2)/(1.-0.607*S+21.95*S2) *
41304 & X**(-12.1*S2/(1.+2.62*S+16.7*S2)) * X1**4 * XL**S
41305 XSEA0 = 0.242 * X1**4
41308 C...Evaluate set 2M parton distributions below or above threshold.
41309 ELSEIF(ISET.EQ.4) THEN
41310 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
41311 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
41312 XVAL = 1.168 * X**0.50 * X1**2.60 + 0.965 * X
41313 XGLU = 1.808 * X1**2
41314 XSEA = 0.209 * X1**4
41316 XVAL = (1.168+1.771*S+29.35*S2) * EXP(-5.776*S) *
41317 & X**((0.5+0.208*S)/(1.-0.794*S+1.516*S2)) *
41318 & X1**((2.6+7.6*S)/(1.+5.*S)) * XL**(5.15*S/(1.+2.*S)) +
41319 & (0.965+22.35*S)/(1.+18.4*S) * X * X1**(2.667*S)
41320 XGLU = (1.808+29.9*S)/(1.+26.4*S) * EXP(-5.28*S) *
41321 & X**((-5.35*S-10.11*S2)/(1.+31.71*S)) *
41322 & X1**((2.-7.3*S+4.*S2)/(1.+2.5*S)) *
41323 & XL**(10.9*S/(1.+2.5*S))
41324 XSEA = (0.209+0.644*S2)/(1.+0.319*S+17.6*S2) *
41325 & X**((-0.373*S-7.71*S2)/(1.+0.815*S+11.0*S2)) *
41326 & X1**(4.+S) * XL**(0.45*S)
41327 XSEA0 = 0.209 * X1**4
41331 C...Threshold factors for c and b sea.
41332 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
41334 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
41335 SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41337 XCHM=XSEA*(1.-(SCH/SLL)**2)
41339 XCHM=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SCH/SLL)
41343 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
41344 SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41346 XBOT=XSEA*(1.-(SBT/SLL)**2)
41348 XBOT=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SBT/SLL)
41352 C...Fill parton distributions.
41359 XPGA(KFA)=XPGA(KFA)+XVAL
41361 XPGA(-KFL)=XPGA(KFL)
41369 C*********************************************************************
41371 *$ CREATE PHO_SASANO.FOR
41373 CDECK ID>, PHO_SASANO
41374 SUBROUTINE PHO_SASANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
41375 C...Purpose: to evaluate the parton distributions of the anomalous
41376 C...photon, inhomogeneously evolved from a scale P2 (where it vanishes)
41378 C...KF=0 gives the sum over (up to) 5 flavours,
41379 C...KF<0 limits to flavours up to abs(KF),
41380 C...KF>0 is for flavour KF only.
41381 C...ALAM is the 4-flavour Lambda, which is automatically converted
41382 C...to 3- and 5-flavour equivalents as needed.
41385 C input/output channels
41387 COMMON /POINOU/ LI,LO
41389 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
41390 DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
41397 IF(Q2.LE.P2) RETURN
41400 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
41401 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2./27.))**2
41403 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2./23.))**2
41404 P2EFF=MAX(P2,1.2*ALAMSQ(3))
41405 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
41406 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
41407 Q2EFF=MAX(Q2,P2EFF)
41410 C...Find number of flavours at lower and upper scale.
41412 IF(P2EFF.LT.PMC**2) NFP=3
41413 IF(P2EFF.GT.PMB**2) NFP=5
41415 IF(Q2EFF.LT.PMC**2) NFQ=3
41416 IF(Q2EFF.GT.PMB**2) NFQ=5
41418 C...Define range of flavour loop.
41422 ELSEIF(KF.LT.0) THEN
41430 C...Loop over flavours the photon can branch into.
41431 DO 110 KFL=KFLMN,KFLMX
41433 C...Light flavours: calculate t range and (approximate) s range.
41434 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
41435 TDIFF=LOG(Q2EFF/P2EFF)
41436 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41437 & LOG(P2EFF/ALAMSQ(NFQ)))
41438 IF(NFQ.GT.NFP) THEN
41440 IF(NFQ.EQ.4) Q2DIV=PMC**2
41441 SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
41442 & LOG(P2EFF/ALAMSQ(NFQ)))
41443 SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
41444 & LOG(P2EFF/ALAMSQ(NFQ-1)))
41445 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
41447 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
41449 SNF4=(6./(33.-2.*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
41450 & LOG(P2EFF/ALAMSQ(4)))
41451 SNF3=(6./(33.-2.*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
41452 & LOG(P2EFF/ALAMSQ(3)))
41453 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
41456 C...u and s quark do not need a separate treatment when d has been done.
41457 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
41459 C...Charm: as above, but only include range above c threshold.
41460 ELSEIF(KFL.EQ.4) THEN
41461 IF(Q2.LE.PMC**2) GOTO 110
41462 P2EFF=MAX(P2EFF,PMC**2)
41463 Q2EFF=MAX(Q2EFF,P2EFF)
41464 TDIFF=LOG(Q2EFF/P2EFF)
41465 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41466 & LOG(P2EFF/ALAMSQ(NFQ)))
41467 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
41469 SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
41470 & LOG(P2EFF/ALAMSQ(NFQ)))
41471 SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
41472 & LOG(P2EFF/ALAMSQ(NFQ-1)))
41473 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
41476 C...Bottom: as above, but only include range above b threshold.
41477 ELSEIF(KFL.EQ.5) THEN
41478 IF(Q2.LE.PMB**2) GOTO 110
41479 P2EFF=MAX(P2EFF,PMB**2)
41480 Q2EFF=MAX(Q2,P2EFF)
41481 TDIFF=LOG(Q2EFF/P2EFF)
41482 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41483 & LOG(P2EFF/ALAMSQ(NFQ)))
41486 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
41488 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4./9.
41489 FAC=AEM2PI*2.*CHSQ*TDIFF
41491 C...Evaluate parton distributions (normalized to unit momentum sum).
41492 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
41493 XVAL= ((1.5+2.49*S+26.9*S**2)/(1.+32.3*S**2)*X**2 +
41494 & (1.5-0.49*S+7.83*S**2)/(1.+7.68*S**2)*(1.-X)**2 +
41495 & 1.5*S/(1.-3.2*S+7.*S**2)*X*(1.-X)) *
41496 & X**(1./(1.+0.58*S)) * (1.-X**2)**(2.5*S/(1.+10.*S))
41497 XGLU= 2.*S/(1.+4.*S+7.*S**2) *
41498 & X**(-1.67*S/(1.+2.*S)) * (1.-X**2)**(1.2*S) *
41499 & ((4.*X**2+7.*X+4.)*(1.-X)/3. - 2.*X*(1.+X)*XL)
41500 XSEA= 0.333*S**2/(1.+4.90*S+4.69*S**2+21.4*S**3) *
41501 & X**(-1.18*S/(1.+1.22*S)) * (1.-X)**(1.2*S) *
41502 & ((8.-73.*X+62.*X**2)*(1.-X)/9. + (3.-8.*X**2/3.)*X*XL +
41503 & (2.*X-1.)*X*XL**2)
41505 C...Threshold factors for c and b sea.
41506 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
41508 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
41509 SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41510 XCHM=XSEA*(1.-(SCH/SLL)**3)
41513 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
41514 SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41515 XBOT=XSEA*(1.-(SBT/SLL)**3)
41519 C...Add contribution of each valence flavour.
41520 XPGA(0)=XPGA(0)+FAC*XGLU
41521 XPGA(1)=XPGA(1)+FAC*XSEA
41522 XPGA(2)=XPGA(2)+FAC*XSEA
41523 XPGA(3)=XPGA(3)+FAC*XSEA
41524 XPGA(4)=XPGA(4)+FAC*XCHM
41525 XPGA(5)=XPGA(5)+FAC*XBOT
41526 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
41527 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
41530 XPGA(-KFL)=XPGA(KFL)
41531 VXPGA(-KFL)=VXPGA(KFL)
41536 C*********************************************************************
41538 *$ CREATE PHO_SASBEH.FOR
41540 CDECK ID>, PHO_SASBEH
41541 SUBROUTINE PHO_SASBEH(KF,X,Q2,P2,PM2,XPBH)
41542 C...Purpose: to evaluate the Bethe-Heitler cross section for
41543 C...heavy flavour production.
41545 DATA AEM2PI/0.0011614/
41551 C...Check kinematics limits.
41552 IF(X.GE.Q2/(4.*PM2+Q2+P2)) RETURN
41555 IF(BETA2.LT.1E-10) RETURN
41559 C...Simple case: P2 = 0.
41560 IF(P2.LT.1E-4) THEN
41561 IF(BETA.LT.0.99) THEN
41562 XBL=LOG((1.+BETA)/(1.-BETA))
41564 XBL=LOG((1.+BETA)**2*W2/(4.*PM2))
41566 SIGBH=BETA*(8.*X*(1.-X)-1.-RMQ*X*(1.-X))+
41567 & XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)
41569 C...Complicated case: P2 > 0, based on approximation of
41570 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
41572 RPQ=1.-4.*X**2*P2/Q2
41573 IF(RPQ.GT.1E-10) THEN
41574 RPBE=SQRT(RPQ*BETA2)
41575 IF(RPBE.LT.0.99) THEN
41576 XBL=LOG((1.+RPBE)/(1.-RPBE))
41577 XBI=2.*RPBE/(1.-RPBE**2)
41579 RPBESN=4.*PM2/W2+(4.*X**2*P2/Q2)*BETA2
41580 XBL=LOG((1.+RPBE)**2/RPBESN)
41583 SIGBH=BETA*(6.*X*(1.-X)-1.)+
41584 & XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)+
41585 & XBI*(2.*X/Q2)*(PM2*X*(2.-RMQ)-P2*X)
41589 C...Multiply by charge-squared etc. to get parton distribution.
41591 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4./9.
41592 XPBH=3.*CHSQ*AEM2PI*X*SIGBH
41596 C*********************************************************************
41598 *$ CREATE PHO_SASDIR.FOR
41600 CDECK ID>, PHO_SASDIR
41601 SUBROUTINE PHO_SASDIR(X,Q2,P2,Q02,XPGA)
41602 C...Purpose: to evaluate the direct contribution, i.e. the C^gamma term,
41603 C...as needed in MSbar parametrizations.
41605 DIMENSION XPGA(-6:6)
41606 DATA PMC/1.3/, PMB/4.6/, AEM2PI/0.0011614/
41613 C...Evaluate common x-dependent expression.
41614 XTMP = (X**2+(1.-X)**2) * (-LOG(X)) - 1.
41615 CGAM = 3.*AEM2PI*X * (XTMP*(1.+P2/(P2+Q02)) + 6.*X*(1.-X))
41617 C...d, u, s part by simple charge factor.
41618 XPGA(1)=(1./9.)*CGAM
41619 XPGA(2)=(4./9.)*CGAM
41620 XPGA(3)=(1./9.)*CGAM
41622 C...Also fill for antiquarks.
41629 *$ CREATE PHO_PHGAL.FOR
41631 CDECK ID>, PHO_PHGAL
41632 SUBROUTINE PHO_PHGAL(X,Q2,XPDF)
41633 C***********************************************************************
41635 C photon parton densities with built-in momentum sum rule and
41636 C Regge-based low-x behaviour
41638 C H. Abramowicz, E. Gurvich, A. Levy: Phys.Lett.B420:104-108,1998
41639 C e-Print Archive: hep-ph/9711355
41641 C code submitted by E.Gurvich, slightly modified (R.Engel, 09/1998)
41643 C***********************************************************************
41644 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
41647 PARAMETER(IX=100,IQ=7,NARG=2,NFUN=4)
41649 & XT(IX),Q2T(IQ),ARG(NARG),ENT(IX+IQ),
41650 & XPV(IX,IQ,0:NFUN),XPDF(-6:6)
41656 C...100 x values; in (D-4,.77) log spaced (78 points)
41657 C... in (.78,.995) lineary spaced (22 points)
41658 DATA Q2T/4.D0,10.D0,50.D0,1.D2,1.D3,1.D4,1.D5/
41660 &0.1000D-03,0.1123D-03,0.1262D-03,0.1417D-03,0.1592D-03,0.1789D-03,
41661 &0.2009D-03,0.2257D-03,0.2535D-03,0.2848D-03,0.3199D-03,0.3593D-03,
41662 &0.4037D-03,0.4534D-03,0.5093D-03,0.5722D-03,0.6427D-03,0.7220D-03,
41663 &0.8110D-03,0.9110D-03,0.1023D-02,0.1150D-02,0.1291D-02,0.1451D-02,
41664 &0.1629D-02,0.1830D-02,0.2056D-02,0.2310D-02,0.2594D-02,0.2914D-02,
41665 &0.3274D-02,0.3677D-02,0.4131D-02,0.4640D-02,0.5212D-02,0.5855D-02,
41666 &0.6577D-02,0.7388D-02,0.8299D-02,0.9323D-02,0.1047D-01,0.1176D-01,
41667 &0.1321D-01,0.1484D-01,0.1667D-01,0.1873D-01,0.2104D-01,0.2363D-01,
41668 &0.2655D-01,0.2982D-01,0.3350D-01,0.3763D-01,0.4227D-01,0.4748D-01,
41669 &0.5334D-01,0.5992D-01,0.6731D-01,0.7560D-01,0.8493D-01,0.9540D-01,
41670 &0.1072D+00,0.1204D+00,0.1352D+00,0.1519D+00,0.1706D+00,0.1917D+00,
41671 &0.2153D+00,0.2419D+00,0.2717D+00,0.3052D+00,0.3428D+00,0.3851D+00,
41672 &0.4326D+00,0.4859D+00,0.5458D+00,0.6131D+00,0.6887D+00,0.7737D+00,
41673 &0.7837D+00,0.7937D+00,0.8037D+00,0.8137D+00,0.8237D+00,0.8337D+00,
41674 &0.8437D+00,0.8537D+00,0.8637D+00,0.8737D+00,0.8837D+00,0.8937D+00,
41675 &0.9037D+00,0.9137D+00,0.9237D+00,0.9337D+00,0.9437D+00,0.9537D+00,
41676 &0.9637D+00,0.9737D+00,0.9837D+00,0.9937D+00/
41678 C...place for DATA blocks
41679 DATA (XPV(I,1,0),I=1,100)/
41680 &0.6632D-01,0.6536D-01,0.6390D-01,0.6196D-01,0.5952D-01,0.5663D-01,
41681 &0.5339D-01,0.5124D-01,0.5029D-01,0.4893D-01,0.4718D-01,0.4505D-01,
41682 &0.4259D-01,0.4038D-01,0.3966D-01,0.3860D-01,0.3721D-01,0.3551D-01,
41683 &0.3354D-01,0.3206D-01,0.3134D-01,0.3031D-01,0.2902D-01,0.2747D-01,
41684 &0.2608D-01,0.2543D-01,0.2451D-01,0.2335D-01,0.2202D-01,0.2132D-01,
41685 &0.2051D-01,0.1950D-01,0.1851D-01,0.1783D-01,0.1696D-01,0.1609D-01,
41686 &0.1539D-01,0.1454D-01,0.1386D-01,0.1310D-01,0.1242D-01,0.1169D-01,
41687 &0.1104D-01,0.1036D-01,0.9694D-02,0.9046D-02,0.8400D-02,0.7792D-02,
41688 &0.7173D-02,0.6573D-02,0.5978D-02,0.5411D-02,0.4853D-02,0.4307D-02,
41689 &0.3791D-02,0.3292D-02,0.2818D-02,0.2382D-02,0.1976D-02,0.1606D-02,
41690 &0.1275D-02,0.9866D-03,0.7403D-03,0.5351D-03,0.3713D-03,0.2450D-03,
41691 &0.1524D-03,0.8849D-04,0.4730D-04,0.2278D-04,0.9707D-05,0.3518D-05,
41692 &0.1041D-05,0.2356D-06,0.3682D-07,0.3365D-08,0.1333D-09,0.1188D-11,
41693 &0.6095D-12,0.3031D-12,0.1457D-12,0.6733D-13,0.2986D-13,0.1262D-13,
41694 &0.5060D-14,0.1912D-14,0.6734D-15,0.2199D-15,0.6498D-16,0.1729D-16,
41695 &0.4059D-17,0.8091D-18,0.1324D-18,0.1691D-19,0.1518D-20,0.8785D-22,
41696 &0.2519D-23,0.2197D-25,0.2840D-28,0.1908D-33/
41697 DATA (XPV(I,1,1),I=1,100)/
41698 &0.5848D-03,0.5838D-03,0.5793D-03,0.5713D-03,0.5597D-03,0.5447D-03,
41699 &0.5270D-03,0.5167D-03,0.5143D-03,0.5087D-03,0.4998D-03,0.4879D-03,
41700 &0.4731D-03,0.4599D-03,0.4584D-03,0.4538D-03,0.4461D-03,0.4355D-03,
41701 &0.4223D-03,0.4133D-03,0.4109D-03,0.4053D-03,0.3970D-03,0.3859D-03,
41702 &0.3763D-03,0.3739D-03,0.3686D-03,0.3605D-03,0.3504D-03,0.3473D-03,
41703 &0.3426D-03,0.3355D-03,0.3286D-03,0.3253D-03,0.3196D-03,0.3138D-03,
41704 &0.3102D-03,0.3047D-03,0.3014D-03,0.2971D-03,0.2939D-03,0.2901D-03,
41705 &0.2875D-03,0.2849D-03,0.2824D-03,0.2805D-03,0.2787D-03,0.2780D-03,
41706 &0.2772D-03,0.2771D-03,0.2773D-03,0.2784D-03,0.2799D-03,0.2820D-03,
41707 &0.2850D-03,0.2886D-03,0.2930D-03,0.2985D-03,0.3050D-03,0.3126D-03,
41708 &0.3215D-03,0.3316D-03,0.3432D-03,0.3564D-03,0.3714D-03,0.3883D-03,
41709 &0.4073D-03,0.4287D-03,0.4526D-03,0.4794D-03,0.5092D-03,0.5425D-03,
41710 &0.5796D-03,0.6207D-03,0.6664D-03,0.7171D-03,0.7733D-03,0.8356D-03,
41711 &0.8429D-03,0.8502D-03,0.8574D-03,0.8647D-03,0.8719D-03,0.8791D-03,
41712 &0.8863D-03,0.8935D-03,0.9007D-03,0.9079D-03,0.9151D-03,0.9222D-03,
41713 &0.9294D-03,0.9365D-03,0.9436D-03,0.9508D-03,0.9579D-03,0.9650D-03,
41714 &0.9720D-03,0.9791D-03,0.9862D-03,0.9932D-03/
41715 DATA (XPV(I,1,2),I=1,100)/
41716 &0.2339D-02,0.2335D-02,0.2317D-02,0.2285D-02,0.2239D-02,0.2179D-02,
41717 &0.2108D-02,0.2067D-02,0.2057D-02,0.2035D-02,0.1999D-02,0.1951D-02,
41718 &0.1892D-02,0.1840D-02,0.1833D-02,0.1815D-02,0.1784D-02,0.1742D-02,
41719 &0.1689D-02,0.1653D-02,0.1643D-02,0.1621D-02,0.1588D-02,0.1544D-02,
41720 &0.1505D-02,0.1496D-02,0.1474D-02,0.1442D-02,0.1402D-02,0.1389D-02,
41721 &0.1370D-02,0.1342D-02,0.1314D-02,0.1301D-02,0.1278D-02,0.1255D-02,
41722 &0.1241D-02,0.1219D-02,0.1205D-02,0.1188D-02,0.1176D-02,0.1160D-02,
41723 &0.1150D-02,0.1139D-02,0.1130D-02,0.1122D-02,0.1115D-02,0.1112D-02,
41724 &0.1109D-02,0.1108D-02,0.1109D-02,0.1114D-02,0.1120D-02,0.1128D-02,
41725 &0.1140D-02,0.1154D-02,0.1172D-02,0.1194D-02,0.1220D-02,0.1251D-02,
41726 &0.1286D-02,0.1326D-02,0.1373D-02,0.1426D-02,0.1485D-02,0.1553D-02,
41727 &0.1629D-02,0.1715D-02,0.1811D-02,0.1917D-02,0.2037D-02,0.2170D-02,
41728 &0.2318D-02,0.2483D-02,0.2666D-02,0.2868D-02,0.3093D-02,0.3342D-02,
41729 &0.3372D-02,0.3401D-02,0.3430D-02,0.3459D-02,0.3488D-02,0.3517D-02,
41730 &0.3545D-02,0.3574D-02,0.3603D-02,0.3632D-02,0.3660D-02,0.3689D-02,
41731 &0.3717D-02,0.3746D-02,0.3775D-02,0.3803D-02,0.3831D-02,0.3860D-02,
41732 &0.3888D-02,0.3916D-02,0.3945D-02,0.3973D-02/
41733 DATA (XPV(I,1,3),I=1,100)/
41734 &0.1755D-03,0.1751D-03,0.1738D-03,0.1714D-03,0.1679D-03,0.1634D-03,
41735 &0.1581D-03,0.1550D-03,0.1543D-03,0.1526D-03,0.1499D-03,0.1464D-03,
41736 &0.1419D-03,0.1380D-03,0.1375D-03,0.1361D-03,0.1338D-03,0.1306D-03,
41737 &0.1267D-03,0.1240D-03,0.1233D-03,0.1216D-03,0.1191D-03,0.1158D-03,
41738 &0.1129D-03,0.1122D-03,0.1106D-03,0.1082D-03,0.1051D-03,0.1042D-03,
41739 &0.1028D-03,0.1006D-03,0.9857D-04,0.9759D-04,0.9587D-04,0.9414D-04,
41740 &0.9305D-04,0.9140D-04,0.9041D-04,0.8912D-04,0.8817D-04,0.8702D-04,
41741 &0.8626D-04,0.8546D-04,0.8472D-04,0.8415D-04,0.8362D-04,0.8339D-04,
41742 &0.8317D-04,0.8312D-04,0.8318D-04,0.8352D-04,0.8398D-04,0.8459D-04,
41743 &0.8550D-04,0.8658D-04,0.8789D-04,0.8956D-04,0.9151D-04,0.9379D-04,
41744 &0.9644D-04,0.9948D-04,0.1030D-03,0.1069D-03,0.1114D-03,0.1165D-03,
41745 &0.1222D-03,0.1286D-03,0.1358D-03,0.1438D-03,0.1528D-03,0.1628D-03,
41746 &0.1739D-03,0.1862D-03,0.1999D-03,0.2151D-03,0.2320D-03,0.2507D-03,
41747 &0.2529D-03,0.2551D-03,0.2572D-03,0.2594D-03,0.2616D-03,0.2637D-03,
41748 &0.2659D-03,0.2681D-03,0.2702D-03,0.2724D-03,0.2745D-03,0.2767D-03,
41749 &0.2788D-03,0.2810D-03,0.2831D-03,0.2852D-03,0.2874D-03,0.2895D-03,
41750 &0.2916D-03,0.2937D-03,0.2959D-03,0.2980D-03/
41751 DATA (XPV(I,1,4),I=1,100)/
41752 &0.7018D-03,0.7006D-03,0.6951D-03,0.6855D-03,0.6716D-03,0.6537D-03,
41753 &0.6324D-03,0.6200D-03,0.6172D-03,0.6104D-03,0.5998D-03,0.5854D-03,
41754 &0.5677D-03,0.5519D-03,0.5500D-03,0.5445D-03,0.5353D-03,0.5226D-03,
41755 &0.5068D-03,0.4960D-03,0.4930D-03,0.4864D-03,0.4764D-03,0.4631D-03,
41756 &0.4516D-03,0.4487D-03,0.4423D-03,0.4326D-03,0.4205D-03,0.4167D-03,
41757 &0.4111D-03,0.4026D-03,0.3943D-03,0.3903D-03,0.3835D-03,0.3765D-03,
41758 &0.3722D-03,0.3656D-03,0.3616D-03,0.3565D-03,0.3527D-03,0.3481D-03,
41759 &0.3450D-03,0.3418D-03,0.3389D-03,0.3366D-03,0.3345D-03,0.3336D-03,
41760 &0.3327D-03,0.3325D-03,0.3327D-03,0.3341D-03,0.3359D-03,0.3383D-03,
41761 &0.3420D-03,0.3463D-03,0.3516D-03,0.3582D-03,0.3660D-03,0.3752D-03,
41762 &0.3858D-03,0.3979D-03,0.4118D-03,0.4277D-03,0.4456D-03,0.4660D-03,
41763 &0.4887D-03,0.5145D-03,0.5432D-03,0.5752D-03,0.6111D-03,0.6510D-03,
41764 &0.6955D-03,0.7448D-03,0.7997D-03,0.8605D-03,0.9280D-03,0.1003D-02,
41765 &0.1011D-02,0.1020D-02,0.1029D-02,0.1038D-02,0.1046D-02,0.1055D-02,
41766 &0.1064D-02,0.1072D-02,0.1081D-02,0.1089D-02,0.1098D-02,0.1107D-02,
41767 &0.1115D-02,0.1124D-02,0.1132D-02,0.1141D-02,0.1149D-02,0.1158D-02,
41768 &0.1166D-02,0.1175D-02,0.1183D-02,0.1192D-02/
41769 DATA (XPV(I,2,0),I=1,100)/
41770 &0.1024D+00,0.1007D+00,0.9821D-01,0.9497D-01,0.9093D-01,0.8617D-01,
41771 &0.8086D-01,0.7731D-01,0.7566D-01,0.7338D-01,0.7048D-01,0.6700D-01,
41772 &0.6300D-01,0.5939D-01,0.5814D-01,0.5638D-01,0.5410D-01,0.5135D-01,
41773 &0.4819D-01,0.4580D-01,0.4460D-01,0.4293D-01,0.4087D-01,0.3843D-01,
41774 &0.3624D-01,0.3517D-01,0.3372D-01,0.3192D-01,0.2988D-01,0.2879D-01,
41775 &0.2755D-01,0.2602D-01,0.2454D-01,0.2352D-01,0.2224D-01,0.2097D-01,
41776 &0.1995D-01,0.1875D-01,0.1779D-01,0.1673D-01,0.1580D-01,0.1480D-01,
41777 &0.1393D-01,0.1305D-01,0.1218D-01,0.1136D-01,0.1055D-01,0.9801D-02,
41778 &0.9052D-02,0.8337D-02,0.7641D-02,0.6989D-02,0.6357D-02,0.5747D-02,
41779 &0.5179D-02,0.4637D-02,0.4127D-02,0.3663D-02,0.3232D-02,0.2840D-02,
41780 &0.2487D-02,0.2174D-02,0.1901D-02,0.1662D-02,0.1459D-02,0.1285D-02,
41781 &0.1137D-02,0.1010D-02,0.9006D-03,0.8023D-03,0.7126D-03,0.6276D-03,
41782 &0.5458D-03,0.4661D-03,0.3876D-03,0.3101D-03,0.2334D-03,0.1570D-03,
41783 &0.1486D-03,0.1404D-03,0.1322D-03,0.1242D-03,0.1162D-03,0.1084D-03,
41784 &0.1007D-03,0.9304D-04,0.8554D-04,0.7817D-04,0.7086D-04,0.6372D-04,
41785 &0.5670D-04,0.4982D-04,0.4307D-04,0.3647D-04,0.3005D-04,0.2382D-04,
41786 &0.1781D-04,0.1208D-04,0.6720D-05,0.1928D-05/
41787 DATA (XPV(I,2,1),I=1,100)/
41788 &0.1449D-02,0.1433D-02,0.1407D-02,0.1370D-02,0.1324D-02,0.1268D-02,
41789 &0.1204D-02,0.1163D-02,0.1147D-02,0.1123D-02,0.1089D-02,0.1048D-02,
41790 &0.1000D-02,0.9567D-03,0.9446D-03,0.9250D-03,0.8981D-03,0.8642D-03,
41791 &0.8244D-03,0.7951D-03,0.7821D-03,0.7623D-03,0.7362D-03,0.7043D-03,
41792 &0.6759D-03,0.6640D-03,0.6459D-03,0.6223D-03,0.5945D-03,0.5817D-03,
41793 &0.5660D-03,0.5455D-03,0.5256D-03,0.5132D-03,0.4963D-03,0.4794D-03,
41794 &0.4669D-03,0.4510D-03,0.4394D-03,0.4261D-03,0.4151D-03,0.4031D-03,
41795 &0.3934D-03,0.3838D-03,0.3747D-03,0.3666D-03,0.3591D-03,0.3533D-03,
41796 &0.3477D-03,0.3433D-03,0.3397D-03,0.3376D-03,0.3364D-03,0.3361D-03,
41797 &0.3375D-03,0.3399D-03,0.3437D-03,0.3492D-03,0.3562D-03,0.3648D-03,
41798 &0.3751D-03,0.3871D-03,0.4009D-03,0.4167D-03,0.4344D-03,0.4543D-03,
41799 &0.4760D-03,0.5003D-03,0.5268D-03,0.5558D-03,0.5876D-03,0.6226D-03,
41800 &0.6610D-03,0.7035D-03,0.7509D-03,0.8041D-03,0.8638D-03,0.9294D-03,
41801 &0.9367D-03,0.9440D-03,0.9511D-03,0.9581D-03,0.9648D-03,0.9714D-03,
41802 &0.9776D-03,0.9836D-03,0.9891D-03,0.9942D-03,0.9987D-03,0.1003D-02,
41803 &0.1006D-02,0.1008D-02,0.1008D-02,0.1007D-02,0.1004D-02,0.9977D-03,
41804 &0.9868D-03,0.9681D-03,0.9347D-03,0.8678D-03/
41805 DATA (XPV(I,2,2),I=1,100)/
41806 &0.3175D-02,0.3156D-02,0.3117D-02,0.3057D-02,0.2976D-02,0.2876D-02,
41807 &0.2760D-02,0.2689D-02,0.2666D-02,0.2625D-02,0.2566D-02,0.2489D-02,
41808 &0.2398D-02,0.2316D-02,0.2299D-02,0.2266D-02,0.2217D-02,0.2152D-02,
41809 &0.2073D-02,0.2018D-02,0.1998D-02,0.1962D-02,0.1911D-02,0.1847D-02,
41810 &0.1791D-02,0.1773D-02,0.1739D-02,0.1692D-02,0.1636D-02,0.1614D-02,
41811 &0.1586D-02,0.1545D-02,0.1506D-02,0.1485D-02,0.1452D-02,0.1420D-02,
41812 &0.1398D-02,0.1368D-02,0.1348D-02,0.1324D-02,0.1306D-02,0.1285D-02,
41813 &0.1271D-02,0.1256D-02,0.1243D-02,0.1233D-02,0.1224D-02,0.1220D-02,
41814 &0.1217D-02,0.1217D-02,0.1220D-02,0.1227D-02,0.1237D-02,0.1249D-02,
41815 &0.1267D-02,0.1288D-02,0.1313D-02,0.1345D-02,0.1381D-02,0.1422D-02,
41816 &0.1469D-02,0.1522D-02,0.1582D-02,0.1648D-02,0.1722D-02,0.1804D-02,
41817 &0.1893D-02,0.1992D-02,0.2099D-02,0.2216D-02,0.2345D-02,0.2486D-02,
41818 &0.2641D-02,0.2812D-02,0.3002D-02,0.3216D-02,0.3455D-02,0.3718D-02,
41819 &0.3748D-02,0.3777D-02,0.3806D-02,0.3833D-02,0.3861D-02,0.3887D-02,
41820 &0.3912D-02,0.3936D-02,0.3958D-02,0.3978D-02,0.3996D-02,0.4012D-02,
41821 &0.4024D-02,0.4032D-02,0.4035D-02,0.4031D-02,0.4018D-02,0.3993D-02,
41822 &0.3949D-02,0.3875D-02,0.3741D-02,0.3474D-02/
41823 DATA (XPV(I,2,3),I=1,100)/
41824 &0.1046D-02,0.1031D-02,0.1008D-02,0.9768D-03,0.9381D-03,0.8923D-03,
41825 &0.8410D-03,0.8074D-03,0.7928D-03,0.7720D-03,0.7450D-03,0.7121D-03,
41826 &0.6741D-03,0.6398D-03,0.6287D-03,0.6123D-03,0.5906D-03,0.5640D-03,
41827 &0.5332D-03,0.5101D-03,0.4988D-03,0.4827D-03,0.4624D-03,0.4380D-03,
41828 &0.4161D-03,0.4059D-03,0.3914D-03,0.3732D-03,0.3524D-03,0.3416D-03,
41829 &0.3290D-03,0.3133D-03,0.2981D-03,0.2878D-03,0.2747D-03,0.2616D-03,
41830 &0.2515D-03,0.2392D-03,0.2296D-03,0.2191D-03,0.2100D-03,0.2004D-03,
41831 &0.1923D-03,0.1842D-03,0.1764D-03,0.1694D-03,0.1627D-03,0.1571D-03,
41832 &0.1517D-03,0.1469D-03,0.1427D-03,0.1394D-03,0.1367D-03,0.1345D-03,
41833 &0.1333D-03,0.1327D-03,0.1329D-03,0.1340D-03,0.1360D-03,0.1387D-03,
41834 &0.1424D-03,0.1469D-03,0.1522D-03,0.1584D-03,0.1654D-03,0.1733D-03,
41835 &0.1819D-03,0.1915D-03,0.2019D-03,0.2132D-03,0.2257D-03,0.2396D-03,
41836 &0.2553D-03,0.2737D-03,0.2956D-03,0.3227D-03,0.3570D-03,0.4009D-03,
41837 &0.4064D-03,0.4119D-03,0.4175D-03,0.4231D-03,0.4287D-03,0.4344D-03,
41838 &0.4400D-03,0.4457D-03,0.4512D-03,0.4567D-03,0.4621D-03,0.4673D-03,
41839 &0.4723D-03,0.4769D-03,0.4811D-03,0.4848D-03,0.4875D-03,0.4891D-03,
41840 &0.4888D-03,0.4853D-03,0.4756D-03,0.4518D-03/
41841 DATA (XPV(I,2,4),I=1,100)/
41842 &0.1564D-02,0.1548D-02,0.1521D-02,0.1483D-02,0.1434D-02,0.1375D-02,
41843 &0.1308D-02,0.1265D-02,0.1249D-02,0.1223D-02,0.1188D-02,0.1145D-02,
41844 &0.1094D-02,0.1048D-02,0.1035D-02,0.1015D-02,0.9868D-03,0.9509D-03,
41845 &0.9086D-03,0.8776D-03,0.8644D-03,0.8436D-03,0.8161D-03,0.7822D-03,
41846 &0.7521D-03,0.7400D-03,0.7212D-03,0.6963D-03,0.6669D-03,0.6538D-03,
41847 &0.6377D-03,0.6163D-03,0.5956D-03,0.5832D-03,0.5658D-03,0.5486D-03,
41848 &0.5363D-03,0.5203D-03,0.5091D-03,0.4962D-03,0.4859D-03,0.4746D-03,
41849 &0.4661D-03,0.4578D-03,0.4502D-03,0.4441D-03,0.4387D-03,0.4355D-03,
41850 &0.4329D-03,0.4318D-03,0.4320D-03,0.4342D-03,0.4379D-03,0.4429D-03,
41851 &0.4503D-03,0.4594D-03,0.4704D-03,0.4839D-03,0.4996D-03,0.5177D-03,
41852 &0.5383D-03,0.5613D-03,0.5869D-03,0.6152D-03,0.6462D-03,0.6802D-03,
41853 &0.7167D-03,0.7565D-03,0.7995D-03,0.8461D-03,0.8972D-03,0.9538D-03,
41854 &0.1018D-02,0.1092D-02,0.1181D-02,0.1290D-02,0.1428D-02,0.1604D-02,
41855 &0.1626D-02,0.1649D-02,0.1671D-02,0.1694D-02,0.1716D-02,0.1739D-02,
41856 &0.1762D-02,0.1784D-02,0.1806D-02,0.1828D-02,0.1850D-02,0.1871D-02,
41857 &0.1891D-02,0.1909D-02,0.1926D-02,0.1941D-02,0.1952D-02,0.1958D-02,
41858 &0.1957D-02,0.1943D-02,0.1905D-02,0.1811D-02/
41859 DATA (XPV(I,3,0),I=1,100)/
41860 &0.1761D+00,0.1728D+00,0.1680D+00,0.1619D+00,0.1544D+00,0.1456D+00,
41861 &0.1358D+00,0.1292D+00,0.1260D+00,0.1218D+00,0.1165D+00,0.1101D+00,
41862 &0.1029D+00,0.9643D-01,0.9409D-01,0.9087D-01,0.8680D-01,0.8192D-01,
41863 &0.7638D-01,0.7217D-01,0.7000D-01,0.6708D-01,0.6352D-01,0.5934D-01,
41864 &0.5561D-01,0.5375D-01,0.5129D-01,0.4829D-01,0.4491D-01,0.4309D-01,
41865 &0.4104D-01,0.3857D-01,0.3618D-01,0.3454D-01,0.3252D-01,0.3053D-01,
41866 &0.2896D-01,0.2712D-01,0.2565D-01,0.2407D-01,0.2268D-01,0.2123D-01,
41867 &0.1997D-01,0.1870D-01,0.1748D-01,0.1634D-01,0.1523D-01,0.1422D-01,
41868 &0.1321D-01,0.1227D-01,0.1137D-01,0.1053D-01,0.9723D-02,0.8952D-02,
41869 &0.8241D-02,0.7563D-02,0.6926D-02,0.6345D-02,0.5801D-02,0.5298D-02,
41870 &0.4833D-02,0.4407D-02,0.4017D-02,0.3657D-02,0.3327D-02,0.3021D-02,
41871 &0.2735D-02,0.2469D-02,0.2217D-02,0.1976D-02,0.1746D-02,0.1522D-02,
41872 &0.1307D-02,0.1098D-02,0.8959D-03,0.7002D-03,0.5112D-03,0.3292D-03,
41873 &0.3097D-03,0.2906D-03,0.2718D-03,0.2534D-03,0.2354D-03,0.2178D-03,
41874 &0.2005D-03,0.1836D-03,0.1672D-03,0.1511D-03,0.1354D-03,0.1203D-03,
41875 &0.1055D-03,0.9128D-04,0.7756D-04,0.6440D-04,0.5185D-04,0.3998D-04,
41876 &0.2891D-04,0.1876D-04,0.9776D-05,0.2464D-05/
41877 DATA (XPV(I,3,1),I=1,100)/
41878 &0.3351D-02,0.3297D-02,0.3217D-02,0.3112D-02,0.2981D-02,0.2828D-02,
41879 &0.2656D-02,0.2543D-02,0.2493D-02,0.2422D-02,0.2332D-02,0.2223D-02,
41880 &0.2097D-02,0.1984D-02,0.1946D-02,0.1892D-02,0.1821D-02,0.1734D-02,
41881 &0.1635D-02,0.1560D-02,0.1523D-02,0.1471D-02,0.1406D-02,0.1329D-02,
41882 &0.1260D-02,0.1228D-02,0.1182D-02,0.1126D-02,0.1061D-02,0.1028D-02,
41883 &0.9902D-03,0.9426D-03,0.8967D-03,0.8664D-03,0.8274D-03,0.7890D-03,
41884 &0.7596D-03,0.7240D-03,0.6969D-03,0.6671D-03,0.6417D-03,0.6149D-03,
41885 &0.5928D-03,0.5708D-03,0.5502D-03,0.5317D-03,0.5144D-03,0.5002D-03,
41886 &0.4867D-03,0.4753D-03,0.4655D-03,0.4582D-03,0.4526D-03,0.4487D-03,
41887 &0.4475D-03,0.4480D-03,0.4506D-03,0.4559D-03,0.4632D-03,0.4729D-03,
41888 &0.4849D-03,0.4991D-03,0.5155D-03,0.5343D-03,0.5552D-03,0.5783D-03,
41889 &0.6033D-03,0.6307D-03,0.6600D-03,0.6915D-03,0.7256D-03,0.7626D-03,
41890 &0.8031D-03,0.8482D-03,0.8993D-03,0.9582D-03,0.1026D-02,0.1099D-02,
41891 &0.1107D-02,0.1115D-02,0.1122D-02,0.1129D-02,0.1136D-02,0.1142D-02,
41892 &0.1148D-02,0.1152D-02,0.1156D-02,0.1159D-02,0.1161D-02,0.1161D-02,
41893 &0.1160D-02,0.1156D-02,0.1150D-02,0.1141D-02,0.1127D-02,0.1107D-02,
41894 &0.1078D-02,0.1036D-02,0.9685D-03,0.8413D-03/
41895 DATA (XPV(I,3,2),I=1,100)/
41896 &0.5039D-02,0.4982D-02,0.4889D-02,0.4761D-02,0.4597D-02,0.4401D-02,
41897 &0.4179D-02,0.4036D-02,0.3979D-02,0.3893D-02,0.3777D-02,0.3634D-02,
41898 &0.3466D-02,0.3315D-02,0.3273D-02,0.3206D-02,0.3114D-02,0.2997D-02,
41899 &0.2860D-02,0.2760D-02,0.2717D-02,0.2650D-02,0.2562D-02,0.2454D-02,
41900 &0.2359D-02,0.2321D-02,0.2262D-02,0.2184D-02,0.2092D-02,0.2052D-02,
41901 &0.2003D-02,0.1938D-02,0.1875D-02,0.1839D-02,0.1787D-02,0.1736D-02,
41902 &0.1700D-02,0.1653D-02,0.1622D-02,0.1585D-02,0.1557D-02,0.1526D-02,
41903 &0.1504D-02,0.1483D-02,0.1464D-02,0.1450D-02,0.1438D-02,0.1433D-02,
41904 &0.1430D-02,0.1432D-02,0.1438D-02,0.1450D-02,0.1466D-02,0.1487D-02,
41905 &0.1515D-02,0.1547D-02,0.1585D-02,0.1631D-02,0.1683D-02,0.1742D-02,
41906 &0.1808D-02,0.1880D-02,0.1960D-02,0.2048D-02,0.2142D-02,0.2245D-02,
41907 &0.2354D-02,0.2471D-02,0.2596D-02,0.2729D-02,0.2872D-02,0.3025D-02,
41908 &0.3193D-02,0.3378D-02,0.3587D-02,0.3827D-02,0.4100D-02,0.4397D-02,
41909 &0.4429D-02,0.4461D-02,0.4490D-02,0.4519D-02,0.4545D-02,0.4570D-02,
41910 &0.4592D-02,0.4611D-02,0.4627D-02,0.4639D-02,0.4646D-02,0.4647D-02,
41911 &0.4642D-02,0.4628D-02,0.4604D-02,0.4566D-02,0.4510D-02,0.4431D-02,
41912 &0.4317D-02,0.4147D-02,0.3877D-02,0.3370D-02/
41913 DATA (XPV(I,3,3),I=1,100)/
41914 &0.2958D-02,0.2904D-02,0.2827D-02,0.2727D-02,0.2604D-02,0.2461D-02,
41915 &0.2301D-02,0.2195D-02,0.2146D-02,0.2079D-02,0.1995D-02,0.1894D-02,
41916 &0.1778D-02,0.1674D-02,0.1637D-02,0.1586D-02,0.1520D-02,0.1440D-02,
41917 &0.1349D-02,0.1280D-02,0.1245D-02,0.1197D-02,0.1138D-02,0.1068D-02,
41918 &0.1005D-02,0.9742D-03,0.9325D-03,0.8812D-03,0.8233D-03,0.7922D-03,
41919 &0.7568D-03,0.7138D-03,0.6722D-03,0.6438D-03,0.6084D-03,0.5735D-03,
41920 &0.5460D-03,0.5138D-03,0.4883D-03,0.4609D-03,0.4371D-03,0.4123D-03,
41921 &0.3912D-03,0.3704D-03,0.3507D-03,0.3327D-03,0.3158D-03,0.3012D-03,
41922 &0.2873D-03,0.2751D-03,0.2641D-03,0.2551D-03,0.2474D-03,0.2410D-03,
41923 &0.2365D-03,0.2334D-03,0.2318D-03,0.2321D-03,0.2339D-03,0.2372D-03,
41924 &0.2421D-03,0.2485D-03,0.2562D-03,0.2652D-03,0.2755D-03,0.2870D-03,
41925 &0.2995D-03,0.3131D-03,0.3278D-03,0.3438D-03,0.3615D-03,0.3814D-03,
41926 &0.4046D-03,0.4328D-03,0.4682D-03,0.5142D-03,0.5747D-03,0.6529D-03,
41927 &0.6625D-03,0.6722D-03,0.6819D-03,0.6916D-03,0.7012D-03,0.7107D-03,
41928 &0.7200D-03,0.7292D-03,0.7380D-03,0.7464D-03,0.7544D-03,0.7617D-03,
41929 &0.7681D-03,0.7735D-03,0.7776D-03,0.7798D-03,0.7796D-03,0.7761D-03,
41930 &0.7676D-03,0.7510D-03,0.7195D-03,0.6522D-03/
41931 DATA (XPV(I,3,4),I=1,100)/
41932 &0.3464D-02,0.3410D-02,0.3329D-02,0.3222D-02,0.3090D-02,0.2933D-02,
41933 &0.2758D-02,0.2643D-02,0.2593D-02,0.2521D-02,0.2430D-02,0.2318D-02,
41934 &0.2190D-02,0.2075D-02,0.2037D-02,0.1982D-02,0.1910D-02,0.1821D-02,
41935 &0.1720D-02,0.1643D-02,0.1607D-02,0.1554D-02,0.1489D-02,0.1410D-02,
41936 &0.1340D-02,0.1308D-02,0.1262D-02,0.1205D-02,0.1140D-02,0.1108D-02,
41937 &0.1070D-02,0.1023D-02,0.9772D-03,0.9482D-03,0.9103D-03,0.8732D-03,
41938 &0.8458D-03,0.8121D-03,0.7877D-03,0.7607D-03,0.7388D-03,0.7157D-03,
41939 &0.6981D-03,0.6812D-03,0.6662D-03,0.6540D-03,0.6438D-03,0.6377D-03,
41940 &0.6331D-03,0.6316D-03,0.6326D-03,0.6376D-03,0.6453D-03,0.6560D-03,
41941 &0.6708D-03,0.6887D-03,0.7102D-03,0.7361D-03,0.7656D-03,0.7991D-03,
41942 &0.8365D-03,0.8777D-03,0.9226D-03,0.9714D-03,0.1024D-02,0.1080D-02,
41943 &0.1138D-02,0.1201D-02,0.1267D-02,0.1338D-02,0.1415D-02,0.1501D-02,
41944 &0.1599D-02,0.1717D-02,0.1863D-02,0.2051D-02,0.2296D-02,0.2612D-02,
41945 &0.2650D-02,0.2689D-02,0.2729D-02,0.2767D-02,0.2806D-02,0.2844D-02,
41946 &0.2882D-02,0.2919D-02,0.2954D-02,0.2988D-02,0.3020D-02,0.3049D-02,
41947 &0.3075D-02,0.3097D-02,0.3114D-02,0.3123D-02,0.3122D-02,0.3108D-02,
41948 &0.3074D-02,0.3008D-02,0.2881D-02,0.2614D-02/
41949 DATA (XPV(I,4,0),I=1,100)/
41950 &0.2113D+00,0.2071D+00,0.2012D+00,0.1936D+00,0.1844D+00,0.1736D+00,
41951 &0.1616D+00,0.1536D+00,0.1497D+00,0.1445D+00,0.1380D+00,0.1303D+00,
41952 &0.1215D+00,0.1136D+00,0.1108D+00,0.1069D+00,0.1019D+00,0.9605D-01,
41953 &0.8939D-01,0.8432D-01,0.8171D-01,0.7821D-01,0.7395D-01,0.6897D-01,
41954 &0.6452D-01,0.6231D-01,0.5938D-01,0.5583D-01,0.5185D-01,0.4969D-01,
41955 &0.4728D-01,0.4438D-01,0.4158D-01,0.3967D-01,0.3731D-01,0.3500D-01,
41956 &0.3318D-01,0.3105D-01,0.2936D-01,0.2754D-01,0.2595D-01,0.2429D-01,
41957 &0.2285D-01,0.2141D-01,0.2003D-01,0.1874D-01,0.1749D-01,0.1635D-01,
41958 &0.1523D-01,0.1418D-01,0.1317D-01,0.1223D-01,0.1134D-01,0.1048D-01,
41959 &0.9692D-02,0.8938D-02,0.8227D-02,0.7578D-02,0.6967D-02,0.6398D-02,
41960 &0.5867D-02,0.5377D-02,0.4922D-02,0.4497D-02,0.4101D-02,0.3730D-02,
41961 &0.3379D-02,0.3048D-02,0.2732D-02,0.2429D-02,0.2139D-02,0.1858D-02,
41962 &0.1588D-02,0.1328D-02,0.1077D-02,0.8361D-03,0.6052D-03,0.3850D-03,
41963 &0.3616D-03,0.3387D-03,0.3162D-03,0.2943D-03,0.2728D-03,0.2518D-03,
41964 &0.2314D-03,0.2114D-03,0.1919D-03,0.1731D-03,0.1546D-03,0.1369D-03,
41965 &0.1197D-03,0.1032D-03,0.8729D-04,0.7214D-04,0.5778D-04,0.4429D-04,
41966 &0.3179D-04,0.2044D-04,0.1053D-04,0.2601D-05/
41967 DATA (XPV(I,4,1),I=1,100)/
41968 &0.4299D-02,0.4223D-02,0.4115D-02,0.3974D-02,0.3799D-02,0.3595D-02,
41969 &0.3367D-02,0.3216D-02,0.3148D-02,0.3054D-02,0.2934D-02,0.2790D-02,
41970 &0.2625D-02,0.2476D-02,0.2426D-02,0.2353D-02,0.2260D-02,0.2147D-02,
41971 &0.2018D-02,0.1920D-02,0.1871D-02,0.1804D-02,0.1720D-02,0.1620D-02,
41972 &0.1532D-02,0.1489D-02,0.1431D-02,0.1359D-02,0.1277D-02,0.1234D-02,
41973 &0.1185D-02,0.1125D-02,0.1067D-02,0.1028D-02,0.9791D-03,0.9308D-03,
41974 &0.8936D-03,0.8491D-03,0.8150D-03,0.7777D-03,0.7459D-03,0.7125D-03,
41975 &0.6849D-03,0.6575D-03,0.6318D-03,0.6088D-03,0.5872D-03,0.5693D-03,
41976 &0.5524D-03,0.5380D-03,0.5254D-03,0.5159D-03,0.5084D-03,0.5028D-03,
41977 &0.5003D-03,0.4998D-03,0.5017D-03,0.5066D-03,0.5139D-03,0.5237D-03,
41978 &0.5360D-03,0.5508D-03,0.5679D-03,0.5875D-03,0.6093D-03,0.6334D-03,
41979 &0.6593D-03,0.6876D-03,0.7177D-03,0.7500D-03,0.7848D-03,0.8225D-03,
41980 &0.8639D-03,0.9103D-03,0.9634D-03,0.1025D-02,0.1097D-02,0.1174D-02,
41981 &0.1183D-02,0.1191D-02,0.1199D-02,0.1206D-02,0.1212D-02,0.1219D-02,
41982 &0.1224D-02,0.1229D-02,0.1232D-02,0.1235D-02,0.1236D-02,0.1235D-02,
41983 &0.1232D-02,0.1227D-02,0.1219D-02,0.1207D-02,0.1190D-02,0.1167D-02,
41984 &0.1133D-02,0.1085D-02,0.1009D-02,0.8680D-03/
41985 DATA (XPV(I,4,2),I=1,100)/
41986 &0.5972D-02,0.5895D-02,0.5773D-02,0.5610D-02,0.5402D-02,0.5156D-02,
41987 &0.4878D-02,0.4698D-02,0.4623D-02,0.4513D-02,0.4369D-02,0.4191D-02,
41988 &0.3984D-02,0.3798D-02,0.3743D-02,0.3659D-02,0.3544D-02,0.3402D-02,
41989 &0.3235D-02,0.3113D-02,0.3058D-02,0.2976D-02,0.2870D-02,0.2740D-02,
41990 &0.2626D-02,0.2578D-02,0.2507D-02,0.2414D-02,0.2305D-02,0.2257D-02,
41991 &0.2198D-02,0.2121D-02,0.2046D-02,0.2003D-02,0.1942D-02,0.1882D-02,
41992 &0.1840D-02,0.1786D-02,0.1749D-02,0.1707D-02,0.1674D-02,0.1639D-02,
41993 &0.1613D-02,0.1589D-02,0.1567D-02,0.1551D-02,0.1538D-02,0.1533D-02,
41994 &0.1530D-02,0.1533D-02,0.1540D-02,0.1554D-02,0.1573D-02,0.1597D-02,
41995 &0.1628D-02,0.1665D-02,0.1709D-02,0.1760D-02,0.1818D-02,0.1884D-02,
41996 &0.1957D-02,0.2038D-02,0.2125D-02,0.2221D-02,0.2324D-02,0.2434D-02,
41997 &0.2551D-02,0.2676D-02,0.2807D-02,0.2946D-02,0.3095D-02,0.3254D-02,
41998 &0.3428D-02,0.3621D-02,0.3839D-02,0.4092D-02,0.4382D-02,0.4698D-02,
41999 &0.4731D-02,0.4764D-02,0.4795D-02,0.4824D-02,0.4851D-02,0.4876D-02,
42000 &0.4898D-02,0.4917D-02,0.4931D-02,0.4941D-02,0.4945D-02,0.4943D-02,
42001 &0.4933D-02,0.4913D-02,0.4881D-02,0.4833D-02,0.4766D-02,0.4671D-02,
42002 &0.4538D-02,0.4344D-02,0.4039D-02,0.3475D-02/
42003 DATA (XPV(I,4,3),I=1,100)/
42004 &0.3908D-02,0.3834D-02,0.3728D-02,0.3592D-02,0.3425D-02,0.3231D-02,
42005 &0.3015D-02,0.2871D-02,0.2804D-02,0.2714D-02,0.2600D-02,0.2464D-02,
42006 &0.2309D-02,0.2169D-02,0.2119D-02,0.2050D-02,0.1962D-02,0.1855D-02,
42007 &0.1735D-02,0.1643D-02,0.1596D-02,0.1532D-02,0.1453D-02,0.1361D-02,
42008 &0.1278D-02,0.1237D-02,0.1183D-02,0.1116D-02,0.1040D-02,0.9992D-03,
42009 &0.9531D-03,0.8972D-03,0.8434D-03,0.8065D-03,0.7608D-03,0.7159D-03,
42010 &0.6806D-03,0.6392D-03,0.6067D-03,0.5717D-03,0.5414D-03,0.5098D-03,
42011 &0.4831D-03,0.4567D-03,0.4317D-03,0.4090D-03,0.3877D-03,0.3693D-03,
42012 &0.3517D-03,0.3363D-03,0.3224D-03,0.3109D-03,0.3010D-03,0.2928D-03,
42013 &0.2869D-03,0.2826D-03,0.2801D-03,0.2799D-03,0.2814D-03,0.2848D-03,
42014 &0.2899D-03,0.2967D-03,0.3051D-03,0.3151D-03,0.3263D-03,0.3390D-03,
42015 &0.3528D-03,0.3678D-03,0.3841D-03,0.4018D-03,0.4214D-03,0.4437D-03,
42016 &0.4700D-03,0.5022D-03,0.5431D-03,0.5965D-03,0.6670D-03,0.7574D-03,
42017 &0.7684D-03,0.7795D-03,0.7905D-03,0.8015D-03,0.8124D-03,0.8230D-03,
42018 &0.8335D-03,0.8436D-03,0.8533D-03,0.8624D-03,0.8708D-03,0.8784D-03,
42019 &0.8849D-03,0.8901D-03,0.8934D-03,0.8945D-03,0.8925D-03,0.8863D-03,
42020 &0.8739D-03,0.8517D-03,0.8113D-03,0.7282D-03/
42021 DATA (XPV(I,4,4),I=1,100)/
42022 &0.4411D-02,0.4336D-02,0.4226D-02,0.4084D-02,0.3907D-02,0.3700D-02,
42023 &0.3469D-02,0.3316D-02,0.3248D-02,0.3153D-02,0.3032D-02,0.2886D-02,
42024 &0.2718D-02,0.2567D-02,0.2516D-02,0.2444D-02,0.2349D-02,0.2235D-02,
42025 &0.2103D-02,0.2004D-02,0.1956D-02,0.1888D-02,0.1804D-02,0.1703D-02,
42026 &0.1613D-02,0.1571D-02,0.1514D-02,0.1441D-02,0.1359D-02,0.1317D-02,
42027 &0.1269D-02,0.1210D-02,0.1153D-02,0.1116D-02,0.1069D-02,0.1022D-02,
42028 &0.9882D-03,0.9465D-03,0.9161D-03,0.8828D-03,0.8558D-03,0.8276D-03,
42029 &0.8060D-03,0.7854D-03,0.7672D-03,0.7526D-03,0.7404D-03,0.7330D-03,
42030 &0.7277D-03,0.7261D-03,0.7277D-03,0.7338D-03,0.7434D-03,0.7565D-03,
42031 &0.7745D-03,0.7963D-03,0.8222D-03,0.8532D-03,0.8886D-03,0.9283D-03,
42032 &0.9728D-03,0.1021D-02,0.1074D-02,0.1131D-02,0.1192D-02,0.1257D-02,
42033 &0.1325D-02,0.1397D-02,0.1473D-02,0.1554D-02,0.1642D-02,0.1739D-02,
42034 &0.1852D-02,0.1988D-02,0.2158D-02,0.2377D-02,0.2664D-02,0.3029D-02,
42035 &0.3074D-02,0.3119D-02,0.3163D-02,0.3207D-02,0.3251D-02,0.3294D-02,
42036 &0.3336D-02,0.3377D-02,0.3416D-02,0.3452D-02,0.3486D-02,0.3517D-02,
42037 &0.3543D-02,0.3564D-02,0.3578D-02,0.3582D-02,0.3574D-02,0.3549D-02,
42038 &0.3500D-02,0.3411D-02,0.3249D-02,0.2916D-02/
42039 DATA (XPV(I,5,0),I=1,100)/
42040 &0.3395D+00,0.3321D+00,0.3219D+00,0.3090D+00,0.2933D+00,0.2751D+00,
42041 &0.2550D+00,0.2414D+00,0.2348D+00,0.2261D+00,0.2153D+00,0.2025D+00,
42042 &0.1881D+00,0.1751D+00,0.1704D+00,0.1640D+00,0.1559D+00,0.1464D+00,
42043 &0.1357D+00,0.1276D+00,0.1233D+00,0.1178D+00,0.1110D+00,0.1032D+00,
42044 &0.9616D-01,0.9268D-01,0.8813D-01,0.8262D-01,0.7648D-01,0.7317D-01,
42045 &0.6948D-01,0.6506D-01,0.6083D-01,0.5795D-01,0.5442D-01,0.5097D-01,
42046 &0.4827D-01,0.4513D-01,0.4265D-01,0.4000D-01,0.3769D-01,0.3529D-01,
42047 &0.3322D-01,0.3117D-01,0.2920D-01,0.2737D-01,0.2561D-01,0.2402D-01,
42048 &0.2245D-01,0.2098D-01,0.1958D-01,0.1829D-01,0.1704D-01,0.1585D-01,
42049 &0.1476D-01,0.1370D-01,0.1270D-01,0.1178D-01,0.1090D-01,0.1007D-01,
42050 &0.9286D-02,0.8547D-02,0.7848D-02,0.7182D-02,0.6551D-02,0.5949D-02,
42051 &0.5372D-02,0.4823D-02,0.4298D-02,0.3794D-02,0.3314D-02,0.2852D-02,
42052 &0.2413D-02,0.1995D-02,0.1599D-02,0.1223D-02,0.8693D-03,0.5397D-03,
42053 &0.5052D-03,0.4716D-03,0.4388D-03,0.4068D-03,0.3757D-03,0.3454D-03,
42054 &0.3160D-03,0.2875D-03,0.2599D-03,0.2332D-03,0.2073D-03,0.1825D-03,
42055 &0.1587D-03,0.1359D-03,0.1142D-03,0.9370D-04,0.7445D-04,0.5655D-04,
42056 &0.4018D-04,0.2553D-04,0.1296D-04,0.3149D-05/
42057 DATA (XPV(I,5,1),I=1,100)/
42058 &0.7886D-02,0.7728D-02,0.7505D-02,0.7221D-02,0.6873D-02,0.6469D-02,
42059 &0.6022D-02,0.5723D-02,0.5585D-02,0.5398D-02,0.5164D-02,0.4885D-02,
42060 &0.4568D-02,0.4283D-02,0.4181D-02,0.4041D-02,0.3864D-02,0.3650D-02,
42061 &0.3408D-02,0.3225D-02,0.3131D-02,0.3005D-02,0.2850D-02,0.2668D-02,
42062 &0.2506D-02,0.2427D-02,0.2321D-02,0.2191D-02,0.2045D-02,0.1968D-02,
42063 &0.1880D-02,0.1774D-02,0.1672D-02,0.1604D-02,0.1519D-02,0.1435D-02,
42064 &0.1371D-02,0.1295D-02,0.1236D-02,0.1172D-02,0.1118D-02,0.1062D-02,
42065 &0.1015D-02,0.9690D-03,0.9257D-03,0.8867D-03,0.8503D-03,0.8197D-03,
42066 &0.7906D-03,0.7655D-03,0.7432D-03,0.7255D-03,0.7107D-03,0.6987D-03,
42067 &0.6911D-03,0.6864D-03,0.6850D-03,0.6876D-03,0.6934D-03,0.7025D-03,
42068 &0.7147D-03,0.7300D-03,0.7482D-03,0.7692D-03,0.7926D-03,0.8187D-03,
42069 &0.8465D-03,0.8768D-03,0.9089D-03,0.9431D-03,0.9801D-03,0.1020D-02,
42070 &0.1065D-02,0.1116D-02,0.1177D-02,0.1250D-02,0.1336D-02,0.1431D-02,
42071 &0.1441D-02,0.1451D-02,0.1460D-02,0.1468D-02,0.1476D-02,0.1483D-02,
42072 &0.1489D-02,0.1494D-02,0.1497D-02,0.1499D-02,0.1499D-02,0.1497D-02,
42073 &0.1492D-02,0.1483D-02,0.1471D-02,0.1454D-02,0.1430D-02,0.1398D-02,
42074 &0.1354D-02,0.1291D-02,0.1195D-02,0.1022D-02/
42075 DATA (XPV(I,5,2),I=1,100)/
42076 &0.9523D-02,0.9362D-02,0.9127D-02,0.8821D-02,0.8442D-02,0.7997D-02,
42077 &0.7501D-02,0.7174D-02,0.7029D-02,0.6828D-02,0.6569D-02,0.6258D-02,
42078 &0.5901D-02,0.5579D-02,0.5475D-02,0.5323D-02,0.5125D-02,0.4884D-02,
42079 &0.4606D-02,0.4399D-02,0.4301D-02,0.4162D-02,0.3986D-02,0.3776D-02,
42080 &0.3590D-02,0.3508D-02,0.3391D-02,0.3242D-02,0.3073D-02,0.2992D-02,
42081 &0.2897D-02,0.2777D-02,0.2663D-02,0.2592D-02,0.2499D-02,0.2408D-02,
42082 &0.2344D-02,0.2263D-02,0.2207D-02,0.2144D-02,0.2095D-02,0.2043D-02,
42083 &0.2005D-02,0.1970D-02,0.1939D-02,0.1917D-02,0.1898D-02,0.1891D-02,
42084 &0.1887D-02,0.1891D-02,0.1901D-02,0.1921D-02,0.1948D-02,0.1981D-02,
42085 &0.2025D-02,0.2076D-02,0.2134D-02,0.2204D-02,0.2281D-02,0.2367D-02,
42086 &0.2463D-02,0.2566D-02,0.2678D-02,0.2798D-02,0.2925D-02,0.3060D-02,
42087 &0.3199D-02,0.3347D-02,0.3500D-02,0.3659D-02,0.3827D-02,0.4007D-02,
42088 &0.4203D-02,0.4424D-02,0.4679D-02,0.4981D-02,0.5336D-02,0.5723D-02,
42089 &0.5764D-02,0.5803D-02,0.5840D-02,0.5875D-02,0.5906D-02,0.5934D-02,
42090 &0.5959D-02,0.5978D-02,0.5992D-02,0.6000D-02,0.6000D-02,0.5991D-02,
42091 &0.5971D-02,0.5938D-02,0.5890D-02,0.5821D-02,0.5726D-02,0.5597D-02,
42092 &0.5419D-02,0.5166D-02,0.4781D-02,0.4089D-02/
42093 DATA (XPV(I,5,3),I=1,100)/
42094 &0.7505D-02,0.7347D-02,0.7127D-02,0.6848D-02,0.6508D-02,0.6113D-02,
42095 &0.5677D-02,0.5385D-02,0.5248D-02,0.5065D-02,0.4837D-02,0.4566D-02,
42096 &0.4259D-02,0.3982D-02,0.3881D-02,0.3744D-02,0.3571D-02,0.3365D-02,
42097 &0.3131D-02,0.2953D-02,0.2861D-02,0.2738D-02,0.2589D-02,0.2414D-02,
42098 &0.2257D-02,0.2179D-02,0.2077D-02,0.1952D-02,0.1812D-02,0.1736D-02,
42099 &0.1651D-02,0.1549D-02,0.1451D-02,0.1384D-02,0.1302D-02,0.1222D-02,
42100 &0.1159D-02,0.1086D-02,0.1028D-02,0.9666D-03,0.9136D-03,0.8587D-03,
42101 &0.8123D-03,0.7666D-03,0.7236D-03,0.6846D-03,0.6479D-03,0.6163D-03,
42102 &0.5861D-03,0.5595D-03,0.5354D-03,0.5152D-03,0.4975D-03,0.4824D-03,
42103 &0.4710D-03,0.4620D-03,0.4558D-03,0.4530D-03,0.4527D-03,0.4552D-03,
42104 &0.4601D-03,0.4675D-03,0.4771D-03,0.4889D-03,0.5026D-03,0.5181D-03,
42105 &0.5351D-03,0.5540D-03,0.5746D-03,0.5972D-03,0.6228D-03,0.6525D-03,
42106 &0.6882D-03,0.7329D-03,0.7908D-03,0.8669D-03,0.9668D-03,0.1092D-02,
42107 &0.1106D-02,0.1121D-02,0.1136D-02,0.1150D-02,0.1164D-02,0.1178D-02,
42108 &0.1191D-02,0.1203D-02,0.1214D-02,0.1225D-02,0.1234D-02,0.1242D-02,
42109 &0.1247D-02,0.1250D-02,0.1251D-02,0.1247D-02,0.1239D-02,0.1224D-02,
42110 &0.1199D-02,0.1159D-02,0.1093D-02,0.9633D-03/
42111 DATA (XPV(I,5,4),I=1,100)/
42112 &0.7997D-02,0.7838D-02,0.7615D-02,0.7329D-02,0.6980D-02,0.6573D-02,
42113 &0.6123D-02,0.5823D-02,0.5684D-02,0.5497D-02,0.5261D-02,0.4981D-02,
42114 &0.4662D-02,0.4375D-02,0.4274D-02,0.4134D-02,0.3955D-02,0.3741D-02,
42115 &0.3497D-02,0.3313D-02,0.3221D-02,0.3095D-02,0.2940D-02,0.2758D-02,
42116 &0.2596D-02,0.2518D-02,0.2414D-02,0.2285D-02,0.2140D-02,0.2065D-02,
42117 &0.1981D-02,0.1877D-02,0.1779D-02,0.1715D-02,0.1634D-02,0.1555D-02,
42118 &0.1497D-02,0.1427D-02,0.1376D-02,0.1320D-02,0.1276D-02,0.1229D-02,
42119 &0.1194D-02,0.1161D-02,0.1131D-02,0.1108D-02,0.1089D-02,0.1077D-02,
42120 &0.1069D-02,0.1067D-02,0.1070D-02,0.1080D-02,0.1095D-02,0.1116D-02,
42121 &0.1144D-02,0.1178D-02,0.1218D-02,0.1265D-02,0.1318D-02,0.1378D-02,
42122 &0.1444D-02,0.1516D-02,0.1594D-02,0.1677D-02,0.1764D-02,0.1858D-02,
42123 &0.1954D-02,0.2056D-02,0.2162D-02,0.2275D-02,0.2398D-02,0.2536D-02,
42124 &0.2696D-02,0.2890D-02,0.3134D-02,0.3450D-02,0.3859D-02,0.4365D-02,
42125 &0.4425D-02,0.4485D-02,0.4544D-02,0.4602D-02,0.4658D-02,0.4713D-02,
42126 &0.4765D-02,0.4815D-02,0.4861D-02,0.4903D-02,0.4940D-02,0.4970D-02,
42127 &0.4993D-02,0.5007D-02,0.5008D-02,0.4994D-02,0.4961D-02,0.4900D-02,
42128 &0.4801D-02,0.4642D-02,0.4373D-02,0.3853D-02/
42129 DATA (XPV(I,6,0),I=1,100)/
42130 &0.4823D+00,0.4713D+00,0.4562D+00,0.4371D+00,0.4141D+00,0.3874D+00,
42131 &0.3580D+00,0.3381D+00,0.3284D+00,0.3157D+00,0.3000D+00,0.2816D+00,
42132 &0.2609D+00,0.2422D+00,0.2354D+00,0.2262D+00,0.2147D+00,0.2012D+00,
42133 &0.1860D+00,0.1744D+00,0.1685D+00,0.1606D+00,0.1511D+00,0.1401D+00,
42134 &0.1304D+00,0.1255D+00,0.1192D+00,0.1116D+00,0.1031D+00,0.9852D-01,
42135 &0.9345D-01,0.8740D-01,0.8162D-01,0.7769D-01,0.7289D-01,0.6822D-01,
42136 &0.6457D-01,0.6033D-01,0.5700D-01,0.5343D-01,0.5035D-01,0.4714D-01,
42137 &0.4439D-01,0.4166D-01,0.3905D-01,0.3663D-01,0.3429D-01,0.3219D-01,
42138 &0.3012D-01,0.2819D-01,0.2634D-01,0.2464D-01,0.2300D-01,0.2142D-01,
42139 &0.1997D-01,0.1857D-01,0.1723D-01,0.1600D-01,0.1482D-01,0.1370D-01,
42140 &0.1263D-01,0.1162D-01,0.1065D-01,0.9734D-02,0.8858D-02,0.8020D-02,
42141 &0.7218D-02,0.6455D-02,0.5727D-02,0.5031D-02,0.4372D-02,0.3743D-02,
42142 &0.3148D-02,0.2587D-02,0.2059D-02,0.1563D-02,0.1101D-02,0.6756D-03,
42143 &0.6315D-03,0.5886D-03,0.5468D-03,0.5062D-03,0.4667D-03,0.4284D-03,
42144 &0.3913D-03,0.3553D-03,0.3206D-03,0.2871D-03,0.2547D-03,0.2238D-03,
42145 &0.1942D-03,0.1660D-03,0.1392D-03,0.1139D-03,0.9030D-04,0.6843D-04,
42146 &0.4849D-04,0.3074D-04,0.1557D-04,0.3784D-05/
42147 DATA (XPV(I,6,1),I=1,100)/
42148 &0.1205D-01,0.1178D-01,0.1142D-01,0.1096D-01,0.1041D-01,0.9763D-02,
42149 &0.9053D-02,0.8577D-02,0.8354D-02,0.8057D-02,0.7688D-02,0.7251D-02,
42150 &0.6756D-02,0.6310D-02,0.6149D-02,0.5929D-02,0.5654D-02,0.5325D-02,
42151 &0.4953D-02,0.4670D-02,0.4526D-02,0.4332D-02,0.4097D-02,0.3822D-02,
42152 &0.3577D-02,0.3456D-02,0.3297D-02,0.3102D-02,0.2885D-02,0.2769D-02,
42153 &0.2639D-02,0.2483D-02,0.2333D-02,0.2232D-02,0.2107D-02,0.1985D-02,
42154 &0.1891D-02,0.1781D-02,0.1696D-02,0.1604D-02,0.1526D-02,0.1445D-02,
42155 &0.1377D-02,0.1310D-02,0.1248D-02,0.1192D-02,0.1139D-02,0.1094D-02,
42156 &0.1052D-02,0.1015D-02,0.9816D-03,0.9544D-03,0.9311D-03,0.9114D-03,
42157 &0.8975D-03,0.8872D-03,0.8810D-03,0.8801D-03,0.8830D-03,0.8899D-03,
42158 &0.9007D-03,0.9151D-03,0.9330D-03,0.9541D-03,0.9781D-03,0.1005D-02,
42159 &0.1034D-02,0.1065D-02,0.1099D-02,0.1135D-02,0.1174D-02,0.1217D-02,
42160 &0.1266D-02,0.1323D-02,0.1392D-02,0.1478D-02,0.1581D-02,0.1696D-02,
42161 &0.1708D-02,0.1720D-02,0.1731D-02,0.1741D-02,0.1751D-02,0.1759D-02,
42162 &0.1766D-02,0.1772D-02,0.1776D-02,0.1778D-02,0.1778D-02,0.1775D-02,
42163 &0.1769D-02,0.1759D-02,0.1744D-02,0.1723D-02,0.1695D-02,0.1657D-02,
42164 &0.1604D-02,0.1530D-02,0.1417D-02,0.1218D-02/
42165 DATA (XPV(I,6,2),I=1,100)/
42166 &0.1365D-01,0.1339D-01,0.1302D-01,0.1254D-01,0.1195D-01,0.1127D-01,
42167 &0.1051D-01,0.1001D-01,0.9777D-02,0.9465D-02,0.9073D-02,0.8604D-02,
42168 &0.8069D-02,0.7589D-02,0.7425D-02,0.7195D-02,0.6900D-02,0.6544D-02,
42169 &0.6138D-02,0.5834D-02,0.5686D-02,0.5481D-02,0.5226D-02,0.4925D-02,
42170 &0.4658D-02,0.4536D-02,0.4367D-02,0.4157D-02,0.3918D-02,0.3801D-02,
42171 &0.3667D-02,0.3499D-02,0.3340D-02,0.3241D-02,0.3112D-02,0.2987D-02,
42172 &0.2897D-02,0.2787D-02,0.2709D-02,0.2624D-02,0.2557D-02,0.2487D-02,
42173 &0.2436D-02,0.2387D-02,0.2346D-02,0.2315D-02,0.2290D-02,0.2279D-02,
42174 &0.2273D-02,0.2277D-02,0.2289D-02,0.2313D-02,0.2346D-02,0.2387D-02,
42175 &0.2441D-02,0.2503D-02,0.2575D-02,0.2660D-02,0.2755D-02,0.2859D-02,
42176 &0.2974D-02,0.3099D-02,0.3232D-02,0.3374D-02,0.3523D-02,0.3680D-02,
42177 &0.3841D-02,0.4010D-02,0.4183D-02,0.4363D-02,0.4552D-02,0.4754D-02,
42178 &0.4976D-02,0.5229D-02,0.5526D-02,0.5885D-02,0.6313D-02,0.6782D-02,
42179 &0.6832D-02,0.6879D-02,0.6924D-02,0.6966D-02,0.7004D-02,0.7038D-02,
42180 &0.7067D-02,0.7091D-02,0.7108D-02,0.7117D-02,0.7116D-02,0.7105D-02,
42181 &0.7081D-02,0.7041D-02,0.6982D-02,0.6899D-02,0.6786D-02,0.6631D-02,
42182 &0.6421D-02,0.6123D-02,0.5672D-02,0.4871D-02/
42183 DATA (XPV(I,6,3),I=1,100)/
42184 &0.1167D-01,0.1141D-01,0.1105D-01,0.1060D-01,0.1005D-01,0.9414D-02,
42185 &0.8715D-02,0.8245D-02,0.8024D-02,0.7730D-02,0.7367D-02,0.6937D-02,
42186 &0.6451D-02,0.6013D-02,0.5853D-02,0.5637D-02,0.5366D-02,0.5044D-02,
42187 &0.4680D-02,0.4403D-02,0.4259D-02,0.4069D-02,0.3839D-02,0.3571D-02,
42188 &0.3331D-02,0.3212D-02,0.3055D-02,0.2866D-02,0.2654D-02,0.2540D-02,
42189 &0.2413D-02,0.2260D-02,0.2114D-02,0.2014D-02,0.1892D-02,0.1773D-02,
42190 &0.1680D-02,0.1572D-02,0.1488D-02,0.1398D-02,0.1320D-02,0.1240D-02,
42191 &0.1173D-02,0.1106D-02,0.1044D-02,0.9874D-03,0.9342D-03,0.8881D-03,
42192 &0.8442D-03,0.8052D-03,0.7698D-03,0.7399D-03,0.7134D-03,0.6903D-03,
42193 &0.6722D-03,0.6574D-03,0.6463D-03,0.6397D-03,0.6365D-03,0.6368D-03,
42194 &0.6405D-03,0.6473D-03,0.6570D-03,0.6695D-03,0.6844D-03,0.7019D-03,
42195 &0.7213D-03,0.7431D-03,0.7673D-03,0.7943D-03,0.8253D-03,0.8617D-03,
42196 &0.9063D-03,0.9627D-03,0.1036D-02,0.1133D-02,0.1259D-02,0.1412D-02,
42197 &0.1430D-02,0.1448D-02,0.1465D-02,0.1482D-02,0.1499D-02,0.1514D-02,
42198 &0.1529D-02,0.1543D-02,0.1556D-02,0.1567D-02,0.1576D-02,0.1583D-02,
42199 &0.1587D-02,0.1588D-02,0.1586D-02,0.1578D-02,0.1563D-02,0.1539D-02,
42200 &0.1504D-02,0.1448D-02,0.1358D-02,0.1189D-02/
42201 DATA (XPV(I,6,4),I=1,100)/
42202 &0.1216D-01,0.1189D-01,0.1153D-01,0.1107D-01,0.1051D-01,0.9868D-02,
42203 &0.9154D-02,0.8677D-02,0.8454D-02,0.8157D-02,0.7787D-02,0.7349D-02,
42204 &0.6851D-02,0.6404D-02,0.6244D-02,0.6025D-02,0.5749D-02,0.5420D-02,
42205 &0.5047D-02,0.4764D-02,0.4621D-02,0.4429D-02,0.4195D-02,0.3920D-02,
42206 &0.3677D-02,0.3559D-02,0.3402D-02,0.3211D-02,0.2996D-02,0.2884D-02,
42207 &0.2759D-02,0.2608D-02,0.2463D-02,0.2369D-02,0.2251D-02,0.2138D-02,
42208 &0.2053D-02,0.1952D-02,0.1879D-02,0.1800D-02,0.1736D-02,0.1670D-02,
42209 &0.1619D-02,0.1572D-02,0.1531D-02,0.1498D-02,0.1470D-02,0.1454D-02,
42210 &0.1442D-02,0.1439D-02,0.1442D-02,0.1455D-02,0.1475D-02,0.1502D-02,
42211 &0.1539D-02,0.1584D-02,0.1637D-02,0.1699D-02,0.1769D-02,0.1847D-02,
42212 &0.1934D-02,0.2027D-02,0.2128D-02,0.2235D-02,0.2348D-02,0.2468D-02,
42213 &0.2591D-02,0.2721D-02,0.2857D-02,0.3001D-02,0.3158D-02,0.3333D-02,
42214 &0.3538D-02,0.3788D-02,0.4102D-02,0.4506D-02,0.5022D-02,0.5648D-02,
42215 &0.5720D-02,0.5792D-02,0.5862D-02,0.5931D-02,0.5997D-02,0.6060D-02,
42216 &0.6120D-02,0.6176D-02,0.6226D-02,0.6271D-02,0.6308D-02,0.6337D-02,
42217 &0.6354D-02,0.6359D-02,0.6348D-02,0.6316D-02,0.6257D-02,0.6163D-02,
42218 &0.6019D-02,0.5797D-02,0.5436D-02,0.4755D-02/
42219 DATA (XPV(I,7,0),I=1,100)/
42220 &0.6367D+00,0.6216D+00,0.6010D+00,0.5752D+00,0.5440D+00,0.5081D+00,
42221 &0.4686D+00,0.4418D+00,0.4287D+00,0.4116D+00,0.3907D+00,0.3662D+00,
42222 &0.3385D+00,0.3137D+00,0.3045D+00,0.2923D+00,0.2772D+00,0.2594D+00,
42223 &0.2393D+00,0.2241D+00,0.2163D+00,0.2060D+00,0.1936D+00,0.1792D+00,
42224 &0.1665D+00,0.1602D+00,0.1520D+00,0.1421D+00,0.1311D+00,0.1252D+00,
42225 &0.1187D+00,0.1109D+00,0.1035D+00,0.9842D-01,0.9228D-01,0.8630D-01,
42226 &0.8164D-01,0.7624D-01,0.7200D-01,0.6747D-01,0.6355D-01,0.5948D-01,
42227 &0.5601D-01,0.5255D-01,0.4926D-01,0.4620D-01,0.4326D-01,0.4061D-01,
42228 &0.3801D-01,0.3557D-01,0.3324D-01,0.3109D-01,0.2903D-01,0.2705D-01,
42229 &0.2521D-01,0.2344D-01,0.2175D-01,0.2018D-01,0.1868D-01,0.1725D-01,
42230 &0.1589D-01,0.1460D-01,0.1337D-01,0.1219D-01,0.1107D-01,0.9999D-02,
42231 &0.8975D-02,0.8003D-02,0.7079D-02,0.6199D-02,0.5369D-02,0.4581D-02,
42232 &0.3839D-02,0.3144D-02,0.2492D-02,0.1883D-02,0.1320D-02,0.8054D-03,
42233 &0.7523D-03,0.7006D-03,0.6504D-03,0.6016D-03,0.5543D-03,0.5084D-03,
42234 &0.4640D-03,0.4210D-03,0.3796D-03,0.3397D-03,0.3011D-03,0.2644D-03,
42235 &0.2292D-03,0.1957D-03,0.1640D-03,0.1342D-03,0.1063D-03,0.8046D-04,
42236 &0.5699D-04,0.3611D-04,0.1829D-04,0.4453D-05/
42237 DATA (XPV(I,7,1),I=1,100)/
42238 &0.1667D-01,0.1629D-01,0.1577D-01,0.1511D-01,0.1431D-01,0.1340D-01,
42239 &0.1239D-01,0.1171D-01,0.1139D-01,0.1097D-01,0.1045D-01,0.9835D-02,
42240 &0.9139D-02,0.8514D-02,0.8286D-02,0.7979D-02,0.7594D-02,0.7137D-02,
42241 &0.6621D-02,0.6230D-02,0.6029D-02,0.5762D-02,0.5438D-02,0.5061D-02,
42242 &0.4726D-02,0.4560D-02,0.4342D-02,0.4078D-02,0.3784D-02,0.3626D-02,
42243 &0.3451D-02,0.3240D-02,0.3038D-02,0.2902D-02,0.2735D-02,0.2572D-02,
42244 &0.2446D-02,0.2299D-02,0.2185D-02,0.2064D-02,0.1960D-02,0.1852D-02,
42245 &0.1762D-02,0.1673D-02,0.1591D-02,0.1516D-02,0.1446D-02,0.1386D-02,
42246 &0.1329D-02,0.1278D-02,0.1233D-02,0.1195D-02,0.1162D-02,0.1134D-02,
42247 &0.1113D-02,0.1096D-02,0.1084D-02,0.1078D-02,0.1077D-02,0.1081D-02,
42248 &0.1090D-02,0.1103D-02,0.1119D-02,0.1140D-02,0.1164D-02,0.1191D-02,
42249 &0.1220D-02,0.1253D-02,0.1288D-02,0.1325D-02,0.1367D-02,0.1413D-02,
42250 &0.1466D-02,0.1530D-02,0.1609D-02,0.1708D-02,0.1830D-02,0.1967D-02,
42251 &0.1981D-02,0.1995D-02,0.2008D-02,0.2021D-02,0.2032D-02,0.2042D-02,
42252 &0.2051D-02,0.2058D-02,0.2063D-02,0.2066D-02,0.2066D-02,0.2063D-02,
42253 &0.2057D-02,0.2045D-02,0.2029D-02,0.2005D-02,0.1973D-02,0.1929D-02,
42254 &0.1869D-02,0.1784D-02,0.1655D-02,0.1427D-02/
42255 DATA (XPV(I,7,2),I=1,100)/
42256 &0.1825D-01,0.1787D-01,0.1734D-01,0.1666D-01,0.1584D-01,0.1488D-01,
42257 &0.1382D-01,0.1312D-01,0.1280D-01,0.1236D-01,0.1182D-01,0.1117D-01,
42258 &0.1044D-01,0.9780D-02,0.9550D-02,0.9233D-02,0.8830D-02,0.8348D-02,
42259 &0.7799D-02,0.7387D-02,0.7184D-02,0.6906D-02,0.6565D-02,0.6163D-02,
42260 &0.5808D-02,0.5642D-02,0.5418D-02,0.5140D-02,0.4827D-02,0.4670D-02,
42261 &0.4493D-02,0.4274D-02,0.4067D-02,0.3936D-02,0.3769D-02,0.3607D-02,
42262 &0.3489D-02,0.3347D-02,0.3246D-02,0.3136D-02,0.3050D-02,0.2959D-02,
42263 &0.2893D-02,0.2830D-02,0.2777D-02,0.2736D-02,0.2703D-02,0.2687D-02,
42264 &0.2678D-02,0.2680D-02,0.2693D-02,0.2720D-02,0.2757D-02,0.2805D-02,
42265 &0.2867D-02,0.2940D-02,0.3024D-02,0.3123D-02,0.3233D-02,0.3355D-02,
42266 &0.3489D-02,0.3632D-02,0.3785D-02,0.3948D-02,0.4118D-02,0.4297D-02,
42267 &0.4479D-02,0.4668D-02,0.4863D-02,0.5063D-02,0.5274D-02,0.5499D-02,
42268 &0.5750D-02,0.6038D-02,0.6381D-02,0.6800D-02,0.7306D-02,0.7864D-02,
42269 &0.7924D-02,0.7980D-02,0.8034D-02,0.8085D-02,0.8131D-02,0.8172D-02,
42270 &0.8208D-02,0.8236D-02,0.8258D-02,0.8270D-02,0.8271D-02,0.8259D-02,
42271 &0.8233D-02,0.8188D-02,0.8122D-02,0.8027D-02,0.7897D-02,0.7721D-02,
42272 &0.7480D-02,0.7139D-02,0.6624D-02,0.5709D-02/
42273 DATA (XPV(I,7,3),I=1,100)/
42274 &0.1630D-01,0.1592D-01,0.1540D-01,0.1475D-01,0.1396D-01,0.1305D-01,
42275 &0.1205D-01,0.1138D-01,0.1107D-01,0.1065D-01,0.1013D-01,0.9526D-02,
42276 &0.8839D-02,0.8222D-02,0.7995D-02,0.7690D-02,0.7310D-02,0.6860D-02,
42277 &0.6352D-02,0.5966D-02,0.5766D-02,0.5502D-02,0.5183D-02,0.4813D-02,
42278 &0.4483D-02,0.4318D-02,0.4103D-02,0.3844D-02,0.3555D-02,0.3399D-02,
42279 &0.3225D-02,0.3018D-02,0.2820D-02,0.2685D-02,0.2521D-02,0.2360D-02,
42280 &0.2235D-02,0.2091D-02,0.1978D-02,0.1857D-02,0.1754D-02,0.1647D-02,
42281 &0.1557D-02,0.1468D-02,0.1385D-02,0.1310D-02,0.1239D-02,0.1177D-02,
42282 &0.1118D-02,0.1066D-02,0.1018D-02,0.9774D-03,0.9411D-03,0.9091D-03,
42283 &0.8835D-03,0.8619D-03,0.8450D-03,0.8338D-03,0.8268D-03,0.8242D-03,
42284 &0.8257D-03,0.8312D-03,0.8403D-03,0.8529D-03,0.8686D-03,0.8875D-03,
42285 &0.9087D-03,0.9331D-03,0.9605D-03,0.9915D-03,0.1028D-02,0.1070D-02,
42286 &0.1124D-02,0.1191D-02,0.1279D-02,0.1395D-02,0.1545D-02,0.1725D-02,
42287 &0.1746D-02,0.1766D-02,0.1786D-02,0.1805D-02,0.1823D-02,0.1841D-02,
42288 &0.1857D-02,0.1872D-02,0.1886D-02,0.1897D-02,0.1907D-02,0.1913D-02,
42289 &0.1916D-02,0.1915D-02,0.1909D-02,0.1897D-02,0.1877D-02,0.1846D-02,
42290 &0.1799D-02,0.1729D-02,0.1618D-02,0.1411D-02/
42291 DATA (XPV(I,7,4),I=1,100)/
42292 &0.1678D-01,0.1640D-01,0.1587D-01,0.1522D-01,0.1442D-01,0.1350D-01,
42293 &0.1249D-01,0.1181D-01,0.1149D-01,0.1107D-01,0.1055D-01,0.9935D-02,
42294 &0.9238D-02,0.8611D-02,0.8385D-02,0.8078D-02,0.7694D-02,0.7237D-02,
42295 &0.6721D-02,0.6331D-02,0.6132D-02,0.5867D-02,0.5545D-02,0.5170D-02,
42296 &0.4837D-02,0.4676D-02,0.4462D-02,0.4202D-02,0.3912D-02,0.3761D-02,
42297 &0.3592D-02,0.3388D-02,0.3194D-02,0.3068D-02,0.2911D-02,0.2759D-02,
42298 &0.2646D-02,0.2513D-02,0.2415D-02,0.2310D-02,0.2226D-02,0.2139D-02,
42299 &0.2072D-02,0.2010D-02,0.1955D-02,0.1911D-02,0.1875D-02,0.1852D-02,
42300 &0.1836D-02,0.1830D-02,0.1833D-02,0.1848D-02,0.1872D-02,0.1905D-02,
42301 &0.1950D-02,0.2004D-02,0.2069D-02,0.2145D-02,0.2231D-02,0.2327D-02,
42302 &0.2432D-02,0.2547D-02,0.2669D-02,0.2800D-02,0.2937D-02,0.3082D-02,
42303 &0.3232D-02,0.3389D-02,0.3553D-02,0.3727D-02,0.3917D-02,0.4130D-02,
42304 &0.4378D-02,0.4681D-02,0.5061D-02,0.5547D-02,0.6163D-02,0.6897D-02,
42305 &0.6981D-02,0.7063D-02,0.7144D-02,0.7221D-02,0.7296D-02,0.7367D-02,
42306 &0.7433D-02,0.7494D-02,0.7548D-02,0.7595D-02,0.7632D-02,0.7658D-02,
42307 &0.7671D-02,0.7667D-02,0.7644D-02,0.7595D-02,0.7513D-02,0.7388D-02,
42308 &0.7203D-02,0.6923D-02,0.6476D-02,0.5646D-02/
42315 ENT(I)=LOG10(XT(I))
42320 ENT(IX+I)=LOG10(Q2T(I))
42324 C..various flavours (u-->2,d-->1)
42325 XPDF(0)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,0))
42326 XPDF(1)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,1))
42327 XPDF(2)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,2))
42328 XPDF(3)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,3))
42329 XPDF(4)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,4))
42336 *$ CREATE PHO_DBFINT.FOR
42338 CDECK ID>, PHO_DBFINT
42339 DOUBLE PRECISION FUNCTION PHO_DBFINT(NARG,ARG,NA,ENT,TABLE)
42340 C***********************************************************************
42342 C routine based on CERN library E104
42344 C multi-dimensional interpolation routine, needed for PHOJET
42345 C internal cross section tables and several PDF sets (GRV98 and AGL)
42347 C changed to avoid recursive function calls (R.Engel, 09/98)
42349 C***********************************************************************
42350 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
42353 INTEGER NA(NARG), INDEX(32)
42354 DOUBLE PRECISION ARG(NARG),ENT(NARG),TABLE(*),WEIGHT(32)
42361 IF(NARG .LT. 1 .OR. NARG .GT. 5) RETURN
42374 IF(NDIM .GT. 2) GOTO 10
42375 IF(NDIM .EQ. 1) GOTO 100
42377 IF(H .EQ. ZEROD) GOTO 90
42379 IF(X-ENT(LMIN+1) .EQ. ZEROD) GOTO 21
42381 ETA = H / (ENT(LMIN+1) - ENT(LMIN))
42384 11 LOCC = (LOCA+LOCB) / 2
42385 IF(X-ENT(LOCC)) 12, 20, 13
42389 14 IF(LOCB-LOCA .GT. 1) GOTO 11
42390 LOCA = MIN ( MAX (LOCA,LMIN), LMAX-1 )
42391 ISHIFT = (LOCA - LMIN) * ISTEP
42392 ETA = (X - ENT(LOCA)) / (ENT(LOCA+1) - ENT(LOCA))
42394 20 ISHIFT = (LOCC - LMIN) * ISTEP
42395 21 DO 22 K = 1, KNOTS
42396 INDEX(K) = INDEX(K) + ISHIFT
42399 30 DO 31 K = 1, KNOTS
42400 INDEX(K) = INDEX(K) + ISHIFT
42401 INDEX(K+KNOTS) = INDEX(K) + ISTEP
42402 WEIGHT(K+KNOTS) = WEIGHT(K) * ETA
42403 WEIGHT(K) = WEIGHT(K) - WEIGHT(K+KNOTS)
42406 90 ISTEP = ISTEP * NDIM
42408 DO 200 K = 1, KNOTS
42410 DBFINT = DBFINT + WEIGHT(K) * TABLE(I)
42413 PHO_DBFINT = DBFINT
42417 *$ CREATE PHVAL.FOR
42420 SUBROUTINE PHVAL(IGRP,ISET,XI,SCALE2,PD,IRET)
42421 C**********************************************************************
42423 C dummy subroutine, remove to link PHOLIB
42425 C**********************************************************************
42426 IMPLICIT DOUBLE PRECISION (A-H,O-Z)