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
34 C interface to PYTHIA 6.1 (or higher)
35 C for usage in DPMJET 3.x (Lund common block dimensions increased)
37 C***********************************************************************
40 C List of subroutines and functions
41 C ---------------------------------
44 C main event simulation routines
54 C user steering interface
60 C experimental setup / photon flux calculation
94 C cross section calculation
114 C multiple interaction structure
122 C hadron / photon remnant treatment, soft x selection
143 C primordial kt and soft parton pt
154 C simulation of hard scattering, initial state radiation
184 C diffraction dissociation
212 C fragmentation, treatment of low-mass strings
231 C particle code tables, particle numbering conversion
250 C Lorentz transformations, rotations and mass adjustment
266 C program debugging and internal cross-checks
279 C cross section fitting
293 C cross section parametrizations
302 C DPMJET random number generator DT_RNDM used
309 C auxiliary routines / numerical methods
331 C parton density parametrization management / interface
344 C parton density parametrizations from other authors
389 C***********************************************************************
391 *$ CREATE PHO_INIT.FOR
394 SUBROUTINE PHO_INIT(LINP,LOUT,IREJ)
395 C***********************************************************************
397 C main subroutine to configure and manage PHOJET calculations
399 C input: LINP input unit to read from
400 C -1 to skip reading of input file
401 C LOUT output unit to write to
403 C output: IREJ 0 success
406 C***********************************************************************
407 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
410 C input/output channels
412 COMMON /POINOU/ LI,LO
413 C event debugging information
415 PARAMETER (NMAXD=100)
416 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
417 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
418 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
419 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
420 C model switches and parameters
422 INTEGER ISWMDL,IPAMDL
423 DOUBLE PRECISION PARMDL
424 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
425 C general process information
426 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
427 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
429 C global event kinematics and particle IDs
431 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
432 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
433 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
434 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
435 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
436 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
437 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
438 C integration precision for hard cross sections (obsolete)
439 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
440 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
441 C some hadron information, will be deleted in future versions
443 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
444 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
445 C obsolete cut-off information
446 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
447 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
448 C photon flux kinematics and cuts
449 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
450 & YMIN1,YMAX1,YMIN2,YMAX2,
451 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
452 & THMIN1,THMAX1,THMIN2,THMAX2
454 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
455 & YMIN1,YMAX1,YMIN2,YMAX2,
456 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
457 & THMIN1,THMAX1,THMIN2,THMAX2,
459 C cut probability distribution
460 INTEGER IEETA1,IIMAX,KKMAX
461 PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
462 INTEGER IEEMAX,IMAX,KMAX
464 DOUBLE PRECISION EPTAB
465 COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
467 C event weights and generated cross section
468 INTEGER IPOWGC,ISWCUT,IVWGHT
469 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
470 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
471 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
472 C names of hard scattering processes
474 PARAMETER ( Max_pro_1 = 16 )
476 COMMON /POHPRO/ PROC(0:Max_pro_1)
477 C hard cross sections and MC selection weights
479 PARAMETER ( Max_pro_2 = 16 )
480 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
482 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
483 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
484 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
485 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
486 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
487 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
490 DOUBLE PRECISION PARU,PARJ
491 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
493 DOUBLE PRECISION PMAS,PARF,VCKM
494 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
495 INTEGER MDCY,MDME,KFDP
496 DOUBLE PRECISION BRAT
497 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
503 CHARACTER*70 NUMBER,FILENA
508 C define input/output units
519 WRITE(LO,*) ' ==================================================='
521 WRITE(LO,*) ' ---- PHOJET version 1.12 ---- '
523 WRITE(LO,*) ' ==================================================='
524 WRITE(LO,*) ' Authors: Ralph Engel (FZ Karlsruhe)'
525 WRITE(LO,*) ' Johannes Ranft (Siegen Univ.)'
526 WRITE(LO,*) ' Stefan Roesler (CERN)'
527 WRITE(LO,*) ' ---------------------------------------------------'
528 WRITE(LO,*) ' Manual, updates, and further information:'
529 WRITE(LO,*) ' http://www-ik.fzk.de/~engel/phojet.html'
530 WRITE(LO,*) ' ---------------------------------------------------'
531 WRITE(LO,*) ' please send suggestions / bug reports etc. to:'
532 WRITE(LO,*) ' ralph.engel@fzk.de'
533 WRITE(LO,*) ' ==================================================='
534 WRITE(LO,*) ' $Date: 2000/06/25 21:59:19 $'
535 WRITE(LO,*) ' $Revision: 1.12.1.35 $'
536 WRITE(LO,*) ' (code version with interface to PYTHIA 6.x)'
537 WRITE(LO,*) ' (code version for usage in DPMJET 3.x)'
538 WRITE(LO,*) ' ==================================================='
541 C standard initializations
544 DUM = PHO_PMASS(0,-1)
546 C initialize standard PDFs
548 CALL PHO_SETPDF(2212,IDUM,5,6,0,0,-1)
549 CALL PHO_SETPDF(-2212,IDUM,5,6,0,0,-1)
551 CALL PHO_SETPDF(2112,IDUM,5,6,0,0,-1)
552 CALL PHO_SETPDF(-2112,IDUM,5,6,0,0,-1)
554 CALL PHO_SETPDF(22,IDUM,5,3,0,0,-1)
556 CALL PHO_SETPDF(990,IDUM,4,0,0,0,-1)
558 CALL PHO_SETPDF(211,IDUM,5,2,0,0,-1)
559 CALL PHO_SETPDF(-211,IDUM,5,2,0,0,-1)
560 CALL PHO_SETPDF(111,IDUM,5,2,0,0,-1)
562 CALL PHO_SETPDF(321,IDUM,5,2,0,0,-1)
563 CALL PHO_SETPDF(-321,IDUM,5,2,0,0,-1)
564 CALL PHO_SETPDF(130,IDUM,5,2,0,0,-1)
565 CALL PHO_SETPDF(310,IDUM,5,2,0,0,-1)
570 C main loop to read input cards
572 READ(LINP,14,END=1300) CNAME,NUMBER
573 IF(CNAME.EQ.'ENDINPUT ') THEN
575 ELSE IF(CNAME.EQ.'STOP ') THEN
578 ELSE IF(CNAME.EQ.'COMMENT ') THEN
579 WRITE(LO,'(1X,A10,A69)') 'COMMENT ',NUMBER
580 ELSE IF(CNAME(1:1).EQ.'*') THEN
581 WRITE(LO,'(1X,A10,A69)') CNAME,NUMBER
582 ELSE IF(CNAME.EQ.'PTCUT ') THEN
583 READ(NUMBER,*) PARMDL(36),PARMDL(37),PARMDL(38),PARMDL(39)
584 WRITE(LO,*) 'PTCUT ',PARMDL(36),PARMDL(37),
585 & PARMDL(38),PARMDL(39)
586 ELSE IF(CNAME.EQ.'PROCESS ') THEN
587 READ(NUMBER,*) (IPRON(KK,1),KK=1,8)
588 WRITE(LO,*) 'PROCESS ',(IPRON(KK,1),KK=1,8)
589 ELSE IF(CNAME.EQ.'DIFF-PROC ') THEN
590 READ(NUMBER,*) (ITMP(KK),KK=0,11)
591 WRITE(LO,*) 'DIFF-PROC ',(ITMP(KK),KK=0,8)
593 IPRON(KK,ITMP(0)) = ITMP(KK)
595 ELSE IF(CNAME.EQ.'SUBPROCESS') THEN
596 READ(NUMBER,*) IMPRO,IP,ION
597 WRITE(LO,*) 'SUBPROCESS',IMPRO,IP,ION
598 MH_pro_on(IMPRO,IP) = ION
599 ELSE IF(CNAME.EQ.'PARTICLE1 ') THEN
600 READ(NUMBER,*) IDPDG,PVIR
603 CALL PHO_SETPAR(1,IDPDG,0,PVIR)
604 WRITE(LO,*) 'PARTICLE1 ',IDPDG,PVIR
605 ELSE IF(CNAME.EQ.'PARTICLE2 ') THEN
606 READ(NUMBER,*) IDPDG,PVIR
609 CALL PHO_SETPAR(2,IDPDG,0,PVIR)
610 WRITE(LO,*) 'PARTICLE2 ',IDPDG,PVIR
611 ELSE IF(CNAME.EQ.'REMNANT1 ') THEN
612 READ(NUMBER,*) IDPDG,IFL1,IFL2,IVAL,XSUB
618 CALL PHO_SETPAR(1,IDPDG,-1,PVIR)
619 WRITE(LO,*) 'REMNANT1 ',IDPDG,IFL1,IFL2,IVAL,XSUB
620 ELSE IF(CNAME.EQ.'REMNANT2 ') THEN
621 READ(NUMBER,*) IDPDG,IFL1,IFL2,IVAL,XSUB
627 CALL PHO_SETPAR(2,IDPDG,-1,PVIR)
628 WRITE(LO,*) 'REMNANT2 ',IDPDG,IFL1,IFL2,IVAL,XSUB
629 ELSE IF(CNAME.EQ.'PDF ') THEN
630 READ(NUMBER,*) IDPDG,IPAR,ISET,IEXT
631 WRITE(LO,*) 'PDF ',IDPDG,IPAR,ISET,IEXT
632 CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,IEXT,0,-1)
633 ELSE IF(CNAME.EQ.'SETMODEL ') THEN
634 READ(NUMBER,*) I,IVAL
635 WRITE(LO,*) 'SETMODEL ',I,IVAL
636 CALL PHO_SETMDL(I,IVAL,1)
637 ELSE IF(CNAME.EQ.'SETPARAM ') THEN
638 READ(NUMBER,*) I,PARNEW
639 WRITE(LO,*) 'SETPARAM ',I,PARNEW
641 ELSE IF(CNAME.EQ.'DEBUG ') THEN
642 READ(NUMBER,*) IDEBF,IDEBN,IDLEV
643 WRITE(LO,*) 'DEBUG ',IDEBF,IDEBN,IDLEV
644 CALL PHO_TRACE(IDEBF,IDEBN,IDLEV)
645 ELSE IF(CNAME.EQ.'TRACE ') THEN
646 READ(NUMBER,*) IDEBF,IDLEV
647 WRITE(LO,*) 'TRACE ',IDEBF,IDLEV
649 ELSE IF(CNAME.EQ.'SETICUT ') THEN
650 READ(NUMBER,*) I,ICUT
651 WRITE(LO,*) 'SETICUT ',I,ICUT
653 ELSE IF(CNAME.EQ.'SETFCUT ') THEN
654 READ(NUMBER,*) I,PARNEW
655 WRITE(LO,*) 'SETFCUT ',I,PARNEW
657 ELSE IF(CNAME.EQ.'LUND-MSTU ') THEN
658 READ(NUMBER,*) I,IVAL
659 WRITE(LO,*) 'LUND-MSTU ',I,IVAL
661 ELSE IF(CNAME.EQ.'LUND-MSTJ ') THEN
662 READ(NUMBER,*) I,IVAL
663 WRITE(LO,*) 'LUND-MSTJ ',I,IVAL
665 ELSE IF(CNAME.EQ.'LUND-PARJ ') THEN
667 WRITE(LO,*) 'LUND-PARJ ',I,EE
669 ELSE IF(CNAME.EQ.'LUND-PARU ') THEN
671 WRITE(LO,*) 'LUND-PARU ',I,EE
673 ELSE IF(CNAME.EQ.'LUND-DECAY') THEN
674 READ(NUMBER,*) ID,ION
675 WRITE(LO,*) 'LUND-DECAY ',ID,ION
678 ELSE IF(CNAME.EQ.'PSOFTMIN ') THEN
679 READ(NUMBER,*) PSOMIN
680 WRITE(LO,*) 'PSOFTMIN ',PSOMIN
681 ELSE IF(CNAME.EQ.'INTPREC ') THEN
682 READ(NUMBER,*) NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
683 WRITE(LO,*) 'INTPREC ',NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
686 ELSE IF(CNAME.EQ.'PDFTEST ') THEN
687 READ(NUMBER,*) IDPDG,SCALE2,PVIRT2
689 WRITE(LO,*) 'PDFTEST ',IDPDG,' ',SCALE2,' ',PVIRT2
690 CALL PHO_PDFTST(IDPDG,SCALE2,PVIRT2)
692 C mass cut on gamma-gamma or gamma-hadron system
693 ELSE IF(CNAME.EQ.'ECMS-CUT ') THEN
694 READ(NUMBER,*) ECMIN,ECMAX
695 WRITE(LO,*) 'ECMS-CUT ',ECMIN,ECMAX
697 C beam lepton (anti-)tagging system
698 ELSE IF(CNAME.EQ.'TAG-METHOD') THEN
699 READ(NUMBER,*) ITAG1,ITAG2
700 WRITE(LO,*) 'TAG-METHOD',ITAG1,ITAG2
701 ELSE IF(CNAME.EQ.'E-TAG1 ') THEN
703 & EEMIN1,YMIN1,YMAX1,Q2MIN1,Q2MAX1,THMIN1,THMAX1
704 WRITE(LO,*) 'E-TAG1 ',EEMIN1,YMIN1,YMAX1,
705 & Q2MIN1,Q2MAX1,THMIN1,THMAX1
706 ELSE IF(CNAME.EQ.'E-TAG2 ') THEN
708 & EEMIN2,YMIN2,YMAX2,Q2MIN2,Q2MAX2,THMIN2,THMAX2
709 WRITE(LO,*) 'E-TAG2 ',EEMIN2,YMIN2,YMAX2,
710 & Q2MIN2,Q2MAX2,THMIN2,THMAX2
712 C sampling of gamma-p events in ep (HERA)
713 ELSE IF( (CNAME.EQ.'WW-HERA ')
714 & .OR.(CNAME.EQ.'GP-HERA ')) THEN
715 READ(NUMBER,*) EE1,EE2,NEV
716 WRITE(LO,*) 'GP-HERA ',EE1,EE2,NEV
717 IF(YMAX2.LT.0.D0) THEN
718 WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGER NOT SET'
720 CALL PHO_GPHERA(NEV,EE1,EE2)
724 C sampling of gamma-gamma events in e+e- (LEP)
725 ELSE IF( (CNAME.EQ.'GG-EPEM ')
726 & .OR.(CNAME.EQ.'WW-EPEM ')) THEN
727 READ(NUMBER,*) EE1,EE2,NEV
728 WRITE(LO,*) 'GG-EPEM ',EE1,EE2,NEV
729 IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
730 WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGERS NOT SET'
732 CALL PHO_GGEPEM(-1,EE1,EE2)
733 CALL PHO_GGEPEM(NEV,EE1,EE2)
734 CALL PHO_GGEPEM(-2,sig_tot,sig_gg)
738 C sampling of gamma-gamma in heavy-ion collisions
739 ELSE IF(CNAME.EQ.'GG-HION-F ') THEN
740 READ(NUMBER,*) EE,NA,NZ,NEV
741 WRITE(LO,*) 'GG-HION-F ',EE,NA,NZ,NEV
742 IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
743 WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
745 CALL PHO_GGHIOF(NEV,EE,NA,NZ)
748 ELSE IF(CNAME.EQ.'GG-HION-G ') THEN
749 READ(NUMBER,*) EE,NA,NZ,NEV
750 WRITE(LO,*) 'GG-HION-G ',EE,NA,NZ,NEV
751 IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
752 WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
754 CALL PHO_GGHIOG(NEV,EE,NA,NZ)
758 C sampling of gamma-hadron events in heavy ion collisions
759 ELSE IF(CNAME.EQ.'GH-HION-F ') THEN
760 READ(NUMBER,*) EE,NA,NZ,NEV
761 WRITE(LO,*) 'GH-HION-F ',EE,NA,NZ,NEV
762 IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
763 WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
765 CALL PHO_GHHIOF(NEV,EE,NA,NZ)
769 C sampling of hadron-gamma events in hadron - heavy ion collisions
770 ELSE IF(CNAME.EQ.'HG-HIAS-F ') THEN
771 READ(NUMBER,*) EP,EE,NA,NZ,NEV
772 WRITE(LO,*) 'HG-HIAS-F ',EP,EE,NA,NZ,NEV
773 IF(YMAX2.LT.0.D0) THEN
774 WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
776 CALL PHO_GHHIAS(NEV,EP,EE,NA,NZ)
780 C sampling of photoproduction events e+e-, backscattered laser
781 ELSE IF(CNAME.EQ.'BLASER ') THEN
782 READ(NUMBER,*) EE1,EE2,Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A,NEV
783 WRITE(LO,*) 'BLASER ',EE1,EE2,
784 & Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A,NEV
785 CALL PHO_GGBLSR(NEV,EE1,EE2,Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A)
788 C sampling of photoproduction events beamstrahlung
789 ELSE IF(CNAME.EQ.'BEAMST ') THEN
790 READ(NUMBER,*) EE1,YPSI,SIGX,SIGY,SIGZ,AEB,NEV
791 WRITE(LO,*) 'BEAMST ',EE1,YPSI,SIGX,SIGY,SIGZ,AEB,NEV
792 IF(YMAX1.LT.0.D0) THEN
793 WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGER 1 NOT SET'
795 CALL PHO_GGBEAM(NEV,EE1,YPSI,SIGX,SIGY,SIGZ,AEB)
799 C fixed-energy events in LAB system of particle 2
800 ELSE IF(CNAME.EQ.'EVENT-LAB ') THEN
801 READ(NUMBER,*) PLAB,NEV
802 WRITE(LO,*) 'EVENT-LAB ',PLAB,NEV
803 CALL PHO_FIXLAB(PLAB,NEV)
806 C fixed-energy events in CM system
807 ELSE IF(CNAME.EQ.'EVENT-CMS ') THEN
808 READ(NUMBER,*) ECM,NEV
809 WRITE(LO,*) 'EVENT-CMS ',ECM,NEV
810 PMASS1 = PHO_PMASS(IFPAB(1),0)-SQRT(PVIRT(1))
811 PMASS2 = PHO_PMASS(IFPAB(2),0)-SQRT(PVIRT(2))
812 CALL PHO_PECMS(1,PMASS1,PMASS2,ECM,PCM,EE)
817 CALL PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
820 C fixed-energy events for collider setup with crossing angle
821 ELSE IF(CNAME.EQ.'EVENT-COLL') THEN
822 READ(NUMBER,*) E1,E2,THETA,PHI,NEV
823 WRITE(LO,*) 'EVENT-COLL',E1,E2,THETA,PHI,NEV
824 CALL PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
829 WRITE(LO,*) 'PHO_INIT: unknown data card: ',CNAME,NUMBER
834 WRITE(LO,*) ' RETURN'
838 *$ CREATE PHO_SETMDL.FOR
840 CDECK ID>, PHO_SETMDL
841 SUBROUTINE PHO_SETMDL(INDX,IVAL,IMODE)
842 C**********************************************************************
846 C input: INDX model parameter number
847 C (positive: ISWMDL, negative: IPAMDL)
849 C IMODE -1 print value of parameter INDX
851 C -2 print current settings
853 C**********************************************************************
854 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
857 C input/output channels
859 COMMON /POINOU/ LI,LO
860 C model switches and parameters
862 INTEGER ISWMDL,IPAMDL
863 DOUBLE PRECISION PARMDL
864 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
867 WRITE(LO,'(/1X,A,/1X,A,/)') 'PHO_SETMDL: current settings',
868 & '----------------------------'
870 IF(ISWMDL(I).EQ.-9999) GOTO 200
871 IF(ISWMDL(I+1).EQ.-9999) THEN
872 WRITE(LO,'(5X,I3,A1,A,I6)') I,':',MDLNA(I),ISWMDL(I)
874 ELSE IF(ISWMDL(I+2).EQ.-9999) THEN
875 WRITE(LO,'(2(5X,I3,A1,A,I6))') I,':',MDLNA(I),ISWMDL(I),
876 & I+1,':',MDLNA(I+1),ISWMDL(I+1)
879 WRITE(LO,'(3(5X,I3,A1,A,I6))')
880 & (I+K,':',MDLNA(I+K),ISWMDL(I+K),K=0,2)
884 ELSE IF(IMODE.EQ.-1) THEN
885 WRITE(LO,'(1X,A,1X,A,I6)')
886 & 'PHO_SETMDL:',MDLNA(INDX),ISWMDL(INDX)
887 ELSE IF(IMODE.EQ.1) THEN
889 IF(ISWMDL(INDX).NE.IVAL) THEN
890 WRITE(LO,'(1X,A,I4,1X,A,2I6)')
891 & 'PHO_SETMDL:ISWMDL(OLD/NEW):',
892 & INDX,MDLNA(INDX),ISWMDL(INDX),IVAL
895 ELSE IF(INDX.LT.0) THEN
896 IF(IPAMDL(-INDX).NE.IVAL) THEN
897 WRITE(LO,'(1X,A,I4,1X,2I6)') 'PHO_SETMDL:IPAMDL(OLD/NEW):',
898 & -INDX,IPAMDL(-INDX),IVAL
903 WRITE(LO,'(/1X,A,I6)')
904 & 'PHO_SETMDL:ERROR: unsupported mode',IMODE
908 *$ CREATE PHO_DATINI.FOR
910 CDECK ID>, PHO_DATINI
911 SUBROUTINE PHO_DATINI
912 C*********************************************************************
914 C initialization of variables and switches
916 C*********************************************************************
917 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
920 C input/output channels
922 COMMON /POINOU/ LI,LO
924 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
925 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
926 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
927 C event debugging information
929 PARAMETER (NMAXD=100)
930 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
931 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
932 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
933 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
934 C event weights and generated cross section
935 INTEGER IPOWGC,ISWCUT,IVWGHT
936 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
937 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
938 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
939 C scale parameters for parton model calculations
940 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
941 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
942 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
943 & NQQAL,NQQALI,NQQALF,NQQPD
944 C integration precision for hard cross sections (obsolete)
945 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
946 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
947 C hard scattering parameters used for most recent hard interaction
949 DOUBLE PRECISION ALQCD2,BQCD
950 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
951 C cut probability distribution
952 INTEGER IEETA1,IIMAX,KKMAX
953 PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
954 INTEGER IEEMAX,IMAX,KMAX
956 DOUBLE PRECISION EPTAB
957 COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
959 C gamma-lepton or gamma-hadron vertex information
960 INTEGER IGHEL,IDPSRC,IDBSRC
961 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
962 & RADSRC,AMSRC,GAMSRC
963 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
964 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
965 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
966 C photon flux kinematics and cuts
967 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
968 & YMIN1,YMAX1,YMIN2,YMAX2,
969 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
970 & THMIN1,THMAX1,THMIN2,THMAX2
972 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
973 & YMIN1,YMAX1,YMIN2,YMAX2,
974 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
975 & THMIN1,THMAX1,THMIN2,THMAX2,
977 C obsolete cut-off information
978 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
979 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
980 C global event kinematics and particle IDs
982 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
983 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
984 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
985 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
986 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
987 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
988 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
989 C some hadron information, will be deleted in future versions
991 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
992 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
993 C model switches and parameters
995 INTEGER ISWMDL,IPAMDL
996 DOUBLE PRECISION PARMDL
997 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
998 C general process information
999 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
1000 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
1001 C parameters of the "simple" Vector Dominance Model
1002 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
1003 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
1004 C parameters for DGLAP backward evolution in ISR
1006 DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
1007 COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
1008 C particles created by initial state evolution
1009 INTEGER MXISR1,MXISR2
1010 PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
1011 INTEGER IFLISR,IPOISR,IMXISR
1012 DOUBLE PRECISION PHISR
1013 COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
1014 & IPOISR(2,2,MXISR2),IMXISR(2)
1015 C names of hard scattering processes
1017 PARAMETER ( Max_pro_1 = 16 )
1019 COMMON /POHPRO/ PROC(0:Max_pro_1)
1020 C hard cross sections and MC selection weights
1022 PARAMETER ( Max_pro_2 = 16 )
1023 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
1025 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
1026 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
1027 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
1028 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
1029 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
1030 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
1031 C interpolation tables for hard cross section and MC selection weights
1032 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
1033 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
1034 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
1035 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
1036 & HQ2a_tab,HQ2b_tab,HEcm_tab
1038 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1039 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1040 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1041 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1042 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
1043 & HEcm_tab(1:Max_tab_E,0:4),
1044 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
1046 C initialize /POCONS/
1047 PI = ATAN(1.D0)*4.D0
1050 C GeV**-2 --> millibarn (multiply by GEV2MB to get mb as units)
1052 C precalculate quark charges
1054 Q_ch(i) = dble(2-3*mod(i,2))/3.D0
1057 Q_ch2(i) = Q_ch(i)**2
1058 Q_ch2(-i) = Q_ch2(i)
1060 Q_ch4(i) = Q_ch2(i)**2
1061 Q_ch4(-i) = Q_ch4(i)
1067 C initialize /GLOCMS/
1075 C initialize /HADVAL/
1082 C initialize /MODELS/
1084 MDLNA(1) = 'AMPL MOD'
1086 MDLNA(2) = 'MIN-BIAS'
1088 MDLNA(3) = 'PTS DISH'
1090 MDLNA(4) = 'PTS DISP'
1092 MDLNA(5) = 'PTS ASSI'
1094 MDLNA(6) = 'HADRONIZ'
1096 MDLNA(7) = 'MASS COR'
1098 MDLNA(8) = 'PAR SHOW'
1100 MDLNA(9) = 'GLU SPLI'
1102 MDLNA(10) = 'VIRT PHO'
1104 MDLNA(11) = 'LARGE NC'
1106 MDLNA(12) = 'LIPA POM'
1108 MDLNA(13) = 'QELAS VM'
1110 MDLNA(14) = 'ENHA GRA'
1112 MDLNA(15) = 'MULT SCA'
1114 MDLNA(16) = 'MULT DIF'
1116 MDLNA(17) = 'MULT CDF'
1118 MDLNA(18) = 'BALAN PT'
1120 MDLNA(19) = 'POMV FLA'
1122 MDLNA(20) = 'SEA FLA'
1124 MDLNA(21) = 'SPIN DEC'
1126 MDLNA(22) = 'DIF.MASS'
1128 MDLNA(23) = 'DIFF RES'
1130 MDLNA(24) = 'PTS HPOM'
1132 MDLNA(25) = 'POM CORR'
1134 MDLNA(26) = 'OVERLAP '
1136 MDLNA(27) = 'MUL R/AN'
1138 MDLNA(28) = 'SUR PROB'
1140 MDLNA(29) = 'PRIMO KT'
1142 MDLNA(30) = 'DIFF. CS'
1144 C mass-independent sea flavour ratios (for low-mass strings)
1151 C suppression by energy momentum conservation
1155 PARMDL(10) = 0.866D0
1156 PARMDL(11) = 0.288D0
1157 PARMDL(12) = 0.288D0
1158 PARMDL(13) = 0.288D0
1159 PARMDL(14) = 0.866D0
1160 PARMDL(15) = 0.288D0
1161 PARMDL(16) = 0.288D0
1162 PARMDL(17) = 0.288D0
1164 C lower energy limit for initialization
1166 C soft pt for hard scattering remnants
1168 C low energy beta of soft pt distribution 1
1170 C high energy beta of soft pt distribution 1
1172 C low energy beta of soft pt distribution 0
1174 C high energy beta of soft pt distribution 0
1176 C effective quark mass in photon wave function
1178 C normalization of unevolved Pomeron PDFs
1180 C effective VDM parameters for Q**2 dependence of cross section
1185 PARMDL(31) = 0.589824D0
1186 PARMDL(32) = 0.609961D0
1187 PARMDL(33) = 1.038361D0
1189 C Q**2 suppression of multiple interactions
1191 C pt cutoff defaults
1196 C enhancement factor for diffractive cross sections
1200 C mass in soft pt distribution
1202 C maximum of x allowed for leading particle
1204 C max. mass sampled in diffraction
1205 PARMDL(45) = sqrt(0.4D0)
1206 C mass threshold in diffraction (2pi mass)
1208 C regularization of slope parameter in diffraction
1210 C renormalized intercept for enhanced graphs
1212 C coherence constraint for diff. cross sections
1213 PARMDL(49) = sqrt(0.05D0)
1214 C exponents of x distributions
1218 PARMDL(52) = -0.99D0
1219 PARMDL(53) = -0.99D0
1220 C meson (non-strangeness part)
1223 PARMDL(56) = -0.99D0
1224 PARMDL(57) = -0.99D0
1225 C meson (strangeness part)
1228 PARMDL(60) = -0.99D0
1229 PARMDL(61) = -0.99D0
1230 C particle remnant (no valence quarks)
1233 PARMDL(64) = -0.99D0
1234 PARMDL(65) = -0.99D0
1235 C ratio beetween triple-pomeron/reggeon couplings grrp/gppp
1237 C ratio beetween triple-pomeron/reggeon couplings gppr/gppp
1239 C min. abs(t) in diffraction
1241 C max. abs(t) in diffraction
1243 C min. mass for elastic pomerons in central diffraction
1245 C min. mass of diffractive blob in central diffraction
1247 C min. Feynman x cut in central diffraction
1249 C direct pomeron coupling
1251 C relative deviation allowed for energy-momentum conservation
1252 C energy-momentum relative deviation
1254 C transverse momentum deviation
1256 C couplings for unitarization in diffraction
1257 C non-unitarized pomeron coupling (sqrt(mb))
1259 C rescaling factor for pomeron PDF
1261 C coupling probabilities
1264 C scales to calculate alpha-s of matrix element
1268 C scales to calculate alpha-s of initial state radiation
1272 C scales to calculate alpha-s of final state radiation
1276 C scales to calculate PDFs
1280 C scale for ISR starting virtuality
1282 C min. virtuality to generate time-like showers in ISR
1284 C factor to scale the max. allowed time-like parton shower virtuality
1286 C max. transverse momentum for primordial kt
1288 C weight factors for pt-distribution
1296 * PARMDL(110-125) reserved for hard scattering
1297 C currently chosen scales for hard scattering
1299 PARMDL(109+I) = 0.D0
1301 C virtuality cutoff in initial state evolution
1302 PARMDL(126) = PARMDL(36)**2
1303 PARMDL(127) = PARMDL(37)**2
1304 PARMDL(128) = PARMDL(38)**2
1305 PARMDL(129) = PARMDL(39)**2
1306 C virtuality cutoff for direct contribution to photon PDF
1311 C fraction of events without popcorn
1313 C fraction of diquarks with spin 1 (relative to sum of spin 1 and 0)
1315 C soft color re-connection (fraction)
1317 PARMDL(140) = 1.D0/64.D0
1319 PARMDL(141) = 1.D0/24.D0
1321 PARMDL(142) = 1.D0/9.D0
1322 C effective scale in Drees-Godbole like suppresion in photon PDF
1323 PARMDL(144) = 0.766D0**2
1324 C QCD scales (if PDF scales are not used, 4 active flavours)
1325 PARMDL(145) = 0.2D0**2
1326 PARMDL(146) = 0.2D0**2
1327 PARMDL(147) = 0.2D0**2
1328 C threshold scales for variable flavour calculation (GeV**2)
1329 PARMDL(148) = 1.5D0**2
1330 PARMDL(149) = 4.5D0**2
1331 PARMDL(150) = 175.D0**2
1332 C constituent quark masses
1338 PARMDL(156) = 174.D0
1339 C min. masses of valence quark
1341 C min. masses of valence diquark
1343 C min. mass of sea quark
1345 C suppression of strange quarks as photon valences
1347 C min. masses for strings (used in PHO_SOFTXX)
1352 C min. momentum fraction for soft processes
1354 C min. phase space for x-sampling
1355 PARMDL(166) = 0.135D0
1356 C Ross-Stodolsky exponent
1358 C cutoff on photon-pomeron invariant mass in hadron-hadron collisions
1361 * extra factor multiplying difference between Goulianos and PHOJET-
1362 * diff. cross sections
1365 C complex amplitudes, eikonal functions
1367 C allow for Reggeon cuts
1369 C decay of hadron resonances in diffraction (0 iso, 1 trans, 2 long)
1371 C polarization of photon resonances (0 none, 1 trans, 2 long)
1373 C pt of valence partons
1375 C pt of hard scattering remnant
1377 C running cutoff for hard scattering
1379 C intercept used for the calculation of enhanced graphs
1381 C effective slope of hard scattering amplitde
1383 C mass dependence of slope parameters
1385 C lepton-photon vertex 1
1387 C lepton-photon vertex 2
1391 C method to sample x distributions
1393 C energy-momentum check
1395 C phase space correction for DPMJET interface
1397 C fragment strings from projectile/target/central diff. separately
1399 C method to construct strings for hard interactions
1401 C method to construct strings for soft sea (pomeron cuts)
1403 C method to construct strings in pomeron interactions
1405 C soft color re-connection
1407 C resummation of triple- and loop-Pomeron
1409 C resummation of X iterated triple-Pomeron
1411 C dimension of interpolation table for weights in hard scattering
1412 IPAMDL(30) = Max_tab_E
1413 C dimension of interpolation table for pomeron cut distribution
1415 C number of cut soft pomerons (restriction by field dimension)
1417 C number of cut hard pomerons (restriction by field dimension)
1419 C tau pair production in direct photon-photon collisions
1421 C currently chosen scales for hard scattering
1422 C ATTENTION: IPAMDL(65-80) reserved for hard scattering!
1424 IPAMDL(64+I) = -99999
1426 C scales to calculate alpha-s of matrix element
1430 C scales to calculate alpha-s of initial state radiation
1434 C scales to calculate alpha-s of final state radiation
1438 C scales to calculate PDFs
1442 C where to get the parameter sets from
1444 C program PHO_ABORT for fatal errors (simulation of division by zero)
1446 C initial state parton showers for all / hardest interaction(s)
1448 C final state parton showers for all / hardest interaction(s)
1450 C initial virtuality for ISR generation
1452 C qqbar-gamma coupling in initial state showers
1454 C generation of time-like showers during ISR
1456 C reweighting of multiple soft contributions for virtual photons
1458 C reweighting / use photon virtuality in photon PDF calculations
1460 C use full QPM model incl. interference terms (direct part in gam-gam)
1462 C matching sigma_tot to F2 as given by parton density at high Q2
1464 C use virtuality of target in F2 calculations (two-gamma only)
1466 C calculation of alpha_em
1468 C strict pt cutoff for gamma-gamma events
1470 C photon virtuality sampled in photon flux approximations
1472 C photon-pomeron: 0,1,2: both,left,right photon emission
1474 C keep full history information in PHOJET-JETSET interface
1476 C max. number of conservation law violations allowed in one run
1478 C selection of soft X values
1479 C max. iteration number in PHO_SELSXS
1481 C max. iteration number in PHO_SELSXR
1483 C max. iteration number in PHO_SELSX2
1485 C max. iteration number in PHO_SELSXI
1488 C initialize /PROBAB/
1494 PARMDL(300+I) = -100000.D0
1496 C initialize /POHDRN/
1497 QMASS(1) = PARMDL(151)
1498 QMASS(2) = PARMDL(152)
1499 QMASS(3) = PARMDL(153)
1500 QMASS(4) = PARMDL(154)
1501 QMASS(5) = PARMDL(155)
1502 QMASS(6) = PARMDL(156)
1507 C number of light flavours (quarks treated as massless)
1509 C initialize /POCUT1/
1510 PTCUT(1) = PARMDL(36)
1511 PTCUT(2) = PARMDL(37)
1512 PTCUT(3) = PARMDL(38)
1513 PTCUT(4) = PARMDL(39)
1516 C initialize /POHAPA/
1519 BQCD(1) = PI4/(11.D0-(2.D0/3.D0)*3)
1520 BQCD(2) = PI4/(11.D0-(2.D0/3.D0)*4)
1521 BQCD(3) = PI4/(11.D0-(2.D0/3.D0)*5)
1522 BQCD(4) = PI4/(11.D0-(2.D0/3.D0)*6)
1523 C initialize /POGAUP/
1533 C initialize /PROCES/
1537 C DPMJET default: no elastic scattering
1546 C initialize /POSVDM/
1560 RMAX(1) = VMAS(1)+TWOPIM
1561 RMAX(2) = VMAS(2)+TWOPIM
1562 RMAX(3) = VMAS(3)+TWOPIM
1563 RMAX(4) = VMAS(1)+TWOPIM
1572 C initialize /PODGL1/
1573 Q2MISR(1) = PARMDL(36)**2
1574 Q2MISR(2) = PARMDL(36)**2
1582 C initialize /POPISR/
1587 C initialize /POHPRO/
1588 PROC(0) = 'sum over processes'
1589 PROC(1) = 'G +G --> G +G '
1590 PROC(2) = 'Q +QB --> G +G '
1591 PROC(3) = 'G +Q --> G +Q '
1592 PROC(4) = 'G +G --> Q +QB '
1593 PROC(5) = 'Q +QB --> Q +QB '
1594 PROC(6) = 'Q +QB --> QP +QBP'
1595 PROC(7) = 'Q +Q --> Q +Q '
1596 PROC(8) = 'Q +QP --> Q +QP '
1597 PROC(9) = 'resolved processes'
1598 PROC(10) = 'gam+Q --> G +Q '
1599 PROC(11) = 'gam+G --> Q +QB '
1600 PROC(12) = 'Q +gam--> G +Q '
1601 PROC(13) = 'G +gam--> Q +QB '
1602 PROC(14) = 'gam+gam--> Q +QB '
1603 PROC(15) = 'direct processes '
1604 PROC(16) = 'gam+gam--> l+ +l- '
1606 C initialize /POHRCS/
1614 C switch all hard subprocesses on
1616 C reset all counters
1624 C initialize /POHTAB/
1629 HEcm_tab(1,I) = 0.D0
1635 C initialize /POFSRC/
1638 C initialize /LEPCUT/
1651 C initialize /POWGHT/
1665 *$ CREATE PHO_PARDAT.FOR
1667 CDECK ID>, PHO_PARDAT
1668 SUBROUTINE PHO_PARDAT
1669 C***********************************************************************
1671 C particle data (based on 1996 PDG naming scheme and data tables)
1673 C***********************************************************************
1677 C input/output channels
1679 COMMON /POINOU/ LI,LO
1680 C event debugging information
1682 PARAMETER (NMAXD=100)
1683 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
1684 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
1685 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
1686 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
1687 C particle ID translation table
1688 integer ID_pdg_list,ID_list,ID_pdg_max
1689 character*12 name_list
1690 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
1692 C general particle data
1693 double precision xm_list,tau_list,gam_list,
1694 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
1695 & xm_bb82_list,xm_bb102_list
1696 integer ich3_list,iba3_list,iq_list,
1697 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
1698 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
1699 & xm_psm2_list(6,6),xm_vem2_list(6,6),
1700 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
1701 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
1702 & ich3_list(300),iba3_list(300),iq_list(3,300),
1703 & id_psm_list(6,6),id_vem_list(6,6),
1704 & id_b8_list(6,6,6),id_b10_list(6,6,6)
1705 C particle decay data
1706 double precision wg_sec_list
1707 integer idec_list,isec_list
1708 COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
1711 C external functions
1714 double precision pho_pmass
1716 C local variables for storing data tables
1718 integer number,ich3,iba3,iq_linear,idec_linear,isec_linear,
1719 & id_psm_linear,id_vem_linear,id_b8_linear,id_b10_linear
1721 dimension number(300),ich3(300),iba3(300),iq_linear(900),
1722 & idec_linear(900),isec_linear(900),id_psm_linear(36),
1723 & id_vem_linear(36),id_b8_linear(216),id_b10_linear(216)
1725 double precision xmass,gamma,wg_chan
1726 dimension xmass(300),gamma(300),wg_chan(300)
1731 integer i,i1,i2,ii,j,jj,k,l,ichan,i_tab_max,K8,K10,L8,L10
1732 double precision AM1,AM2,AM2P,AM2V,AM82,AM102,AMM
1735 DATA i_tab_max /260/
1737 DATA (number(K),K= 1, 171) /
1738 & 1, 2, 3, 4, 5, 6, 1103, 2101, 2103,
1739 & 2203, 3101, 3103, 3201, 3203, 3303, 4101, 4103, 4201,
1740 & 4203, 4301, 4303, 4403, 81, 82, 90, 91, 92,
1741 & 110, 990, 21, 22, 24, 23, 11, 13, 15,
1742 & 12, 14, 16, 211, 111, 221, 113, 213, 223,
1743 & 331, 10221, 10111, 10211, 333, 10223, 10113, 10213, 20113,
1744 & 20213, 225, 20223, 20221, 20111, 20211, 115, 215, 30223,
1745 & 50223, 40113, 40213, 50221, 335, 60223, 227, 10115, 10215,
1746 & 10333, 117, 217, 30113, 30213, 60221, 337, 20225, 229,
1747 & 30225, 40225, 321, 311, 310, 130, 323, 313, 10313,
1748 & 10323, 20313, 20323, 30313, 30323, 10311, 10321, 325, 315,
1749 & 40313, 40323, 10315, 10325, 317, 327, 20315, 20325, 319,
1750 & 329, 411, 421, 423, 413, 10423, 425, 415, 431,
1751 & 433, 10433, 521, 511, 513, 523, 531, 441, 443,
1752 & 10441, 10443, 445, 20443, 30443, 40443, 50443, 60443, 553,
1753 & 551, 10553, 555, 20553, 10551, 70553, 10555, 30553, 40553,
1754 & 50553, 60553, 2212, 2112, 12112, 12212, 1214, 2124, 22112,
1755 & 22212, 32112, 32212, 2116, 2216, 12116, 12216, 21214, 22124,
1756 & 42112, 42212, 31214, 32124, 1218, 2128, 1114, 2114, 2214/
1757 DATA (number(K),K= 172, 260) /
1758 & 2224, 31114, 32114, 32214, 32224, 1112, 1212, 2122, 2222,
1759 & 11114, 12114, 12214, 12224, 1116, 1216, 2126, 2226, 21112,
1760 & 21212, 22122, 22222, 21114, 22114, 22214, 22224, 11116, 11216,
1761 & 12126, 12226, 1118, 2118, 2218, 2228, 3122, 13122, 3124,
1762 & 23122, 33122, 13124, 43122, 53122, 3126, 13126, 23124, 3128,
1763 & 23126, 3222, 3212, 3112, 3224, 3214, 3114, 13112, 13212,
1764 & 13222, 13114, 13214, 13224, 23112, 23212, 23222, 3116, 3216,
1765 & 3226, 13116, 13216, 13226, 23114, 23214, 23224, 3118, 3218,
1766 & 3228, 3322, 3312, 3324, 3314, 13314, 13324, 3334, 4122,
1767 & 14122, 4222, 4212, 4112, 4232, 4132, 4332, 5122/
1768 DATA (name(K),K= 1, 76) /
1769 &'d ','u ','s ','c ',
1770 &'b ','t ','(dd)_1 ','(ud)_0 ',
1771 &'(ud)_1 ','(uu)_1 ','(sd)_0 ','(sd)_1 ',
1772 &'(su)_0 ','(su)_1 ','(ss)_1 ','(cd)_0 ',
1773 &'(cd)_1 ','(cu)_0 ','(cu)_1 ','(cs)_0 ',
1774 &'(cs)_1 ','(cc)_1 ','remnant 1 ','remnant 2 ',
1775 &'string ','mod. string ','coll. string','reggeon ',
1776 &'pomeron ','gluon ','gamma ','W ',
1777 &'Z ','e ','mu ','tau ',
1778 &'nu(e) ','nu(mu) ','nu(tau) ','pi ',
1779 &'pi ','eta ','rho(770) ','rho(770) ',
1780 &'ome(782) ','etap(958) ','f(0)(980) ','a(0)(980) ',
1781 &'a(0)(980) ','phi(1020) ','h(1)(1170) ','b(1)(1235) ',
1782 &'b(1)(1235) ','a(1)(1260) ','a(1)(1260) ','f(2)(1270) ',
1783 &'f(1)(1285) ','eta(1295) ','pi(1300) ','pi(1300) ',
1784 &'a(2)(1320) ','a(2)(1320) ','f(1)(1420) ','ome(1420) ',
1785 &'rho(1450) ','rho(1450) ','f(0)(1500) ','f(2)p(1525) ',
1786 &'ome(1600) ','ome(3)(1670)','pi(2)(1670) ','pi(2)(1670) ',
1787 &'phi(1680) ','rho(3)(1690)','rho(3)(1690)','rho(1700) '/
1788 DATA (name(K),K= 77, 152) /
1789 &'rho(1700) ','f(J)(1710) ','phi(3)(1850)','f(2)(2010) ',
1790 &'f(4)(2050) ','f(2)(2300) ','f(2)(2340) ','K ',
1791 &'K ','K(S) ','K(L) ','K*(892) ',
1792 &'K*(892) ','K(1)(1270) ','K(1)(1270) ','K(1)(1400) ',
1793 &'K(1)(1400) ','K*(1410) ','K*(1410) ','K(0)*(1430) ',
1794 &'K(0)*(1430) ','K(2)*(1430) ','K(2)*(1430) ','K*(1680) ',
1795 &'K*(1680) ','K(2)(1770) ','K(2)(1770) ','K(3)*(1780) ',
1796 &'K(3)*(1780) ','K(2)(1820) ','K(2)(1820) ','K(4)*(2045) ',
1797 &'K(4)*(2045) ','D ','D ','D*(2007) ',
1798 &'D*(2010) ','D(1)(2420) ','D(2)*(2460) ','D(2)*(2460) ',
1799 &'D(s) ','D(s)* ','D(s1)(2536) ','B ',
1800 &'B ','B* ','B* ','B(s) ',
1801 &'eta(c)(1S) ','J/psi(1S) ','chi(c0)(1P) ','chi(c1)(1P) ',
1802 &'chi(c2)(1P) ','psi(2S) ','psi(3770) ','psi(4040) ',
1803 &'psi(4160) ','psi(4415) ','Ups(1S) ','chi(b0)(1P) ',
1804 &'chi(b1)(1P) ','chi(b2)(1P) ','Ups(2S) ','chi(b0)(2P) ',
1805 &'chi(b1)(2P) ','chi(b2)(2P) ','Ups(3S) ','Ups(4S) ',
1806 &'Ups(10860) ','Ups(11020) ','p ','n ',
1807 &'N(1440) ','N(1440) ','N(1520) ','N(1520) '/
1808 DATA (name(K),K= 153, 228) /
1809 &'N(1535) ','N(1535) ','N(1650) ','N(1650) ',
1810 &'N(1675) ','N(1675) ','N(1680) ','N(1680) ',
1811 &'N(1700) ','N(1700) ','N(1710) ','N(1710) ',
1812 &'N(1720) ','N(1720) ','N(2190) ','N(2190) ',
1813 &'Del(1232) ','Del(1232) ','Del(1232) ','Del(1232) ',
1814 &'Del(1600) ','Del(1600) ','Del(1600) ','Del(1600) ',
1815 &'Del(1620) ','Del(1620) ','Del(1620) ','Del(1620) ',
1816 &'Del(1700) ','Del(1700) ','Del(1700) ','Del(1700) ',
1817 &'Del(1905) ','Del(1905) ','Del(1905) ','Del(1905) ',
1818 &'Del(1910) ','Del(1910) ','Del(1910) ','Del(1910) ',
1819 &'Del(1920) ','Del(1920) ','Del(1920) ','Del(1920) ',
1820 &'Del(1930) ','Del(1930) ','Del(1930) ','Del(1930) ',
1821 &'Del(1950) ','Del(1950) ','Del(1950) ','Del(1950) ',
1822 &'Lambda ','Lam(1405) ','Lam(1520) ','Lam(1600) ',
1823 &'Lam(1670) ','Lam(1690) ','Lam(1800) ','Lam(1810) ',
1824 &'Lam(1820) ','Lam(1830) ','Lam(1890) ','Lam(2100) ',
1825 &'Lam(2110) ','Sigma ','Sigma ','Sigma ',
1826 &'Sig(1385) ','Sig(1385) ','Sig(1385) ','Sig(1660) ',
1827 &'Sig(1660) ','Sig(1660) ','Sig(1670) ','Sig(1670) '/
1828 DATA (name(K),K= 229, 260) /
1829 &'Sig(1670) ','Sig(1750) ','Sig(1750) ','Sig(1750) ',
1830 &'Sig(1775) ','Sig(1775) ','Sig(1775) ','Sig(1915) ',
1831 &'Sig(1915) ','Sig(1915) ','Sig(1940) ','Sig(1940) ',
1832 &'Sig(1940) ','Sig(2030) ','Sig(2030) ','Sig(2030) ',
1833 &'Xi ','Xi ','Xi(1530) ','Xi(1530) ',
1834 &'Xi(1820) ','Xi(1820) ','Omega ','Lam(c) ',
1835 &'Lam(c)(2593)','Sig(c)(2455)','Sig(c)(2455)','Sig(c)(2455)',
1836 &'Xi(c) ','Xi(c) ','Ome(c) ','Lam(b) '/
1837 DATA (ich3(K),K= 1, 260) /
1838 &-1, 2,-1, 2,-1, 2,-2, 1, 1, 4,-2,-2, 1, 1,-2, 1, 1, 4, 4, 1, 1, 4,
1839 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0,-3,-3,-3, 0, 0, 0, 3, 0, 0, 0, 3,
1840 & 0, 0, 0, 0, 3, 0, 0, 0, 3, 0, 3, 0, 0, 0, 0, 3, 0, 3, 0, 0, 0, 3,
1841 & 0, 0, 0, 0, 0, 3, 0, 0, 3, 0, 3, 0, 0, 0, 0, 0, 0, 3, 0, 0, 0, 3,
1842 & 0, 0, 3, 0, 3, 0, 3, 0, 3, 3, 0, 0, 3, 0, 3, 0, 3, 0, 3, 0, 3, 3,
1843 & 0, 0, 3, 0, 0, 3, 3, 3, 3, 3, 0, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1844 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 0, 3, 0, 3, 0, 3,
1845 & 0, 3, 0, 3, 0, 3, 0, 3, 0, 3, 0, 3, 0, 3,-3, 0, 3, 6,-3, 0, 3, 6,
1846 &-3, 0, 3, 6,-3, 0, 3, 6,-3, 0, 3, 6,-3, 0, 3, 6,-3, 0, 3, 6,-3, 0,
1847 & 3, 6,-3, 0, 3, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0,-3,
1848 & 3, 0,-3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3,
1849 & 0, 3, 0,-3, 0,-3,-3, 0,-3, 3, 3, 6, 3, 0, 3, 0, 0, 0/
1850 DATA (iba3(K),K= 1, 260) /
1851 &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,
1852 &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
1853 &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
1854 &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
1855 &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,
1856 &3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
1857 &3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
1858 &3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3/
1859 DATA (iq_linear(K),K= 1, 418) /
1860 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 2,
1861 & 1, 0, 2, 1, 0, 2, 2, 0, 3, 1, 0, 3, 1, 0, 3, 2, 0, 3, 2, 0, 3, 3,
1862 & 0, 4, 1, 0, 4, 1, 0, 4, 2, 0, 4, 2, 0, 4, 3, 0, 4, 3, 0, 4, 4, 0,
1863 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1864 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1865 & 0, 0, 0, 0, 0, 0, 0, 2,-1, 0, 1,-1, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0,
1866 & 2,-2, 0, 3,-3, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0, 3,-3, 0, 2,-2, 0, 1,
1867 &-1, 0, 2,-1, 0, 1,-1, 0, 2, 1, 0, 2,-2, 0, 2,-2, 0, 2,-2, 0, 1,-1,
1868 & 0, 2,-1, 0, 1,-1, 0, 2,-1, 0, 2,-2, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0,
1869 & 2,-2, 0, 3,-3, 0, 2,-2, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0, 3,-3, 0, 1,
1870 &-1, 0, 2,-1, 0, 1,-1, 0, 2,-1, 0, 2,-2, 0, 3,-3, 0, 2,-2, 0, 2,-2,
1871 & 0, 2,-2, 0, 2,-2, 0, 2,-3, 0, 1,-3, 0, 1,-3, 0, 3,-1, 0, 2,-3, 0,
1872 & 1,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 1,
1873 &-3, 0, 2,-3, 0, 2,-3, 0, 1,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3,
1874 & 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 4,-1, 0,
1875 & 4,-2, 0, 4,-2, 0, 4,-1, 0, 4,-2, 0, 4,-2, 0, 4,-1, 0, 4,-3, 0, 4,
1876 &-3, 0, 4,-3, 0, 2,-5, 0, 1,-5, 0, 1,-5, 0, 2,-5, 0, 3,-5, 0, 4,-4,
1877 & 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0,
1878 & 4,-4, 0, 4,-4, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5/
1879 DATA (iq_linear(K),K= 419, 780) /
1880 &-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 2, 2,
1881 & 1, 2, 1, 1, 2, 1, 1, 2, 2, 1, 1, 2, 1, 2, 1, 2, 2, 1, 1, 2, 2, 1,
1882 & 2, 1, 1, 2, 2, 1, 2, 2, 2, 2, 2, 1, 2, 1, 1, 2, 2, 1, 1, 2, 1, 2,
1883 & 1, 2, 2, 1, 1, 2, 2, 1, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 1,
1884 & 1, 2, 1, 1, 2, 2, 1, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 2, 1, 2, 2, 2,
1885 & 1, 1, 1, 1, 2, 1, 2, 1, 2, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 2, 1, 2,
1886 & 2, 2, 1, 1, 1, 1, 2, 1, 2, 1, 2, 2, 2, 2, 1, 1, 1, 1, 2, 1, 2, 1,
1887 & 2, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 1, 1, 2, 2, 2, 1, 1, 1, 1, 2, 1,
1888 & 2, 1, 2, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 2, 1, 2, 2, 2, 3, 1, 2, 3,
1889 & 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1,
1890 & 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 2, 2, 3, 2, 1, 3, 1, 1, 3,
1891 & 3, 2, 2, 3, 2, 1, 3, 1, 1, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1, 3,
1892 & 2, 1, 3, 2, 2, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1, 3, 2, 1, 3, 2,
1893 & 2, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1,
1894 & 3, 2, 1, 3, 2, 2, 2, 3, 3, 1, 3, 3, 2, 3, 3, 1, 3, 3, 3, 3, 1, 3,
1895 & 3, 2, 3, 3, 3, 2, 1, 4, 4, 1, 2, 2, 2, 4, 2, 1, 2, 1, 1, 4, 3, 2,
1896 & 2, 3, 1, 2, 3, 3, 4, 5, 1, 2/
1897 DATA (xmass(K),K= 1, 114) /
1898 &3.0000E-01,3.0000E-01,3.5000E-01,1.4500E+00,4.5000E+00,1.7400E+02,
1899 &7.7133E-01,5.7933E-01,7.7133E-01,7.7133E-01,8.0473E-01,9.2953E-01,
1900 &8.0473E-01,9.2953E-01,1.0936E+00,1.9691E+00,2.0081E+00,1.9691E+00,
1901 &2.0081E+00,2.1543E+00,2.1797E+00,3.2753E+00,0.0000E+00,0.0000E+00,
1902 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
1903 &0.0000E+00,8.0410E+01,9.1187E+01,5.1100E-04,1.0566E-01,1.7771E+00,
1904 &0.0000E+00,0.0000E+00,0.0000E+00,1.3957E-01,1.3498E-01,5.4730E-01,
1905 &7.7000E-01,7.7000E-01,7.8194E-01,9.5778E-01,9.8000E-01,9.8340E-01,
1906 &9.8340E-01,1.0194E+00,1.1700E+00,1.2295E+00,1.2295E+00,1.2300E+00,
1907 &1.2300E+00,1.2750E+00,1.2819E+00,1.2970E+00,1.3000E+00,1.3000E+00,
1908 &1.3181E+00,1.3181E+00,1.4262E+00,1.4190E+00,1.4650E+00,1.4650E+00,
1909 &1.5000E+00,1.5250E+00,1.6490E+00,1.6670E+00,1.6700E+00,1.6700E+00,
1910 &1.6800E+00,1.6910E+00,1.6910E+00,1.7000E+00,1.7000E+00,1.7120E+00,
1911 &1.8540E+00,2.0100E+00,2.0440E+00,2.2970E+00,2.3400E+00,4.9368E-01,
1912 &4.9767E-01,4.9767E-01,4.9767E-01,8.9166E-01,8.9610E-01,1.2720E+00,
1913 &1.2720E+00,1.4020E+00,1.4020E+00,1.4140E+00,1.4140E+00,1.4290E+00,
1914 &1.4290E+00,1.4256E+00,1.4324E+00,1.7170E+00,1.7170E+00,1.7730E+00,
1915 &1.7730E+00,1.7760E+00,1.7760E+00,1.8160E+00,1.8160E+00,2.0450E+00,
1916 &2.0450E+00,1.8693E+00,1.8646E+00,2.0067E+00,2.0100E+00,2.4222E+00/
1917 DATA (xmass(K),K= 115, 228) /
1918 &2.4589E+00,2.4590E+00,1.9685E+00,2.1124E+00,2.5353E+00,5.2789E+00,
1919 &5.2792E+00,5.3249E+00,5.3249E+00,5.3693E+00,2.9798E+00,3.0969E+00,
1920 &3.4173E+00,3.5105E+00,3.5562E+00,3.6860E+00,3.7699E+00,4.0400E+00,
1921 &4.1590E+00,4.4150E+00,9.4604E+00,9.8598E+00,9.8919E+00,9.9132E+00,
1922 &1.0023E+01,1.0232E+01,1.0255E+01,1.0268E+01,1.0355E+01,1.0580E+01,
1923 &1.0865E+01,1.1019E+01,9.3827E-01,9.3957E-01,1.4400E+00,1.4400E+00,
1924 &1.5200E+00,1.5200E+00,1.5350E+00,1.5350E+00,1.6500E+00,1.6500E+00,
1925 &1.6750E+00,1.6750E+00,1.6800E+00,1.6800E+00,1.7000E+00,1.7000E+00,
1926 &1.7100E+00,1.7100E+00,1.7200E+00,1.7200E+00,2.1900E+00,2.1900E+00,
1927 &1.2320E+00,1.2320E+00,1.2320E+00,1.2320E+00,1.6000E+00,1.6000E+00,
1928 &1.6000E+00,1.6000E+00,1.6200E+00,1.6200E+00,1.6200E+00,1.6200E+00,
1929 &1.7000E+00,1.7000E+00,1.7000E+00,1.7000E+00,1.9050E+00,1.9050E+00,
1930 &1.9050E+00,1.9050E+00,1.9100E+00,1.9100E+00,1.9100E+00,1.9100E+00,
1931 &1.9200E+00,1.9200E+00,1.9200E+00,1.9200E+00,1.9300E+00,1.9300E+00,
1932 &1.9300E+00,1.9300E+00,1.9500E+00,1.9500E+00,1.9500E+00,1.9500E+00,
1933 &1.1157E+00,1.4070E+00,1.5195E+00,1.6000E+00,1.6700E+00,1.6900E+00,
1934 &1.8000E+00,1.8100E+00,1.8200E+00,1.8300E+00,1.8900E+00,2.1000E+00,
1935 &2.1100E+00,1.1894E+00,1.1926E+00,1.1974E+00,1.3828E+00,1.3837E+00,
1936 &1.3872E+00,1.6600E+00,1.6600E+00,1.6600E+00,1.6700E+00,1.6700E+00/
1937 DATA (xmass(K),K= 229, 260) /
1938 &1.6700E+00,1.7500E+00,1.7500E+00,1.7500E+00,1.7750E+00,1.7750E+00,
1939 &1.7750E+00,1.9150E+00,1.9150E+00,1.9150E+00,1.9400E+00,1.9400E+00,
1940 &1.9400E+00,2.0300E+00,2.0300E+00,2.0300E+00,1.3149E+00,1.3213E+00,
1941 &1.5318E+00,1.5350E+00,1.8230E+00,1.8230E+00,1.6724E+00,2.2849E+00,
1942 &2.5939E+00,2.4528E+00,2.4536E+00,2.4522E+00,2.4656E+00,2.4703E+00,
1943 &2.7040E+00,5.6240E+00/
1944 DATA (gamma(K),K= 1, 114) /
1945 &8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,
1946 &8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,
1947 &8.0000E-01,8.0000E-01,8.0000E-01,0.0000E+00,0.0000E+00,0.0000E+00,
1948 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
1949 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
1950 &0.0000E+00,2.0600E+00,2.4900E+00,0.0000E+00,2.9959E-19,2.2700E-12,
1951 &0.0000E+00,0.0000E+00,0.0000E+00,2.5284E-17,7.8000E-09,1.1800E-06,
1952 &1.5070E-01,1.5070E-01,8.4100E-03,2.0300E-04,0.0000E+00,0.0000E+00,
1953 &0.0000E+00,4.4300E-03,3.6000E-01,1.4200E-01,1.4200E-01,0.0000E+00,
1954 &0.0000E+00,1.8550E-01,2.4000E-02,5.3000E-02,0.0000E+00,0.0000E+00,
1955 &1.0700E-01,1.0700E-01,5.5000E-02,1.7000E-01,3.1000E-01,3.1000E-01,
1956 &1.1200E-01,7.6000E-02,2.2000E-01,1.6800E-01,2.5800E-01,2.5800E-01,
1957 &1.5000E-01,1.6000E-01,1.6000E-01,2.4000E-01,2.4000E-01,1.3300E-01,
1958 &8.7000E-02,2.0000E-01,2.0800E-01,1.5000E-01,3.2000E-01,5.3140E-17,
1959 &0.0000E+00,7.3730E-15,1.2730E-17,5.0800E-02,5.0500E-02,9.0000E-02,
1960 &9.0000E-02,1.7400E-01,1.7400E-01,2.3200E-01,2.3200E-01,2.8700E-01,
1961 &2.8700E-01,9.8500E-02,1.0900E-01,3.2000E-01,3.2000E-01,1.8600E-01,
1962 &1.8600E-01,1.5900E-01,1.5900E-01,2.7600E-01,2.7600E-01,1.9800E-01,
1963 &1.9800E-01,6.2300E-13,1.5860E-12,5.0000E-03,2.0000E-03,1.8900E-02/
1964 DATA (gamma(K),K= 115, 228) /
1965 &2.3000E-02,2.5000E-02,1.4100E-12,2.0000E-03,0.0000E+00,3.9900E-13,
1966 &4.2200E-13,0.0000E+00,0.0000E+00,4.2700E-13,1.3200E-02,8.7000E-05,
1967 &1.4000E-02,8.8000E-04,2.0000E-03,2.7700E-04,2.3600E-02,5.2000E-02,
1968 &7.8000E-02,4.3000E-02,5.2500E-05,0.0000E+00,0.0000E+00,0.0000E+00,
1969 &4.4000E-05,0.0000E+00,0.0000E+00,0.0000E+00,2.6300E-05,1.0000E-02,
1970 &1.1000E-01,7.9000E-02,0.0000E+00,7.4240E-28,3.5000E-01,3.5000E-01,
1971 &1.2000E-01,1.2000E-01,1.5000E-01,1.5000E-01,1.5000E-01,1.5000E-01,
1972 &1.5000E-01,1.5000E-01,1.3000E-01,1.3000E-01,1.0000E-01,1.0000E-01,
1973 &1.0000E-01,1.0000E-01,1.5000E-01,1.5000E-01,4.5000E-01,4.5000E-01,
1974 &1.2000E-01,1.2000E-01,1.2000E-01,1.2000E-01,3.5000E-01,3.5000E-01,
1975 &3.5000E-01,3.5000E-01,1.5000E-01,1.5000E-01,1.5000E-01,1.5000E-01,
1976 &3.0000E-01,3.0000E-01,3.0000E-01,3.0000E-01,3.5000E-01,3.5000E-01,
1977 &3.5000E-01,3.5000E-01,2.5000E-01,2.5000E-01,2.5000E-01,2.5000E-01,
1978 &2.0000E-01,2.0000E-01,2.0000E-01,2.0000E-01,3.5000E-01,3.5000E-01,
1979 &3.5000E-01,3.5000E-01,3.0000E-01,3.0000E-01,3.0000E-01,3.0000E-01,
1980 &2.5010E-15,5.0000E-02,1.5600E-02,1.5000E-01,3.5000E-02,6.0000E-02,
1981 &3.0000E-01,1.5000E-01,8.0000E-02,9.5000E-02,1.0000E-01,2.0000E-01,
1982 &2.0000E-01,8.2400E-15,8.9000E-06,4.4500E-15,3.5800E-02,3.6000E-02,
1983 &3.9400E-02,1.0000E-01,1.0000E-01,1.0000E-01,6.0000E-02,6.0000E-02/
1984 DATA (gamma(K),K= 229, 260) /
1985 &6.0000E-02,9.0000E-02,9.0000E-02,9.0000E-02,1.2000E-01,1.2000E-01,
1986 &1.2000E-01,1.2000E-01,1.2000E-01,1.2000E-01,2.2000E-01,2.2000E-01,
1987 &2.2000E-01,1.8000E-01,1.8000E-01,1.8000E-01,2.2700E-15,4.0200E-15,
1988 &9.1000E-03,9.9000E-03,2.4000E-02,2.4000E-02,8.0100E-15,3.1900E-12,
1989 &3.6000E-03,0.0000E+00,0.0000E+00,0.0000E+00,1.8600E-12,6.7000E-12,
1990 &1.0200E-11,5.3100E-13/
1991 DATA (idec_linear(K),K= 1, 304) /
1992 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1993 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1994 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1995 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1996 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1997 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1998 & 0, 0, 0, 0, 0, 0, 3, 1, 1, 2, 2, 6, 0, 0, 0, 0,
1999 & 0, 0, 0, 0, 0, 3, 7, 7, 3, 8, 9, 1, 10, 14, 1, 15,
2000 & 16, 1, 17, 17, 1, 18, 20, 1, 21, 24, 0, 0, 0, 0, 0, 0,
2001 & 0, 0, 0, 1, 25, 29, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2002 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2003 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 30, 32,
2004 & 1, 33, 34, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 35, 37, 0,
2005 & 0, 0, 0, 0, 0, 0, 0, 0, 1, 38, 39, 0, 0, 0, 0, 0,
2006 & 0, 1, 40, 40, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2007 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 41, 46, 0, 0, 0, 3,
2008 & 47, 48, 3, 49, 52, 1, 53, 54, 1, 55, 56, 1, 57, 58, 1, 59,
2009 & 60, 0, 0, 0, 0, 0, 0, 1, 61, 68, 1, 69, 76, 0, 0, 0,
2010 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
2011 DATA (idec_linear(K),K= 305, 608) /
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, 2, 77, 78, 2, 79, 82, 1, 83, 84,
2014 & 1, 85, 87, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 88, 90, 1,
2015 & 91, 92, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2016 & 0, 0, 0, 0, 2, 93, 95, 1, 96, 98, 0, 0, 0, 0, 0, 0,
2017 & 0, 0, 0, 1, 99,101, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2018 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2019 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2020 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 3,102,102, 1,103,112, 1,
2021 &113,122, 0, 0, 0, 0, 0, 0, 1,123,129, 1,130,136, 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, 1,137,144, 1,145,152, 0, 0, 0, 0,
2024 & 0, 0, 0, 0, 0, 0, 0, 0, 1,153,153, 1,154,155, 1,156,
2025 &157, 1,158,158, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2026 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1,159,162, 1,
2027 &163,169, 1,170,176, 1,177,180, 0, 0, 0, 0, 0, 0, 0, 0,
2028 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2029 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 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= 609, 780) /
2032 & 0, 0, 0, 0, 3,181,182, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2033 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2034 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3,183,184, 3,185,
2035 &185, 3,186,186, 1,187,189, 1,190,192, 1,193,194, 0, 0, 0,
2036 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2037 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1,195,203, 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, 1,204,216, 0, 0, 0, 3,217,217, 3,
2040 &218,218, 1,219,220, 1,221,222, 0, 0, 0, 0, 0, 0, 2,223,
2041 &225, 2,226,239, 0, 0, 0, 2,240,240, 2,241,241, 2,242,242,
2042 & 2,243,246, 2,247,251, 2,252,255, 0, 0, 0/
2043 DATA (isec_linear(K),K= 1, 152) /
2044 & 11, 12, -12, 13, -14, 16, 11, -12,
2045 & 16, -213, 16, 0, -211, 16, 0, -323,
2046 & 16, 0, -13, 12, 0, 22, 22, 0,
2047 & 22, -11, 11, 22, 22, 0, 111, 22,
2048 & 22, 111, 111, 111, 211, -211, 111, 211,
2049 & -211, 22, 211, -211, 0, 111, 111, 0,
2050 & 211, 111, 0, 211, -211, 111, 211, -211,
2051 & 0, 111, 22, 0, 221, 211, -211, 221,
2052 & 111, 111, 211, -211, 22, 22, 22, 0,
2053 & 321, -321, 0, 130, 310, 0, 113, 111,
2054 & 0, 211, -211, 111, 221, 22, 0, 113,
2055 & 111, 0, -213, 211, 0, 213, -211, 0,
2056 & 211, -211, 0, 111, 111, 0, 113, 111,
2057 & 0, -213, 211, 0, 213, -211, 0, 311,
2058 & -313, 0, -311, 313, 0, 113, 211, -211,
2059 & -13, 12, 0, 211, 111, 0, 211, 211,
2060 & -211, 211, 111, 111, -13, 111, 12, -11,
2061 & 111, 12, 211, -211, 0, 111, 111, 0,
2062 & 111, 111, 111, 211, -211, 111, 211, 13/
2063 DATA (isec_linear(K),K= 153, 304) /
2064 & 12, 211, 11, 12, 321, 111, 0, 311,
2065 & 211, 0, 311, 111, 0, 321, -211, 0,
2066 & 311, 111, 0, 321, -211, 0, 321, 111,
2067 & 0, 311, 211, 0, 311, 111, 0, 321,
2068 & -211, 0, 313, 111, 0, 323, -211, 0,
2069 & 311, 113, 0, 321, -213, 0, 311, 223,
2070 & 0, 311, 221, 0, 321, 111, 0, 311,
2071 & 211, 0, 323, 111, 0, 313, 211, 0,
2072 & 321, 113, 0, 311, 213, 0, 321, 223,
2073 & 0, 321, 221, 0, -321, 211, 211, -311,
2074 & 211, 0, -321, 211, 0, -321, 211, 111,
2075 & 311, 211, -211, 311, 111, 0, 421, 111,
2076 & 0, 421, 22, 0, 421, 211, 0, 411,
2077 & 111, 0, 411, 22, 0, 221, 211, 0,
2078 & 321, -321, 321, 321, -311, 0, 431, 22,
2079 & 0, 431, 22, 0, 111, 111, 0, 211,
2080 & -211, 0, 22, 22, 0, -11, 11, 0,
2081 & -13, 13, 0, 211, -211, 111, 443, 211,
2082 & -211, 443, 111, 111, 443, 221, 0, 2212/
2083 DATA (isec_linear(K),K= 305, 456) /
2084 & 11, 12, 2112, 111, 0, 2212, -211, 0,
2085 & 2112, 111, 111, 2112, 211, -211, 1114, 211,
2086 & 0, 2114, 111, 0, 2214, -211, 0, 2112,
2087 & 113, 0, 2212, -213, 0, 2112, 221, 0,
2088 & 2212, 111, 0, 2112, 211, 0, 2212, 111,
2089 & 111, 2212, 211, -211, 2224, -211, 0, 2214,
2090 & 111, 0, 2114, 211, 0, 2212, 113, 0,
2091 & 2112, 213, 0, 2212, 221, 0, 2212, -211,
2092 & 0, 2112, 111, 0, 2214, -211, 0, 2114,
2093 & 111, 0, 1114, 211, 0, 2212, -213, 0,
2094 & 2112, 113, 0, 2212, 111, 0, 2112, 211,
2095 & 0, 2224, -211, 0, 2214, 111, 0, 2114,
2096 & 211, 0, 2212, 113, 0, 2112, 213, 0,
2097 & 2212, -211, 0, 2112, 111, 0, 2212, -213,
2098 & 0, 2112, 113, 0, 3122, 311, 0, 3212,
2099 & 311, 0, 3112, 321, 0, 2112, 221, 0,
2100 & 2212, 111, 0, 2112, 211, 0, 2212, 113,
2101 & 0, 2112, 213, 0, 3122, 321, 0, 3222,
2102 & 311, 0, 3212, 321, 0, 2212, 221, 0/
2103 DATA (isec_linear(K),K= 457, 608) /
2104 & 2112, -211, 0, 2212, -211, 0, 2112, 111,
2105 & 0, 2212, 111, 0, 2112, 211, 0, 2212,
2106 & 211, 0, 2112, -211, 0, 2114, -211, 0,
2107 & 1114, 111, 0, 2112, -213, 0, 2212, -211,
2108 & 0, 2112, 111, 0, 2214, -211, 0, 2114,
2109 & 111, 0, 1114, 211, 0, 2212, -213, 0,
2110 & 2112, 113, 0, 2212, 111, 0, 2112, 211,
2111 & 0, 2224, -211, 0, 2214, 111, 0, 2114,
2112 & 211, 0, 2212, 113, 0, 2112, 213, 0,
2113 & 2212, 211, 0, 2224, 111, 0, 2214, 211,
2114 & 0, 2212, 213, 0, 2212, -211, 0, 2112,
2115 & 111, 0, 2212, 111, 0, 2112, 211, 0,
2116 & 3122, 22, 0, 2112, -211, 0, 3122, 211,
2117 & 0, 3212, 211, 0, 3222, 111, 0, 3122,
2118 & 111, 0, 3222, -211, 0, 3112, 211, 0,
2119 & 3122, -211, 0, 3212, -211, 0, 2112, -311,
2120 & 0, 2212, -321, 0, 3222, -211, 0, 3212,
2121 & 111, 0, 3112, 211, 0, 3122, 221, 0,
2122 & 3224, -211, 0, 3114, 211, 0, 3214, 111/
2123 DATA (isec_linear(K),K= 609, 760) /
2124 & 0, 2112, -311, 0, 2212, -321, 0, 3122,
2125 & 111, 0, 3122, 223, 0, 3122, 113, 0,
2126 & 3222, -213, 0, 3112, 213, 0, 3212, 113,
2127 & 0, 3122, 221, 0, 3212, 221, 0, 3222,
2128 & -211, 0, 3112, 211, 0, 3212, 111, 0,
2129 & 3122, 111, 0, 3122, -211, 0, 3322, 111,
2130 & 0, 3312, 211, 0, 3322, -211, 0, 3312,
2131 & 111, 0, 3322, -211, 0, 3312, 111, 0,
2132 & 3122, -321, 0, 3222, 221, 0, 3222, 331,
2133 & 0, 2212, -311, 0, 3322, 321, 0, 3224,
2134 & 221, 0, 2214, 331, 0, 2224, -321, 0,
2135 & 3122, 213, 0, 3212, 213, 0, 3222, 113,
2136 & 0, 3222, 223, 0, 2212, -313, 0, 2214,
2137 & -313, 0, 2224, -323, 0, 4122, 211, 0,
2138 & 4122, 111, 0, 4122, -211, 0, 3222, -311,
2139 & 0, 3322, 211, 0, 3222, -313, 0, 3322,
2140 & 213, 0, 3212, -313, 0, 3222, -323, 0,
2141 & 3322, 223, 0, 3312, 213, 0, 3214, -313,
2142 & 0, 3322, -311, 0, 3322, 313, 0, 3334/
2143 DATA (isec_linear(K),K= 761, 765) /
2144 & 213, 0, 3334, 211, 0/
2145 DATA (wg_chan(K),K= 1, 114) /
2146 &1.0000E+00,2.8000E-01,2.8000E-01,3.5000E-01,7.0000E-02,2.0000E-02,
2147 &1.0000E+00,9.9000E-01,1.0000E-02,3.8000E-01,3.0000E-02,3.0000E-01,
2148 &2.4000E-01,5.0000E-02,1.0000E+00,0.0000E+00,1.0000E+00,8.8800E-01,
2149 &2.5000E-02,8.7000E-02,4.8000E-01,2.4000E-01,2.6000E-01,2.0000E-02,
2150 &4.9100E-01,3.4400E-01,1.2900E-01,2.4000E-02,1.2000E-02,4.0000E-01,
2151 &3.0000E-01,3.0000E-01,6.0000E-01,4.0000E-01,4.0000E-01,3.0000E-01,
2152 &3.0000E-01,5.0000E-01,5.0000E-01,1.0000E+00,6.4000E-01,2.1000E-01,
2153 &6.0000E-02,2.0000E-02,3.0000E-02,4.0000E-02,6.9000E-01,3.1000E-01,
2154 &2.1000E-01,1.2000E-01,2.7000E-01,4.0000E-01,3.3000E-01,6.7000E-01,
2155 &3.3000E-01,6.7000E-01,3.3000E-01,6.7000E-01,3.3000E-01,6.7000E-01,
2156 &1.9000E-01,3.8000E-01,9.0000E-02,2.0000E-01,3.0000E-02,4.0000E-02,
2157 &5.0000E-02,2.0000E-02,1.9000E-01,3.8000E-01,9.0000E-02,2.0000E-01,
2158 &3.0000E-02,4.0000E-02,5.0000E-02,2.0000E-02,7.0000E-01,3.0000E-01,
2159 &1.0000E-01,5.0000E-01,1.6000E-01,2.4000E-01,5.5000E-01,4.5000E-01,
2160 &6.8000E-01,3.0000E-01,2.0000E-02,3.0000E-01,4.0000E-01,3.0000E-01,
2161 &9.0000E-01,1.0000E-01,4.9000E-01,4.9000E-01,2.0000E-02,1.0000E-01,
2162 &1.0000E-01,8.0000E-01,6.0000E-01,3.0000E-01,1.0000E-01,1.0000E+00,
2163 &1.5000E-01,3.5000E-01,7.0000E-02,1.8000E-01,1.1000E-01,6.0000E-02,
2164 &3.0000E-02,1.0000E-02,3.0000E-02,1.0000E-02,1.5000E-01,3.5000E-01/
2165 DATA (wg_chan(K),K= 115, 228) /
2166 &7.0000E-02,1.8000E-01,1.1000E-01,6.0000E-02,3.0000E-02,1.0000E-02,
2167 &3.0000E-02,1.0000E-02,3.7000E-01,1.8000E-01,4.0000E-02,8.0000E-02,
2168 &1.3000E-01,1.3000E-01,7.0000E-02,1.8000E-01,3.7000E-01,1.3000E-01,
2169 &8.0000E-02,4.0000E-02,7.0000E-02,1.3000E-01,1.3000E-01,7.0000E-02,
2170 &4.7000E-01,2.3000E-01,5.0000E-02,1.0000E-02,2.0000E-02,2.0000E-02,
2171 &7.0000E-02,1.3000E-01,2.3000E-01,4.7000E-01,5.0000E-02,2.0000E-02,
2172 &1.0000E-02,2.0000E-02,1.0000E+00,3.3000E-01,6.7000E-01,6.7000E-01,
2173 &3.3000E-01,1.0000E+00,2.5000E-01,1.8000E-01,2.7000E-01,3.0000E-01,
2174 &8.0000E-02,1.7000E-01,2.4000E-01,3.0000E-02,1.8000E-01,1.0000E-01,
2175 &2.0000E-01,1.7000E-01,8.0000E-02,1.8000E-01,3.0000E-02,2.4000E-01,
2176 &2.0000E-01,1.0000E-01,2.5000E-01,2.7000E-01,1.8000E-01,3.0000E-01,
2177 &6.4000E-01,3.6000E-01,5.2000E-01,4.8000E-01,1.0000E+00,1.0000E+00,
2178 &8.8000E-01,6.0000E-02,6.0000E-02,8.8000E-01,6.0000E-02,6.0000E-02,
2179 &8.8000E-01,1.2000E-01,1.9000E-01,1.9000E-01,1.6000E-01,1.6000E-01,
2180 &1.7000E-01,3.0000E-02,3.0000E-02,3.0000E-02,4.0000E-02,1.0000E-01,
2181 &1.0000E-01,2.0000E-01,1.2000E-01,1.0000E-01,4.0000E-02,4.0000E-02,
2182 &5.0000E-02,7.5000E-02,7.5000E-02,3.0000E-02,3.0000E-02,4.0000E-02,
2183 &1.0000E+00,1.0000E+00,3.3000E-01,6.7000E-01,6.7000E-01,3.3000E-01,
2184 &2.5000E-01,2.5000E-01,5.0000E-01,2.0000E-02,3.0000E-02,7.0000E-02/
2185 DATA (wg_chan(K),K= 229, 255) /
2186 &2.0000E-02,2.0000E-02,4.0000E-02,1.3000E-01,7.0000E-02,6.0000E-02,
2187 &6.0000E-02,2.0000E-01,1.4000E-01,4.0000E-02,1.0000E-01,1.0000E+00,
2188 &1.0000E+00,1.0000E+00,2.5000E-01,3.0000E-02,3.0000E-01,4.2000E-01,
2189 &2.2000E-01,3.5000E-01,1.9000E-01,1.6000E-01,8.0000E-02,3.7000E-01,
2190 &2.0000E-01,3.6000E-01,7.0000E-02/
2191 DATA (id_psm_linear(K),K= 1, 36) /
2192 & 111, 211, -311, 411, 0, 0, -211, 111,
2193 & -321, 421, 0, 0, 311, 321, 221, 431,
2194 & 0, 0, -411, -421, -431, 441, 0, 0,
2195 & 0, 0, 0, 0, 0, 0, 0, 0,
2197 DATA (id_vem_linear(K),K= 1, 36) /
2198 & 113, 213, -313, 413, 0, 0, -213, 113,
2199 & -323, 423, 0, 0, 313, 323, 333, 433,
2200 & 0, 0, -413, -423, -433, 20443, 0, 0,
2201 & 0, 0, 0, 0, 0, 0, 0, 0,
2203 DATA (id_b8_linear(K),K= 1, 171) /
2204 & 1114, 2112, 3112, 4112, 0, 0, 2112, 2212, 3212,
2205 & 4122, 0, 0, 3112, 3212, 3312, 4132, 0, 0,
2206 & 4112, 4122, 4132, 4412, 0, 0, 0, 0, 0,
2207 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2208 & 2112, 2212, 3212, 4122, 0, 0, 2212, 2224, 3222,
2209 & 4222, 0, 0, 3212, 3222, 3322, 4232, 0, 0,
2210 & 4122, 4222, 4232, 4422, 0, 0, 0, 0, 0,
2211 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2212 & 3112, 3212, 3312, 4132, 0, 0, 3212, 3222, 3322,
2213 & 4232, 0, 0, 3312, 3322, 3334, 4332, 0, 0,
2214 & 4132, 4232, 4332, 4432, 0, 0, 0, 0, 0,
2215 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2216 & 4112, 4122, 4132, 4412, 0, 0, 4122, 4222, 4232,
2217 & 4422, 0, 0, 4132, 4232, 4332, 4432, 0, 0,
2218 & 4412, 4422, 4432, 4444, 0, 0, 0, 0, 0,
2219 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2220 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2221 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2222 & 0, 0, 0, 0, 0, 0, 0, 0, 0/
2223 DATA (id_b8_linear(K),K= 172, 216) /
2224 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2225 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2226 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2227 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2228 & 0, 0, 0, 0, 0, 0, 0, 0, 0/
2229 DATA (id_b10_linear(K),K= 1, 171) /
2230 & 1114, 2114, 3114, 4114, 0, 0, 2114, 2214, 3214,
2231 & 4214, 0, 0, 3114, 3214, 3314, 4314, 0, 0,
2232 & 4114, 4214, 4314, 4414, 0, 0, 0, 0, 0,
2233 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2234 & 2114, 2214, 3214, 4214, 0, 0, 2214, 2224, 3224,
2235 & 4224, 0, 0, 3214, 3224, 3324, 4324, 0, 0,
2236 & 4214, 4224, 4324, 4424, 0, 0, 0, 0, 0,
2237 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2238 & 3114, 3214, 3314, 4314, 0, 0, 3214, 3224, 3324,
2239 & 4324, 0, 0, 3314, 3324, 3334, 4334, 0, 0,
2240 & 4314, 4324, 4334, 4434, 0, 0, 0, 0, 0,
2241 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2242 & 4114, 4214, 4314, 4414, 0, 0, 4214, 4224, 4324,
2243 & 4424, 0, 0, 4314, 4324, 4334, 4434, 0, 0,
2244 & 4414, 4424, 4434, 4444, 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= 172, 216) /
2250 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2251 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2252 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2253 & 0, 0, 0, 0, 0, 0, 0, 0, 0,
2254 & 0, 0, 0, 0, 0, 0, 0, 0, 0/
2256 ID_pdg_max = i_tab_max
2258 C copy from local to global variables
2260 ID_pdg_list(i) = number(i)
2261 name_list(i) = name(i)
2262 xm_list(i) = xmass(i)
2263 gam_list(i) = gamma(i)
2264 ich3_list(i) = ich3(i)
2265 iba3_list(i) = iba3(i)
2267 iq_list(j,i) = iq_linear(3*(i-1)+j)
2268 idec_list(j,i) = idec_linear(3*(i-1)+j)
2272 C initialize hash table
2273 call pho_cpcini(ID_pdg_max,ID_pdg_list,ID_list)
2278 C quark index table for mesons
2281 id_psm_list(i,j) = ipho_pdg2id(id_psm_linear(6*(j-1)+i))
2282 id_vem_list(i,j) = ipho_pdg2id(id_vem_linear(6*(j-1)+i))
2286 C quark index table for baryons
2291 & ipho_pdg2id(id_b8_linear(36*(k-1)+6*(j-1)+i))
2292 id_b10_list(i,j,k) =
2293 & ipho_pdg2id(id_b10_linear(36*(k-1)+6*(j-1)+i))
2300 C copy secondary particles
2301 C (translate PDG-ID to CPC and sort according to CPC)
2304 if(idec_list(1,i).ne.0) then
2305 do j=idec_list(2,i),idec_list(3,i)
2307 wg_sec_list(ichan) = wg_chan(j)
2309 if(isec_linear(3*(j-1)+k).ne.0) then
2310 isec_list(k,ichan) = ipho_pdg2id(isec_linear(3*(j-1)+k))
2312 isec_list(k,ichan) = 0
2319 C add two-pion background (low-mass photon dissociation)
2323 idec_list(2,i) = ichan
2324 idec_list(3,i) = ichan
2325 wg_sec_list(ichan) = 1.D0
2326 isec_list(1,ichan) = ipho_pdg2id(211)
2327 isec_list(2,ichan) = ipho_pdg2id(-211)
2328 isec_list(3,ichan) = 0
2330 C min. mass limits for strings: q-qbar
2336 C pseudo-scalar mesons
2337 i1 = iabs(id_psm_list(i,k))
2341 AM1 = pho_pmass(i,3)+pho_pmass(k,3)
2343 i2 = iabs(id_psm_list(k,j))
2347 AM2 = pho_pmass(k,3)+pho_pmass(j,3)
2349 AM2P = MIN(AM2P,AM1+AM2)
2351 i1 = iabs(id_vem_list(i,k))
2355 AM1 = pho_pmass(i,3)+pho_pmass(k,3)
2357 i2 = iabs(id_vem_list(k,j))
2361 AM2 = pho_pmass(k,3)+pho_pmass(j,3)
2363 AM2V = MIN(AM2V,AM1+AM2)
2365 xm_psm2_list(i,j) = AM2P
2366 xm_vem2_list(i,j) = AM2V
2370 C min. mass limits for strings: qq-q
2377 C pseudo-scalar meson
2378 i1 = iabs(id_psm_list(k,l))
2382 AM1 = pho_pmass(i,3)+pho_pmass(k,3)
2385 i2 = iabs(id_vem_list(k,l))
2389 AM2 = pho_pmass(i,3)+pho_pmass(k,3)
2393 K8 = id_b8_list(i,j,l)
2397 AM1 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
2399 AM82 = MIN(AM82, AM1 + AMM)
2401 K10 = id_b10_list(i,j,l)
2405 AM2 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
2407 AM102 = MIN(AM102, AM2 + AMM)
2409 xm_b82_list(i,j,k) = AM82
2410 xm_b102_list(i,j,k) = AM102
2415 C min. mass limits for strings: qq-qbarqbar
2424 K8 = id_b8_list(i,j,l)
2428 AM1 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
2430 L8 = id_b8_list(ii,jj,l)
2434 AM2 = pho_pmass(ii,3)+pho_pmass(jj,3)+pho_pmass(l,3)
2436 AM82 = MIN(AM82, AM1+AM2)
2438 K10 = id_b10_list(i,j,l)
2442 AM1 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
2444 L10 = id_b10_list(ii,jj,l)
2448 AM2 = pho_pmass(ii,3)+pho_pmass(jj,3)+pho_pmass(l,3)
2450 AM102 = MIN(AM102, AM1+AM2)
2452 xm_bb82_list(i,j,ii,jj) = AM82
2453 xm_bb102_list(i,j,ii,jj) = AM102
2461 *$ CREATE PHO_PRESEL.FOR
2463 CDECK ID>, PHO_PRESEL
2464 SUBROUTINE PHO_PRESEL(MODE,IREJ)
2465 C**********************************************************************
2467 C user specific function to pre-select events during generation
2469 C input: MODE 5 electron and photon kinematics
2470 C 10 process and number of cut Pomerons
2471 C 15 partons without construction of strings
2472 C 20 partons assigned to strings
2473 C 25 after fragmentation, complete final state
2475 C output: IREJ 0 event accepted
2478 C**********************************************************************
2479 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2482 C input/output channels
2484 COMMON /POINOU/ LI,LO
2485 C event debugging information
2487 PARAMETER (NMAXD=100)
2488 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2489 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2490 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2491 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2492 C standard particle data interface
2494 PARAMETER (NMXHEP=4000)
2495 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
2496 DOUBLE PRECISION PHEP,VHEP
2497 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2498 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
2499 & VHEP(4,NMXHEP), NSD1, NSD2, NDD
2500 C extension to standard particle data interface (PHOJET specific)
2501 INTEGER IMPART,IPHIST,ICOLOR
2502 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
2503 C global event kinematics and particle IDs
2505 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
2506 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
2507 C gamma-lepton or gamma-hadron vertex information
2508 INTEGER IGHEL,IDPSRC,IDBSRC
2509 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
2510 & RADSRC,AMSRC,GAMSRC
2511 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
2512 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
2513 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
2514 C hard scattering data
2516 PARAMETER ( MSCAHD = 50 )
2517 INTEGER LSCAHD,LSC1HD,LSIDX,
2518 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
2519 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
2520 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
2521 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
2522 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
2523 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
2524 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
2525 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
2526 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
2527 C event weights and generated cross section
2528 INTEGER IPOWGC,ISWCUT,IVWGHT
2529 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2530 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2531 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2535 * XBJ = GQ2(2)/(GGECM**2+GQ2(2))
2536 * IF(XBJ.LT.0.002D0) IREJ = 1
2540 *$ CREATE PHO_FIXCOL.FOR
2542 CDECK ID>, PHO_FIXCOL
2543 SUBROUTINE PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
2544 C**********************************************************************
2546 C interface to call PHOJET (fixed energy run) with
2547 C collider kinematics
2549 C equivalen photon approximation to get photon flux
2551 C input: NEV number of events to generate
2552 C THETA azimuthal angle (micro radians)
2553 C PHI beam crossing angle
2554 C (with respect to x, in degrees)
2555 C E1 energy of particle 1 (+z direction, GeV)
2556 C E2 energy of particle 2 (-z direction, GeV)
2558 C note: particle types have to be specified before
2561 C**********************************************************************
2562 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2565 PARAMETER(TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
2567 C input/output channels
2569 COMMON /POINOU/ LI,LO
2570 C event debugging information
2572 PARAMETER (NMAXD=100)
2573 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2574 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2575 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2576 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2577 C general process information
2578 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
2579 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
2580 C global event kinematics and particle IDs
2582 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
2583 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
2584 C model switches and parameters
2586 INTEGER ISWMDL,IPAMDL
2587 DOUBLE PRECISION PARMDL
2588 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
2589 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
2590 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
2591 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
2592 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
2593 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
2594 C integration precision for hard cross sections (obsolete)
2595 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2596 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2597 C event weights and generated cross section
2598 INTEGER IPOWGC,ISWCUT,IVWGHT
2599 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2600 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2601 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2603 DIMENSION P1(4),P2(4)
2605 C remnant initialization (only needed for DPMJET)
2608 IF(IFPAP(1).EQ.81) THEN
2614 IF(IFPAP(2).EQ.82) THEN
2618 PMASS1 = PHO_PMASS(IFPAB(1),0)-SQRT(PVIRT(1))
2619 PMASS2 = PHO_PMASS(IFPAB(2),0)-SQRT(PVIRT(2))
2620 PP1 = SQRT(E1**2-PMASS1**2)
2621 PP2 = SQRT(E2**2-PMASS2**2)
2622 C beam crossing angle
2623 TH = 1.D-6*THETA/2.D0
2625 P1(1) = PP1*SIN(TH)*COS(PH)
2626 P1(2) = PP1*SIN(TH)*SIN(PH)
2629 P2(1) = PP2*SIN(TH)*COS(PH)
2630 P2(2) = PP2*SIN(TH)*SIN(PH)
2631 P2(3) = -PP2*COS(TH)
2633 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
2639 CALL PHO_PHIST(-1,SIGMAX)
2640 CALL PHO_LHIST(-1,SIGMAX)
2641 C test of DPMJET interface (default is IPAMDL(13)=0)
2642 if(IPAMDL(13).gt.0) then
2648 C main generation loop
2652 CALL PHO_EVENT(MODE,P1,P2,SIGCUR,IREJ)
2653 IF(IREJ.NE.0) GOTO 55
2654 CALL PHO_PHIST(1,HSWGHT(0))
2655 CALL PHO_LHIST(1,HSWGHT(0))
2659 SIGMAX = SIGMAX*DBLE(NEV)/DBLE(ITRY)
2660 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
2661 & '=========================================================',
2662 & ' ***** simulated cross section: ',SIGMAX,' mb *****',
2663 & '========================================================='
2664 CALL PHO_EVENT(-2,P1,P2,SIGCUR,IREJ)
2665 CALL PHO_PHIST(-2,SIGMAX)
2666 CALL PHO_LHIST(-2,SIGMAX)
2668 WRITE(LO,'(1X,A,I5)') 'POFCOL: no events simulated',NEV
2673 *$ CREATE PHO_FIXLAB.FOR
2675 CDECK ID>, PHO_FIXLAB
2676 SUBROUTINE PHO_FIXLAB(PLAB,NEV)
2677 C**********************************************************************
2679 C interface to call PHOJET (fixed energy run) with
2680 C LAB kinematics (second particle as target)
2682 C equivalent photon approximation to get photon flux
2684 C input: NEV number of events to generate
2685 C PLAB LAB momentum of particle 1
2687 C note: particle types have to be specified before
2690 C**********************************************************************
2691 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2694 C input/output channels
2696 COMMON /POINOU/ LI,LO
2697 C event debugging information
2699 PARAMETER (NMAXD=100)
2700 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2701 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2702 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2703 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2704 C general process information
2705 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
2706 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
2707 C global event kinematics and particle IDs
2709 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
2710 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
2711 C model switches and parameters
2713 INTEGER ISWMDL,IPAMDL
2714 DOUBLE PRECISION PARMDL
2715 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
2716 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
2717 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
2718 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
2719 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
2720 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
2721 C integration precision for hard cross sections (obsolete)
2722 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2723 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2724 C event weights and generated cross section
2725 INTEGER IPOWGC,ISWCUT,IVWGHT
2726 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2727 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2728 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2730 DIMENSION P1(4),P2(4)
2732 C remnant initialization (only needed for DPMJET)
2736 IF(IFPAP(1).EQ.81) THEN
2742 IF(IFPAP(2).EQ.82) THEN
2746 C get momenta in LAB system
2747 PMASS1 = PHO_PMASS(IFPAB(1),0)**2-PVIRT(1)
2748 PMASS2 = PHO_PMASS(IFPAB(2),0)**2-PVIRT(2)
2749 IF(PMASS2.LT.0.1D0) THEN
2750 WRITE(LO,'(/1X,2A,2I7)') 'PHO_FIXLAB:ERROR: ',
2751 & 'no LAB system possible',IFPAB(1),IFPAB(2)
2756 P1(4) = SQRT(PMASS1+PLAB**2)
2760 P2(4) = SQRT(PMASS2)
2761 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
2767 CALL PHO_PHIST(-1,SIGMAX)
2768 CALL PHO_LHIST(-1,SIGMAX)
2769 C event generation loop
2773 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
2774 IF(IREJ.NE.0) GOTO 45
2775 CALL PHO_LHIST(1,HSWGHT(0))
2776 CALL PHO_PHIST(10,HSWGHT(0))
2779 SIGMAX = SIGMAX*DBLE(NEV)/DBLE(ITRY)
2780 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
2781 & '=========================================================',
2782 & ' ***** simulated cross section: ',SIGMAX,' mb *****',
2783 & '========================================================='
2784 CALL PHO_EVENT(-2,P1,P2,SIGCUR,IREJ)
2785 CALL PHO_PHIST(-2,SIGMAX)
2786 CALL PHO_LHIST(-2,SIGMAX)
2788 WRITE(LO,'(1X,A,I5)')
2789 & 'PHO_FIXLAB: no events simulated',NEV
2795 *$ CREATE PHO_GPHERA.FOR
2797 CDECK ID>, PHO_GPHERA
2798 SUBROUTINE PHO_GPHERA(NEVENT,EE1,EE2)
2799 C**********************************************************************
2801 C interface to call PHOJET (variable energy run) with
2802 C HERA kinematics, photon as particle 2
2804 C equivalent photon approximation to get photon flux
2806 C input: NEVENT number of events to generate
2807 C EE1 proton energy (LAB system)
2808 C EE2 electron energy (LAB system)
2810 C YMIN2 lower limit of Y
2811 C (energy fraction taken by photon from electron)
2812 C YMAX2 upper limit of Y
2813 C Q2MIN2 lower limit of photon virtuality
2814 C Q2MAX2 upper limit of photon virtuality
2816 C**********************************************************************
2817 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2820 PARAMETER ( DEPS = 1.D-10,
2821 & PI = 3.14159265359D0 )
2823 C input/output channels
2825 COMMON /POINOU/ LI,LO
2826 C event debugging information
2828 PARAMETER (NMAXD=100)
2829 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2830 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2831 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2832 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2833 C model switches and parameters
2835 INTEGER ISWMDL,IPAMDL
2836 DOUBLE PRECISION PARMDL
2837 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
2838 C photon flux kinematics and cuts
2839 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
2840 & YMIN1,YMAX1,YMIN2,YMAX2,
2841 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
2842 & THMIN1,THMAX1,THMIN2,THMAX2
2844 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
2845 & YMIN1,YMAX1,YMIN2,YMAX2,
2846 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
2847 & THMIN1,THMAX1,THMIN2,THMAX2,
2849 C gamma-lepton or gamma-hadron vertex information
2850 INTEGER IGHEL,IDPSRC,IDBSRC
2851 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
2852 & RADSRC,AMSRC,GAMSRC
2853 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
2854 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
2855 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
2856 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
2857 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
2858 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
2859 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
2860 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
2861 C event weights and generated cross section
2862 INTEGER IPOWGC,ISWCUT,IVWGHT
2863 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2864 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2865 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2867 DIMENSION P1(4),P2(4)
2869 WRITE(LO,'(//1X,A,I10)') 'PHO_GPHERA: events to process',NEVENT
2870 C assign particle momenta according to HERA kinematics
2872 PROM = PHO_PMASS(2212,1)
2881 IDBSRC(2) = ipho_pdg2id(11)
2890 IF(Q2MIN.GT.ELEM2*YMIN2**2/(1.D0-YMIN2))
2891 & WRITE(LO,'(/1X,A,1P2E11.4)')
2892 & 'PHO_GPHERA: lower Q2 cutoff larger than kin. limit:',
2893 & Q2MIN,ELEM2*YMIN2**2/(1.D0-YMIN2)
2896 DELLY = LOG(YMAX2/YMIN2)/DBLE(Max_tab-1)
2899 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
2900 & 'PHO_GPHERA: table of photon flux (trans/long)',Max_tab
2902 Y = EXP(XIMIN+DELLY*DBLE(I-1))
2903 Q2LOW = MAX(Q2MIN,ELEM2*Y**2/(1.D0-Y))
2904 FFT = ((1.D0+(1.D0-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2905 & -2.D0*ELEM2*Y*(1.D0/Q2LOW-1.D0/Q2MAX))/(2.D0*PI*137.D0)
2906 FFL = 2.D0*(1.D0-Y)/Y*LOG(Q2MAX/Q2LOW)/(2.D0*PI*137.D0)
2907 FLUXT = FLUXT + Y*FFT
2908 FLUXL = FLUXL + Y*FFL
2909 IF(IDEB(30).GE.1) WRITE(LO,'(5X,1P3E14.4)') Y,FFT,FFL
2913 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,1P2E12.4)')
2914 & 'PHO_GPHERA: integrated flux (trans./long.):',FLUXT,FLUXL
2919 Q2LOW = MAX(Q2MIN,ELEM2*YY**2/(1.D0-YY))
2920 WGMAX = (1.D0+(1.D0-YY)**2)*LOG(Q2MAX/Q2LOW)
2921 & -2.D0*ELEM2*YY*(1.D0/Q2LOW-1.D0/Q2MAX)*YY
2922 IF(ISWMDL(10).GE.2) WGMAX = WGMAX+2.D0*(1.D0-YY)*LOG(Q2MAX/Q2LOW)
2924 C initialization of PHOJET at upper energy limit
2928 P1(3) = SQRT(EE1**2-PROM2+DEPS)
2936 C sum of both photon polarizations
2939 CALL PHO_SETPAR(1,2212,0,0.D0)
2940 CALL PHO_SETPAR(2,22,0,0.D0)
2941 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
2942 CALL PHO_PHIST(-1,SIGMAX)
2943 CALL PHO_LHIST(-1,SIGMAX)
2945 C generation of events, flux calculation
2967 YY = EXP(XIDEL*DT_RNDM(AY)+XIMIN)
2968 IF(ISWMDL(10).GE.2) THEN
2969 YEFF = 1.D0+(1.D0-YY)**2+2.D0*(1.D0-YY)
2971 YEFF = 1.D0+(1.D0-YY)**2
2973 Q2LOW = MAX(Q2MIN,ELEM2*YY**2/(1.D0-YY))
2974 Q2LOG = LOG(Q2MAX/Q2LOW)
2975 WGH = YEFF*Q2LOG-2.D0*ELEM2*YY**2*(1.D0/Q2LOW-1.D0/Q2MAX)
2976 IF(WGMAX.LT.WGH) THEN
2977 WRITE(LO,'(1X,A,3E12.5)')
2978 & 'PHO_GPHERA: inconsistent weight:',YY,WGMAX,WGH
2980 IF(DT_RNDM(AY2)*WGMAX.GT.WGH) GOTO 175
2982 IF(IPAMDL(174).EQ.1) THEN
2984 Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
2985 WEIGHT = (YEFF-2.D0*ELEM2*YY**2/Q2)/YEFF
2986 IF(WEIGHT.LT.DT_RNDM(Q2)) GOTO 185
2998 YQ2 = SQRT((1.D0-YY)*Q2)
3001 CALL PHO_SFECFE(SIF,COF)
3004 PFIN(3,2) = -E1Y+Q2E
3011 PFTHE(2) = ACOS(PFIN(3,2)/PFIN(4,2))
3013 IF(PFIN(4,2).GT.EEMIN2) THEN
3014 IF((PFTHE(2).LT.THMIN2).OR.(PFTHE(2).GT.THMAX2)) GOTO 175
3017 PFPHI(2) = ATAN2(COF,SIF)
3021 P2(3) = PINI(3,2)-PFIN(3,2)
3022 P2(4) = PINI(4,2)-PFIN(4,2)
3026 P1(3) = SQRT(EE1**2-PROM2)
3029 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
3030 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
3031 IF((GGECM.LT.ECMIN2).OR.(GGECM.GT.ECMAX2)) GOTO 175
3038 PGAM(5,2) = -SQRT(Q2)
3040 IF(ISWMDL(10).GE.2) THEN
3041 WGH = YEFF-2.D0*ELEM2*YY**2/Q2
3043 IF(DT_RNDM(YY).GE.WGHL/WGH) THEN
3052 CALL PHO_PRESEL(5,IREJ)
3053 IF(IREJ.NE.0) GOTO 175
3055 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
3056 IF(IREJ.NE.0) GOTO 150
3060 YY2MIN = MIN(YY2MIN,YY)
3061 YY2MAX = MAX(YY2MAX,YY)
3062 Q22MIN = MIN(Q22MIN,Q2)
3063 Q22MAX = MAX(Q22MAX,Q2)
3065 Q22AV2 = Q22AV2+Q2*Q2
3066 AN2MIN = MIN(AN2MIN,PFTHE(2))
3067 AN2MAX = MAX(AN2MAX,PFTHE(2))
3069 CALL PHO_PHIST(1,HSWGHT(0))
3070 CALL PHO_LHIST(1,HSWGHT(0))
3073 WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW)/(137.D0*2.D0*PI)
3074 WGY = WGY*LOG(YMAX2/YMIN2)
3076 AY2 = AY2/DBLE(NITER)
3077 DAY = SQRT((AY2-AY**2)/DBLE(NITER))
3078 Q22AVE = Q22AVE/DBLE(NITER)
3079 Q22AV2 = Q22AV2/DBLE(NITER)
3080 Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
3081 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
3082 C output of histograms
3083 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
3084 &'=========================================================',
3085 &' ***** simulated cross section: ',WEIGHT,' mb *****',
3086 &'========================================================='
3087 WRITE(LO,'(//1X,A,3I10)')
3088 & 'PHO_GPHERA:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
3089 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
3091 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y,DY ',AY,DAY
3092 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON ',
3094 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 ',
3096 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON ',
3098 WRITE(LO,'(1X,A,1P4E12.4)') 'SAMPLED THETA RANGE ELECTRON ',
3099 & AN2MIN,AN2MAX,PI-AN2MAX,PI-AN2MIN
3101 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
3103 CALL PHO_PHIST(-2,WEIGHT)
3104 CALL PHO_LHIST(-2,WEIGHT)
3106 WRITE(LO,'(1X,A,I4)') 'PHO_GPHERA:NO OUTPUT OF HISTOGRAMS',NITER
3111 *$ CREATE PHO_GGEPEM.FOR
3113 CDECK ID>, PHO_GGEPEM
3114 SUBROUTINE PHO_GGEPEM(NEVENT,EE1,EE2)
3115 C**********************************************************************
3117 C interface to call PHOJET (variable energy run) for
3118 C gamma-gamma collisions on e+e- collider
3120 C fully differential equivalent (improved) photon approximation
3121 C to get photon flux
3123 C input: EE1 LAB system energy of electron/positron 1
3124 C EE2 LAB system energy of electron/positron 2
3125 C NEVENT >0 number of events to generate
3127 C -2 final call (cross section calculation)
3129 C YMIN1 lower limit of Y1
3130 C (energy fraction taken by photon from electron)
3131 C YMAX1 upper limit of Y1
3132 C Q2MIN1 lower limit of photon virtuality
3133 C Q2MAX1 upper limit of photon virtuality
3134 C THMIN1 lower limit of scattered electron
3135 C THMAX1 upper limit of scattered electron
3136 C YMIN2 lower limit of Y2
3137 C (energy fraction taken by photon from electron)
3138 C YMAX2 upper limit of Y2
3139 C Q2MIN2 lower limit of photon virtuality
3140 C Q2MAX2 upper limit of photon virtuality
3141 C THMIN2 lower limit of scattered electron
3142 C THMAX2 upper limit of scattered electron
3144 C output: after final call with NEVENT=-2
3145 C EE1 e+ e- cross section (mb)
3146 C EE2 gamma-gamma cross section (mb)
3148 C**********************************************************************
3152 DOUBLE PRECISION EE1,EE2
3155 C input/output channels
3157 COMMON /POINOU/ LI,LO
3158 C event debugging information
3160 PARAMETER (NMAXD=100)
3161 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3162 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3163 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3164 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3165 C model switches and parameters
3167 INTEGER ISWMDL,IPAMDL
3168 DOUBLE PRECISION PARMDL
3169 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3171 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
3172 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
3173 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
3174 C photon flux kinematics and cuts
3175 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
3176 & YMIN1,YMAX1,YMIN2,YMAX2,
3177 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
3178 & THMIN1,THMAX1,THMIN2,THMAX2
3180 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
3181 & YMIN1,YMAX1,YMIN2,YMAX2,
3182 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
3183 & THMIN1,THMAX1,THMIN2,THMAX2,
3185 C gamma-lepton or gamma-hadron vertex information
3186 INTEGER IGHEL,IDPSRC,IDBSRC
3187 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
3188 & RADSRC,AMSRC,GAMSRC
3189 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
3190 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
3191 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
3192 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
3193 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3194 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3195 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3196 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3197 C event weights and generated cross section
3198 INTEGER IPOWGC,ISWCUT,IVWGHT
3199 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
3200 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
3201 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
3203 C external functions
3204 DOUBLE PRECISION DT_RNDM
3207 DOUBLE PRECISION AN1MAX,AN1MIN,AN2MAX,AN2MIN,AY1,AY2,AYS1,AYS2,
3208 & COF1,COF2,CPFTHE,DAY1,DAY2,DELLY,DITRY,DITRW,
3209 & ECFRAC,ECMAX2,ECMIN2,EGAM,ELEM,ELEM2,FFL,FFT,FLUXL,FLUXT,
3210 & FLXAPP,FLXQPM,GGECM2,P1,P2,PP,PT,PT2,Q21AV2,Q21AVE,Q21MAX,
3211 & Q21MIN,Q22AV2,Q22AVE,Q22MAX,Q22MIN,Q2LOG1,Q2LOG2,Q2LOW1,
3212 & Q2LOW2,Q2P1,Q2P2,SIF1,SIF2,SIGCUR,SIGMAX,THMAC1,
3213 & THMAC2,THMIC1,THMIC2,WEIGHT,WG,WGFX,WGH,WGHAPP,WGHL,WGHQPM,
3214 & WGMAX,WGY,X1DEL,X1MAX,X1MIN,X2DEL,X2MAX,X2MIN,Y1,Y2,YEFF1,YEFF2,
3215 & YMI,YY1MAX,YY1MIN,YY2MAX,YY2MIN
3217 INTEGER I,IHEAC1,IHEAC2,IHETRY,IREJ,ITRW_low,ITRW_high,ITRY_low,
3218 & ITRY_high,K,Max_tab,NITER,ITG1,ITG2
3220 DIMENSION P1(4),P2(4),IHETRY(4),IHEAC1(4),IHEAC2(4)
3223 C initialization of event generation
3225 if(NEVENT.eq.-1) then
3233 WRITE(LO,'(//1X,A)') 'PHO_GGEPEM: initialization'
3243 IDBSRC(1) = ipho_pdg2id(11)
3244 IDBSRC(2) = ipho_pdg2id(-11)
3246 C check/update kinematic limitations
3248 Ymi = min(Ymax1,1.D0-ELEM/EE1)
3249 if(Ymi.lt.Ymax1) then
3250 WRITE(LO,'(/1X,A,2E12.5)')
3251 & 'PHO_GGEPEM: Ymax1 decreased (old/new)',Ymax1,Ymi
3254 Ymi = min(Ymax2,1.D0-ELEM/EE2)
3255 if(Ymi.lt.Ymax2) then
3256 WRITE(LO,'(/1X,A,2E12.5)')
3257 & 'PHO_GGEPEM: Ymax2 decreased (old/new)',Ymax2,Ymi
3261 YMI = ECMIN**2/(4.D0*EE1*EE2*YMAX2)
3262 IF(YMIN1.LT.YMI) THEN
3263 WRITE(LO,'(/1X,A,2E12.5)')
3264 & 'PHO_GGEPEM: Ymin1 increased (old/new)',YMIN1,YMI
3266 ELSE IF(YMIN1.GT.YMI) THEN
3267 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
3268 & 'PHO_GGEPEM:','ECM-CUT corresponds to YMIN1 of',YMI,
3269 & ' INSTEAD OF',YMIN1
3271 YMI = ECMIN**2/(4.D0*EE1*EE2*YMAX1)
3272 IF(YMIN2.LT.YMI) THEN
3273 WRITE(LO,'(/1X,A,2E12.5)')
3274 & 'PHO_GGEPEM: Ymin2 increased (old/new)',YMIN2,YMI
3276 ELSE IF(YMIN2.GT.YMI) THEN
3277 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
3278 & 'PHO_GGEPEM:','ECM-CUT corresponds to YMIN2 of',YMI,
3279 & ' INSTEAD OF',YMIN2
3282 C store COS of angular tagging range
3283 THMIC1 = COS(MAX(0.D0,THMIN1))
3284 THMAC1 = COS(MIN(THMAX1,PI))
3285 THMIC2 = COS(MAX(0.D0,THMIN2))
3286 THMAC2 = COS(MIN(THMAX2,PI))
3295 C debug: integrated photon flux
3297 if(IDEB(30).ge.1) then
3301 DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
3302 IF(IDEB(30).GE.2) WRITE(LO,'(1X,2A,I5)') 'PHO_GGEPEM: ',
3303 & 'table of photon flux (trans/long side 1)',Max_tab
3305 Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
3306 if((1.D0-Y1).gt.1.D-8) then
3307 Q2LOW1 = MAX(Q2MIN1,ELEM2*Y1*Y1/(1.D0-Y1))
3309 Q2low1 = 2.D0*Q2max1
3311 if(Q2low1.lt.Q2max1) then
3312 FFT = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
3313 & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))/(2.D0*PI*137.D0)
3314 FFL = 2.D0*(1.D0-Y1)*LOG(Q2MAX1/Q2LOW1)/(2.D0*PI*137.D0)
3319 FLUXT = FLUXT + Y1*FFL
3320 FLUXL = FLUXL + Y1*FFT
3321 IF(IDEB(30).GE.2) WRITE(LO,'(5X,1P3E14.4)') Y1,FFT,FFL
3325 WRITE(LO,'(1X,2A,1P2E12.4)') 'PHO_GGEPEM: ',
3326 & 'integrated flux (trans/long side 1):',FLUXT,FLUXL
3331 Q2LOW1 = MAX(Q2MIN1,ELEM2*YMIN1**2/(1.D0-YMIN1))
3332 Q2LOW2 = MAX(Q2MIN2,ELEM2*YMIN2**2/(1.D0-YMIN2))
3335 IF(ISWMDL(10).GE.2) THEN
3336 C long. and transversely polarized photons
3337 WGMAX = ((1.D0+(1.D0-Y1)**2+2.D0*(1.D0-Y1))*LOG(Q2MAX1/Q2LOW1)
3338 & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
3339 & *((1.D0+(1.D0-Y2)**2+2.D0*(1.D0-Y2))*LOG(Q2MAX2/Q2LOW2)
3340 & -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
3342 C transversely polarized photons only
3343 WGMAX = ((1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
3344 & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
3345 & *((1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
3346 & -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
3349 C initialize gamma-gamma event generator
3355 P1(3) = SQRT(EGAM**2-Q2LOW1)
3361 P2(3) = -SQRT(EGAM**2-Q2LOW2)
3367 C set min. energy for interpolation tables
3368 parmdl(19) = min(parmdl(19),ecmin)
3370 C initialize event gneration
3371 CALL PHO_SETPAR(1,22,0,0.D0)
3372 CALL PHO_SETPAR(2,22,0,0.D0)
3373 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
3374 CALL PHO_PHIST(-1,SIGMAX)
3375 CALL PHO_LHIST(-1,SIGMAX)
3377 C generation of events, flux calculation
3380 ECFRAC = ECMIN2/(4.D0*EE1*EE2)
3407 C generate NEVENT events (might be just 1 per call)
3409 else if(NEVENT.gt.0) then
3411 NITER = NITER+NEVENT
3417 ITRY_low = ITRY_low+1
3418 if(ITRY_low.eq.1000000) then
3420 ITRY_high = ITRY_high+1
3424 ITRW_low = ITRW_low+1
3425 if(ITRW_low.eq.1000000) then
3427 ITRW_high = ITRW_high+1
3430 Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
3431 Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
3432 IF(Y1*Y2.LT.ECFRAC) GOTO 175
3433 IF(ISWMDL(10).GE.2) THEN
3434 YEFF1 = 1.D0+(1.D0-Y1)**2+2.D0*(1.D0-Y1)
3435 YEFF2 = 1.D0+(1.D0-Y2)**2+2.D0*(1.D0-Y2)
3437 YEFF1 = 1.D0+(1.D0-Y1)**2
3438 YEFF2 = 1.D0+(1.D0-Y2)**2
3441 Q2LOW1 = MAX(Q2MIN1,ELEM2*Y1**2/(1.D0-Y1))
3442 Q2LOW2 = MAX(Q2MIN2,ELEM2*Y2**2/(1.D0-Y2))
3443 Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
3444 Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
3446 & -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
3448 & -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
3449 IF(WGMAX.LT.WGH) THEN
3450 WRITE(LO,'(1X,A,4E12.5)')
3451 & 'PHO_GGEPEM: inconsistent weight:',Y1,Y2,WGMAX,WGH
3453 IF(DT_RNDM(AYS1)*WGMAX.GT.WGH) GOTO 175
3455 C limit on Ecm_gg (app. cut, precise cut applied later)
3456 GGECM2 = 4.D0*Y1*Y2*EE1*EE2
3457 if(GGECM2.lt.ECMIN2) goto 175
3460 IF(IPAMDL(174).EQ.1) THEN
3462 Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
3463 WEIGHT = (YEFF1-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF1
3464 IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
3469 IF(IPAMDL(174).EQ.1) THEN
3471 Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
3472 WEIGHT = (YEFF2-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF2
3473 IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
3483 C incoming electron 1
3486 PINI(3,1) = EE1*(1.D0-0.5D0*ELEM2/EE1**2)
3490 PP = (2.D0*EE1**2*Y1+Q2P1)/(2.D0*PINI(3,1))
3491 PT2 = (EE1**2*(Q2P1*(1.D0-Y1)-ELEM2*Y1**2)
3492 & -0.25D0*Q2P1**2-Q2P1*ELEM2)/PINI(3,1)**2
3493 IF(PT2.LT.0.D0) GOTO 175
3495 CALL PHO_SFECFE(SIF1,COF1)
3500 C outgoing electron 1
3503 PFIN(3,1) = PINI(3,1)-P1(3)
3504 PFIN(4,1) = PINI(4,1)-P1(4)
3506 C incoming electron 2
3509 PINI(3,2) = -EE2*(1.D0-0.5D0*ELEM2/EE2**2)
3513 PP = (2.D0*EE2**2*Y2+Q2P2)/(2.D0*PINI(3,2))
3514 PT2 = (EE2**2*(Q2P2*(1.D0-Y2)-ELEM2*Y2**2)
3515 & -0.25D0*Q2P2**2-Q2P2*ELEM2)/PINI(3,2)**2
3516 IF(PT2.LT.0.D0) GOTO 175
3518 CALL PHO_SFECFE(SIF2,COF2)
3523 C outgoing electron 2
3526 PFIN(3,2) = PINI(3,2)-P2(3)
3527 PFIN(4,2) = PINI(4,2)-P2(4)
3532 GGECM2 = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
3533 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
3534 IF((GGECM2.LT.ECMIN2).OR.(GGECM2.GT.ECMAX2)) GOTO 175
3535 GGECM = SQRT(GGECM2)
3537 C beam lepton detector acceptance
3540 CPFTHE = PFIN(3,1)/PFIN(4,1)
3542 IF(PFIN(4,1).GE.EEMIN1) THEN
3543 IF((CPFTHE.LE.THMIC1).AND.(CPFTHE.GE.THMAC1)) ITG1 = 1
3547 CPFTHE = PFIN(3,2)/PFIN(4,2)
3549 IF(PFIN(4,2).GE.EEMIN2) THEN
3550 IF((CPFTHE.LE.THMIC2).AND.(CPFTHE.GE.THMAC2)) ITG2 = 1
3553 C beam lepton taggers
3556 IF((ITAG1.EQ.-1).AND.(ITG1.NE.0)) GOTO 175
3557 IF((ITAG2.EQ.-1).AND.(ITG2.NE.0)) GOTO 175
3559 IF((ITAG1.EQ.1).AND.(ITG1.EQ.0)) GOTO 175
3560 IF((ITAG2.EQ.1).AND.(ITG2.EQ.0)) GOTO 175
3561 C single-tag inclusive
3562 IF((ITAG1.EQ.0).AND.(ITAG2.EQ.0).AND.(ITG1+ITG2.EQ.0))
3564 C single-tag/anti-tag
3565 IF((ITAG1.EQ.2).AND.(ITAG2.EQ.2).AND.(ITG1+ITG2.NE.1))
3572 PGAM(5,1) = -SQRT(Q2P1)
3577 PGAM(5,2) = -SQRT(Q2P2)
3580 IF(ISWMDL(10).GE.2) THEN
3581 WGH = YEFF1-2.D0*ELEM2*Y1**2/Q2P1
3583 IF(DT_RNDM(Y1).GT.WGHL/WGH) THEN
3588 WGH = YEFF2-2.D0*ELEM2*Y2**2/Q2P2
3590 IF(DT_RNDM(Y2).GT.WGHL/WGH) THEN
3595 K = 2*IGHEL(1)+IGHEL(2)+1
3596 IHETRY(K) = IHETRY(K)+1
3603 CALL PHO_PRESEL(5,IREJ)
3604 IF(IREJ.NE.0) GOTO 175
3607 C reweight according to LO photon emission diagrams (Budnev et al.)
3608 IF(IPAMDL(116).GE.1) THEN
3609 CALL PHO_WGEPEM(FLXAPP,FLXQPM,0)
3610 WGFX = FLXQPM/FLXAPP
3611 if(WGFX.gt.1.D0) then
3612 WRITE(LO,'(1x,a,/,5x,1p,5e11.4)')
3613 & ' PHO_GGEPEM: flux weight > 1 (y1/2,Q21/2,W)',
3614 & Y1,Y2,Q2P1,Q2P2,GGECM
3620 * EVWGHT(1) = MAX(WGFX,1.D0)
3621 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
3622 IF(IREJ.NE.0) GOTO 150
3623 IF(ISWMDL(10).GE.2) THEN
3624 K = 2*IGHEL(1)+IGHEL(2)+1
3625 IHEAC1(K) = IHEAC1(K)+1
3628 C reweight according to QPM model (e+e- collider only)
3629 IF((KHDIR.GT.0).AND.
3630 & (IPAMDL(116).GE.2).AND.(ISWMDL(10).GE.2)) THEN
3631 CALL PHO_WGEPEM(WGHAPP,WGHQPM,1)
3632 WG = WGHQPM/WGHAPP/MAX(1.D0,WGFX)
3633 IF(DT_RNDM(WG).GT.WG) GOTO 150
3634 ELSE IF(IPAMDL(116).GE.1) THEN
3635 IF(DT_RNDM(WG).GT.WGFX) GOTO 150
3639 PFTHE(1) = ACOS(PFIN(3,1)/PFIN(4,1))
3640 PFTHE(2) = ACOS(PFIN(3,2)/PFIN(4,2))
3642 PFPHI(1) = ATAN2(COF1,SIF1)
3643 PFPHI(2) = ATAN2(COF2,SIF2)
3650 Q21MIN = MIN(Q21MIN,Q2P1)
3651 Q22MIN = MIN(Q22MIN,Q2P2)
3652 Q21MAX = MAX(Q21MAX,Q2P1)
3653 Q22MAX = MAX(Q22MAX,Q2P2)
3654 AN1MIN = MIN(AN1MIN,PFTHE(1))
3655 AN2MIN = MIN(AN2MIN,PFTHE(2))
3656 AN1MAX = MAX(AN1MAX,PFTHE(1))
3657 AN2MAX = MAX(AN2MAX,PFTHE(2))
3658 YY1MIN = MIN(YY1MIN,Y1)
3659 YY2MIN = MIN(YY2MIN,Y2)
3660 YY1MAX = MAX(YY1MAX,Y1)
3661 YY2MAX = MAX(YY2MAX,Y2)
3662 Q21AVE = Q21AVE+Q2P1
3663 Q22AVE = Q22AVE+Q2P2
3664 Q21AV2 = Q21AV2+Q2P1*Q2P1
3665 Q22AV2 = Q22AV2+Q2P2*Q2P2
3666 IF(ISWMDL(10).GE.2) THEN
3667 K = 2*IGHEL(1)+IGHEL(2)+1
3668 IHEAC2(K) = IHEAC2(K)+1
3670 C external histograms
3671 CALL PHO_PHIST(1,HSWGHT(0))
3672 CALL PHO_LHIST(1,HSWGHT(0))
3675 C final cross section calculation and event generation summary
3677 else if(NEVENT.eq.-2) then
3681 DITRY = dble(ITRY_high)*1.D+6+dble(ITRY_low)
3682 DITRW = dble(ITRW_high)*1.D+6+dble(ITRW_low)
3683 WGY = WGMAX*DITRY/DITRW/(137.D0*2.D0*PI)**2
3684 WGY = WGY*LOG(YMAX1/YMIN1)*LOG(YMAX2/YMIN2)
3685 AY1 = AY1/DBLE(NITER)
3686 AYS1 = AYS1/DBLE(NITER)
3687 DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
3688 AY2 = AY2/DBLE(NITER)
3689 AYS2 = AYS2/DBLE(NITER)
3690 DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
3691 Q21AVE = Q21AVE/DBLE(NITER)
3692 Q21AV2 = Q21AV2/DBLE(NITER)
3693 Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(NITER))
3694 Q22AVE = Q22AVE/DBLE(NITER)
3695 Q22AV2 = Q22AV2/DBLE(NITER)
3696 Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
3697 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DITRY
3699 EE2 = SIGMAX*DBLE(NITER)/DITRY
3701 C output of statistics, histograms
3702 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
3703 & '=========================================================',
3704 & ' ***** simulated cross section: ',WEIGHT,' mb *****',
3705 & '========================================================='
3706 WRITE(LO,'(//1X,A,I10,1p,2e14.6)')
3707 & 'PHO_GGEPEM:summary: NITER,ITRY,ITRW',NITER,DITRY,DITRW
3708 WRITE(LO,'(1X,A,1P2E12.4)') 'effective weight (FLUX,TOTAL)',
3710 WRITE(LO,'(1X,A,1P2E12.4)') 'average Y1,DY1 ',
3712 WRITE(LO,'(1X,A,1P2E12.4)') 'average Y2,DY2 ',
3714 WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Y range photon 1 ',
3716 WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Y range photon 2 ',
3718 WRITE(LO,'(1X,A,1P2E12.4)') 'average Q2,DQ2 photon 1 ',
3720 WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Q2 range photon 1 ',
3722 WRITE(LO,'(1X,A,1P2E12.4)') 'average Q2,DQ2 photon 2 ',
3724 WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Q2 range photon 2 ',
3726 WRITE(LO,'(1X,A,1P2E12.4)') 'sampled THETA range electron1',
3728 WRITE(LO,'(1X,A,1P4E12.4)') 'sampled THETA range electron2',
3729 & AN2MIN,AN2MAX,PI-AN2MAX,PI-AN2MIN
3731 IF(ISWMDL(10).GE.2) THEN
3732 WRITE(LO,'(/1X,A,3(/1X,A,4I12))')
3733 & 'Helicity decomposition: 0 0 0 1 1 0 1 1',
3735 & 'accepted (1): ',IHEAC1,
3736 & 'accepted (2): ',IHEAC2
3739 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
3741 CALL PHO_PHIST(-2,WEIGHT)
3742 CALL PHO_LHIST(-2,WEIGHT)
3744 WRITE(LO,'(1X,A,I4)')
3745 & 'PHO_GGEPEM: no output of histograms',NITER
3752 *$ CREATE PHO_WGEPEM.FOR
3754 CDECK ID>, PHO_WGEPEM
3755 SUBROUTINE PHO_WGEPEM(WGHAPP,WGHQPM,IMODE)
3756 C**********************************************************************
3758 C calculate cross section weights for
3759 C fully differential equivalent (improved) photon approximation
3761 C fully differential QPM model with exact one-photon exchange graphs
3763 C (unpolarized lepton beams)
3765 C input: IMODE 0 flux calculation only
3766 C 1 flux folded with QPM cross section
3767 C /POFSRC/ photon and electron momenta
3768 C /POPRCS/ process type
3769 C /POCKIN/ kinematics of hard scattering
3771 C output: WGHAPP weight of event according to approximation
3772 C WGHQPM weight of event according to one-photon exchange
3774 C**********************************************************************
3778 DOUBLE PRECISION WGHAPP,WGHQPM
3781 C input/output channels
3783 COMMON /POINOU/ LI,LO
3784 C event debugging information
3786 PARAMETER (NMAXD=100)
3787 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3788 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3789 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3790 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3791 C model switches and parameters
3793 INTEGER ISWMDL,IPAMDL
3794 DOUBLE PRECISION PARMDL
3795 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3797 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
3798 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
3799 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
3800 C gamma-lepton or gamma-hadron vertex information
3801 INTEGER IGHEL,IDPSRC,IDBSRC
3802 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
3803 & RADSRC,AMSRC,GAMSRC
3804 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
3805 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
3806 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
3807 C general process information
3808 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3809 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3810 C data on most recent hard scattering
3811 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
3812 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
3813 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
3814 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
3815 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
3816 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
3817 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
3818 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
3819 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
3820 C hard scattering parameters used for most recent hard interaction
3822 DOUBLE PRECISION ALQCD2,BQCD
3823 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
3824 C currently activated parton density parametrizations
3826 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
3827 DOUBLE PRECISION PDFLAM,PDFQ2M
3828 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
3829 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
3830 C standard particle data interface
3832 PARAMETER (NMXHEP=4000)
3833 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
3834 DOUBLE PRECISION PHEP,VHEP
3835 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
3836 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
3838 C extension to standard particle data interface (PHOJET specific)
3839 INTEGER IMPART,IPHIST,ICOLOR
3840 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
3842 DOUBLE PRECISION AA,ALPHA1,ALPHA2,BB,CC,CCAP,DD,FAC,HELFLX,
3843 & P1,P1P2,P1Q2,P2,P2Q1,Q1KK,Q1Q2,Q2,Q2KK,QC2,RHO100,RHO1PP,
3844 & RHO200,RHO2PP,RHOP08,RHOPM2,RR,SH,SIGQPM,SP,SS,SW0000,SW0P0M,
3845 & SW0P0P,SW0PM0,SWP00P,SWP0M0,SWP0P0,SWPMPM,SWPP00,SWPPMM,SWPPPP,
3846 & TH,TP,UH,W2,WGHEQ,WGHQQ,XCAP,XK1,XK2,XKAM,XKAP,
3847 & XM2,XQ2,XTM1,XTM2,XTM3,YCAP
3848 DOUBLE PRECISION PHO_ALPHAS,pho_alphae
3850 INTEGER I,I1,I2,IDIR,IPFL1,IPFL2,IPOS,K
3852 DIMENSION WGHEQ(2),XM2(2),P1(4),P2(4),XK1(4),XK2(4)
3853 DIMENSION HELFLX(6),SIGQPM(6)
3858 C strict pt cutoff after putting partons on mass shell,
3859 C calculated in gamma-gamma CMS
3860 if((Imode.eq.1).and.(ipamdl(121).gt.0)) then
3861 if(PTfin.lt.PTwant) then
3862 if(ipamdl(121).gt.1) return
3863 if((ipamdl(121).eq.1).and.(MSPR.eq.14)) return
3867 C cross section of sampled event (approximate treatment)
3871 XM2(K) = AMSRC(K)**2
3872 IF(abs(IGHEL(K)).EQ.1) THEN
3873 WGHEQ(K) = ((1.D0+(1.D0-GYY(K))**2)/GYY(K)
3874 & -2.D0*XM2(K)*GYY(K)/GQ2(K))/(137.D0*2.D0*PI*GQ2(K))
3876 WGHEQ(K) = (1.D0-GYY(K))/GYY(K)/(137.D0*PI*GQ2(K))
3884 C direct or single-resolved gam-gam interaction
3885 IF((IMODE.GE.1).AND.
3886 & (IPROCE.EQ.8).AND.(MSPR.GE.10)) THEN
3889 C determine final state partons
3891 IF(ISTHEP(I).EQ.25) GOTO 110
3893 WRITE(LO,'(/1X,2A,I5)') 'PHO_WGEPEM:ERROR: ',
3894 & 'inconsistent process information (MSPR)',MSPR
3898 C final state flavors
3899 IPFL1 = ABS(IDHEP(IPOS+3))
3900 IPFL2 = ABS(IDHEP(IPOS+4))
3902 C calculate alpha-em
3903 ALPHA1 = pho_alphae(QQAL)
3906 ALPHA2 = PHO_ALPHAS(QQAL,3)
3908 C LO matrix element (8 pi s dsig/dt)
3909 * QC2 = 4.D0/9.D0 - DBLE(MOD(IPFL2,2))*3.D0/9.D0
3912 WRITE(LO,'(1X,2A,/,5X,A,I12,I3,4I4)') 'PHO_WGEPEM:ERROR: ',
3913 & 'invalid hard process - flavor combination',
3914 & 'EVENT,MSPR,IA,IB,IC,ID:',KEVENT,MSPR,IA,IB,IC,ID
3917 WGHQQ = -8.D0*PI/(3.D0*SH**2)*ALPHA1*QC2*ALPHA2*(U**2+1.D0)/U
3919 ELSE IF(MSPR.EQ.11) THEN
3920 WGHQQ = PI/SH**2*ALPHA1*QC2*ALPHA2*(V**2+U**2)/(U*V)
3922 ELSE IF(MSPR.EQ.12) THEN
3923 WGHQQ = -8.D0*PI/(3.D0*SH**2)*ALPHA1*QC2*ALPHA2*(V**2+1.D0)/V
3925 ELSE IF(MSPR.EQ.13) THEN
3926 WGHQQ = PI/SH**2*ALPHA1*QC2*ALPHA2*(V**2+U**2)/(U*V)
3928 ELSE IF(MSPR.EQ.14) THEN
3929 WGHQQ = 6.D0*PI/SH**2*(ALPHA1*QC2)**2*(V**2+U**2)/(U*V)
3934 C fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
3935 WGHAPP = WGHEQ(1)*WGHEQ(2)*WGHQQ/(2.D0*PI)
3937 C full leading-order QPM prediction (Budnev et al.)
3939 C full two-gamma flux
3941 P1Q2 = PINI(4,1)*PGAM(4,2)-PINI(1,1)*PGAM(1,2)
3942 & -PINI(2,1)*PGAM(2,2)-PINI(3,1)*PGAM(3,2)
3943 P2Q1 = PINI(4,2)*PGAM(4,1)-PINI(1,2)*PGAM(1,1)
3944 & -PINI(2,2)*PGAM(2,1)-PINI(3,2)*PGAM(3,1)
3945 Q1Q2 = PGAM(4,1)*PGAM(4,2)-PGAM(1,1)*PGAM(1,2)
3946 & -PGAM(2,1)*PGAM(2,2)-PGAM(3,1)*PGAM(3,2)
3947 P1P2 = PINI(4,1)*PINI(4,2)-PINI(1,1)*PINI(1,2)
3948 & -PINI(2,1)*PINI(2,2)-PINI(3,1)*PINI(3,2)
3950 P1(I) = 2.D0*PINI(I,1)-PGAM(I,1)
3951 P2(I) = 2.D0*PINI(I,2)-PGAM(I,2)
3953 XTM1 = 2.D0*P1Q2-Q1Q2
3954 XTM2 = 2.D0*P2Q1-Q1Q2
3955 XTM3 = P1(4)*P2(4)-P1(1)*P2(1)-P1(2)*P2(2)-P1(3)*P2(3)
3956 XCAP = Q1Q2**2-GQ2(1)*GQ2(2)
3957 YCAP = P1P2**2-XM2(1)*XM2(2)
3958 CCAP = -XTM3 + Q1Q2*XTM1*XTM2/XCAP
3960 RHO1PP = (XTM1**2/XCAP+1.D0-4.D0*XM2(1)/GQ2(1))/2.D0
3961 RHO2PP = (XTM2**2/XCAP+1.D0-4.D0*XM2(2)/GQ2(2))/2.D0
3962 RHO100 = XTM1**2/XCAP-1.D0
3963 RHO200 = XTM2**2/XCAP-1.D0
3964 RHOPM2 = CCAP**2/(GQ2(1)*GQ2(2))-2.D0*(RHO1PP-1.D0)*(RHO2PP-1.D0)
3965 RHOP08 = 4.D0*XTM1*XTM2*CCAP/XCAP/SQRT(GQ2(1)*GQ2(2))
3966 SS = 2.D0*P1P2+XM2(1)+XM2(2)
3968 HELFLX(1) = 4.D0*RHO1PP*RHO2PP
3970 HELFLX(3) = 2.D0*RHO1PP*RHO200
3971 HELFLX(4) = 2.D0*RHO100*RHO2PP
3972 HELFLX(5) = RHO100*RHO200
3975 C only flux calculation
3978 IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.1)) THEN
3980 ELSE IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.0)) THEN
3982 ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.1)) THEN
3984 ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.0)) THEN
3986 ELSE IF((IGHEL(1).EQ.-1).AND.(IGHEL(2).EQ.-1)) THEN
3989 WRITE(LO,'(/1X,A,2I3)')
3990 & 'PHO_GGEPEM:ERROR: invalid photon helicities: ',IGHEL
3991 WRITE(LO,'(1X,A,I12)')
3992 & 'PHO_GGEPEM: event rejected (KEVENT)',KEVENT
3996 C fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
3997 WGHQPM = WEIGHT/(137.D0**2*16.D0*PI**4*GQ2(1)*GQ2(2))
3998 & *SQRT(XCAP/YCAP)*PI*SS/(2.D0*YCAP)*PINI(4,1)*PINI(4,2)
4002 C flux folded with cross section
4003 C polarized, leading order gam gam --> q qbar cross sections
4008 C momenta of produced parton pair
4018 C direct photon-photon interaction
4019 XKAP = XQ2-(PGAM(4,1)-XK1(4))**2
4020 & +(PGAM(1,1)-XK1(1))**2+(PGAM(2,1)-XK1(2))**2
4021 & +(PGAM(3,1)-XK1(3))**2
4022 XKAM = XQ2-(PGAM(4,1)-XK2(4))**2
4023 & +(PGAM(1,1)-XK2(1))**2+(PGAM(2,1)-XK2(2))**2
4024 & +(PGAM(3,1)-XK2(3))**2
4026 AA = XKAP*XKAM-GQ2(1)*GQ2(2)
4027 BB = CC**2-XKAP*XKAM
4028 DD = CC**2-GQ2(1)*GQ2(2)
4029 RR = -XQ2+W2*AA/(4.D0*DD)
4032 FAC = 192.D0*(PI*ALPHA1*QC2/(XKAP*XKAM))**2/(4.D0*SQRT(XCAP))
4035 C single-resolved photon-hadron interactions
4036 C Mandelstam variables
4038 TH = (PGAM(4,1)-XK1(4))**2-(PGAM(1,1)-XK1(1))**2
4039 & -(PGAM(2,1)-XK1(2))**2-(PGAM(3,1)-XK1(3))**2
4040 UH = (PGAM(4,1)-XK2(4))**2-(PGAM(1,1)-XK2(1))**2
4041 & -(PGAM(2,1)-XK2(2))**2-(PGAM(3,1)-XK2(3))**2
4043 TH = (PGAM(4,2)-XK2(4))**2-(PGAM(1,2)-XK2(1))**2
4044 & -(PGAM(2,2)-XK2(2))**2-(PGAM(3,2)-XK2(3))**2
4045 UH = (PGAM(4,2)-XK1(4))**2-(PGAM(1,2)-XK1(1))**2
4046 & -(PGAM(2,2)-XK1(2))**2-(PGAM(3,2)-XK1(3))**2
4053 IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.1)) THEN
4054 IF((MSPR.EQ.10).OR.(MSPR.EQ.12)) THEN
4064 SIGQPM(1)= -32.D0*PI**2*4.D0/3.D0*ALPHA1*QC2*ALPHA2
4065 & *(SP*TP*(2.D0*Q2**4-4.D0*Q2*SP**3-2.D0*Q2**3*(3*SP+TP)
4066 & +SP**2*(SP**2+TP**2)+Q2**2*(7.D0*SP**2+2.D0*SP*TP+TP**2))
4067 & -2.D0*(2.D0*SP**3*TP*(SP+TP)+Q2**3*(SP**2+6.D0*SP*TP+TP**2)
4068 & -2.D0*Q2**2*SP*(SP**2+4.D0*SP*TP+3.D0*TP**2)+Q2*SP*
4069 & (SP**3+SP**2*TP-SP*TP**2+TP**3))*XQ2 +
4070 & 4.D0*(2.D0*Q2**2-SP**2)*(SP+TP)**2*XQ2**2)/
4071 & (SP**2*TP**2*((Q2-SP)**2-4.D0*Q2*XQ2))
4072 WEIGHT = HELFLX(1)*SIGQPM(1)/(2.D0*(SH+GQ2(1)+GQ2(2)))
4073 ELSE IF((MSPR.EQ.11).OR.(MSPR.EQ.13)) THEN
4081 SIGQPM(1) = -32.D0*PI**2/2.D0*ALPHA1*QC2*ALPHA2
4082 & *(-((Q2**2+SP**2)*TP*(Q2**3-SP**3-3.D0*SP**2*TP
4083 & - 4.D0*SP*TP**2 - 2.D0*TP**3 - 3.D0*Q2**2*(SP + TP) + Q2*
4084 & (3.D0*SP**2 + 6.D0*SP*TP + 4.D0*TP**2))) +
4085 & (3.D0*Q2**5 - Q2**4*(11.D0*SP + 10.D0*TP) +
4086 & 4.D0*Q2**3*(4.D0*SP**2 + 5.D0*SP*TP + 4.D0*TP**2)
4087 & +Q2*SP**2*(5.D0*SP**2+4.D0*SP*TP+8.D0*TP**2)-4.D0*Q2**2
4088 & *(3.D0*SP**3+3.D0*SP**2*TP+4.D0*SP*TP**2+2.D0*TP**3)-
4089 & SP**2*(SP**3+2.D0*SP**2*TP+8.D0*SP*TP**2+8.D0*TP**3))*XQ2+
4090 & (11.D0*Q2**4-10.D0*Q2**3*(3.D0*SP+2.D0*TP)-2.D0*Q2*SP**2
4091 & *(7.D0*SP+2.D0*TP)+2.D0*Q2**2*(15.D0*SP**2+10.D0*SP*TP
4092 & +6.D0*TP**2)+SP**2*(3.D0*SP**2+4.D0*SP*TP+12.D0*TP**2))
4093 & *XQ2**2+8.D0*(Q2**3-SP**2*TP-Q2**2*(SP+TP))*XQ2**3+
4094 & 2.D0*(Q2**2+SP**2)*XQ2**4)/((Q2-SP)**2*(-TP+XQ2)**2*
4095 & (Q2-SP-TP+XQ2)**2)
4096 WEIGHT = HELFLX(1)*SIGQPM(1)/(2.D0*(SH+GQ2(1)+GQ2(2)))
4097 ELSE IF(MSPR.EQ.14) THEN
4098 SWPMPM = 4.D0*CC**2*RR*(W2-2.D0*RR)
4099 SWPPPP = SWPMPM +2.D0*(CC**2+BB)*(AA-4.D0*RR*CC)
4100 SWPPMM = 8.D0*RR*CC*(XKAP*XKAM-RR*CC)
4101 & -2.D0*XKAP*XKAM*AA
4102 SIGQPM(1) = (SWPPPP+SWPMPM)/2.D0*FAC
4103 SIGQPM(2) = SWPPMM*FAC
4104 WEIGHT = HELFLX(1)*SIGQPM(1)
4105 & +HELFLX(2)*SIGQPM(2)
4107 ELSE IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.0)) THEN
4112 SIGQPM(3) = 32.D0*PI**2*8.D0/3.D0*ALPHA1*QC2*ALPHA2
4113 & *Q2*(-(SP**2*TP**2*(-Q2 + SP + TP)) +
4114 & SP*TP*(2.D0*Q2**2 + 3.D0*SP**2 + 2.D0*SP*TP -
4115 & TP**2 - 2.D0*Q2*(3*SP + TP))*XQ2 -
4116 & 2.D0*(Q2*(SP**2 + 6.D0*SP*TP + TP**2) -
4117 & 2.D0*SP*(SP**2 + 4.D0*SP*TP + 3.D0*TP**2))*
4118 & XQ2**2 + 8.D0*(SP + TP)**2*XQ2**3)/
4119 & (SP**2*TP**2*((Q2 - SP)**2 - 4.D0*Q2*XQ2))
4120 WEIGHT = HELFLX(3)*SIGQPM(3)/(2.D0*(SH+GQ2(2)))
4121 ELSE IF(MSPR.EQ.13) THEN
4125 SIGQPM(3) = 32.D0*PI**2*2.D0*ALPHA1*QC2*ALPHA2
4126 & *(-Q2*(SP*TP*(-Q2+SP+TP)+(Q2**2-Q2*SP-2*SP*TP)*XQ2 +
4127 & SP*XQ2**2))/((Q2-SP)**2*(-TP+XQ2)*(Q2-SP-TP+XQ2))
4128 WEIGHT = HELFLX(3)*SIGQPM(3)/(2.D0*(SH+GQ2(2)))
4129 ELSE IF(MSPR.EQ.14) THEN
4130 SWP0M0 = 4.D0*RR*GQ2(2)*(-CC**2*GQ2(1)*W2
4131 & -XKAP*XKAM*Q1KK**2)/DD
4132 SWP0P0 = - SWP0M0+2.D0*GQ2(2)*GQ2(1)**2*W2*BB/DD
4133 SWPP00 = 2.D0*W2*BB*(AA-2.D0*CC*RR)
4134 & *SQRT(GQ2(1)*GQ2(2))/DD
4135 SWP00P = 4.D0*RR*(CC**2*(GQ2(1)*Q2KK+GQ2(2)*Q1KK)
4136 & +XKAP*XKAM*Q1KK*Q2KK)*SQRT(GQ2(1)*GQ2(2))/DD
4137 SW0PM0 = -SWP00P-2.D0*GQ2(1)*GQ2(2)*W2*BB
4138 & *SQRT(GQ2(1)*GQ2(2))/DD
4139 SIGQPM(3) = SWP0P0*FAC
4140 SIGQPM(6) = (SWPP00+SW0PM0)/2.D0*FAC
4141 WEIGHT = HELFLX(3)*SIGQPM(3)
4142 & +HELFLX(6)*SIGQPM(6)/2.D0
4144 ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.1)) THEN
4149 SIGQPM(4) = 32.D0*PI**2*8.D0/3.D0*ALPHA1*QC2*ALPHA2
4150 & *Q2*(-(SP**2*TP**2*(-Q2 + SP + TP)) +
4151 & SP*TP*(2.D0*Q2**2 + 3.D0*SP**2 + 2.D0*SP*TP -
4152 & TP**2 - 2.D0*Q2*(3*SP + TP))*XQ2 -
4153 & 2.D0*(Q2*(SP**2 + 6.D0*SP*TP + TP**2) -
4154 & 2.D0*SP*(SP**2 + 4.D0*SP*TP + 3.D0*TP**2))*
4155 & XQ2**2 + 8.D0*(SP + TP)**2*XQ2**3)/
4156 & (SP**2*TP**2*((Q2 - SP)**2 - 4.D0*Q2*XQ2))
4157 WEIGHT = HELFLX(4)*SIGQPM(4)/(2.D0*(SH+GQ2(1)))
4158 ELSE IF(MSPR.EQ.11) THEN
4162 SIGQPM(4) = 32.D0*PI**2*2.D0*ALPHA1*QC2*ALPHA2
4163 & *(-Q2*(SP*TP*(-Q2+SP+TP)+(Q2**2-Q2*SP-2*SP*TP)*XQ2 +
4164 & SP*XQ2**2))/((Q2-SP)**2*(-TP+XQ2)*(Q2-SP-TP+XQ2))
4165 WEIGHT = HELFLX(4)*SIGQPM(4)/(2.D0*(SH+GQ2(2)))
4166 ELSE IF(MSPR.EQ.14) THEN
4167 SW0P0M = 4.D0*RR*GQ2(1)*(-CC**2*GQ2(2)*W2
4168 & -XKAP*XKAM*Q2KK**2)/DD
4169 SW0P0P = - SW0P0M+2.D0*GQ2(1)*GQ2(2)**2*W2*BB/DD
4170 SWPP00 = 2.D0*W2*BB*(AA-2.D0*CC*RR)
4171 & *SQRT(GQ2(1)*GQ2(2))/DD
4172 SWP00P = 4.D0*RR*(CC**2*(GQ2(1)*Q2KK+GQ2(2)*Q1KK)
4173 & +XKAP*XKAM*Q1KK*Q2KK)*SQRT(GQ2(1)*GQ2(2))/DD
4174 SW0PM0 = -SWP00P-2.D0*GQ2(1)*GQ2(2)*W2*BB
4175 & *SQRT(GQ2(1)*GQ2(2))/DD
4176 SIGQPM(4) = SW0P0P*FAC
4177 SIGQPM(6) = (SWPP00+SW0PM0)/2.D0*FAC
4178 WEIGHT = HELFLX(4)*SIGQPM(4)
4179 & +HELFLX(6)*SIGQPM(6)/2.D0
4181 ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.0)) THEN
4183 SW0000 = 2.D0*GQ2(1)*GQ2(2)*W2*W2*AA*BB/DD**2
4184 SIGQPM(5) = SW0000*FAC
4185 WEIGHT = HELFLX(5)*SIGQPM(5)
4188 WRITE(LO,'(/1X,A,2I3)')
4189 & 'PHO_GGEPEM:ERROR: invalid photon helicities: ',IGHEL
4190 WRITE(LO,'(1X,A,I12)')
4191 & 'PHO_GGEPEM: event rejected (KEVENT)',KEVENT
4195 C fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
4197 WGHQPM = WEIGHT/(137.D0**2*16.D0*PI**4*GQ2(1)*GQ2(2))
4198 & *SQRT(XCAP/YCAP)*PI*SS/(2.D0*YCAP)*PINI(4,1)*PINI(4,2)
4204 *$ CREATE PHO_GGBLSR.FOR
4206 CDECK ID>, PHO_GGBLSR
4207 SUBROUTINE PHO_GGBLSR(NEVENT,EE1,EE2,
4208 & Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A)
4209 C***********************************************************************
4211 C interface to call PHOJET (variable energy run) for
4212 C gamma-gamma collisions via laser backscattering
4214 C input: EE1 lab. system energy of electron/positron 1
4215 C EE2 lab. system energy of electron/positron 2
4216 C NEVENT number of events to generate
4217 C Pl_lam_1/2 product of electron and photon pol.
4218 C X_1/2 standard X parameter
4219 C rho ratio of distance to conversion point and
4220 C transverse beam size
4221 C A ellipticity of electon beam
4223 C (see Ginzburg & Kotkin hep-ph/9905462)
4226 C YMIN1 lower limit of Y1
4227 C (energy fraction taken by photon from electron)
4228 C YMAX1 upper limit of Y1
4229 C YMIN2 lower limit of Y2
4230 C (energy fraction taken by photon from electron)
4231 C YMAX2 upper limit of Y2
4233 C***********************************************************************
4234 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4237 PARAMETER ( PI = 3.14159265359D0 )
4239 C input/output channels
4241 COMMON /POINOU/ LI,LO
4242 C event debugging information
4244 PARAMETER (NMAXD=100)
4245 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4246 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4247 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4248 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4249 C photon flux kinematics and cuts
4250 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
4251 & YMIN1,YMAX1,YMIN2,YMAX2,
4252 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4253 & THMIN1,THMAX1,THMIN2,THMAX2
4255 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
4256 & YMIN1,YMAX1,YMIN2,YMAX2,
4257 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4258 & THMIN1,THMAX1,THMIN2,THMAX2,
4260 C gamma-lepton or gamma-hadron vertex information
4261 INTEGER IGHEL,IDPSRC,IDBSRC
4262 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
4263 & RADSRC,AMSRC,GAMSRC
4264 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
4265 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
4266 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
4267 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
4268 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
4269 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
4270 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
4271 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
4272 C event weights and generated cross section
4273 INTEGER IPOWGC,ISWCUT,IVWGHT
4274 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
4275 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
4276 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
4278 parameter (N_dim=100)
4279 dimension X_inp_1(N_dim),F_inp_1(N_dim),F_int_1(N_dim),
4280 & X_inp_2(N_dim),F_inp_2(N_dim),F_int_2(N_dim),
4281 & Xgrid(96),Wgrid(96)
4283 DIMENSION P1(4),P2(4)
4287 WRITE(LO,'(//1X,A,I10)') 'PHO_GGBLSR: events to process',NEVENT
4289 YMAX1 = MIN(X_1/(1.D0+X_1),YMAX1)
4290 YMAX2 = MIN(X_2/(1.D0+X_2),YMAX2)
4291 IF((YMIN1.GT.YMAX1).OR.(YMIN2.GT.YMAX2)) THEN
4292 WRITE(LO,'(/1X,2A,2E12.4)') 'PHO_GGBLSR:ERROR: ',
4293 & 'invalid Ymin1,Ymin2',YMIN1,YMIN2
4301 C initialize sampling
4304 DELY1 = (YMAX1-YMIN1)/DBLE(Max_tab-1)
4305 DELY2 = (YMAX2-YMIN2)/DBLE(Max_tab-1)
4307 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
4308 & 'PHO_GGBLSR: table of photon flux ',Max_tab
4312 y1 = YMIN1+DELY1*DBLE(I-1)
4313 r1 = y1/(X_1*(1.D0-y1))
4315 F_inp_1(i) = 1.D0/(1.D0-y1)-y1+(2.D0*r1-1.D0)**2
4316 & -Pl_lam_1*X_1*r1*(2.D0*r1-1.D0)*(2.D0-y1)
4318 y2 = YMIN2+DELY2*DBLE(I-1)
4319 r2 = y2/(X_2*(1.D0-y2))
4321 F_inp_2(i) = 1.D0/(1.D0-y2)-y2+(2.D0*r2-1.D0)**2
4322 & -Pl_lam_2*X_2*r2*(2.D0*r2-1.D0)*(2.D0-y2)
4324 IF(IDEB(30).GE.1) WRITE(LO,'(5X,1p,2E13.4,5x,2E13.4)')
4325 & y1,F_inp_1(i),y2,F_inp_2(i)
4329 call pho_samp1d(-1,X_inp_1,F_inp_1,F_int_1,Max_tab,X_out_1)
4330 call pho_samp1d(-1,X_inp_2,F_inp_2,F_int_2,Max_tab,X_out_2)
4332 C initialize event generator
4346 CALL PHO_SETPAR(1,22,0,0.D0)
4347 CALL PHO_SETPAR(2,22,0,0.D0)
4348 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
4349 CALL PHO_PHIST(-1,SIGMAX)
4350 CALL PHO_LHIST(-1,SIGMAX)
4352 C generation of events
4366 call pho_samp1d(1,X_inp_1,F_inp_1,F_int_1,Max_tab,X_out_1)
4367 call pho_samp1d(1,X_inp_2,F_inp_2,F_int_2,Max_tab,X_out_2)
4369 g_1 = sqrt(max(0.D0,X_1/(X_out_1+1.D-6)-X_1-1.D0))
4370 g_2 = sqrt(max(0.D0,X_2/(X_out_2+1.D-6)-X_2-1.D0))
4371 if(abs(1.D0-A).lt.1.D-3) then
4372 v = rho**2/4.D0*g_1*g_2
4373 Wght = exp(-rho**2/8.D0*(g_1-g_2)**2)*pho_ExpBessI0(v)
4376 call pho_gauset(0.D0,Pi2,Nint,Xgrid,Wgrid)
4378 fac = rho**2/(4.D0*(1.D0+A2))
4385 & +exp(-fac*(A2*(g_1*cos(phi_1)+g_2*cos(phi_2))**2
4386 & +(g_1*sin(phi_1)+g_2*sin(phi_2))**2))
4387 & *Wgrid(i1)*Wgrid(i2)
4393 IF(Wght.GT.1.D0) THEN
4394 WRITE(LO,'(1X,A,5E11.4)')
4395 & 'PHO_GGBLSR:WEIGHT ERROR:',Y1,Y2,Wght
4397 IF(DT_RNDM(dum).GT.Wght) GOTO 175
4408 C incoming electron 1
4414 C outgoing electron 1
4415 YQ2 = SQRT((1.D0-Y1)*Q2P2)
4416 Q2E = Q2P1/(4.D0*EE1)
4418 CALL PHO_SFECFE(SIF,COF)
4427 P1(3) = PINI(3,1)-PFIN(3,1)
4428 P1(4) = PINI(4,1)-PFIN(4,1)
4429 C incoming electron 2
4435 C outgoing electron 2
4436 YQ2 = SQRT((1.D0-Y2)*Q2P2)
4437 Q2E = Q2P2/(4.D0*EE2)
4439 CALL PHO_SFECFE(SIF,COF)
4442 PFIN(3,2) = -E1Y+Q2E
4448 P2(3) = PINI(3,2)-PFIN(3,2)
4449 P2(4) = PINI(4,2)-PFIN(4,2)
4451 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
4452 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
4453 IF(GGECM.LT.0.1D0) GOTO 175
4455 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
4471 CALL PHO_PRESEL(5,IREJ)
4472 IF(IREJ.NE.0) GOTO 175
4474 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
4475 IF(IREJ.NE.0) GOTO 150
4482 CALL PHO_PHIST(1,HSWGHT(0))
4483 CALL PHO_LHIST(1,HSWGHT(0))
4486 WGY = DBLE(ITRY)/DBLE(ITRW)
4487 AY1 = AY1/DBLE(NITER)
4488 AYS1 = AYS1/DBLE(NITER)
4489 DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
4490 AY2 = AY2/DBLE(NITER)
4491 AYS2 = AYS2/DBLE(NITER)
4492 DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
4493 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
4494 C output of statistics, histograms
4495 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
4496 &'=========================================================',
4497 &' ***** simulated cross section: ',WEIGHT,' mb *****',
4498 &'========================================================='
4499 WRITE(LO,'(//1X,A,3I10)')
4500 & 'PHO_GGBLSR:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
4501 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
4503 WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBLSR:AVERAGE Y1,DY1 ',AY1,DAY1
4504 WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBLSR:AVERAGE Y2,DY2 ',AY2,DAY2
4506 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
4508 CALL PHO_PHIST(-2,WEIGHT)
4509 CALL PHO_LHIST(-2,WEIGHT)
4511 WRITE(LO,'(1X,A,I4)') 'PHO_GGBLSR:NO OUTPUT OF HISTOGRAMS',NITER
4516 *$ CREATE pho_samp1d.FOR
4518 CDECK ID>, pho_samp1d
4519 SUBROUTINE pho_samp1d(Imode,X_inp,F_inp,F_int,N_dim,X_out)
4520 C***********************************************************************
4522 C Monte Carlo sampling from arbitrary 1d distribution
4523 C (linear interpolation to improve reproduction of initial function)
4525 C input: Imode -1 initialization
4526 C 1 sampling (after initialization)
4527 C X_inp(N_dim) array with x values
4528 C F_inp(N_dim) array with function values
4529 C F_int(N_dim) array with integral
4531 C output: X_out sampled value (Imode=1)
4535 C***********************************************************************
4539 C input/output channels
4541 COMMON /POINOU/ LI,LO
4544 double precision X_inp,F_inp,F_int,X_out
4545 dimension X_inp(N_dim),F_inp(N_dim),F_int(N_dim)
4549 double precision dum,xi,a,b
4551 C external functions
4552 double precision DT_RNDM
4555 if(Imode.eq.-1) then
4561 F_int(i) = F_int(i-1)
4562 & +0.5D0*(F_inp(i)+F_inp(i-1))*(X_inp(i)-X_inp(i-1))
4565 else if(Imode.eq.1) then
4567 C sample from previously calculated integral
4569 xi = DT_RNDM(dum)*F_int(N_dim)
4572 if(xi.lt.F_int(i)) then
4573 a = (F_inp(i)-F_inp(i-1))/(X_inp(i)-X_inp(i-1))
4574 b = F_inp(i)-a*X_inp(i)
4575 xi = xi-F_int(i-1)+0.5D0*a*X_inp(i-1)**2+b*X_inp(i-1)
4576 X_out = (sqrt(b**2+2.D0*a*xi)-b)/a
4580 X_out = X_inp(N_dim)
4584 C invalid option Imode
4586 WRITE(LO,'(1x,a,i6)') 'PHO_SAMP1D: invalid option Imode: ',Imode
4593 *$ CREATE pho_ExpBessI0.FOR
4595 CDECK ID>, pho_ExpBessI0
4596 DOUBLE PRECISION FUNCTION pho_ExpBessI0(X)
4597 C**********************************************************************
4599 C Bessel Function I0 times exponential function from neg. arg.
4600 C (defined for pos. arguments only)
4602 C**********************************************************************
4603 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4607 IF (AX .LT. 3.75D0) THEN
4610 & (1.0D0+Y*(3.5156229D0+Y*(3.0899424D0+Y*(1.2067492D0
4611 & +Y*(0.2659732D0+Y*(0.360768D-1+Y*0.45813D-2))))))*EXP(-AX)
4615 & (1.D0/SQRT(AX))*(0.39894228D0+Y*(0.1328592D-1
4616 & +Y*(0.225319D-2+Y*(-0.157565D-2+Y*(0.916281D-2
4617 & +Y*(-0.2057706D-1+Y*(0.2635537D-1+Y*(-0.1647633D-1
4618 & +Y*0.392377D-2))))))))
4623 *$ CREATE PHO_GGBEAM.FOR
4625 CDECK ID>, PHO_GGBEAM
4626 SUBROUTINE PHO_GGBEAM(NEVENT,EE,YPSI,SIGX,SIGY,SIGZ,AEB)
4627 C**********************************************************************
4629 C interface to call PHOJET (variable energy run) for
4630 C gamma-gamma collisions via beamstrahlung
4632 C input: EE LAB system energy of electron/positron
4633 C YPSI beamstrahlung parameter
4634 C SIGX,Y transverse bunch dimensions
4635 C SIGZ longitudinal bunch dimension
4636 C AEB number of electrons/positrons in a bunch
4637 C NEVENT number of events to generate
4639 C YMIN1 lower limit of Y
4640 C (energy fraction taken by photon from electron)
4641 C YMAX1 upper cutoff for Y, necessary to avoid
4644 C**********************************************************************
4645 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4648 PARAMETER ( DEPS = 1.D-20,
4649 & PI = 3.14159265359D0 )
4651 C input/output channels
4653 COMMON /POINOU/ LI,LO
4654 C event debugging information
4656 PARAMETER (NMAXD=100)
4657 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4658 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4659 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4660 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4661 C photon flux kinematics and cuts
4662 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
4663 & YMIN1,YMAX1,YMIN2,YMAX2,
4664 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4665 & THMIN1,THMAX1,THMIN2,THMAX2
4667 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
4668 & YMIN1,YMAX1,YMIN2,YMAX2,
4669 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4670 & THMIN1,THMAX1,THMIN2,THMAX2,
4672 C gamma-lepton or gamma-hadron vertex information
4673 INTEGER IGHEL,IDPSRC,IDBSRC
4674 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
4675 & RADSRC,AMSRC,GAMSRC
4676 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
4677 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
4678 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
4679 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
4680 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
4681 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
4682 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
4683 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
4684 C event weights and generated cross section
4685 INTEGER IPOWGC,ISWCUT,IVWGHT
4686 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
4687 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
4688 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
4690 PARAMETER (Max_tab=100)
4691 DIMENSION P1(4),P2(4),TABCU(0:Max_tab),TABYL(0:Max_tab)
4693 WRITE(LO,'(//1X,A,I10)') 'PHO_GGBEAM: events to process',NEVENT
4701 C table of flux function, log interpolation
4702 IF(YPSI.LE.0.D0) THEN
4703 YPSI = 5.D0*RE**2*EE*AEB*137.D0/(6.D0*SIGZ*(SIGX+SIGY)*ELEM)
4705 WRITE(LO,'(/1X,A,E12.4)')
4706 & 'PHO_GGBEAM: beamstrahlung parameter:',YPSI
4707 WRITE(LO,'(/1X,A,2E12.4)')
4708 & 'PHO_GGBEAM: sigma-z,ne-bunch:',SIGZ,AEB
4712 GAOT = 2.6789385347D0
4714 WW = 1.D0/(6.D0*SQRT(AKAP))
4715 ANGAM = 5.D0*SIGZ*ELEM/(137.D0**2*2.D0*RE*EE)
4716 & *YPSI/SQRT(1.D0+YPSI**TT)
4719 YMAX = MIN(YMAX1,0.9D0)
4721 TABYL(0) = LOG(YMIN)
4722 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
4724 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
4725 & 'PHO_GGBEAM: table of photon flux',Max_tab
4727 Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
4728 GG = 1.D0-0.5D0*(1-Y)**TT*(1.D0-Y+(1.D0+Y)*SQRT(1.D0+YPSI**TT))
4729 FF = AKAP**OT/GAOT/Y**TT/(1.D0-Y)**OT*EXP(-AKAP*Y/(1.D0-Y))
4730 & *((1.D0-WW)/GG*(1.D0-(1.D0-EXP(-ANGAM*GG))/(ANGAM*GG))
4731 & +WW*(1.D0-(1.D0-EXP(-ANGAM))/ANGAM))
4732 TABCU(I) = TABCU(I-1)+FF*Y
4735 IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y,FF
4738 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
4739 & 'PHO_GGBEAM: integrated flux (one side):',FLUX
4755 CALL PHO_SETPAR(1,22,0,0.D0)
4756 CALL PHO_SETPAR(2,22,0,0.D0)
4757 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
4758 CALL PHO_PHIST(-1,SIGMAX)
4759 CALL PHO_LHIST(-1,SIGMAX)
4761 C generation of events
4774 XI = DT_RNDM(AY1)*TABCU(Max_tab)
4776 IF(TABCU(K).GE.XI) THEN
4777 Y1 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
4784 XI = DT_RNDM(AY2)*TABCU(Max_tab)
4786 IF(TABCU(K).GE.XI) THEN
4787 Y2 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
4800 C incoming electron 1
4806 C outgoing electron 1
4807 YQ2 = SQRT((1.D0-Y1)*Q2P2)
4808 Q2E = Q2P1/(4.D0*EE1)
4810 CALL PHO_SFECFE(SIF,COF)
4819 P1(3) = PINI(3,1)-PFIN(3,1)
4820 P1(4) = PINI(4,1)-PFIN(4,1)
4821 C incoming electron 2
4827 C outgoing electron 2
4828 YQ2 = SQRT((1.D0-Y2)*Q2P2)
4829 Q2E = Q2P2/(4.D0*EE2)
4831 CALL PHO_SFECFE(SIF,COF)
4834 PFIN(3,2) = -E1Y+Q2E
4840 P2(3) = PINI(3,2)-PFIN(3,2)
4841 P2(4) = PINI(4,2)-PFIN(4,2)
4843 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
4844 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
4845 IF(GGECM.LT.0.1D0) GOTO 175
4847 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
4863 CALL PHO_PRESEL(5,IREJ)
4864 IF(IREJ.NE.0) GOTO 175
4866 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
4867 IF(IREJ.NE.0) GOTO 150
4875 CALL PHO_PHIST(1,HSWGHT(0))
4876 CALL PHO_LHIST(1,HSWGHT(0))
4879 WGY = FLUX**2*DBLE(ITRY)/DBLE(ITRW)
4880 AY1 = AY1/DBLE(NITER)
4881 AYS1 = AYS1/DBLE(NITER)
4882 DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
4883 AY2 = AY2/DBLE(NITER)
4884 AYS2 = AYS2/DBLE(NITER)
4885 DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
4886 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
4887 C output of statistics, histograms
4888 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
4889 &'=========================================================',
4890 &' ***** simulated cross section: ',WEIGHT,' mb *****',
4891 &'========================================================='
4892 WRITE(LO,'(//1X,A,2I10)')
4893 & 'PHO_GGBEAM:SUMMARY:NITER,ITRY',NITER,ITRY
4894 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
4896 WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBEAM:AVERAGE Y1,DY1 ',AY1,DAY1
4897 WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBEAM:AVERAGE Y2,DY2 ',AY2,DAY2
4899 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
4901 CALL PHO_PHIST(-2,WEIGHT)
4902 CALL PHO_LHIST(-2,WEIGHT)
4904 WRITE(LO,'(1X,A,I4)') 'PHO_GGBEAM:NO OUTPUT OF HISTOGRAMS',NITER
4909 *$ CREATE PHO_GGHIOF.FOR
4911 CDECK ID>, PHO_GGHIOF
4912 SUBROUTINE PHO_GGHIOF(NEVENT,EEN,NA,NZ)
4913 C**********************************************************************
4915 C interface to call PHOJET (variable energy run) for
4916 C gamma-gamma collisions via heavy ions (form factor approach)
4918 C input: EEN LAB system energy per nucleon
4919 C NA atomic number of ion/hadron
4920 C NZ charge number of ion/hadron
4921 C NEVENT number of events to generate
4923 C YMIN1,2 lower limit of Y
4924 C (energy fraction taken by photon from hadron)
4925 C YMAX1,2 upper cutoff for Y, necessary to avoid
4927 C Q2MIN1,2 minimum Q**2 of photons (should be set to 0)
4928 C Q2MAX1,2 maximum Q**2 of photons (if necessary,
4929 C corrected according size of hadron)
4931 C currently implemented approximation similar to:
4932 C E.Papageorgiu PhysLettB250(1990)155
4934 C**********************************************************************
4935 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4938 PARAMETER ( PI = 3.14159265359D0 )
4940 C input/output channels
4942 COMMON /POINOU/ LI,LO
4943 C model switches and parameters
4945 INTEGER ISWMDL,IPAMDL
4946 DOUBLE PRECISION PARMDL
4947 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4948 C event debugging information
4950 PARAMETER (NMAXD=100)
4951 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4952 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4953 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4954 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4955 C photon flux kinematics and cuts
4956 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
4957 & YMIN1,YMAX1,YMIN2,YMAX2,
4958 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4959 & THMIN1,THMAX1,THMIN2,THMAX2
4961 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
4962 & YMIN1,YMAX1,YMIN2,YMAX2,
4963 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4964 & THMIN1,THMAX1,THMIN2,THMAX2,
4966 C gamma-lepton or gamma-hadron vertex information
4967 INTEGER IGHEL,IDPSRC,IDBSRC
4968 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
4969 & RADSRC,AMSRC,GAMSRC
4970 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
4971 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
4972 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
4973 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
4974 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
4975 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
4976 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
4977 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
4978 C event weights and generated cross section
4979 INTEGER IPOWGC,ISWCUT,IVWGHT
4980 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
4981 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
4982 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
4984 DIMENSION P1(4),P2(4),BIMP(2,2)
4986 WRITE(LO,'(2(/1X,A))') 'PHO_GGHIOF:GAMMA-GAMMA EVENT GENERATION',
4987 & '--------------------------------------'
4988 C hadron size and mass
4990 HIMASS = DBLE(NA)*0.938D0
4992 HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
4993 ALPHA = DBLE(NZ**2)/137.D0
4994 C correct Q2MAX1,2 according to hadron size
4995 Q2MAXH = 2.D0/HIRADI**2
4996 Q2MAX1 = MIN(Q2MAX1,Q2MAXH)
4997 Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
4998 IF(Q2MAX1.LT.1.D-20) Q2MAX1 = Q2MAXH
4999 IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
5000 C total hadron / heavy ion energy
5010 C kinematic limitations
5011 YMI = (ECMIN/(2.D0*EE))**2
5012 IF(YMIN1.LT.YMI) THEN
5013 WRITE(LO,'(/1X,A,2E12.5)')
5014 & 'PHO_GGHIOF: ymin1 increased to (old/new)',YMIN1,YMI
5016 ELSE IF(YMIN1.GT.YMI) THEN
5017 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5018 & 'PHO_GGHIOF:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
5019 & ' INSTEAD OF',YMIN1
5021 IF(YMIN2.LT.YMI) THEN
5022 WRITE(LO,'(/1X,A,2E12.5)')
5023 & 'PHO_GGHIOF: ymin2 increased to (old/new)',YMIN2,YMI
5025 ELSE IF(YMIN2.GT.YMI) THEN
5026 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5027 & 'PHO_GGHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
5028 & ' INSTEAD OF',YMIN2
5030 C kinematic limitation
5031 Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
5032 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
5034 WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
5035 WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV) ',HIMASS
5036 WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1) ',HIRADI
5037 WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 1 (GEV**2)',Q2LOW1,
5039 WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
5041 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1 ',YMIN1,
5043 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
5045 WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
5047 WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
5048 IF(Q2LOW1.GE.Q2MAX1) THEN
5049 WRITE(LO,'(/1X,A,2E12.4)')
5050 & 'PHO_GGHIOF:ERROR:INCONSISTENT Q**2 RANGE 1',Q2LOW1,Q2MAX1
5053 IF(Q2LOW2.GE.Q2MAX2) THEN
5054 WRITE(LO,'(/1X,A,2E12.4)')
5055 & 'PHO_GGHIOF:ERROR:INCONSISTENT Q**2 RANGE 2',Q2LOW2,Q2MAX2
5058 C hadron numbers set to 0
5070 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5072 Y1 = EXP(XMIN+DELLY*DBLE(I-1))
5073 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
5074 IF(Q2LOW1.GE.Q2MAX1) THEN
5075 WRITE(LO,'(/1X,A,2E12.4)')
5076 & 'PHO_GGHIOF: ymax1 changed from/to',YMAX1,Y1
5077 YMAX1 = MIN(Y1,YMAX1)
5087 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5089 Y1 = EXP(XMIN+DELLY*DBLE(I-1))
5090 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
5091 IF(Q2LOW2.GE.Q2MAX2) THEN
5092 WRITE(LO,'(/1X,A,2E12.4)')
5093 & 'PHO_GGHIOF: ymax2 changed from/to',YMAX2,Y1
5094 YMAX2 = MIN(Y1,YMAX2)
5099 YMI = (ECMIN/(2.D0*EE))**2/YMAX2
5100 IF(YMI.GT.YMIN1) THEN
5101 WRITE(LO,'(/1X,A,2E12.4)')
5102 & 'PHO_GGHIOF: ymin1 changed from/to',YMIN1,YMI
5105 YMI = (ECMIN/(2.D0*EE))**2/YMAX1
5106 IF(YMI.GT.YMIN2) THEN
5107 WRITE(LO,'(/1X,A,2E12.4)')
5108 & 'PHO_GGHIOF: ymin2 changed from/to',YMIN2,YMI
5118 DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
5120 IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
5121 & 'PHO_GGHIOF: table of raw photon flux (side 1)',Max_tab
5123 Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
5124 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
5125 FF = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
5126 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))*ALPHA/(2.D0*PI)
5128 IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y1,FF
5131 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
5132 & 'PHO_GGHIOF: integrated flux (one side):',FLUX
5134 Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
5135 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
5138 WGMAX = ((1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
5139 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
5140 & *((1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
5141 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
5155 CALL PHO_SETPAR(1,22,0,0.D0)
5156 CALL PHO_SETPAR(2,22,0,0.D0)
5157 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
5158 CALL PHO_PHIST(-1,SIGMAX)
5159 CALL PHO_LHIST(-1,SIGMAX)
5161 C generation of events, flux calculation
5162 ECFRAC = ECMIN**2/(4.D0*EE*EE)
5188 Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
5189 Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
5190 IF(Y1*Y2.LT.ECFRAC) GOTO 175
5192 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1**2/(1.D0-Y1))
5193 IF(Q2LOW1.GE.Q2MAX1) GOTO 175
5194 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
5195 IF(Q2LOW2.GE.Q2MAX2) GOTO 175
5196 Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
5197 Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
5198 WGH = ((1.D0+(1.D0-Y1)**2)*Q2LOG1
5199 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
5200 & *((1.D0+(1.D0-Y2)**2)*Q2LOG2
5201 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
5202 IF(WGMAX.LT.WGH) THEN
5203 WRITE(LO,'(1X,A,4E12.5)')
5204 & 'PHO_GGHIOF:WEIGHT ERROR:',Y1,Y2,WGMAX,WGH
5206 IF(DT_RNDM(AYS1)*WGMAX.GT.WGH) GOTO 175
5208 IF(IPAMDL(174).EQ.1) THEN
5209 YEFF = 1.D0+(1.D0-Y1)**2
5211 Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
5212 WEIGHT = (YEFF-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF
5213 IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
5217 IF(IPAMDL(174).EQ.1) THEN
5218 YEFF = 1.D0+(1.D0-Y2)**2
5220 Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
5221 WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
5222 IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
5227 GAIMP(1) = 1.D0/SQRT(Q2P1)
5228 GAIMP(2) = 1.D0/SQRT(Q2P2)
5229 C form factor (squared)
5231 IF(GAIMP(1).LT.HIRADI) FF21 = 0.D0
5233 IF(GAIMP(2).LT.HIRADI) FF22 = 0.D0
5234 IF(DT_RNDM(Q2P1).GE.FF21*FF22) GOTO 175
5235 C do the hadrons overlap?
5236 IF(ISWMDL(26).GT.0) THEN
5238 CALL PHO_SFECFE(SIF,COF)
5239 BIMP(1,K) = SIF*GAIMP(K)
5240 BIMP(2,K) = COF*GAIMP(K)
5242 BBABS = SQRT((BIMP(1,1)-BIMP(1,2))**2
5243 & +(BIMP(2,1)-BIMP(2,2))**2)
5244 IF(BBABS.LT.HIRADI+HIRADI) GOTO 175
5259 YQ2 = SQRT((1.D0-Y1)*Q2P1)
5260 Q2E = Q2P1/(4.D0*EE)
5262 CALL PHO_SFECFE(SIF,COF)
5268 PFPHI(1) = ATAN2(COF,SIF)
5269 PFTHE(1) = ACOS((E1Y-Q2E)/(Q2E+E1Y))
5273 P1(3) = PINI(3,1)-PFIN(3,1)
5274 P1(4) = PINI(4,1)-PFIN(4,1)
5282 YQ2 = SQRT((1.D0-Y2)*Q2P2)
5283 Q2E = Q2P2/(4.D0*EE)
5285 CALL PHO_SFECFE(SIF,COF)
5288 PFIN(3,2) = -E1Y+Q2E
5291 PFPHI(2) = ATAN2(COF,SIF)
5292 PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
5296 P2(3) = PINI(3,2)-PFIN(3,2)
5297 P2(4) = PINI(4,2)-PFIN(4,2)
5299 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
5300 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
5301 IF(GGECM.LT.0.1D0) GOTO 175
5303 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
5309 PGAM(5,1) = -SQRT(Q2P1)
5314 PGAM(5,2) = -SQRT(Q2P2)
5319 CALL PHO_PRESEL(5,IREJ)
5320 IF(IREJ.NE.0) GOTO 175
5322 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
5323 IF(IREJ.NE.0) GOTO 150
5329 Q21MIN = MIN(Q21MIN,Q2P1)
5330 Q22MIN = MIN(Q22MIN,Q2P2)
5331 Q21MAX = MAX(Q21MAX,Q2P1)
5332 Q22MAX = MAX(Q22MAX,Q2P2)
5333 YY1MIN = MIN(YY1MIN,Y1)
5334 YY2MIN = MIN(YY2MIN,Y2)
5335 YY1MAX = MAX(YY1MAX,Y1)
5336 YY2MAX = MAX(YY2MAX,Y2)
5337 Q21AVE = Q21AVE+Q2P1
5338 Q22AVE = Q22AVE+Q2P2
5339 Q21AV2 = Q21AV2+Q2P1*Q2P1
5340 Q22AV2 = Q22AV2+Q2P2*Q2P2
5342 CALL PHO_PHIST(1,HSWGHT(0))
5343 CALL PHO_LHIST(1,HSWGHT(0))
5346 WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW)*(ALPHA/(2.D0*PI))**2
5347 WGY = WGY*LOG(YMAX1/YMIN1)*LOG(YMAX2/YMIN2)
5348 AY1 = AY1/DBLE(NITER)
5349 AYS1 = AYS1/DBLE(NITER)
5350 DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
5351 AY2 = AY2/DBLE(NITER)
5352 AYS2 = AYS2/DBLE(NITER)
5353 DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
5354 Q21AVE = Q21AVE/DBLE(NITER)
5355 Q21AV2 = Q21AV2/DBLE(NITER)
5356 Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(NITER))
5357 Q22AVE = Q22AVE/DBLE(NITER)
5358 Q22AV2 = Q22AV2/DBLE(NITER)
5359 Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
5360 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
5361 C output of statistics, histograms
5362 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
5363 &'=========================================================',
5364 &' ***** simulated cross section: ',WEIGHT,' mb *****',
5365 &'========================================================='
5366 WRITE(LO,'(//1X,A,3I10)')
5367 & 'PHO_GGHIOF:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
5368 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
5370 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1 ',
5372 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
5374 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1 ',
5376 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
5378 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 1 ',
5380 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 1 ',
5382 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 2 ',
5384 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2 ',
5387 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
5389 CALL PHO_PHIST(-2,WEIGHT)
5390 CALL PHO_LHIST(-2,WEIGHT)
5392 WRITE(LO,'(1X,A,I4)') 'PHO_GGHIOF:NO OUTPUT OF HISTOGRAMS',NITER
5397 *$ CREATE PHO_GGHIOG.FOR
5399 CDECK ID>, PHO_GGHIOG
5400 SUBROUTINE PHO_GGHIOG(NEVENT,EEN,NA,NZ)
5401 C**********************************************************************
5403 C interface to call PHOJET (variable energy run) for
5404 C gamma-gamma collisions via heavy ions (geometrical approach)
5407 C input: EEN LAB system energy per nucleon
5408 C NA atomic number of ion/hadron
5409 C NZ charge number of ion/hadron
5410 C NEVENT number of events to generate
5412 C YMIN1,2 lower limit of Y
5413 C (energy fraction taken by photon from hadron)
5414 C YMAX1,2 upper cutoff for Y, necessary to avoid
5417 C currently implemented approximation similar to:
5420 C**********************************************************************
5421 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5424 PARAMETER ( DEPS = 1.D-20,
5425 & PI = 3.14159265359D0 )
5427 C input/output channels
5429 COMMON /POINOU/ LI,LO
5430 C event debugging information
5432 PARAMETER (NMAXD=100)
5433 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
5434 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
5435 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
5436 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
5437 C photon flux kinematics and cuts
5438 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
5439 & YMIN1,YMAX1,YMIN2,YMAX2,
5440 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
5441 & THMIN1,THMAX1,THMIN2,THMAX2
5443 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
5444 & YMIN1,YMAX1,YMIN2,YMAX2,
5445 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
5446 & THMIN1,THMAX1,THMIN2,THMAX2,
5448 C gamma-lepton or gamma-hadron vertex information
5449 INTEGER IGHEL,IDPSRC,IDBSRC
5450 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
5451 & RADSRC,AMSRC,GAMSRC
5452 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
5453 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
5454 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
5455 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
5456 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
5457 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
5458 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
5459 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
5460 C event weights and generated cross section
5461 INTEGER IPOWGC,ISWCUT,IVWGHT
5462 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
5463 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
5464 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
5466 PARAMETER (Max_tab=100)
5467 DIMENSION P1(4),P2(4),TABCU(0:Max_tab),TABYL(0:Max_tab)
5469 WRITE(LO,'(2(/1X,A))') 'PHO_GGHIOG: gamma-gamma event generation',
5470 & '---------------------------------------'
5471 C hadron size and mass
5473 HIMASS = DBLE(NA)*0.938D0
5475 HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
5476 ALPHA = DBLE(NZ**2)/137.D0
5477 C total hadron / heavy ion energy
5487 C kinematic limitations
5488 YMI = (ECMIN/(2.D0*EE))**2
5489 IF(YMIN1.LT.YMI) THEN
5490 WRITE(LO,'(/1X,A,2E12.5)')
5491 & 'PHO_GGHIOG: ymin1 increased to (old/new)',YMIN1,YMI
5493 ELSE IF(YMIN1.GT.YMI) THEN
5494 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5495 & 'PHO_GGHIOG:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
5496 & ' INSTEAD OF',YMIN1
5498 IF(YMIN2.LT.YMI) THEN
5499 WRITE(LO,'(/1X,A,2E12.5)')
5500 & 'PHO_GGHIOG: ymin2 increased to (old/new)',YMIN2,YMI
5502 ELSE IF(YMIN2.GT.YMI) THEN
5503 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5504 & 'PHO_GGHIOG:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
5505 & ' INSTEAD OF',YMIN2
5508 WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
5509 WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV) ',HIMASS
5510 WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1) ',HIRADI
5511 WRITE(LO,'(6X,A,E12.5)') 'LORENTZ GAMMA ',GAMMA
5512 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1 ',YMIN1,
5514 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
5516 WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
5518 WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
5519 C hadron numbers set to 0
5524 C table of flux function, log interpolation
5527 YMAX = MIN(YMAX,0.9999999D0)
5528 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5529 TABYL(0) = LOG(YMIN)
5532 Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
5534 XI = WG*HIRADI/GAMMA
5535 FF = ALPHA*PHO_GGFLCL(XI)/Y
5536 FFMAX = MAX(FF,FFMAX)
5537 IF(FF.LT.1.D-10*FFMAX) THEN
5538 WRITE(LO,'(/1X,A,2E12.4)')
5539 & 'PHO_GGHIOG: ymax1 changed from/to',YMAX1,Y
5540 YMAX1 = MIN(Y,YMAX1)
5547 YMAX = MIN(YMAX,0.9999999D0)
5548 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5549 TABYL(0) = LOG(YMIN)
5552 Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
5554 XI = WG*HIRADI/GAMMA
5555 FF = ALPHA*PHO_GGFLCL(XI)/Y
5556 FFMAX = MAX(FF,FFMAX)
5557 IF(FF.LT.1.D-10*FFMAX) THEN
5558 WRITE(LO,'(/1X,A,2E12.4)')
5559 & 'PHO_GGHIOG: ymax2 changed from/to',YMAX2,Y
5560 YMAX2 = MIN(Y,YMAX2)
5565 YMI = (ECMIN/(2.D0*EE))**2/YMAX2
5566 IF(YMI.GT.YMIN1) THEN
5567 WRITE(LO,'(/1X,A,2E12.4)')
5568 & 'PHO_GGHIOG: ymin1 changed from/to',YMIN1,YMI
5571 YMAX1 = MIN(YMAX,YMAX1)
5572 YMI = (ECMIN/(2.D0*EE))**2/YMAX1
5573 IF(YMI.GT.YMIN2) THEN
5574 WRITE(LO,'(/1X,A,2E12.4)')
5575 & 'PHO_GGHIOG: ymin2 changed from/to',YMIN2,YMI
5581 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5583 TABYL(0) = LOG(YMIN)
5585 IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
5586 & 'PHO_GGHIOG: table of raw photon flux (side 1)',Max_tab
5588 Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
5590 XI = WG*HIRADI/GAMMA
5591 FF = ALPHA*PHO_GGFLCL(XI)/Y
5592 FFMAX = MAX(FF,FFMAX)
5593 TABCU(I) = TABCU(I-1)+FF*Y
5596 IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y,FF
5599 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
5600 & 'PHO_GGHIOG: integrated flux (one side):',FLUX
5615 CALL PHO_SETPAR(1,22,0,0.D0)
5616 CALL PHO_SETPAR(2,22,0,0.D0)
5617 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
5618 CALL PHO_PHIST(-1,SIGMAX)
5619 CALL PHO_LHIST(-1,SIGMAX)
5621 C generation of events
5638 XI = DT_RNDM(AY1)*TABCU(Max_tab)
5640 IF(TABCU(K).GE.XI) THEN
5641 Y1 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
5648 XI = DT_RNDM(AY2)*TABCU(Max_tab)
5650 IF(TABCU(K).GE.XI) THEN
5651 Y2 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
5663 C incoming electron 1
5669 C outgoing electron 1
5679 P1(3) = PINI(3,1)-PFIN(3,1)
5680 P1(4) = PINI(4,1)-PFIN(4,1)
5681 C incoming electron 2
5687 C outgoing electron 2
5697 P2(3) = PINI(3,2)-PFIN(3,2)
5698 P2(4) = PINI(4,2)-PFIN(4,2)
5700 GGECM = (P1(4)+P2(4))**2-(P1(3)+P2(3))**2
5701 IF(GGECM.LT.0.1D0) GOTO 175
5703 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
5714 C impact parameter constraints
5715 XI1 = P1(4)*HIRADI/GAMMA
5716 XI2 = P2(4)*HIRADI/GAMMA
5717 FLX = PHO_GGFLCL(XI1)*PHO_GGFLCL(XI2)
5718 FCORR = PHO_GGFLCR(HIRADI)
5719 WGX = (FLX-FCORR)/FLX
5720 IF(DT_RNDM(Y2).GT.WGX) GOTO 175
5725 CALL PHO_PRESEL(5,IREJ)
5726 IF(IREJ.NE.0) GOTO 175
5728 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
5729 IF(IREJ.NE.0) GOTO 150
5735 YY1MIN = MIN(YY1MIN,Y1)
5736 YY2MIN = MIN(YY2MIN,Y2)
5737 YY1MAX = MAX(YY1MAX,Y1)
5738 YY2MAX = MAX(YY2MAX,Y2)
5740 CALL PHO_PHIST(1,HSWGHT(0))
5741 CALL PHO_LHIST(1,HSWGHT(0))
5744 WGY = FLUX**2*DBLE(ITRY)/DBLE(ITRW)
5745 AY1 = AY1/DBLE(NITER)
5746 AYS1 = AYS1/DBLE(NITER)
5747 DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
5748 AY2 = AY2/DBLE(NITER)
5749 AYS2 = AYS2/DBLE(NITER)
5750 DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
5751 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
5752 C output of statistics, histograms
5753 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
5754 &'=========================================================',
5755 &' ***** simulated cross section: ',WEIGHT,' mb *****',
5756 &'========================================================='
5757 WRITE(LO,'(//1X,A,3I12)')
5758 & 'PHO_GGHIOG:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
5759 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
5761 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1 ',
5763 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
5765 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1 ',
5767 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
5771 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
5773 CALL PHO_PHIST(-2,WEIGHT)
5774 CALL PHO_LHIST(-2,WEIGHT)
5776 WRITE(LO,'(1X,A,I4)') 'PHO_GGHIOG:NO OUTPUT OF HISTOGRAMS',NITER
5781 *$ CREATE PHO_GGFLCL.FOR
5783 CDECK ID>, PHO_GGFLCL
5784 DOUBLE PRECISION FUNCTION PHO_GGFLCL(XI)
5785 C*********************************************************************
5787 C semi-classical photon flux (geometrical model)
5789 C*********************************************************************
5790 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5793 PHO_GGFLCL = 2.D0/3.1415927D0*(XI*PHO_BESSK0(XI)*PHO_BESSK1(XI)
5794 & -XI**2/2.D0*(PHO_BESSK1(XI)**2-PHO_BESSK0(XI)**2))
5798 *$ CREATE PHO_GGFLCR.FOR
5800 CDECK ID>, PHO_GGFLCR
5801 DOUBLE PRECISION FUNCTION PHO_GGFLCR(XI)
5802 C*********************************************************************
5804 C semi-classical photon flux correction due to
5805 C overlap in impact parameter space (geometrical model)
5807 C*********************************************************************
5808 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5811 PARAMETER (PI = 3.14159265359D0, ACCUR = 1D-2)
5813 C input/output channels
5815 COMMON /POINOU/ LI,LO
5816 C gamma-lepton or gamma-hadron vertex information
5817 INTEGER IGHEL,IDPSRC,IDBSRC
5818 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
5819 & RADSRC,AMSRC,GAMSRC
5820 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
5821 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
5822 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
5824 DIMENSION XGAUSS(126),WGAUSS(126)
5826 DATA XGAUSS(1)/ .57735026918962576D0/
5827 DATA XGAUSS(2)/-.57735026918962576D0/
5828 DATA WGAUSS(1)/ 1.00000000000000000D0/
5829 DATA WGAUSS(2)/ 1.00000000000000000D0/
5831 DATA XGAUSS(3)/ .33998104358485627D0/
5832 DATA XGAUSS(4)/ .86113631159405258D0/
5833 DATA XGAUSS(5)/-.33998104358485627D0/
5834 DATA XGAUSS(6)/-.86113631159405258D0/
5835 DATA WGAUSS(3)/ .65214515486254613D0/
5836 DATA WGAUSS(4)/ .34785484513745385D0/
5837 DATA WGAUSS(5)/ .65214515486254613D0/
5838 DATA WGAUSS(6)/ .34785484513745385D0/
5840 DATA XGAUSS(7)/ .18343464249564981D0/
5841 DATA XGAUSS(8)/ .52553240991632899D0/
5842 DATA XGAUSS(9)/ .79666647741362674D0/
5843 DATA XGAUSS(10)/ .96028985649753623D0/
5844 DATA XGAUSS(11)/-.18343464249564981D0/
5845 DATA XGAUSS(12)/-.52553240991632899D0/
5846 DATA XGAUSS(13)/-.79666647741362674D0/
5847 DATA XGAUSS(14)/-.96028985649753623D0/
5848 DATA WGAUSS(7)/ .36268378337836198D0/
5849 DATA WGAUSS(8)/ .31370664587788727D0/
5850 DATA WGAUSS(9)/ .22238103445337448D0/
5851 DATA WGAUSS(10)/ .10122853629037627D0/
5852 DATA WGAUSS(11)/ .36268378337836198D0/
5853 DATA WGAUSS(12)/ .31370664587788727D0/
5854 DATA WGAUSS(13)/ .22238103445337448D0/
5855 DATA WGAUSS(14)/ .10122853629037627D0/
5857 DATA XGAUSS(15)/ .0950125098376374402D0/
5858 DATA XGAUSS(16)/ .281603550779258913D0/
5859 DATA XGAUSS(17)/ .458016777657227386D0/
5860 DATA XGAUSS(18)/ .617876244402643748D0/
5861 DATA XGAUSS(19)/ .755404408355003034D0/
5862 DATA XGAUSS(20)/ .865631202387831744D0/
5863 DATA XGAUSS(21)/ .944575023073232576D0/
5864 DATA XGAUSS(22)/ .989400934991649933D0/
5865 DATA XGAUSS(23)/-.0950125098376374402D0/
5866 DATA XGAUSS(24)/-.281603550779258913D0/
5867 DATA XGAUSS(25)/-.458016777657227386D0/
5868 DATA XGAUSS(26)/-.617876244402643748D0/
5869 DATA XGAUSS(27)/-.755404408355003034D0/
5870 DATA XGAUSS(28)/-.865631202387831744D0/
5871 DATA XGAUSS(29)/-.944575023073232576D0/
5872 DATA XGAUSS(30)/-.989400934991649933D0/
5873 DATA WGAUSS(15)/ .189450610455068496D0/
5874 DATA WGAUSS(16)/ .182603415044923589D0/
5875 DATA WGAUSS(17)/ .169156519395002538D0/
5876 DATA WGAUSS(18)/ .149595988816576732D0/
5877 DATA WGAUSS(19)/ .124628971255533872D0/
5878 DATA WGAUSS(20)/ .0951585116824927848D0/
5879 DATA WGAUSS(21)/ .0622535239386478929D0/
5880 DATA WGAUSS(22)/ .0271524594117540949D0/
5881 DATA WGAUSS(23)/ .189450610455068496D0/
5882 DATA WGAUSS(24)/ .182603415044923589D0/
5883 DATA WGAUSS(25)/ .169156519395002538D0/
5884 DATA WGAUSS(26)/ .149595988816576732D0/
5885 DATA WGAUSS(27)/ .124628971255533872D0/
5886 DATA WGAUSS(28)/ .0951585116824927848D0/
5887 DATA WGAUSS(29)/ .0622535239386478929D0/
5888 DATA WGAUSS(30)/ .0271524594117540949D0/
5890 DATA XGAUSS(31)/ .0483076656877383162D0/
5891 DATA XGAUSS(32)/ .144471961582796493D0/
5892 DATA XGAUSS(33)/ .239287362252137075D0/
5893 DATA XGAUSS(34)/ .331868602282127650D0/
5894 DATA XGAUSS(35)/ .421351276130635345D0/
5895 DATA XGAUSS(36)/ .506899908932229390D0/
5896 DATA XGAUSS(37)/ .587715757240762329D0/
5897 DATA XGAUSS(38)/ .663044266930215201D0/
5898 DATA XGAUSS(39)/ .732182118740289680D0/
5899 DATA XGAUSS(40)/ .794483795967942407D0/
5900 DATA XGAUSS(41)/ .849367613732569970D0/
5901 DATA XGAUSS(42)/ .896321155766052124D0/
5902 DATA XGAUSS(43)/ .934906075937739689D0/
5903 DATA XGAUSS(44)/ .964762255587506430D0/
5904 DATA XGAUSS(45)/ .985611511545268335D0/
5905 DATA XGAUSS(46)/ .997263861849481564D0/
5906 DATA XGAUSS(47)/-.0483076656877383162D0/
5907 DATA XGAUSS(48)/-.144471961582796493D0/
5908 DATA XGAUSS(49)/-.239287362252137075D0/
5909 DATA XGAUSS(50)/-.331868602282127650D0/
5910 DATA XGAUSS(51)/-.421351276130635345D0/
5911 DATA XGAUSS(52)/-.506899908932229390D0/
5912 DATA XGAUSS(53)/-.587715757240762329D0/
5913 DATA XGAUSS(54)/-.663044266930215201D0/
5914 DATA XGAUSS(55)/-.732182118740289680D0/
5915 DATA XGAUSS(56)/-.794483795967942407D0/
5916 DATA XGAUSS(57)/-.849367613732569970D0/
5917 DATA XGAUSS(58)/-.896321155766052124D0/
5918 DATA XGAUSS(59)/-.934906075937739689D0/
5919 DATA XGAUSS(60)/-.964762255587506430D0/
5920 DATA XGAUSS(61)/-.985611511545268335D0/
5921 DATA XGAUSS(62)/-.997263861849481564D0/
5922 DATA WGAUSS(31)/ .0965400885147278006D0/
5923 DATA WGAUSS(32)/ .0956387200792748594D0/
5924 DATA WGAUSS(33)/ .0938443990808045654D0/
5925 DATA WGAUSS(34)/ .0911738786957638847D0/
5926 DATA WGAUSS(35)/ .0876520930044038111D0/
5927 DATA WGAUSS(36)/ .0833119242269467552D0/
5928 DATA WGAUSS(37)/ .0781938957870703065D0/
5929 DATA WGAUSS(38)/ .0723457941088485062D0/
5930 DATA WGAUSS(39)/ .0658222227763618468D0/
5931 DATA WGAUSS(40)/ .0586840934785355471D0/
5932 DATA WGAUSS(41)/ .0509980592623761762D0/
5933 DATA WGAUSS(42)/ .0428358980222266807D0/
5934 DATA WGAUSS(43)/ .0342738629130214331D0/
5935 DATA WGAUSS(44)/ .0253920653092620595D0/
5936 DATA WGAUSS(45)/ .0162743947309056706D0/
5937 DATA WGAUSS(46)/ .00701861000947009660D0/
5938 DATA WGAUSS(47)/ .0965400885147278006D0/
5939 DATA WGAUSS(48)/ .0956387200792748594D0/
5940 DATA WGAUSS(49)/ .0938443990808045654D0/
5941 DATA WGAUSS(50)/ .0911738786957638847D0/
5942 DATA WGAUSS(51)/ .0876520930044038111D0/
5943 DATA WGAUSS(52)/ .0833119242269467552D0/
5944 DATA WGAUSS(53)/ .0781938957870703065D0/
5945 DATA WGAUSS(54)/ .0723457941088485062D0/
5946 DATA WGAUSS(55)/ .0658222227763618468D0/
5947 DATA WGAUSS(56)/ .0586840934785355471D0/
5948 DATA WGAUSS(57)/ .0509980592623761762D0/
5949 DATA WGAUSS(58)/ .0428358980222266807D0/
5950 DATA WGAUSS(59)/ .0342738629130214331D0/
5951 DATA WGAUSS(60)/ .0253920653092620595D0/
5952 DATA WGAUSS(61)/ .0162743947309056706D0/
5953 DATA WGAUSS(62)/ .00701861000947009660D0/
5955 DATA XGAUSS(63)/ .02435029266342443250D0/
5956 DATA XGAUSS(64)/ .0729931217877990394D0/
5957 DATA XGAUSS(65)/ .121462819296120554D0/
5958 DATA XGAUSS(66)/ .169644420423992818D0/
5959 DATA XGAUSS(67)/ .217423643740007084D0/
5960 DATA XGAUSS(68)/ .264687162208767416D0/
5961 DATA XGAUSS(69)/ .311322871990210956D0/
5962 DATA XGAUSS(70)/ .357220158337668116D0/
5963 DATA XGAUSS(71)/ .402270157963991604D0/
5964 DATA XGAUSS(72)/ .446366017253464088D0/
5965 DATA XGAUSS(73)/ .489403145707052957D0/
5966 DATA XGAUSS(74)/ .531279464019894546D0/
5967 DATA XGAUSS(75)/ .571895646202634034D0/
5968 DATA XGAUSS(76)/ .611155355172393250D0/
5969 DATA XGAUSS(77)/ .648965471254657340D0/
5970 DATA XGAUSS(78)/ .685236313054233243D0/
5971 DATA XGAUSS(79)/ .719881850171610827D0/
5972 DATA XGAUSS(80)/ .752819907260531897D0/
5973 DATA XGAUSS(81)/ .783972358943341408D0/
5974 DATA XGAUSS(82)/ .813265315122797560D0/
5975 DATA XGAUSS(83)/ .840629296252580363D0/
5976 DATA XGAUSS(84)/ .865999398154092820D0/
5977 DATA XGAUSS(85)/ .889315445995114106D0/
5978 DATA XGAUSS(86)/ .910522137078502806D0/
5979 DATA XGAUSS(87)/ .929569172131939576D0/
5980 DATA XGAUSS(88)/ .946411374858402816D0/
5981 DATA XGAUSS(89)/ .961008799652053719D0/
5982 DATA XGAUSS(90)/ .973326827789910964D0/
5983 DATA XGAUSS(91)/ .983336253884625957D0/
5984 DATA XGAUSS(92)/ .991013371476744321D0/
5985 DATA XGAUSS(93)/ .996340116771955279D0/
5986 DATA XGAUSS(94)/ .999305041735772139D0/
5987 DATA XGAUSS(95)/-.02435029266342443250D0/
5988 DATA XGAUSS(96)/-.0729931217877990394D0/
5989 DATA XGAUSS(97)/-.121462819296120554D0/
5990 DATA XGAUSS(98)/-.169644420423992818D0/
5991 DATA XGAUSS(99)/-.217423643740007084D0/
5992 DATA XGAUSS(100)/-.264687162208767416D0/
5993 DATA XGAUSS(101)/-.311322871990210956D0/
5994 DATA XGAUSS(102)/-.357220158337668116D0/
5995 DATA XGAUSS(103)/-.402270157963991604D0/
5996 DATA XGAUSS(104)/-.446366017253464088D0/
5997 DATA XGAUSS(105)/-.489403145707052957D0/
5998 DATA XGAUSS(106)/-.531279464019894546D0/
5999 DATA XGAUSS(107)/-.571895646202634034D0/
6000 DATA XGAUSS(108)/-.611155355172393250D0/
6001 DATA XGAUSS(109)/-.648965471254657340D0/
6002 DATA XGAUSS(110)/-.685236313054233243D0/
6003 DATA XGAUSS(111)/-.719881850171610827D0/
6004 DATA XGAUSS(112)/-.752819907260531897D0/
6005 DATA XGAUSS(113)/-.783972358943341408D0/
6006 DATA XGAUSS(114)/-.813265315122797560D0/
6007 DATA XGAUSS(115)/-.840629296252580363D0/
6008 DATA XGAUSS(116)/-.865999398154092820D0/
6009 DATA XGAUSS(117)/-.889315445995114106D0/
6010 DATA XGAUSS(118)/-.910522137078502806D0/
6011 DATA XGAUSS(119)/-.929569172131939576D0/
6012 DATA XGAUSS(120)/-.946411374858402816D0/
6013 DATA XGAUSS(121)/-.961008799652053719D0/
6014 DATA XGAUSS(122)/-.973326827789910964D0/
6015 DATA XGAUSS(123)/-.983336253884625957D0/
6016 DATA XGAUSS(124)/-.991013371476744321D0/
6017 DATA XGAUSS(125)/-.996340116771955279D0/
6018 DATA XGAUSS(126)/-.999305041735772139D0/
6019 DATA WGAUSS(63)/ .0486909570091397204D0/
6020 DATA WGAUSS(64)/ .0485754674415034269D0/
6021 DATA WGAUSS(65)/ .0483447622348029572D0/
6022 DATA WGAUSS(66)/ .0479993885964583077D0/
6023 DATA WGAUSS(67)/ .0475401657148303087D0/
6024 DATA WGAUSS(68)/ .0469681828162100173D0/
6025 DATA WGAUSS(69)/ .0462847965813144172D0/
6026 DATA WGAUSS(70)/ .0454916279274181445D0/
6027 DATA WGAUSS(71)/ .0445905581637565631D0/
6028 DATA WGAUSS(72)/ .0435837245293234534D0/
6029 DATA WGAUSS(73)/ .0424735151236535890D0/
6030 DATA WGAUSS(74)/ .0412625632426235286D0/
6031 DATA WGAUSS(75)/ .0399537411327203414D0/
6032 DATA WGAUSS(76)/ .0385501531786156291D0/
6033 DATA WGAUSS(77)/ .0370551285402400460D0/
6034 DATA WGAUSS(78)/ .0354722132568823838D0/
6035 DATA WGAUSS(79)/ .0338051618371416094D0/
6036 DATA WGAUSS(80)/ .0320579283548515535D0/
6037 DATA WGAUSS(81)/ .0302346570724024789D0/
6038 DATA WGAUSS(82)/ .0283396726142594832D0/
6039 DATA WGAUSS(83)/ .0263774697150546587D0/
6040 DATA WGAUSS(84)/ .0243527025687108733D0/
6041 DATA WGAUSS(85)/ .0222701738083832542D0/
6042 DATA WGAUSS(86)/ .0201348231535302094D0/
6043 DATA WGAUSS(87)/ .0179517157756973431D0/
6044 DATA WGAUSS(88)/ .0157260304760247193D0/
6045 DATA WGAUSS(89)/ .0134630478967186426D0/
6046 DATA WGAUSS(90)/ .0111681394601311288D0/
6047 DATA WGAUSS(91)/ .00884675982636394772D0/
6048 DATA WGAUSS(92)/ .00650445796897836286D0/
6049 DATA WGAUSS(93)/ .00414703326056246764D0/
6050 DATA WGAUSS(94)/ .00178328072169643295D0/
6051 DATA WGAUSS(95)/ .0486909570091397204D0/
6052 DATA WGAUSS(96)/ .0485754674415034269D0/
6053 DATA WGAUSS(97)/ .0483447622348029572D0/
6054 DATA WGAUSS(98)/ .0479993885964583077D0/
6055 DATA WGAUSS(99)/ .0475401657148303087D0/
6056 DATA WGAUSS(100)/ .0469681828162100173D0/
6057 DATA WGAUSS(101)/ .0462847965813144172D0/
6058 DATA WGAUSS(102)/ .0454916279274181445D0/
6059 DATA WGAUSS(103)/ .0445905581637565631D0/
6060 DATA WGAUSS(104)/ .0435837245293234534D0/
6061 DATA WGAUSS(105)/ .0424735151236535890D0/
6062 DATA WGAUSS(106)/ .0412625632426235286D0/
6063 DATA WGAUSS(107)/ .0399537411327203414D0/
6064 DATA WGAUSS(108)/ .0385501531786156291D0/
6065 DATA WGAUSS(109)/ .0370551285402400460D0/
6066 DATA WGAUSS(110)/ .0354722132568823838D0/
6067 DATA WGAUSS(111)/ .0338051618371416094D0/
6068 DATA WGAUSS(112)/ .0320579283548515535D0/
6069 DATA WGAUSS(113)/ .0302346570724024789D0/
6070 DATA WGAUSS(114)/ .0283396726142594832D0/
6071 DATA WGAUSS(115)/ .0263774697150546587D0/
6072 DATA WGAUSS(116)/ .0243527025687108733D0/
6073 DATA WGAUSS(117)/ .0222701738083832542D0/
6074 DATA WGAUSS(118)/ .0201348231535302094D0/
6075 DATA WGAUSS(119)/ .0179517157756973431D0/
6076 DATA WGAUSS(120)/ .0157260304760247193D0/
6077 DATA WGAUSS(121)/ .0134630478967186426D0/
6078 DATA WGAUSS(122)/ .0111681394601311288D0/
6079 DATA WGAUSS(123)/ .00884675982636394772D0/
6080 DATA WGAUSS(124)/ .00650445796897836286D0/
6081 DATA WGAUSS(125)/ .00414703326056246764D0/
6082 DATA WGAUSS(126)/ .00178328072169643295D0/
6084 C integrate first over b1
6086 C Loop incrementing the boundary
6095 C Loop for the Gauss integration
6101 DO 200 I=2**N-1,2**(N+1)-2
6102 t = (tmax-tmin)/2.D0*XGAUSS(I)+(tmax+tmin)/2.D0
6103 b1 = RADSRC(1) * EXP (t)
6104 XINT=XINT+WGAUSS(I) * PHO_GGFAUX(b1) * b1**2
6106 XINT = (tmax-tmin)/2.D0*XINT
6107 IF (ABS ((XINT2-XINT)/XINT) .LT. ACCUR) GOTO 300
6109 WRITE(LO,*) ' (b1) GAUSS MAY BE INACCURATE'
6113 IF (ABS (XINT2/Sum) .GT. ACCUR) THEN
6119 PHO_GGFLCR = 4.D0*Pi * Sum
6123 *$ CREATE PHO_GGFAUX.FOR
6125 CDECK ID>, PHO_GGFAUX
6126 DOUBLE PRECISION FUNCTION PHO_GGFAUX(b1)
6127 C*********************************************************************
6129 C auxiliary function for integration over b2,
6130 C semi-classical photon flux correction due to
6131 C overlap in impact parameter space (geometrical model)
6133 C*********************************************************************
6134 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6137 PARAMETER (PI = 3.14159265359D0, ACCUR = 1D-2)
6139 C input/output channels
6141 COMMON /POINOU/ LI,LO
6142 C gamma-lepton or gamma-hadron vertex information
6143 INTEGER IGHEL,IDPSRC,IDBSRC
6144 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
6145 & RADSRC,AMSRC,GAMSRC
6146 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
6147 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
6148 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
6150 DIMENSION XGAUSS(126),WGAUSS(126)
6152 DATA XGAUSS(1)/ .57735026918962576D0/
6153 DATA XGAUSS(2)/-.57735026918962576D0/
6154 DATA WGAUSS(1)/ 1.00000000000000000D0/
6155 DATA WGAUSS(2)/ 1.00000000000000000D0/
6157 DATA XGAUSS(3)/ .33998104358485627D0/
6158 DATA XGAUSS(4)/ .86113631159405258D0/
6159 DATA XGAUSS(5)/-.33998104358485627D0/
6160 DATA XGAUSS(6)/-.86113631159405258D0/
6161 DATA WGAUSS(3)/ .65214515486254613D0/
6162 DATA WGAUSS(4)/ .34785484513745385D0/
6163 DATA WGAUSS(5)/ .65214515486254613D0/
6164 DATA WGAUSS(6)/ .34785484513745385D0/
6166 DATA XGAUSS(7)/ .18343464249564981D0/
6167 DATA XGAUSS(8)/ .52553240991632899D0/
6168 DATA XGAUSS(9)/ .79666647741362674D0/
6169 DATA XGAUSS(10)/ .96028985649753623D0/
6170 DATA XGAUSS(11)/-.18343464249564981D0/
6171 DATA XGAUSS(12)/-.52553240991632899D0/
6172 DATA XGAUSS(13)/-.79666647741362674D0/
6173 DATA XGAUSS(14)/-.96028985649753623D0/
6174 DATA WGAUSS(7)/ .36268378337836198D0/
6175 DATA WGAUSS(8)/ .31370664587788727D0/
6176 DATA WGAUSS(9)/ .22238103445337448D0/
6177 DATA WGAUSS(10)/ .10122853629037627D0/
6178 DATA WGAUSS(11)/ .36268378337836198D0/
6179 DATA WGAUSS(12)/ .31370664587788727D0/
6180 DATA WGAUSS(13)/ .22238103445337448D0/
6181 DATA WGAUSS(14)/ .10122853629037627D0/
6183 DATA XGAUSS(15)/ .0950125098376374402D0/
6184 DATA XGAUSS(16)/ .281603550779258913D0/
6185 DATA XGAUSS(17)/ .458016777657227386D0/
6186 DATA XGAUSS(18)/ .617876244402643748D0/
6187 DATA XGAUSS(19)/ .755404408355003034D0/
6188 DATA XGAUSS(20)/ .865631202387831744D0/
6189 DATA XGAUSS(21)/ .944575023073232576D0/
6190 DATA XGAUSS(22)/ .989400934991649933D0/
6191 DATA XGAUSS(23)/-.0950125098376374402D0/
6192 DATA XGAUSS(24)/-.281603550779258913D0/
6193 DATA XGAUSS(25)/-.458016777657227386D0/
6194 DATA XGAUSS(26)/-.617876244402643748D0/
6195 DATA XGAUSS(27)/-.755404408355003034D0/
6196 DATA XGAUSS(28)/-.865631202387831744D0/
6197 DATA XGAUSS(29)/-.944575023073232576D0/
6198 DATA XGAUSS(30)/-.989400934991649933D0/
6199 DATA WGAUSS(15)/ .189450610455068496D0/
6200 DATA WGAUSS(16)/ .182603415044923589D0/
6201 DATA WGAUSS(17)/ .169156519395002538D0/
6202 DATA WGAUSS(18)/ .149595988816576732D0/
6203 DATA WGAUSS(19)/ .124628971255533872D0/
6204 DATA WGAUSS(20)/ .0951585116824927848D0/
6205 DATA WGAUSS(21)/ .0622535239386478929D0/
6206 DATA WGAUSS(22)/ .0271524594117540949D0/
6207 DATA WGAUSS(23)/ .189450610455068496D0/
6208 DATA WGAUSS(24)/ .182603415044923589D0/
6209 DATA WGAUSS(25)/ .169156519395002538D0/
6210 DATA WGAUSS(26)/ .149595988816576732D0/
6211 DATA WGAUSS(27)/ .124628971255533872D0/
6212 DATA WGAUSS(28)/ .0951585116824927848D0/
6213 DATA WGAUSS(29)/ .0622535239386478929D0/
6214 DATA WGAUSS(30)/ .0271524594117540949D0/
6216 DATA XGAUSS(31)/ .0483076656877383162D0/
6217 DATA XGAUSS(32)/ .144471961582796493D0/
6218 DATA XGAUSS(33)/ .239287362252137075D0/
6219 DATA XGAUSS(34)/ .331868602282127650D0/
6220 DATA XGAUSS(35)/ .421351276130635345D0/
6221 DATA XGAUSS(36)/ .506899908932229390D0/
6222 DATA XGAUSS(37)/ .587715757240762329D0/
6223 DATA XGAUSS(38)/ .663044266930215201D0/
6224 DATA XGAUSS(39)/ .732182118740289680D0/
6225 DATA XGAUSS(40)/ .794483795967942407D0/
6226 DATA XGAUSS(41)/ .849367613732569970D0/
6227 DATA XGAUSS(42)/ .896321155766052124D0/
6228 DATA XGAUSS(43)/ .934906075937739689D0/
6229 DATA XGAUSS(44)/ .964762255587506430D0/
6230 DATA XGAUSS(45)/ .985611511545268335D0/
6231 DATA XGAUSS(46)/ .997263861849481564D0/
6232 DATA XGAUSS(47)/-.0483076656877383162D0/
6233 DATA XGAUSS(48)/-.144471961582796493D0/
6234 DATA XGAUSS(49)/-.239287362252137075D0/
6235 DATA XGAUSS(50)/-.331868602282127650D0/
6236 DATA XGAUSS(51)/-.421351276130635345D0/
6237 DATA XGAUSS(52)/-.506899908932229390D0/
6238 DATA XGAUSS(53)/-.587715757240762329D0/
6239 DATA XGAUSS(54)/-.663044266930215201D0/
6240 DATA XGAUSS(55)/-.732182118740289680D0/
6241 DATA XGAUSS(56)/-.794483795967942407D0/
6242 DATA XGAUSS(57)/-.849367613732569970D0/
6243 DATA XGAUSS(58)/-.896321155766052124D0/
6244 DATA XGAUSS(59)/-.934906075937739689D0/
6245 DATA XGAUSS(60)/-.964762255587506430D0/
6246 DATA XGAUSS(61)/-.985611511545268335D0/
6247 DATA XGAUSS(62)/-.997263861849481564D0/
6248 DATA WGAUSS(31)/ .0965400885147278006D0/
6249 DATA WGAUSS(32)/ .0956387200792748594D0/
6250 DATA WGAUSS(33)/ .0938443990808045654D0/
6251 DATA WGAUSS(34)/ .0911738786957638847D0/
6252 DATA WGAUSS(35)/ .0876520930044038111D0/
6253 DATA WGAUSS(36)/ .0833119242269467552D0/
6254 DATA WGAUSS(37)/ .0781938957870703065D0/
6255 DATA WGAUSS(38)/ .0723457941088485062D0/
6256 DATA WGAUSS(39)/ .0658222227763618468D0/
6257 DATA WGAUSS(40)/ .0586840934785355471D0/
6258 DATA WGAUSS(41)/ .0509980592623761762D0/
6259 DATA WGAUSS(42)/ .0428358980222266807D0/
6260 DATA WGAUSS(43)/ .0342738629130214331D0/
6261 DATA WGAUSS(44)/ .0253920653092620595D0/
6262 DATA WGAUSS(45)/ .0162743947309056706D0/
6263 DATA WGAUSS(46)/ .00701861000947009660D0/
6264 DATA WGAUSS(47)/ .0965400885147278006D0/
6265 DATA WGAUSS(48)/ .0956387200792748594D0/
6266 DATA WGAUSS(49)/ .0938443990808045654D0/
6267 DATA WGAUSS(50)/ .0911738786957638847D0/
6268 DATA WGAUSS(51)/ .0876520930044038111D0/
6269 DATA WGAUSS(52)/ .0833119242269467552D0/
6270 DATA WGAUSS(53)/ .0781938957870703065D0/
6271 DATA WGAUSS(54)/ .0723457941088485062D0/
6272 DATA WGAUSS(55)/ .0658222227763618468D0/
6273 DATA WGAUSS(56)/ .0586840934785355471D0/
6274 DATA WGAUSS(57)/ .0509980592623761762D0/
6275 DATA WGAUSS(58)/ .0428358980222266807D0/
6276 DATA WGAUSS(59)/ .0342738629130214331D0/
6277 DATA WGAUSS(60)/ .0253920653092620595D0/
6278 DATA WGAUSS(61)/ .0162743947309056706D0/
6279 DATA WGAUSS(62)/ .00701861000947009660D0/
6281 DATA XGAUSS(63)/ .02435029266342443250D0/
6282 DATA XGAUSS(64)/ .0729931217877990394D0/
6283 DATA XGAUSS(65)/ .121462819296120554D0/
6284 DATA XGAUSS(66)/ .169644420423992818D0/
6285 DATA XGAUSS(67)/ .217423643740007084D0/
6286 DATA XGAUSS(68)/ .264687162208767416D0/
6287 DATA XGAUSS(69)/ .311322871990210956D0/
6288 DATA XGAUSS(70)/ .357220158337668116D0/
6289 DATA XGAUSS(71)/ .402270157963991604D0/
6290 DATA XGAUSS(72)/ .446366017253464088D0/
6291 DATA XGAUSS(73)/ .489403145707052957D0/
6292 DATA XGAUSS(74)/ .531279464019894546D0/
6293 DATA XGAUSS(75)/ .571895646202634034D0/
6294 DATA XGAUSS(76)/ .611155355172393250D0/
6295 DATA XGAUSS(77)/ .648965471254657340D0/
6296 DATA XGAUSS(78)/ .685236313054233243D0/
6297 DATA XGAUSS(79)/ .719881850171610827D0/
6298 DATA XGAUSS(80)/ .752819907260531897D0/
6299 DATA XGAUSS(81)/ .783972358943341408D0/
6300 DATA XGAUSS(82)/ .813265315122797560D0/
6301 DATA XGAUSS(83)/ .840629296252580363D0/
6302 DATA XGAUSS(84)/ .865999398154092820D0/
6303 DATA XGAUSS(85)/ .889315445995114106D0/
6304 DATA XGAUSS(86)/ .910522137078502806D0/
6305 DATA XGAUSS(87)/ .929569172131939576D0/
6306 DATA XGAUSS(88)/ .946411374858402816D0/
6307 DATA XGAUSS(89)/ .961008799652053719D0/
6308 DATA XGAUSS(90)/ .973326827789910964D0/
6309 DATA XGAUSS(91)/ .983336253884625957D0/
6310 DATA XGAUSS(92)/ .991013371476744321D0/
6311 DATA XGAUSS(93)/ .996340116771955279D0/
6312 DATA XGAUSS(94)/ .999305041735772139D0/
6313 DATA XGAUSS(95)/-.02435029266342443250D0/
6314 DATA XGAUSS(96)/-.0729931217877990394D0/
6315 DATA XGAUSS(97)/-.121462819296120554D0/
6316 DATA XGAUSS(98)/-.169644420423992818D0/
6317 DATA XGAUSS(99)/-.217423643740007084D0/
6318 DATA XGAUSS(100)/-.264687162208767416D0/
6319 DATA XGAUSS(101)/-.311322871990210956D0/
6320 DATA XGAUSS(102)/-.357220158337668116D0/
6321 DATA XGAUSS(103)/-.402270157963991604D0/
6322 DATA XGAUSS(104)/-.446366017253464088D0/
6323 DATA XGAUSS(105)/-.489403145707052957D0/
6324 DATA XGAUSS(106)/-.531279464019894546D0/
6325 DATA XGAUSS(107)/-.571895646202634034D0/
6326 DATA XGAUSS(108)/-.611155355172393250D0/
6327 DATA XGAUSS(109)/-.648965471254657340D0/
6328 DATA XGAUSS(110)/-.685236313054233243D0/
6329 DATA XGAUSS(111)/-.719881850171610827D0/
6330 DATA XGAUSS(112)/-.752819907260531897D0/
6331 DATA XGAUSS(113)/-.783972358943341408D0/
6332 DATA XGAUSS(114)/-.813265315122797560D0/
6333 DATA XGAUSS(115)/-.840629296252580363D0/
6334 DATA XGAUSS(116)/-.865999398154092820D0/
6335 DATA XGAUSS(117)/-.889315445995114106D0/
6336 DATA XGAUSS(118)/-.910522137078502806D0/
6337 DATA XGAUSS(119)/-.929569172131939576D0/
6338 DATA XGAUSS(120)/-.946411374858402816D0/
6339 DATA XGAUSS(121)/-.961008799652053719D0/
6340 DATA XGAUSS(122)/-.973326827789910964D0/
6341 DATA XGAUSS(123)/-.983336253884625957D0/
6342 DATA XGAUSS(124)/-.991013371476744321D0/
6343 DATA XGAUSS(125)/-.996340116771955279D0/
6344 DATA XGAUSS(126)/-.999305041735772139D0/
6345 DATA WGAUSS(63)/ .0486909570091397204D0/
6346 DATA WGAUSS(64)/ .0485754674415034269D0/
6347 DATA WGAUSS(65)/ .0483447622348029572D0/
6348 DATA WGAUSS(66)/ .0479993885964583077D0/
6349 DATA WGAUSS(67)/ .0475401657148303087D0/
6350 DATA WGAUSS(68)/ .0469681828162100173D0/
6351 DATA WGAUSS(69)/ .0462847965813144172D0/
6352 DATA WGAUSS(70)/ .0454916279274181445D0/
6353 DATA WGAUSS(71)/ .0445905581637565631D0/
6354 DATA WGAUSS(72)/ .0435837245293234534D0/
6355 DATA WGAUSS(73)/ .0424735151236535890D0/
6356 DATA WGAUSS(74)/ .0412625632426235286D0/
6357 DATA WGAUSS(75)/ .0399537411327203414D0/
6358 DATA WGAUSS(76)/ .0385501531786156291D0/
6359 DATA WGAUSS(77)/ .0370551285402400460D0/
6360 DATA WGAUSS(78)/ .0354722132568823838D0/
6361 DATA WGAUSS(79)/ .0338051618371416094D0/
6362 DATA WGAUSS(80)/ .0320579283548515535D0/
6363 DATA WGAUSS(81)/ .0302346570724024789D0/
6364 DATA WGAUSS(82)/ .0283396726142594832D0/
6365 DATA WGAUSS(83)/ .0263774697150546587D0/
6366 DATA WGAUSS(84)/ .0243527025687108733D0/
6367 DATA WGAUSS(85)/ .0222701738083832542D0/
6368 DATA WGAUSS(86)/ .0201348231535302094D0/
6369 DATA WGAUSS(87)/ .0179517157756973431D0/
6370 DATA WGAUSS(88)/ .0157260304760247193D0/
6371 DATA WGAUSS(89)/ .0134630478967186426D0/
6372 DATA WGAUSS(90)/ .0111681394601311288D0/
6373 DATA WGAUSS(91)/ .00884675982636394772D0/
6374 DATA WGAUSS(92)/ .00650445796897836286D0/
6375 DATA WGAUSS(93)/ .00414703326056246764D0/
6376 DATA WGAUSS(94)/ .00178328072169643295D0/
6377 DATA WGAUSS(95)/ .0486909570091397204D0/
6378 DATA WGAUSS(96)/ .0485754674415034269D0/
6379 DATA WGAUSS(97)/ .0483447622348029572D0/
6380 DATA WGAUSS(98)/ .0479993885964583077D0/
6381 DATA WGAUSS(99)/ .0475401657148303087D0/
6382 DATA WGAUSS(100)/ .0469681828162100173D0/
6383 DATA WGAUSS(101)/ .0462847965813144172D0/
6384 DATA WGAUSS(102)/ .0454916279274181445D0/
6385 DATA WGAUSS(103)/ .0445905581637565631D0/
6386 DATA WGAUSS(104)/ .0435837245293234534D0/
6387 DATA WGAUSS(105)/ .0424735151236535890D0/
6388 DATA WGAUSS(106)/ .0412625632426235286D0/
6389 DATA WGAUSS(107)/ .0399537411327203414D0/
6390 DATA WGAUSS(108)/ .0385501531786156291D0/
6391 DATA WGAUSS(109)/ .0370551285402400460D0/
6392 DATA WGAUSS(110)/ .0354722132568823838D0/
6393 DATA WGAUSS(111)/ .0338051618371416094D0/
6394 DATA WGAUSS(112)/ .0320579283548515535D0/
6395 DATA WGAUSS(113)/ .0302346570724024789D0/
6396 DATA WGAUSS(114)/ .0283396726142594832D0/
6397 DATA WGAUSS(115)/ .0263774697150546587D0/
6398 DATA WGAUSS(116)/ .0243527025687108733D0/
6399 DATA WGAUSS(117)/ .0222701738083832542D0/
6400 DATA WGAUSS(118)/ .0201348231535302094D0/
6401 DATA WGAUSS(119)/ .0179517157756973431D0/
6402 DATA WGAUSS(120)/ .0157260304760247193D0/
6403 DATA WGAUSS(121)/ .0134630478967186426D0/
6404 DATA WGAUSS(122)/ .0111681394601311288D0/
6405 DATA WGAUSS(123)/ .00884675982636394772D0/
6406 DATA WGAUSS(124)/ .00650445796897836286D0/
6407 DATA WGAUSS(125)/ .00414703326056246764D0/
6408 DATA WGAUSS(126)/ .00178328072169643295D0/
6412 bmin = b1 - 2.D0*RADSRC(1)
6413 IF (RADSRC(1) .GT. bmin) THEN
6416 bmax = b1 + 2.D0 * RADSRC(1)
6422 DO 200 I=2**N-1,2**(N+1)-2
6423 b2 = (bmax-bmin)/2.D0*XGAUSS(I)+(bmax+bmin)/2.D0
6424 XINT3 = PHO_GGFNUC(W1,b1,GAMSRC(1))
6425 & * PHO_GGFNUC(W2,b2,GAMSRC(2))
6426 & * ACOS ((b1**2+b2**2-4.D0*RADSRC(1)**2)/(2.D0*b1*b2))
6427 XINT = XINT +WGAUSS(I) * b2 * XINT3
6429 XINT = (bmax-bmin)/2.D0*XINT
6430 IF (ABS((XINT2 - XINT)/XINT) .LT. ACCUR) GOTO 300
6432 WRITE(LO,*) ' (b2) GAUSS MAY BE INACCURATE'
6439 *$ CREATE PHO_GGFNUC.FOR
6441 CDECK ID>, PHO_GGFNUC
6442 DOUBLE PRECISION FUNCTION PHO_GGFNUC(W,Rho,Gamma)
6443 C**********************************************************************
6445 C differential photonnumber for a nucleus (geometrical model)
6446 C (without form factor)
6448 C*********************************************************************
6449 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6452 PARAMETER (PI = 3.14159265359D0)
6455 Wphib = WGamma * PHO_BESSK1(WGamma*Rho)
6457 PHO_GGFNUC = 1.D0/PI**2 * Wphib**2
6461 *$ CREATE PHO_GHHIOF.FOR
6463 CDECK ID>, PHO_GHHIOF
6464 SUBROUTINE PHO_GHHIOF(NEVENT,EEN,NA,NZ)
6465 C**********************************************************************
6467 C interface to call PHOJET (variable energy run) for
6468 C gamma-hadron collisions in heavy ion collisions
6469 C (form factor approach)
6471 C input: EEN LAB system energy per nucleon
6472 C NA atomic number of ion/hadron
6473 C NZ charge number of ion/hadron
6474 C NEVENT number of events to generate
6476 C YMIN1,2 lower limit of Y
6477 C (energy fraction taken by photon from hadron)
6478 C YMAX1,2 upper cutoff for Y, necessary to avoid
6480 C Q2MIN1,2 minimum Q**2 of photons (should be set to 0)
6481 C Q2MAX1,2 maximum Q**2 of photons (if necessary,
6482 C corrected according size of hadron)
6484 C**********************************************************************
6485 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6488 PARAMETER ( PI = 3.14159265359D0 )
6490 C input/output channels
6492 COMMON /POINOU/ LI,LO
6493 C model switches and parameters
6495 INTEGER ISWMDL,IPAMDL
6496 DOUBLE PRECISION PARMDL
6497 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
6498 C event debugging information
6500 PARAMETER (NMAXD=100)
6501 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
6502 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
6503 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
6504 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
6505 C photon flux kinematics and cuts
6506 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
6507 & YMIN1,YMAX1,YMIN2,YMAX2,
6508 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
6509 & THMIN1,THMAX1,THMIN2,THMAX2
6511 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
6512 & YMIN1,YMAX1,YMIN2,YMAX2,
6513 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
6514 & THMIN1,THMAX1,THMIN2,THMAX2,
6516 C gamma-lepton or gamma-hadron vertex information
6517 INTEGER IGHEL,IDPSRC,IDBSRC
6518 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
6519 & RADSRC,AMSRC,GAMSRC
6520 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
6521 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
6522 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
6523 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
6524 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
6525 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
6526 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
6527 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
6528 C standard particle data interface
6530 PARAMETER (NMXHEP=4000)
6531 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
6532 DOUBLE PRECISION PHEP,VHEP
6533 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
6534 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
6536 C extension to standard particle data interface (PHOJET specific)
6537 INTEGER IMPART,IPHIST,ICOLOR
6538 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
6539 C event weights and generated cross section
6540 INTEGER IPOWGC,ISWCUT,IVWGHT
6541 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
6542 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
6543 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
6545 DIMENSION P1(4),P2(4)
6546 DIMENSION NITERS(2),ITRW(2)
6548 WRITE(LO,'(2(/1X,A))')
6549 & 'PHO_GHHIOF: gamma-hadron event generation',
6550 & '-----------------------------------------'
6551 C hadron size and mass
6553 HIMASS = DBLE(NA)*0.938D0
6555 HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
6556 ALPHA = DBLE(NZ**2)/137.D0
6559 C correct Q2MAX1,2 according to hadron size
6560 Q2MAXH = 2.D0/HIRADI**2
6561 Q2MAX1 = MIN(Q2MAX1,Q2MAXH)
6562 Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
6563 IF(Q2MAX1.LT.1.D-20) Q2MAX1 = Q2MAXH
6564 IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
6565 C total hadron / heavy ion energy
6575 C check cuts on photon-hadron mass
6576 IF((0.765D0+PARMDL(46)).GT.(PARMDL(45)*ECMIN)) THEN
6578 ECMIN = PARMDL(46)/PARMDL(45)+0.1D0
6579 WRITE(LO,'(/1X,A,2E12.5)')
6580 & 'PHO_GHHIOF: ecmin corrected to (old/new)',YMI,ECMIN
6582 C check kinematic limitations
6583 YMI = ECMIN**2/(4.D0*EE*EEN)
6584 IF(YMIN1.LT.YMI) THEN
6585 WRITE(LO,'(/1X,A,2E12.5)')
6586 & 'PHO_GHHIOF: ymin1 increased to (old/new)',YMIN1,YMI
6588 ELSE IF(YMIN1.GT.YMI) THEN
6589 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
6590 & 'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
6591 & ' INSTEAD OF',YMIN1
6593 IF(YMIN2.LT.YMI) THEN
6594 WRITE(LO,'(/1X,A,2E12.5)')
6595 & 'PHO_GHHIOF: ymin2 increased to (old/new)',YMIN2,YMI
6597 ELSE IF(YMIN2.GT.YMI) THEN
6598 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
6599 & 'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
6600 & ' INSTEAD OF',YMIN2
6602 C kinematic limitation
6603 Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
6604 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
6606 WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
6607 WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV) ',HIMASS
6608 WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1) ',HIRADI
6609 WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 1 (GEV**2)',Q2LOW1,
6611 WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
6613 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1 ',YMIN1,
6615 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
6617 WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
6619 WRITE(LO,'(6X,A,2E12.5)') 'INV.MASS PHOTON-HADRON ',ECMIN,
6621 WRITE(LO,'(6X,A,E12.5)') 'MIN. INV.MASS PHOTON-POMERON',
6623 WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
6624 IF(Q2LOW1.GE.Q2MAX1) THEN
6625 WRITE(LO,'(/1X,A,2E12.4)')
6626 & 'PHO_GHHIOF:ERROR:INCONSISTENT Q**2 RANGE 1',Q2LOW1,Q2MAX1
6629 IF(Q2LOW2.GE.Q2MAX2) THEN
6630 WRITE(LO,'(/1X,A,2E12.4)')
6631 & 'PHO_GHHIOF:ERROR:INCONSISTENT Q**2 RANGE 2',Q2LOW2,Q2MAX2
6634 C hadron numbers set to 0
6646 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
6648 Y1 = EXP(XMIN+DELLY*DBLE(I-1))
6649 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
6650 IF(Q2LOW1.GE.Q2MAX1) THEN
6651 WRITE(LO,'(/1X,A,2E12.4)')
6652 & 'PHO_GHHIOF: ymax1 changed from/to',YMAX1,Y1
6653 YMAX1 = MIN(Y1,YMAX1)
6663 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
6665 Y1 = EXP(XMIN+DELLY*DBLE(I-1))
6666 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
6667 IF(Q2LOW2.GE.Q2MAX2) THEN
6668 WRITE(LO,'(/1X,A,2E12.4)')
6669 & 'PHO_GHHIOF: ymax2 changed from/to',YMAX2,Y1
6670 YMAX2 = MIN(Y1,YMAX2)
6682 DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
6684 IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
6685 & 'PHO_GHHIOF: table of raw photon flux (side 1)',Max_tab
6687 Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
6688 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
6689 FF = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
6690 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))*ALPHA/(2.D0*PI)
6692 IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y1,FF
6695 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
6696 & 'PHO_GHHIOF: integrated flux (one side):',FLUX
6699 EGAM = MAX(YMAX1,YMAX2)*EE
6707 P2(3) = -SQRT(EEN**2-AMP2)
6709 CALL PHO_SETPAR(1,22,0,0.D0)
6710 CALL PHO_SETPAR(2,2212,0,0.D0)
6711 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
6713 Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
6714 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
6717 WGMAX1 = (1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
6718 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1
6719 WGMAX2 = (1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
6720 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
6722 IF(IPAMDL(175).EQ.1) WGMAX2 = 0.D0
6723 IF(IPAMDL(175).EQ.2) WGMAX1 = 0.D0
6725 FAC12 = WGMAX1*LOG(YMAX1/YMIN1)
6726 & /(WGMAX1*LOG(YMAX1/YMIN1)+WGMAX2*LOG(YMAX2/YMIN2))
6728 CALL PHO_PHIST(-1,SIGMAX)
6729 CALL PHO_LHIST(-1,SIGMAX)
6731 C generation of events, flux calculation
6760 C select side of photon emission
6761 IF(DT_RNDM(AY1).LT.FAC12) THEN
6764 Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
6765 Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1**2/(1.D0-Y1))
6766 IF(Q2LOW1.GE.Q2MAX1) GOTO 175
6767 Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
6768 WGH = (1.D0+(1.D0-Y1)**2)*Q2LOG1
6769 & -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1
6770 IF(WGMAX1.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
6771 & 'PHO_GHHIOF:WEIGHT ERROR (1):',Y1,WGMAX1,WGH
6772 IF(DT_RNDM(AYS1)*WGMAX1.GT.WGH) GOTO 175
6774 IF(IPAMDL(174).EQ.1) THEN
6775 YEFF = 1.D0+(1.D0-Y1)**2
6777 Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
6778 WEIGHT = (YEFF-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF
6779 IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
6784 GAIMP(1) = 1.D0/SQRT(Q2P1)
6785 C form factor (squared)
6787 IF(GAIMP(1).LT.2.D0*HIRADI) FF2 = 0.D0
6788 IF(DT_RNDM(Q2P1).GE.FF2) GOTO 175
6796 PINI(3,1) = SQRT(EE**2-AMP2)
6800 YQ2 = SQRT((1.D0-Y1)*Q2P1)
6801 Q2E = Q2P1/(4.D0*EE)
6803 CALL PHO_SFECFE(SIF,COF)
6809 PFPHI(1) = ATAN2(COF,SIF)
6810 PFTHE(1) = ACOS((E1Y-Q2E)/(Q2E+E1Y))
6814 PINI(3,2) = -SQRT(EE**2-AMP2)
6820 P1(3) = PINI(3,1)-PFIN(3,1)
6821 P1(4) = PINI(4,1)-PFIN(4,1)
6825 P2(3) = -SQRT(EEN**2-AMP2)
6833 Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
6834 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
6835 IF(Q2LOW2.GE.Q2MAX2) GOTO 175
6836 Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
6837 WGH = (1.D0+(1.D0-Y2)**2)*Q2LOG2
6838 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
6839 IF(WGMAX2.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
6840 & 'PHO_GHHIOF:WEIGHT ERROR (2):',Y2,WGMAX2,WGH
6841 IF(DT_RNDM(AYS1)*WGMAX2.GT.WGH) GOTO 175
6843 IF(IPAMDL(174).EQ.1) THEN
6844 YEFF = 1.D0+(1.D0-Y2)**2
6846 Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
6847 WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
6848 IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
6853 GAIMP(2) = 1.D0/SQRT(Q2P2)
6854 C form factor (squared)
6856 IF(GAIMP(2).LT.2.D0*HIRADI) FF2 = 0.D0
6857 IF(DT_RNDM(Q2P2).GE.FF2) GOTO 175
6865 PINI(3,1) = SQRT(EE**2-AMP2)
6871 PINI(3,2) = -SQRT(EE**2-AMP2)
6875 YQ2 = SQRT((1.D0-Y2)*Q2P2)
6876 Q2E = Q2P2/(4.D0*EE)
6878 CALL PHO_SFECFE(SIF,COF)
6881 PFIN(3,2) = -E1Y+Q2E
6884 PFPHI(2) = ATAN2(COF,SIF)
6885 PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
6889 P2(3) = SQRT(EEN**2-AMP2)
6894 P1(3) = PINI(3,2)-PFIN(3,2)
6895 P1(4) = PINI(4,2)-PFIN(4,2)
6899 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
6900 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
6901 IF(GGECM.LT.0.1D0) GOTO 175
6903 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
6909 PGAM(5,1) = -SQRT(Q2P1)
6914 PGAM(5,2) = -SQRT(Q2P2)
6915 CALL PHO_PRESEL(5,IREJ)
6920 IF(IREJ.NE.0) GOTO 175
6922 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
6923 IF(IREJ.NE.0) GOTO 150
6924 C cut on diffractive mass
6926 IF(ISTHEP(K).EQ.30) THEN
6928 IF(GHDIFF.GE.PARMDL(175)) THEN
6935 WRITE(LO,'(/,1X,A)')
6936 & 'PHO_GHHIOF: no diffractive entry found'
6940 C remove quasi-elastically scattered hadron
6942 IF((ISTHEP(K).EQ.1).AND.(IDHEP(K).EQ.2212)) THEN
6943 XF = ABS(PHEP(3,K)/EEN)
6944 IF(XF.LT.PARMDL(72)) GOTO 150
6952 NITERS(ISIDE) = NITERS(ISIDE)+1
6956 Q21AVE = Q21AVE+Q2P1
6957 Q21AV2 = Q21AV2+Q2P1*Q2P1
6958 Q21MIN = MIN(Q21MIN,Q2P1)
6959 Q21MAX = MAX(Q21MAX,Q2P1)
6960 YY1MIN = MIN(YY1MIN,Y1)
6961 YY1MAX = MAX(YY1MAX,Y1)
6965 Q22AVE = Q22AVE+Q2P2
6966 Q22AV2 = Q22AV2+Q2P2*Q2P2
6967 Q22MIN = MIN(Q22MIN,Q2P2)
6968 Q22MAX = MAX(Q22MAX,Q2P2)
6969 YY2MIN = MIN(YY2MIN,Y2)
6970 YY2MAX = MAX(YY2MAX,Y2)
6973 CALL PHO_PHIST(1,HSWGHT(0))
6974 CALL PHO_LHIST(1,HSWGHT(0))
6977 WGMAX = WGMAX1*LOG(YMAX1/YMIN1)*FAC12
6978 WGY1 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW(1),1))*ALPHA/(2.D0*PI)
6979 WGMAX = WGMAX2*LOG(YMAX2/YMIN2)*(1.D0-FAC12)
6980 WGY2 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW(2),1))*ALPHA/(2.D0*PI)
6981 AY1 = AY1/DBLE(MAX(NITERS(1),1))
6982 AYS1 = AYS1/DBLE(MAX(NITERS(1),1))
6983 DAY1 = SQRT((AYS1-AY1**2)/DBLE(MAX(NITERS(1),1)))
6984 AY2 = AY2/DBLE(MAX(NITERS(2),1))
6985 AYS2 = AYS2/DBLE(MAX(NITERS(2),1))
6986 DAY2 = SQRT((AYS2-AY2**2)/DBLE(MAX(NITERS(2),1)))
6987 Q21AVE = Q21AVE/DBLE(MAX(NITERS(1),1))
6988 Q21AV2 = Q21AV2/DBLE(MAX(NITERS(1),1))
6989 Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(MAX(NITERS(1),1)))
6990 Q22AVE = Q22AVE/DBLE(MAX(NITERS(2),1))
6991 Q22AV2 = Q22AV2/DBLE(MAX(NITERS(2),1))
6992 Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(MAX(NITERS(2),1)))
6993 WGMAX = WGMAX1*LOG(YMAX1/YMIN1)+WGMAX2*LOG(YMAX2/YMIN2)
6994 WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW(1)+ITRW(2))*ALPHA/(2.D0*PI)
6995 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
6996 C output of statistics, histograms
6997 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
6998 &'=========================================================',
6999 &' ***** simulated cross section: ',WEIGHT,' mb *****',
7000 &'========================================================='
7001 WRITE(LO,'(//1X,A,/3X,6I12)')
7002 & 'PHO_GHHIOF:SUMMARY: NITER, NITERS1/2, ITRY, ITRW1,2',
7003 & NITER,NITERS,ITRY,ITRW
7004 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
7006 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1 ',
7008 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
7010 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1 ',
7012 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
7014 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 1 ',
7016 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 1 ',
7018 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 2 ',
7020 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2 ',
7023 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
7025 CALL PHO_PHIST(-2,WEIGHT)
7026 CALL PHO_LHIST(-2,WEIGHT)
7028 WRITE(LO,'(1X,A,I4)') 'PHO_GHHIOF:NO OUTPUT OF HISTOGRAMS',NITER
7033 *$ CREATE PHO_GHHIAS.FOR
7035 CDECK ID>, PHO_GHHIAS
7036 SUBROUTINE PHO_GHHIAS(NEVENT,EEP,EEN,NA,NZ)
7037 C**********************************************************************
7039 C interface to call PHOJET (variable energy run) for
7040 C gamma-hadron collisions in heavy ion - hadron
7041 C collisions (form factor approach)
7043 C input: EEP LAB system energy of proton (GeV)
7044 C EEN LAB system energy per nucleon (GeV)
7045 C NA atomic number of ion/hadron
7046 C NZ charge number of ion/hadron
7047 C NEVENT number of events to generate
7049 C YMIN2 lower limit of Y
7050 C (energy fraction taken by photon from hadron)
7051 C YMAX2 upper cutoff for Y, necessary to avoid
7053 C Q2MIN2 minimum Q**2 of photons (should be set to 0)
7054 C Q2MAX2 maximum Q**2 of photons (if necessary,
7055 C corrected according size of hadron)
7057 C**********************************************************************
7058 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7061 PARAMETER ( PI = 3.14159265359D0 )
7063 C input/output channels
7065 COMMON /POINOU/ LI,LO
7066 C model switches and parameters
7068 INTEGER ISWMDL,IPAMDL
7069 DOUBLE PRECISION PARMDL
7070 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
7071 C event debugging information
7073 PARAMETER (NMAXD=100)
7074 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
7075 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7076 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
7077 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7078 C photon flux kinematics and cuts
7079 DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
7080 & YMIN1,YMAX1,YMIN2,YMAX2,
7081 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
7082 & THMIN1,THMAX1,THMIN2,THMAX2
7084 COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
7085 & YMIN1,YMAX1,YMIN2,YMAX2,
7086 & Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
7087 & THMIN1,THMAX1,THMIN2,THMAX2,
7089 C gamma-lepton or gamma-hadron vertex information
7090 INTEGER IGHEL,IDPSRC,IDBSRC
7091 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
7092 & RADSRC,AMSRC,GAMSRC
7093 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
7094 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
7095 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
7096 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
7097 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
7098 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
7099 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
7100 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
7101 C standard particle data interface
7103 PARAMETER (NMXHEP=4000)
7104 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
7105 DOUBLE PRECISION PHEP,VHEP
7106 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
7107 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
7109 C extension to standard particle data interface (PHOJET specific)
7110 INTEGER IMPART,IPHIST,ICOLOR
7111 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
7112 C event weights and generated cross section
7113 INTEGER IPOWGC,ISWCUT,IVWGHT
7114 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
7115 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
7116 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
7118 DIMENSION P1(4),P2(4)
7120 WRITE(LO,'(2(/1X,A))')
7121 & 'PHO_GHHIAS: hadron-gamma event generation',
7122 & '-----------------------------------------'
7123 C hadron size and mass
7125 HIMASS = DBLE(NA)*0.938D0
7127 HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
7128 ALPHA = DBLE(NZ**2)/137.D0
7131 C correct Q2MAX2 according to hadron size
7132 Q2MAXH = 2.D0/HIRADI**2
7133 Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
7134 IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
7135 C total hadron / heavy ion energy
7142 C check kinematic limitations
7143 YMI = ECMIN**2/(4.D0*EE*EEP)
7144 IF(YMIN2.LT.YMI) THEN
7145 WRITE(LO,'(/1X,A,2E12.5)')
7146 & 'PHO_GHHIOF: ymin2 increased to (old/new)',YMIN2,YMI
7148 ELSE IF(YMIN2.GT.YMI) THEN
7149 WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
7150 & 'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
7151 & ' INSTEAD OF',YMIN2
7153 C kinematic limitation
7154 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
7156 WRITE(LO,'(/6X,A,2I4)') 'MASS NUMBER, CHARGE NUMBER ',NA,NZ
7157 WRITE(LO,'(6X,A,E12.5)') 'HEAVY ION MASS (GeV) ',HIMASS
7158 WRITE(LO,'(6X,A,E12.5)') 'HEAVY ION RADIUS (GeV**-1) ',HIRADI
7159 WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
7161 WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2 ',YMIN2,
7163 WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL ',
7164 & 2.D0*SQRT(EEN*EEP),2.D0*SQRT(EE*EEP)
7165 WRITE(LO,'(6X,A,2E12.5)') 'INV.MASS HADRON-PHOTON ',ECMIN,
7167 WRITE(LO,'(6X,A,I10)') 'EVENTS TO PROCESS ',NEVENT
7168 IF(Q2LOW2.GE.Q2MAX2) THEN
7169 WRITE(LO,'(/1X,A,2E12.4)')
7170 & 'PHO_GHHIOF:ERROR:inconsistent Q**2 range 2',Q2LOW2,Q2MAX2
7173 C hadron numbers set to 0
7185 DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
7187 Y1 = EXP(XMIN+DELLY*DBLE(I-1))
7188 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
7189 IF(Q2LOW2.GE.Q2MAX2) THEN
7190 WRITE(LO,'(/1X,A,2E12.4)')
7191 & 'PHO_GHHIOF: ymax2 changed from/to',YMAX2,Y1
7192 YMAX2 = MIN(Y1,YMAX2)
7201 DELLY = LOG(YMAX2/YMIN2)/DBLE(Max_tab-1)
7203 IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
7204 & 'PHO_GHHIAS: table of raw photon flux (side 2)',Max_tab
7206 Y2 = EXP(X2MIN+DELLY*DBLE(I-1))
7207 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2*Y2/(1.D0-Y2))
7208 FF = ((1.D0+(1.D0-Y2)**2)/Y2*LOG(Q2MAX2/Q2LOW2)
7209 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2))*ALPHA/(2.D0*PI)
7211 IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y2,FF
7214 IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
7215 & 'PHO_GHHIAS: integrated flux:',FLUX
7220 P1(3) = -SQRT(EEP**2-AMP2)
7228 CALL PHO_SETPAR(1,2212,0,0.D0)
7229 CALL PHO_SETPAR(2,22,0,0.D0)
7230 CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
7232 Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
7234 WGMAX2 = (1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
7235 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
7237 CALL PHO_PHIST(-1,SIGMAX)
7238 CALL PHO_LHIST(-1,SIGMAX)
7240 C generation of events, flux calculation
7256 C sample photon flux
7263 Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
7264 Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
7265 IF(Q2LOW2.GE.Q2MAX2) GOTO 175
7266 Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
7267 WGH = (1.D0+(1.D0-Y2)**2)*Q2LOG2
7268 & -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
7269 IF(WGMAX2.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
7270 & 'PHO_GHHIOF:WEIGHT ERROR (2):',Y2,WGMAX2,WGH
7271 IF(DT_RNDM(AYS1)*WGMAX2.GT.WGH) GOTO 175
7273 IF(IPAMDL(174).EQ.1) THEN
7274 YEFF = 1.D0+(1.D0-Y2)**2
7276 Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
7277 WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
7278 IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
7283 GAIMP(2) = 1.D0/SQRT(Q2P2)
7284 C form factor (squared)
7286 IF(GAIMP(2).LT.2.D0*HIRADI) FF2 = 0.D0
7287 IF(DT_RNDM(Q2P2).GE.FF2) GOTO 175
7295 PINI(3,1) = SQRT(EEP**2-AMP2)
7301 PINI(3,2) = -SQRT(EE**2-AMP2)
7305 YQ2 = SQRT((1.D0-Y2)*Q2P2)
7306 Q2E = Q2P2/(4.D0*EE)
7308 CALL PHO_SFECFE(SIF,COF)
7311 PFIN(3,2) = -E1Y+Q2E
7314 PFPHI(2) = ATAN2(COF,SIF)
7315 PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
7319 P1(3) = SQRT(EEP**2-AMP2)
7325 P2(3) = PINI(3,2)-PFIN(3,2)
7326 P2(4) = PINI(4,2)-PFIN(4,2)
7330 GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
7331 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
7332 IF(GGECM.LT.0.1D0) GOTO 175
7334 IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
7345 PGAM(5,2) = -SQRT(Q2P2)
7349 CALL PHO_PRESEL(5,IREJ)
7350 IF(IREJ.NE.0) GOTO 175
7352 CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
7353 IF(IREJ.NE.0) GOTO 150
7354 C cut on diffractive mass
7356 IF(ISTHEP(K).EQ.30) THEN
7358 IF(GHDIFF.GE.PARMDL(175)) THEN
7365 WRITE(LO,'(/,1X,A)')
7366 & 'PHO_GHHIOF: no diffractive entry found'
7370 C remove quasi-elastically scattered hadron
7372 IF((ISTHEP(K).EQ.1).AND.(IDHEP(K).EQ.2212)) THEN
7373 XF = ABS(PHEP(3,K)/EEN)
7374 IF(XF.LT.PARMDL(72)) GOTO 150
7385 Q22AVE = Q22AVE+Q2P2
7386 Q22AV2 = Q22AV2+Q2P2*Q2P2
7387 Q22MIN = MIN(Q22MIN,Q2P2)
7388 Q22MAX = MAX(Q22MAX,Q2P2)
7389 YY2MIN = MIN(YY2MIN,Y2)
7390 YY2MAX = MAX(YY2MAX,Y2)
7392 CALL PHO_PHIST(1,HSWGHT(0))
7393 CALL PHO_LHIST(1,HSWGHT(0))
7396 WGMAX = WGMAX2*LOG(YMAX2/YMIN2)
7397 WGY2 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW,1))*ALPHA/(2.D0*PI)
7398 AY2 = AY2/DBLE(MAX(NITERS,1))
7399 AYS2 = AYS2/DBLE(MAX(NITERS,1))
7400 DAY2 = SQRT((AYS2-AY2**2)/DBLE(MAX(NITERS,1)))
7401 Q22AVE = Q22AVE/DBLE(MAX(NITERS,1))
7402 Q22AV2 = Q22AV2/DBLE(MAX(NITERS,1))
7403 Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(MAX(NITERS,1)))
7404 WGMAX = WGMAX2*LOG(YMAX2/YMIN2)
7405 WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW)*ALPHA/(2.D0*PI)
7406 WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
7407 C output of statistics, histograms
7408 WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
7409 &'=========================================================',
7410 &' ***** simulated cross section: ',WEIGHT,' mb *****',
7411 &'========================================================='
7412 WRITE(LO,'(//1X,A,/3X,4I12)')
7413 & 'PHO_GHHIOF:SUMMARY: NITER, NITERS, ITRY, ITRW',
7414 & NITER,NITERS,ITRY,ITRW
7415 WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
7417 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2 ',
7419 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2 ',
7421 WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 2 ',
7423 WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2 ',
7426 CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
7428 CALL PHO_PHIST(-2,WEIGHT)
7429 CALL PHO_LHIST(-2,WEIGHT)
7431 WRITE(LO,'(1X,A,I4)')
7432 & 'PHO_GHHIOF: no output of histograms',NITER
7437 *$ CREATE PHO_FITPAR.FOR
7439 CDECK ID>, PHO_FITPAR
7440 SUBROUTINE PHO_FITPAR(IOUTP)
7441 C**********************************************************************
7443 C read input parameters according to PDFs
7445 C**********************************************************************
7446 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7449 PARAMETER ( DEFA=-99999.D0,
7453 C input/output channels
7455 COMMON /POINOU/ LI,LO
7456 C event debugging information
7458 PARAMETER (NMAXD=100)
7459 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
7460 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7461 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
7462 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7463 C model switches and parameters
7465 INTEGER ISWMDL,IPAMDL
7466 DOUBLE PRECISION PARMDL
7467 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
7468 C global event kinematics and particle IDs
7470 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
7471 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
7472 C currently activated parton density parametrizations
7474 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
7475 DOUBLE PRECISION PDFLAM,PDFQ2M
7476 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
7477 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
7478 C Reggeon phenomenology parameters
7479 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
7480 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
7481 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
7482 & ALREG,ALREGP,GR(2),B0REG(2),
7483 & GPPP,GPPR,B0PPP,B0PPR,
7484 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
7485 C parameters of 2x2 channel model
7486 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
7487 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
7489 DIMENSION INUM(3),IFPAS(2)
7490 CHARACTER*8 CNAME8,PDFNA1,PDFNA2
7493 PARAMETER ( Max_tab = 22 )
7494 DIMENSION XDPtab(27,Max_tab),IDPtab(8,Max_tab)
7498 C parameter set for 2212 (GRV94 LO) 2212 (GRV94 LO)
7499 DATA (IDPtab(k, 1),k=1,8) /
7500 & 2212, 5, 6, 0, 2212, 5, 6, 0 /
7501 DATA (XDPtab(k, 1),k=1,27) /
7502 &1.1000E+00,2.5000E-01,6.3870E+00,6.3870E+00,1.1610E+00,1.1610E+00,
7503 &4.5000E-01,9.0000E-01,1.0263E+01,1.0263E+01,1.1710E+00,1.1710E+00,
7504 &1.5600E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7505 &1.0000E+00,0.0000E+00,1.0000E+00,0.0000E+00,3.5000E+00,2.0000E+00,
7506 &6.0000E-01,6.0000E-01,1.1000E+00,1.1000E+00,3.000E+00 /
7508 C parameter set for 2212 (GRV94 LO) -2212 (GRV94 LO)
7509 DATA (IDPtab(k, 2),k=1,8) /
7510 & 2212, 5, 6, 0, -2212, 5, 6, 0 /
7511 DATA (XDPtab(k, 2),k=1,27) /
7512 &1.1000E+00,2.5000E-01,6.3870E+00,6.3870E+00,1.1610E+00,1.1610E+00,
7513 &4.5000E-01,9.0000E-01,1.5174E+01,1.5174E+01,1.5400E+00,1.5400E+00,
7514 &1.5600E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7515 &1.0000E+00,0.0000E+00,1.0000E+00,0.0000E+00,3.5000E+00,2.0000E+00,
7516 &6.0000E-01,6.0000E-01,1.1000E+00,1.1000E+00,3.000E+00 /
7518 C parameter set for 22 (GRV-G LO) 2212 (GRV94 LO)
7519 DATA (IDPtab(k, 3),k=1,8) /
7520 & 22, 5, 3, 0, 2212, 5, 6, 0 /
7521 DATA (XDPtab(k, 3),k=1,27) /
7522 &1.0970E+00,2.5000E-01,2.7450E+00,6.8270E+00,1.2250E+00,1.1360E+00,
7523 &5.0000E-01,1.0000E+00,4.7210E+00,1.1740E+01,4.6200E-01,4.2800E-01,
7524 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7525 &4.3100E-03,8.0000E-05,1.0000E+00,0.0000E+00,3.2000E+00,1.0000E+00,
7526 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7528 C parameter set for 22 (GRV-G LO) 22 (GRV-G LO)
7529 DATA (IDPtab(k, 4),k=1,8) /
7530 & 22, 5, 3, 0, 22, 5, 3, 0 /
7531 DATA (XDPtab(k, 4),k=1,27) /
7532 &1.0970E+00,2.5000E-01,2.7450E+00,2.7450E+00,1.2250E+00,1.2250E+00,
7533 &5.0000E-01,1.0000E+00,4.7210E+00,4.7210E+00,4.6200E-01,4.6200E-01,
7534 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7535 &4.3100E-03,8.0000E-05,4.3100E-03,8.0000E-05,3.2000E+00,1.0000E+00,
7536 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7538 C parameter set for 22 (GRS-G LO) 2212 (GRV94 LO)
7539 DATA (IDPtab(k, 5),k=1,8) /
7540 & 22, 5, 4, 4, 2212, 5, 6, 0 /
7541 DATA (XDPtab(k, 5),k=1,27) /
7542 &1.0970E+00,2.5000E-01,2.7450E+00,6.8270E+00,1.2250E+00,1.1360E+00,
7543 &5.0000E-01,1.0000E+00,4.7210E+00,1.1740E+01,4.6200E-01,4.2800E-01,
7544 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7545 &4.3100E-03,8.0000E-05,1.0000E+00,0.0000E+00,3.2000E+00,1.0000E+00,
7546 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7548 C parameter set for 22 (GRS-G LO) 22 (GRS-G LO)
7549 DATA (IDPtab(k, 6),k=1,8) /
7550 & 22, 5, 4, 4, 22, 5, 4, 4 /
7551 DATA (XDPtab(k, 6),k=1,27) /
7552 &1.0970E+00,2.5000E-01,2.7450E+00,2.7450E+00,1.2250E+00,1.2250E+00,
7553 &5.0000E-01,1.0000E+00,4.7210E+00,4.7210E+00,4.6200E-01,4.6200E-01,
7554 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7555 &4.3100E-03,8.0000E-05,4.3100E-03,8.0000E-05,3.2000E+00,1.0000E+00,
7556 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7558 C parameter set for 22 (SaS-1D ) 22 (SaS-1D )
7559 DATA (IDPtab(k, 7),k=1,8) /
7560 & 22, 1, 1, 4, 22, 1, 1, 4 /
7561 DATA (XDPtab(k, 7),k=1,27) /
7562 &1.0970E+00,2.5000E-01,3.1170E+00,3.1170E+00,1.3450E+00,1.3450E+00,
7563 &3.0200E-01,1.0000E+00,6.6050E+00,6.6050E+00,1.7500E-01,1.7500E-01,
7564 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7565 &4.0900E-03,9.0000E-05,4.0900E-03,9.0000E-05,3.2000E+00,1.0000E+00,
7566 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7568 C parameter set for 22 (SaS-1M ) 22 (SaS-1M )
7569 DATA (IDPtab(k, 8),k=1,8) /
7570 & 22, 1, 2, 4, 22, 1, 2, 4 /
7571 DATA (XDPtab(k, 8),k=1,27) /
7572 &1.0970E+00,2.5000E-01,2.5540E+00,2.5540E+00,1.0910E+00,1.0910E+00,
7573 &5.0000E-01,1.0000E+00,4.2580E+00,4.2580E+00,4.9000E-01,4.9000E-01,
7574 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7575 &4.5700E-03,1.0000E-04,4.5700E-03,1.0000E-04,3.2000E+00,1.0000E+00,
7576 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7578 C parameter set for 22 (SaS-2D ) 22 (SaS-2D )
7579 DATA (IDPtab(k, 9),k=1,8) /
7580 & 22, 1, 3, 4, 22, 1, 3, 4 /
7581 DATA (XDPtab(k, 9),k=1,27) /
7582 &1.0970E+00,2.5000E-01,2.5330E+00,2.5330E+00,1.1340E+00,1.1340E+00,
7583 &5.0100E-01,1.0000E+00,4.2300E+00,4.2300E+00,4.9300E-01,4.9300E-01,
7584 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7585 &4.5900E-03,1.0000E-04,4.5900E-03,1.0000E-04,3.2000E+00,1.0000E+00,
7586 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7588 C parameter set for 22 (SaS-2M ) 22 (SaS-2M )
7589 DATA (IDPtab(k, 10),k=1,8) /
7590 & 22, 1, 4, 4, 22, 1, 4, 4 /
7591 DATA (XDPtab(k, 10),k=1,27) /
7592 &1.0970E+00,2.5000E-01,2.8220E+00,2.8220E+00,1.0910E+00,1.0910E+00,
7593 &4.9100E-01,1.0000E+00,4.6870E+00,4.6870E+00,4.5800E-01,4.5800E-01,
7594 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7595 &4.6600E-03,3.0000E-05,4.6600E-03,3.0000E-05,3.2000E+00,1.0000E+00,
7596 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7598 C parameter set for 22 (LAC ) 2212 (GRV94 LO)
7599 DATA (IDPtab(k, 11),k=1,8) /
7600 & 22, 3, 1, 3, 2212, 5, 6, 0 /
7601 DATA (XDPtab(k, 11),k=1,27) /
7602 &1.0970E+00,2.5000E-01,3.3050E+00,6.8270E+00,9.4500E-01,1.1360E+00,
7603 &4.5000E-01,1.0000E+00,6.7120E+00,1.1740E+01,2.5800E-01,4.6200E-01,
7604 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7605 &3.3400E-03,2.4000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7606 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7608 C parameter set for 22 (PDFLIB2 ) 2212 (GRV94 LO)
7609 DATA (IDPtab(k, 12),k=1,8) /
7610 & 22, 3, 1, 2, 2212, 5, 6, 0 /
7611 DATA (XDPtab(k, 12),k=1,27) /
7612 &1.0970E+00,2.5000E-01,3.3050E+00,6.8270E+00,9.4500E-01,1.1360E+00,
7613 &4.5000E-01,1.0000E+00,6.7120E+00,1.1740E+01,2.5800E-01,4.6200E-01,
7614 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7615 &3.3400E-03,2.4000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7616 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7618 C parameter set for 22 (LAC ) 22 (LAC )
7619 DATA (IDPtab(k, 13),k=1,8) /
7620 & 22, 3, 1, 3, 22, 3, 1, 3 /
7621 DATA (XDPtab(k, 13),k=1,27) /
7622 &1.0970E+00,2.5000E-01,3.3050E+00,3.3050E+00,9.4500E-01,9.4500E-01,
7623 &4.5000E-01,1.0000E+00,6.7120E+00,6.7120E+00,2.5800E-01,2.5800E-01,
7624 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7625 &3.3400E-03,2.4000E-04,3.3400E-03,2.4000E-04,2.0000E+00,1.0000E+00,
7626 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7628 C parameter set for 22 (PDFLIB2 ) 22 (PDFLIB2 )
7629 DATA (IDPtab(k, 14),k=1,8) /
7630 & 22, 3, 1, 2, 22, 3, 1, 2 /
7631 DATA (XDPtab(k, 14),k=1,27) /
7632 &1.0970E+00,2.5000E-01,3.3050E+00,3.3050E+00,9.4500E-01,9.4500E-01,
7633 &4.5000E-01,1.0000E+00,6.7120E+00,6.7120E+00,2.5800E-01,2.5800E-01,
7634 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7635 &3.3400E-03,2.4000E-04,3.3400E-03,2.4000E-04,2.0000E+00,1.0000E+00,
7636 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7638 C parameter set for 22 (LAC ) 2212 (GRV94 LO)
7639 DATA (IDPtab(k, 15),k=1,8) /
7640 & 22, 3, 2, 3, 2212, 5, 6, 0 /
7641 DATA (XDPtab(k, 15),k=1,27) /
7642 &1.0970E+00,2.5000E-01,3.1450E+00,6.8270E+00,1.0490E+00,1.1360E+00,
7643 &4.5000E-01,1.0000E+00,6.3680E+00,1.1740E+01,1.4700E-01,4.6200E-01,
7644 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7645 &3.8700E-03,1.1000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7646 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7648 C parameter set for 22 (PDFLIB2 ) 2212 (GRV94 LO)
7649 DATA (IDPtab(k, 16),k=1,8) /
7650 & 22, 3, 2, 2, 2212, 5, 6, 0 /
7651 DATA (XDPtab(k, 16),k=1,27) /
7652 &1.0970E+00,2.5000E-01,3.1450E+00,6.8270E+00,1.0490E+00,1.1360E+00,
7653 &4.5000E-01,1.0000E+00,6.3680E+00,1.1740E+01,1.4700E-01,4.6200E-01,
7654 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7655 &3.8700E-03,1.1000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7656 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7658 C parameter set for 22 (LAC ) 22 (LAC )
7659 DATA (IDPtab(k, 17),k=1,8) /
7660 & 22, 3, 2, 3, 22, 3, 2, 3 /
7661 DATA (XDPtab(k, 17),k=1,27) /
7662 &1.0970E+00,2.5000E-01,3.1450E+00,3.1450E+00,1.0490E+00,1.0490E+00,
7663 &4.5000E-01,1.0000E+00,6.3680E+00,6.3680E+00,1.4700E-01,1.4700E-01,
7664 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7665 &3.8700E-03,1.1000E-04,3.8700E-03,1.0000E-04,2.0000E+00,1.0000E+00,
7666 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7668 C parameter set for 22 (PDFLIB2 ) 22 (PDFLIB2 )
7669 DATA (IDPtab(k, 18),k=1,8) /
7670 & 22, 3, 2, 2, 22, 3, 2, 2 /
7671 DATA (XDPtab(k, 18),k=1,27) /
7672 &1.0970E+00,2.5000E-01,3.1450E+00,3.1450E+00,1.0490E+00,1.0490E+00,
7673 &4.5000E-01,1.0000E+00,6.3680E+00,6.3680E+00,1.4700E-01,1.4700E-01,
7674 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7675 &3.8700E-03,1.1000E-04,3.8700E-03,1.0000E-04,2.0000E+00,1.0000E+00,
7676 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7678 C parameter set for 22 (LAC ) 2212 (GRV94 LO)
7679 DATA (IDPtab(k, 19),k=1,8) /
7680 & 22, 3, 3, 3, 2212, 5, 6, 0 /
7681 DATA (XDPtab(k, 19),k=1,27) /
7682 &1.0970E+00,2.5000E-01,3.0510E+00,6.8270E+00,1.0500E+00,1.1360E+00,
7683 &4.5000E-01,1.0000E+00,6.0060E+00,1.1740E+01,2.0500E-01,4.6200E-01,
7684 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7685 &4.0200E-03,1.0000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7686 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7688 C parameter set for 22 (PDFLIB2 ) 2212 (GRV94 LO)
7689 DATA (IDPtab(k, 20),k=1,8) /
7690 & 22, 3, 3, 2, 2212, 5, 6, 0 /
7691 DATA (XDPtab(k, 20),k=1,27) /
7692 &1.0970E+00,2.5000E-01,3.0510E+00,6.8270E+00,1.0500E+00,1.1360E+00,
7693 &4.5000E-01,1.0000E+00,6.0060E+00,1.1740E+01,2.0500E-01,4.6200E-01,
7694 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7695 &4.0200E-03,1.0000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7696 &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7698 C parameter set for 22 (LAC ) 22 (LAC )
7699 DATA (IDPtab(k, 21),k=1,8) /
7700 & 22, 3, 3, 3, 22, 3, 3, 3 /
7701 DATA (XDPtab(k, 21),k=1,27) /
7702 &1.0970E+00,2.5000E-01,3.0510E+00,3.0510E+00,1.0500E+00,1.0500E+00,
7703 &4.5000E-01,1.0000E+00,6.0060E+00,6.0060E+00,2.0500E-01,2.0500E-01,
7704 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7705 &4.0200E-03,1.0000E-04,4.0200E-03,1.0000E-04,2.0000E+00,1.0000E+00,
7706 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7708 C parameter set for 22 (PDFLIB2 ) 22 (PDFLIB2 )
7709 DATA (IDPtab(k, 22),k=1,8) /
7710 & 22, 3, 3, 2, 22, 3, 3, 2 /
7711 DATA (XDPtab(k, 22),k=1,27) /
7712 &1.0970E+00,2.5000E-01,3.0510E+00,3.0510E+00,1.0500E+00,1.0500E+00,
7713 &4.5000E-01,1.0000E+00,6.0060E+00,6.0060E+00,2.0500E-01,2.0500E-01,
7714 &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7715 &4.0200E-03,1.0000E-04,4.0200E-03,1.0000E-04,2.0000E+00,1.0000E+00,
7716 &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7724 & (IFPAP(1).EQ.IFPAS(1)).AND.(IFPAP(2).EQ.IFPAS(2))) GOTO 1300
7730 C parton distribution functions
7731 CALL PHO_ACTPDF(IFPAP(1),1)
7732 CALL PHO_GETPDF(1,PDFNA1,ALAM2,Q2MIN,Q2MAX,XMIN,XMAX)
7733 CALL PHO_ACTPDF(IFPAP(2),2)
7734 CALL PHO_GETPDF(2,PDFNA2,ALAM2,Q2MIN,Q2MAX,XMIN,XMAX)
7735 C initialize alpha_s calculation
7736 DUMMY = PHO_ALPHAS(0.D0,-4)
7738 IF(IDEB(54).GE.0) THEN
7739 WRITE(LO,'(/1X,A,I7,2X,A,3I7)') 'PHO_FITPAR: looking for PDF',
7740 & IFPAP(1),PDFNA1,IGRP(1),ISET(1),IEXT(1)
7741 WRITE(LO,'(1X,A,I7,2X,A,3I7)') 'PHO_FITPAR: looking for PDF',
7742 & IFPAP(2),PDFNA2,IGRP(2),ISET(2),IEXT(2)
7747 C load parameter set from internal tables
7753 IF((IFPAP(I1).EQ.IDPtab(1,I))
7754 & .AND.(IGRP(I1).EQ.IDPtab(2,I))
7755 & .AND.(ISET(I1).EQ.IDPtab(3,I))
7756 & .AND.(IEXT(I1).EQ.IDPtab(4,I))) THEN
7757 IF((IFPAP(I2).EQ.IDPtab(5,I))
7758 & .AND.(IGRP(I2).EQ.IDPtab(6,I))
7759 & .AND.(ISET(I2).EQ.IDPtab(7,I))
7760 & .AND.(IEXT(I2).EQ.IDPtab(8,I))) THEN
7762 & 'PHO_FITPAR: parameter set found in internal table'
7764 ALPOMP = XDPtab(2,I)
7765 GP(I1) = XDPtab(3,I)
7766 GP(I2) = XDPtab(4,I)
7767 B0POM(I1) = XDPtab(5,I)
7768 B0POM(I2) = XDPtab(6,I)
7770 ALREGP = XDPtab(8,I)
7771 GR(I1) = XDPtab(9,I)
7772 GR(I2) = XDPtab(10,I)
7773 B0REG(I1) = XDPtab(11,I)
7774 B0REG(I2) = XDPtab(12,I)
7776 B0PPP = XDPtab(14,I)
7778 B0PPR = XDPtab(16,I)
7779 VDMFAC(2*I1-1) = XDPtab(17,I)
7780 VDMFAC(2*I1) = XDPtab(18,I)
7781 VDMFAC(2*I2-1) = XDPtab(19,I)
7782 VDMFAC(2*I2) = XDPtab(20,I)
7783 B0HAR = XDPtab(21,I)
7784 AKFAC = XDPtab(22,I)
7785 PHISUP(I1) = XDPtab(23,I)
7786 PHISUP(I2) = XDPtab(24,I)
7787 RMASS(I1) = XDPtab(25,I)
7788 RMASS(I2) = XDPtab(26,I)
7802 & 'PHO_FITPAR: parameter set not found in internal table'
7807 C get parameters of soft cross sections from fitpar.dat
7808 IF(IPAMDL(99).GT.IFOUND) THEN
7811 & 'PHO_FITPAR: loading parameter set from file fitpar.dat'
7812 OPEN(12,FILE='fitpar.dat',ERR=1010,STATUS='OLD')
7815 READ(12,'(A8)',ERR=1020,END=1010) CNAME8
7816 IF(CNAME8.EQ.'STOP') GOTO 1010
7817 IF(CNAME8.EQ.'NEXTDATA') THEN
7818 READ(12,'(I8,2X,A8,3I6)',ERR=1020,END=1010)
7820 IF((IDPA1.EQ.IFPAP(1)).AND.(CNAME8.EQ.PDFNA1)
7821 & .AND.(INUM(1).EQ.IGRP(1)).AND.(INUM(2).EQ.ISET(1))) THEN
7822 READ(12,'(I8,2X,A8,3I6)',ERR=1020,END=1010)
7824 IF((IDPA2.EQ.IFPAP(2)).AND.(CNAME8.EQ.PDFNA2).AND.
7825 & (INUM(1).EQ.IGRP(2)).AND.(INUM(2).EQ.ISET(2))) THEN
7826 WRITE(LO,'(/1X,A)') 'PHO_FITPAR: parameter set found'
7827 READ(12,*) ALPOM,ALPOMP,GP,B0POM
7828 READ(12,*) ALREG,ALREGP,GR,B0REG
7829 READ(12,*) GPPP,B0PPP,GPPR,B0PPR
7830 READ(12,*) VDMFAC(1),VDMFAC(2),VDMFAC(3),VDMFAC(4)
7834 READ(12,*) RMASS,VAR
7843 WRITE(LO,'(/A)') ' PHO_FITPAR: cannot read file fitpar.dat'
7844 WRITE(LO,'(A,A10,A8)') ' last data card: ',CNAM10,CNAME8
7847 & ' PHO_FITPAR: cannot find parameter set in file fitpar.dat'
7855 IF(IFOUND.EQ.0) THEN
7856 WRITE(LO,'(/A)') ' PHO_FITPAR: could not find parameter set'
7857 WRITE(LO,'(3(10X,A,/))')
7858 & '(copy fitpar.dat into the working directory and/or',
7859 & ' request the missing parameter set via e-mail from',
7860 & ' ralph.engel@fzk.de)'
7866 C overwrite parameters with user settings
7867 IF(PARMDL(301).GT.DEFA) THEN
7871 IF(PARMDL(302).GT.DEFA) THEN
7872 ALPOMP = PARMDL(302)
7875 IF(PARMDL(303).GT.DEFA) THEN
7879 IF(PARMDL(304).GT.DEFA) THEN
7883 IF(PARMDL(305).GT.DEFA) THEN
7884 B0POM(1) = PARMDL(305)
7887 IF(PARMDL(306).GT.DEFA) THEN
7888 B0POM(2) = PARMDL(306)
7891 IF(PARMDL(307).GT.DEFA) THEN
7895 IF(PARMDL(308).GT.DEFA) THEN
7896 ALREGP = PARMDL(308)
7899 IF(PARMDL(309).GT.DEFA) THEN
7903 IF(PARMDL(310).GT.DEFA) THEN
7907 IF(PARMDL(311).GT.DEFA) THEN
7908 B0REG(1) = PARMDL(311)
7911 IF(PARMDL(312).GT.DEFA) THEN
7912 B0REG(2) = PARMDL(312)
7915 IF(PARMDL(313).GT.DEFA) THEN
7919 IF(PARMDL(314).GT.DEFA) THEN
7923 IF(PARMDL(315).GT.DEFA) THEN
7924 VDMFAC(1) = PARMDL(315)
7927 IF(PARMDL(316).GT.DEFA) THEN
7928 VDMFAC(2) = PARMDL(316)
7931 IF(PARMDL(317).GT.DEFA) THEN
7932 VDMFAC(3) = PARMDL(317)
7935 IF(PARMDL(318).GT.DEFA) THEN
7936 VDMFAC(4) = PARMDL(318)
7939 IF(PARMDL(319).GT.DEFA) THEN
7943 IF(PARMDL(320).GT.DEFA) THEN
7947 IF(PARMDL(321).GT.DEFA) THEN
7948 PHISUP(1) = PARMDL(321)
7951 IF(PARMDL(322).GT.DEFA) THEN
7952 PHISUP(2) = PARMDL(322)
7955 IF(PARMDL(323).GT.DEFA) THEN
7956 RMASS(1) = PARMDL(323)
7959 IF(PARMDL(324).GT.DEFA) THEN
7960 RMASS(2) = PARMDL(324)
7963 IF(PARMDL(325).GT.DEFA) THEN
7967 IF(PARMDL(327).GT.DEFA) THEN
7971 IF(PARMDL(328).GT.DEFA) THEN
7976 VDMQ2F(1) = VDMFAC(1)
7977 VDMQ2F(2) = VDMFAC(2)
7978 VDMQ2F(3) = VDMFAC(3)
7979 VDMQ2F(4) = VDMFAC(4)
7981 C output of parameter set
7982 IF((IDEB(54).GE.5).OR.(IOUTP.GT.0)) THEN
7983 WRITE(LO,'(/,A,/,A)') ' PHO_FITPAR: parameter set',
7984 & ' -------------------------'
7985 WRITE(LO,'(2(A,F7.3),2(A,2F9.3))')
7986 & ' ALPOM:',ALPOM,' ALPOMP:',ALPOMP,' GP:',GP,' B0POM:',
7988 WRITE(LO,'(2(A,F7.3),2(A,2F9.3))')
7989 & ' ALREG:',ALREG,' ALREGP:',ALREGP,' GR:',GR,' B0REG:',
7991 WRITE(LO,'(4(A,F7.3))')
7992 & ' GPPP :',GPPP,' B0PPP:',B0PPP,' GPPR :',GPPR,' B0PPR:',B0PPR
7993 WRITE(LO,'(A,4F10.5)') ' VDMFAC:',VDMFAC
7994 WRITE(LO,'(A,4F10.5)') ' VDMQ2F:',VDMQ2F
7995 WRITE(LO,'(A,F8.3)') ' B0HAR:',B0HAR
7996 WRITE(LO,'(A,F8.3)') ' AKFAC:',AKFAC
7997 WRITE(LO,'(A,2F8.3)') ' PHISUP:',PHISUP
7998 WRITE(LO,'(A,3F8.3)') ' RMASS:',RMASS,VAR
8001 CALL PHO_HARINI(1,IFPAP(1),IFPAP(2),PVIRT(1),PVIRT(2),6,IOUTP-1)
8005 *$ CREATE PHO_BORNCS.FOR
8007 CDECK ID>, PHO_BORNCS
8008 SUBROUTINE PHO_BORNCS(IP,IFHARD,XM1,XM2,XM3,XM4)
8009 C*********************************************************************
8011 C calculation of Born graph cross sections and slopes
8013 C input: IP particle combination
8014 C IFHARD -1 calculate hard Born graph cross section
8015 C 0 take hard Born graph cross section
8016 C from interpolation table if available
8017 C 1 assume that correct hard cross
8018 C sections are already stored in /POSBRN/
8019 C XM1,XM2,XM3,XM4 masses of external lines
8020 C /GLOCMS/ energy and PT cut-off
8021 C /POPREG/ soft and hard parameters
8022 C /POSBRN/ input cross sections
8023 C /POZBRN/ scaled input values
8024 C IFHARD 0 calculate hard input cross sections
8025 C 1 assume hard input cross sections exist
8027 C output: ZPOM scaled pomeron cross section
8028 C ZIGR scaled reggeon cross section
8029 C ZIGHR scaled hard resolved cross section
8030 C ZIGHD scaled hard direct cross section
8031 C ZIGT1 scaled triple-Pomeron cross section
8032 C ZIGT2 scaled triple-Pomeron cross section
8033 C ZIGL scaled loop-Pomeron cross section
8035 C*********************************************************************
8036 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8048 C input/output channels
8050 COMMON /POINOU/ LI,LO
8052 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
8053 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
8054 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
8055 C event debugging information
8057 PARAMETER (NMAXD=100)
8058 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
8059 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8060 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
8061 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8062 C model switches and parameters
8064 INTEGER ISWMDL,IPAMDL
8065 DOUBLE PRECISION PARMDL
8066 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
8067 C names of hard scattering processes
8069 PARAMETER ( Max_pro_1 = 16 )
8071 COMMON /POHPRO/ PROC(0:Max_pro_1)
8072 C hard cross sections and MC selection weights
8074 PARAMETER ( Max_pro_2 = 16 )
8075 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
8077 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
8078 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
8079 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
8080 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
8081 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
8082 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
8083 C interpolation tables for hard cross section and MC selection weights
8084 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
8085 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
8086 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
8087 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
8088 & HQ2a_tab,HQ2b_tab,HEcm_tab
8090 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8091 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8092 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8093 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8094 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
8095 & HEcm_tab(1:Max_tab_E,0:4),
8096 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
8097 C Born graph cross sections and slopes
8099 PARAMETER ( Max_pro_3 = 16 )
8100 COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
8102 COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
8103 & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
8104 C scaled cross sections and slopes
8105 COMPLEX*16 ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1,ZIGT2,ZIGL,ZIGDP,
8107 & BPOM,BREG,BHAR,BHAD,BTR1,BTR2,BLOO,BDP,BD1,BD2
8108 COMMON /POZBRN/ ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1(2),ZIGT2(2),ZIGL,
8109 & ZIGDP(4),ZIGD1(2),ZIGD2(2),
8110 & BPOM,BREG,BHAR,BHAD,BTR1(2),BTR2(2),BLOO,BDP(4),
8112 C Reggeon phenomenology parameters
8113 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
8114 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
8115 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
8116 & ALREG,ALREGP,GR(2),B0REG(2),
8117 & GPPP,GPPR,B0PPP,B0PPR,
8118 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
8119 C parameters of 2x2 channel model
8120 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
8121 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
8122 C data of c.m. system of Pomeron / Reggeon exchange
8123 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
8124 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
8125 & SIDP,CODP,SIFP,COFP
8126 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
8127 & SIDP,CODP,SIFP,COFP,NPOSP(2),
8128 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
8129 C obsolete cut-off information
8130 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
8131 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
8132 C data needed for soft-pt calculation
8133 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
8134 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
8136 COMPLEX*16 CZERO,BP4,BR4,BHR4,BHD4,BT14,BT24,BD4,SP,SR,SS,
8137 & BPOM1,BPOM2,BREG1,BREG2,B0HARD
8138 DIMENSION SCB1(4),SCB2(4),SCG1(4),SCG2(4)
8139 DIMENSION BT14(2),BT24(2),BD4(4)
8140 DIMENSION DSPT(0:Max_pro_2)
8142 DATA XMPOM / 0.766D0 /
8143 DATA CZERO /(0.D0,0.D0)/
8146 DCMPLX(X,Y) = CMPLX(X,Y)
8149 IF(IDEB(48).GE.10) WRITE(LO,'(/1X,A,I3,4E12.3,I3)')
8150 & 'PHO_BORNCS: IP,M1..M4,IFHARD',IP,XM1,XM2,XM3,XM4,IFHARD
8152 CALL PHO_SCALES(XM1,XM2,XM3,XM4,SCALE1,SCALE2,SCALB1,SCALB2)
8154 C calculate hard input cross sections (output in mb)
8155 IF(IFHARD.NE.1) THEN
8156 IF((IFHARD.EQ.0).AND.(HEcm_tab(1,IP).GT.1.D0)) THEN
8157 C double-log interpolation
8158 CALL PHO_HARINT(IP,ECMP,0.D0,0.D0,0,Max_pro_2,3,4,1)
8165 CALL PHO_HARINT(IP,ECMP,0.D0,0.D0,0,-2,0,0,1)
8166 CALL PHO_HARXTO(ECMP,PTCUT(IP),PTCUT(IP),DSIGH,DSPT)
8169 C save values to calculate soft pt distribution
8171 VDMQ2F(1) = VDMFAC(1)
8172 VDMQ2F(2) = VDMFAC(2)
8173 VDMQ2F(3) = VDMFAC(3)
8174 VDMQ2F(4) = VDMFAC(4)
8175 ELSE IF(IP.EQ.2) THEN
8176 VDMQ2F(1) = VDMFAC(1)
8177 VDMQ2F(2) = VDMFAC(2)
8180 ELSE IF(IP.EQ.3) THEN
8181 VDMQ2F(1) = VDMFAC(3)
8182 VDMQ2F(2) = VDMFAC(4)
8192 AMPFAC(1) = SQRT(VDMQ2F(1)*VDMQ2F(3))
8193 AMPFAC(2) = SQRT(VDMQ2F(2)*VDMQ2F(3))
8194 AMPFAC(3) = SQRT(VDMQ2F(1)*VDMQ2F(4))
8195 AMPFAC(4) = SQRT(VDMQ2F(2)*VDMQ2F(4))
8196 ELAFAC(1) = VDMQ2F(1)*VDMQ2F(3)+VDMQ2F(2)*VDMQ2F(3)
8197 & +VDMQ2F(1)*VDMQ2F(4)+VDMQ2F(2)*VDMQ2F(4)
8198 ELAFAC(2) = 2.D0*(AMPFAC(1)*AMPFAC(2)+AMPFAC(3)*AMPFAC(4))
8199 ELAFAC(3) = 2.D0*(AMPFAC(1)*AMPFAC(3)+AMPFAC(2)*AMPFAC(4))
8200 ELAFAC(4) = 4.D0*AMPFAC(1)*AMPFAC(4)
8201 VFAC = ELAFAC(1)+PHISUP(1)*PHISUP(2)*ELAFAC(4)
8202 & +PHISUP(1)*ELAFAC(2)+PHISUP(2)*ELAFAC(3)
8203 DSIGHP = DSPT(9)/VFAC
8204 SIGH = DSIGH(9)/VFAC
8206 IF(IPAMDL(1).EQ.0) THEN
8208 DSIGH(I)=DCMPLX(DREAL(DSIGH(I)),0.D0)
8212 IF(IDEB(48).GE.15) THEN
8213 WRITE(LO,'(/1X,A,1P,2E11.3)')
8214 & 'PHO_BORNCS: QCD-PM cross sections (mb)',ECMP,PTCUT(IP)
8215 DO 200 I=0,Max_pro_2
8216 WRITE(LO,'(10X,A,2E14.4)') PROC(I),DSIGH(I)
8221 C DPMJET interface: subtract anomalous part
8222 IF((IP.EQ.1).AND.(IPAMDL(13).GT.0))
8223 & DSIGH(9) = DSIGH(9)-DCMPLX(DT_SANO(ECMP),0.D0)
8225 SCALE = CDABS(DSIGH(15))
8226 IF(SCALE.LT.DEPS) THEN
8231 SCALE = CDABS(DSIGH(9))
8232 IF(SCALE.LT.DEPS) THEN
8235 SIGHR=DSIGH(9)*SCALE1*SCALE2/VFAC
8238 C calculate soft input cross sections (output in mb)
8239 SS=DCMPLX(ECMP**2-PMASSP(1)**2-PMASSP(2)**2+0.01D0,0.D0)
8240 IF(IPAMDL(1).EQ.1) THEN
8242 SP=SS*DCMPLX(0.D0,-1.D0)
8244 SR=SS*DCMPLX(0.D0,1.D0)
8249 C coupling constants (mb**1/2)
8250 C particle dependent slopes (GeV**-2)
8263 ELSE IF(IP.EQ.2) THEN
8267 GR2 = PARMDL(77)*GPPR/GPPP
8272 B0HARD = B0POM1+B0POM2
8275 ELSE IF(IP.EQ.3) THEN
8279 GR2 = PARMDL(77)*GPPR/GPPP
8284 B0HARD = B0POM1+B0POM2
8287 ELSE IF(IP.EQ.4) THEN
8290 GR1 = PARMDL(77)*GPPR/GPPP
8296 B0HARD = B0POM1+B0POM2
8300 WRITE(LO,'(/1X,A,I7)') 'PHO_BORNCS:ERROR:invalid IP',IP
8307 C input slope parameters (GeV**-2)
8308 BPOM1 = B0POM1*SCALB1
8309 BPOM2 = B0POM2*SCALB2
8310 BREG1 = B0REG1*SCALB1
8311 BREG2 = B0REG2*SCALB2
8313 XMR2 = (2.D0*MIN(XM1,XM3)*MIN(XM2,XM4))**2
8314 SCALE = SS*XMR2/((XM1**2+XM3**2)*(XM2**2+XM4**2))+2.D0
8315 BPOM = BPOM1 + BPOM2 + ALPOMP*LOG(SCALE)
8316 BREG = BREG1 + BREG2 + ALREGP*LOG(SCALE)
8317 IF(IPAMDL(9).EQ.0) THEN
8320 ELSE IF(IPAMDL(9).EQ.1) THEN
8321 BHAR = B0HARD*(SCALB1+SCALB2)/2.D0
8323 ELSE IF(IPAMDL(9).EQ.2) THEN
8330 C input cross section pomeron
8331 SIGP=GP1*GP2*EXP((ALPOM-1.D0)*LOG(SP))
8332 SIGR=GR1*GR2*EXP((ALREG-1.D0)*LOG(SR))
8333 C save value to calculate soft pt distribution
8334 SIGS = (SIGR+SIGP)/(SCALE1*SCALE2)
8336 C higher order graphs
8339 C bare/renormalized intercept for enhanced graphs
8340 IF(IPAMDL(8).EQ.0) THEN
8343 DELTAP = PARMDL(48)-1.D0
8348 C input cross section high-mass double diffraction
8349 CALL PHO_LOOREG(SD,GP1,BP1,GP2,BP2,
8350 & DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,VIRT2,SIGTR,BTR)
8351 SIGL = DCMPLX(SIGTR,0.D0)
8352 BLOO = DCMPLX(BTR,0.D0)
8354 C input cross section high mass diffraction particle 1
8356 CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
8357 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8358 CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
8359 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8360 SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8361 SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8362 BP1 = 2.D0*BPOM1*SCALB1
8363 BP2 = 2.D0*BPOM2*SCALB2
8364 C input cross section high mass diffraction
8365 CALL PHO_TRIREG(SD,GP1,BP1,GP2,BP2,
8366 & DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,SIGTR,BTR)
8367 SIGT1(1) = SCG1(1)*SCG2(1)*SCG2(2)*DCMPLX(SIGTR,0.D0)
8368 BTR1(1) = DCMPLX(BTR,0.D0)
8369 C second possibility: high-low mass double diffraction
8370 CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
8371 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8372 CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
8373 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8374 SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8375 SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8376 BP1 = 2.D0*BPOM1*SCALB1
8377 BP2 = 2.D0*BPOM2*SCALB2
8378 C input cross section high mass diffraction
8379 CALL PHO_TRIREG(SD,GP1,BP1,GP2,BP2,
8380 & DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,SIGTR,BTR)
8381 SIGT1(2) = SCG1(1)*SCG2(1)*SCG2(2)*DCMPLX(SIGTR,0.D0)
8382 BTR1(2) = DCMPLX(BTR,0.D0)
8384 C input cross section high mass diffraction particle 2
8386 CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
8387 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8388 CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
8389 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8390 SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8391 SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8392 BP1 = 2.D0*BPOM1*SCALB1
8393 BP2 = 2.D0*BPOM2*SCALB2
8394 C input cross section high mass diffraction
8395 CALL PHO_TRIREG(SD,GP2,BP2,GP1,BP1,
8396 & DELTAP,ALPOMP,GPPP,B0PPP,VIRT2,SIGTR,BTR)
8397 SIGT2(1) = SCG1(1)*SCG1(2)*SCG2(1)*DCMPLX(SIGTR,0.D0)
8398 BTR2(1) = DCMPLX(BTR,0.D0)
8399 C second possibility: high-low mass double diffraction
8400 CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
8401 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8402 CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
8403 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8404 SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8405 SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8406 BP1 = 2.D0*BPOM1*SCALB1
8407 BP2 = 2.D0*BPOM2*SCALB2
8408 C input cross section high mass diffraction
8409 CALL PHO_TRIREG(SD,GP2,BP2,GP1,BP1,
8410 & DELTAP,ALPOMP,GPPP,B0PPP,VIRT2,SIGTR,BTR)
8411 SIGT2(2) = SCG1(1)*SCG1(2)*SCG2(1)*DCMPLX(SIGTR,0.D0)
8412 BTR2(2) = DCMPLX(BTR,0.D0)
8414 C input cross section for loop-pomeron
8416 CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
8417 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8418 CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
8419 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8420 CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
8421 & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8422 CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
8423 & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8424 SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8425 SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8428 CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8430 SIGDP(1) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8431 BDP(1) = DCMPLX(BTX,0.D0)
8432 C second possibility
8433 CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
8434 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8435 CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
8436 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8437 CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
8438 & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8439 CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
8440 & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8441 SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8442 SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8445 CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8447 SIGDP(2) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8448 BDP(2) = DCMPLX(BTX,0.D0)
8450 CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
8451 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8452 CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
8453 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8454 CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
8455 & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8456 CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
8457 & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8458 SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8459 SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8462 CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8464 SIGDP(3) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8465 BDP(3) = DCMPLX(BTX,0.D0)
8466 C fourth possibility
8467 CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
8468 & SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8469 CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
8470 & SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8471 CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
8472 & SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8473 CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
8474 & SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8475 SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8476 SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8479 CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8481 SIGDP(4) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8482 BDP(4) = DCMPLX(BTX,0.D0)
8484 C input cross section for YY-iterated triple-pomeron
8487 C write out input cross sections
8488 IF(IDEB(48).GE.5) THEN
8489 WRITE(LO,'(2(/1X,A))')
8490 & 'Born graph input cross sections and slopes',
8491 & '------------------------------------------'
8492 WRITE(LO,'(1X,A,3E12.3)') 'energy ',ECMP,PVIRTP
8493 WRITE(LO,'(1X,A,4E12.3)') 'external masses 1,2,3,4 ',
8495 WRITE(LO,'(A)') ' input cross sections (millibarn):'
8496 WRITE(LO,'(A,2E12.3)') ' SIGR ',SIGR
8497 WRITE(LO,'(A,2E12.3)') ' (soft) SIGP ',SIGP
8498 WRITE(LO,'(A,2E12.3)') ' (hard) SIGHR ',SIGHR
8499 WRITE(LO,'(A,2E12.3)') ' SIGHD ',SIGHD
8500 WRITE(LO,'(A,4E12.3)') ' SIGT1 ',SIGT1
8501 WRITE(LO,'(A,4E12.3)') ' SIGT2 ',SIGT2
8502 WRITE(LO,'(A,2E12.3)') ' SIGL ',SIGL
8503 WRITE(LO,'(A,4E12.3)') ' SIGDP(1-2) ',SIGDP(1),SIGDP(2)
8504 WRITE(LO,'(A,4E12.3)') ' SIGDP(3-4) ',SIGDP(3),SIGDP(4)
8505 WRITE(LO,'(A)') ' input slopes (GeV**-2)'
8506 WRITE(LO,'(A,2E12.3)') ' BREG ',BREG
8507 WRITE(LO,'(A,2E12.3)') ' BREG1 ',BREG1
8508 WRITE(LO,'(A,2E12.3)') ' BREG2 ',BREG2
8509 WRITE(LO,'(A,2E12.3)') ' BPOM ',BPOM
8510 WRITE(LO,'(A,2E12.3)') ' BPOM1 ',BPOM1
8511 WRITE(LO,'(A,2E12.3)') ' BPOM2 ',BPOM2
8512 WRITE(LO,'(A,2E12.3)') ' BHAR ',BHAR
8513 WRITE(LO,'(A,2E12.3)') ' BHAD ',BHAD
8514 WRITE(LO,'(A,E12.3)') ' B0PPP ',B0PPP
8515 WRITE(LO,'(A,4E12.3)') ' BTR1 ',BTR1
8516 WRITE(LO,'(A,4E12.3)') ' BTR2 ',BTR2
8517 WRITE(LO,'(A,2E12.3)') ' BLOO ',BLOO
8518 WRITE(LO,'(A,4E12.3)') ' BDP(1-2) ',BDP(1),BDP(2)
8519 WRITE(LO,'(A,4E12.3)') ' BDP(3-4) ',BDP(3),BDP(4)
8526 BTR1(1) = BTR1(1)*GEV2MB
8527 BTR1(2) = BTR1(2)*GEV2MB
8528 BTR2(1) = BTR2(1)*GEV2MB
8529 BTR2(2) = BTR2(2)*GEV2MB
8536 BT14(1)=BTR1(1)*4.D0
8537 BT14(2)=BTR1(2)*4.D0
8538 BT24(1)=BTR2(1)*4.D0
8539 BT24(2)=BTR2(2)*4.D0
8542 ZIGP = SIGP/(PI2*BP4)
8543 ZIGR = SIGR/(PI2*BR4)
8544 ZIGHR = SIGHR/(PI2*BHR4)
8545 ZIGHD = SIGHD/(PI2*BHD4)
8546 ZIGT1(1) = SIGT1(1)/(PI2*BT14(1))
8547 ZIGT1(2) = SIGT1(2)/(PI2*BT14(2))
8548 ZIGT2(1) = SIGT2(1)/(PI2*BT24(1))
8549 ZIGT2(2) = SIGT2(2)/(PI2*BT24(2))
8550 ZIGL = SIGL/(PI2*BL4)
8552 BDP(I) = BDP(I)*GEV2MB
8553 BD4(I) = BDP(I)*4.D0
8554 ZIGDP(I) = SIGDP(I)/(PI2*BD4(I))
8557 IF(IDEB(48).GE.10) THEN
8558 WRITE(LO,'(A)') ' normalized input values:'
8559 WRITE(LO,'(A,2E12.3)') ' ZIGR ',ZIGR
8560 WRITE(LO,'(A,2E12.3)') ' BREG ',BREG
8561 WRITE(LO,'(A,2E12.3)') ' ZIGP ',ZIGP
8562 WRITE(LO,'(A,2E12.3)') ' BPOM ',BPOM
8563 WRITE(LO,'(A,2E12.3)') ' ZIGHR ',ZIGHR
8564 WRITE(LO,'(A,2E12.3)') ' BHAR ',BHAR
8565 WRITE(LO,'(A,2E12.3)') ' ZIGHD ',ZIGHD
8566 WRITE(LO,'(A,2E12.3)') ' BHAD ',BHAD
8567 WRITE(LO,'(A,4E12.3)') ' ZIGT1 ',ZIGT1
8568 WRITE(LO,'(A,4E12.3)') ' ZIGT2 ',ZIGT2
8569 WRITE(LO,'(A,2E12.3)') ' ZIGL ',ZIGL
8570 WRITE(LO,'(A,4E12.3)') ' ZIGDP(1-2) ',ZIGDP(1),ZIGDP(2)
8571 WRITE(LO,'(A,4E12.3)') ' ZIGDP(3-4) ',ZIGDP(3),ZIGDP(4)
8575 *$ CREATE PHO_SCALES.FOR
8577 CDECK ID>, PHO_SCALES
8578 SUBROUTINE PHO_SCALES(XM1,XM2,XM3,XM4,SCG1,SCG2,SCB1,SCB2)
8579 C**********************************************************************
8581 C calculation of scale factors
8582 C (mass dependent couplings and slopes)
8584 C input: XM1..XM4 external masses
8586 C output: SCG1,SCG2 scales of coupling constants
8587 C SCB1,SCB2 scales of coupling slope parameter
8589 C*********************************************************************
8590 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8593 PARAMETER ( EPS = 1.D-3 )
8595 C input/output channels
8597 COMMON /POINOU/ LI,LO
8598 C event debugging information
8600 PARAMETER (NMAXD=100)
8601 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
8602 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8603 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
8604 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8605 C Reggeon phenomenology parameters
8606 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
8607 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
8608 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
8609 & ALREG,ALREGP,GR(2),B0REG(2),
8610 & GPPP,GPPR,B0PPP,B0PPR,
8611 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
8612 C parameters of 2x2 channel model
8613 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
8614 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
8615 C data of c.m. system of Pomeron / Reggeon exchange
8616 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
8617 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
8618 & SIDP,CODP,SIFP,COFP
8619 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
8620 & SIDP,CODP,SIFP,COFP,NPOSP(2),
8621 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
8622 C model switches and parameters
8624 INTEGER ISWMDL,IPAMDL
8625 DOUBLE PRECISION PARMDL
8626 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
8628 C scale factors for couplings
8632 IF(ABS(XM1-XM3).GT.EPS) THEN
8633 IF(ECMP.LT.ECMTP) THEN
8634 SCG1 = PHISUP(1)*LOG(ECMP**2/ECMMIN)/LOG(ECMTP**2/ECMMIN)
8641 IF(ABS(XM2-XM4).GT.EPS) THEN
8642 IF(ECMP.LT.ECMTP) THEN
8643 SCG2 = PHISUP(2)*LOG(ECMP**2/ECMMIN)/LOG(ECMTP**2/ECMMIN)
8651 C scale factors for slope parameters
8652 IF((ISWMDL(1).LT.2).OR.(IPAMDL(10).EQ.1)) THEN
8655 ELSE IF(ISWMDL(1).EQ.2) THEN
8657 SCB1 = 2.D0*PMASSP(1)**2/(XM1**2+XM3**2)
8658 SCB2 = 2.D0*PMASSP(2)**2/(XM2**2+XM4**2)
8659 ELSE IF(ISWMDL(1).GE.3) THEN
8660 C symmetric gaussian
8661 SCB1 = VAR*(XM1-XM3)**2
8662 IF(SCB1.LT.25.D0) THEN
8667 SCB2 = VAR*(XM2-XM4)**2
8668 IF(SCB2.LT.25.D0) THEN
8674 WRITE(LO,'(/,1X,A,I4)') 'PHO_SCALES:ERROR:invalid ISWMDL(1)',
8679 IF(IDEB(65).GE.10) THEN
8680 WRITE(LO,'(1X,A,4E11.3)') 'PHO_SCALES: M1..M4 ',
8682 WRITE(LO,'(5X,A,4E11.3)') 'SCB1,SCB2,SCG1,SCG2',
8683 & SCB1,SCB2,SCG1,SCG2
8687 *$ CREATE PHO_EIKON.FOR
8689 CDECK ID>, PHO_EIKON
8690 SUBROUTINE PHO_EIKON(IP,IFHARD,B)
8691 C*********************************************************************
8693 C calculation of unitarized amplitudes
8695 C input: IP particle combination
8696 C IFHARD -1 ignore previously calculated Born
8698 C 0 calculate hard Born cross sections or
8699 C take them from interpolation table
8701 C 1 take hard cross sections from /POSBRN/
8702 C B impact parameter (mb**(1/2))
8703 C /POSBRN/ input cross sections
8704 C /GLOCMS/ cm energy
8705 C /POPREG/ soft and hard parameters
8708 C AMPEL purely elastic amplitude
8709 C AMPVM quasi-elastically vectormeson prod.
8710 C AMLMSD(2) amplitudes of low mass sing. diffr.
8711 C AMHMSD(2) amplitudes of high mass sing. diffr.
8712 C AMLMDD amplitude of low mass double diffr.
8713 C AMHMDD amplitude of high mass double diffr.
8715 C*********************************************************************
8716 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8729 C input/output channels
8731 COMMON /POINOU/ LI,LO
8732 C event debugging information
8734 PARAMETER (NMAXD=100)
8735 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
8736 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8737 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
8738 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8739 C complex Born graph amplitudes used for unitarization
8740 COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
8742 COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
8743 & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
8745 INTEGER IPFIL,IFAFIL,IFBFIL
8746 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
8747 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
8748 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
8749 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
8750 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
8751 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
8752 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
8753 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
8754 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
8755 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
8756 & IPFIL,IFAFIL,IFBFIL
8757 C Born graph cross sections and slopes
8759 PARAMETER ( Max_pro_3 = 16 )
8760 COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
8762 COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
8763 & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
8764 C scaled cross sections and slopes
8765 COMPLEX*16 ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1,ZIGT2,ZIGL,ZIGDP,
8767 & BPOM,BREG,BHAR,BHAD,BTR1,BTR2,BLOO,BDP,BD1,BD2
8768 COMMON /POZBRN/ ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1(2),ZIGT2(2),ZIGL,
8769 & ZIGDP(4),ZIGD1(2),ZIGD2(2),
8770 & BPOM,BREG,BHAR,BHAD,BTR1(2),BTR2(2),BLOO,BDP(4),
8772 C Born graph cross sections after applying diffraction model
8773 DOUBLE PRECISION SBOPOM,SBOREG,SBOHAR,SBOHAD,SBOTR1,SBOTR2,
8775 COMMON /POINT1/ SBOPOM(0:4),SBOREG(0:4),SBOHAR(0:4),SBOHAD(0:4),
8776 & SBOTR1(0:4,2),SBOTR2(0:4,2),SBOLPO(0:4),
8778 C global event kinematics and particle IDs
8780 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
8781 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
8782 C data of c.m. system of Pomeron / Reggeon exchange
8783 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
8784 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
8785 & SIDP,CODP,SIFP,COFP
8786 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
8787 & SIDP,CODP,SIFP,COFP,NPOSP(2),
8788 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
8789 C Reggeon phenomenology parameters
8790 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
8791 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
8792 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
8793 & ALREG,ALREGP,GR(2),B0REG(2),
8794 & GPPP,GPPR,B0PPP,B0PPR,
8795 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
8796 C parameters of 2x2 channel model
8797 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
8798 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
8799 C model switches and parameters
8801 INTEGER ISWMDL,IPAMDL
8802 DOUBLE PRECISION PARMDL
8803 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
8804 C unitarized amplitudes for different diffraction channels
8805 DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
8806 & ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
8807 & ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
8809 COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
8810 & ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
8811 & ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
8812 & ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
8813 & ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
8814 & ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
8817 COMPLEX*16 CZERO,CONE,B24,AUXP,AUXR,AUXH,AUXD,AUXT1,AUXT2,
8818 & AUXL,AMPR,AMPO,AMPP,AMPQ
8824 DATA PVOLD / -1.D0, -1.D0 /
8825 DATA XMPOM / 0.766D0 /
8826 DATA XMVDM / 0.766D0 /
8828 DCMPLX(X,Y) = CMPLX(X,Y)
8830 C calculation of scaled cross sections and slopes
8832 C test for redundant calculation
8833 IF((ECM.NE.ELAST).OR.(IFHARD.EQ.-1).OR.(PVIRT(1).NE.PVOLD(1))
8834 & .OR.(PVIRT(2).NE.PVOLD(2)).OR.(IP.NE.IPOLD)) THEN
8835 C effective particle masses, VDM assumption
8840 IF(IFPAP(1).EQ.22) THEN
8842 ELSE IF(IFPAP(1).EQ.990) THEN
8845 IF(IFPAP(2).EQ.22) THEN
8847 ELSE IF(IFPAP(2).EQ.990) THEN
8850 C different particle combinations
8854 ELSE IF(IP.EQ.4) THEN
8862 C update pomeron CM system
8867 CZERO = DCMPLX(0.D0,0.D0)
8868 CONE = DCMPLX(1.D0,0.D0)
8874 C purely elastic scattering
8875 CALL PHO_BORNCS(IP,IFHARD,XMASS1,XMASS2,XMASS1,XMASS2)
8884 ZXT1A(1,1) = ZIGT1(1)
8885 BXT1A(1,1) = BTR1(1)
8886 ZXT1B(1,1) = ZIGT1(2)
8887 BXT1B(1,1) = BTR1(2)
8888 ZXT2A(1,1) = ZIGT2(1)
8889 BXT2A(1,1) = BTR2(1)
8890 ZXT2B(1,1) = ZIGT2(2)
8891 BXT2B(1,1) = BTR2(2)
8894 ZXDPE(1,1) = ZIGDP(1)
8896 ZXDPA(1,1) = ZIGDP(2)
8898 ZXDPB(1,1) = ZIGDP(3)
8900 ZXDPD(1,1) = ZIGDP(4)
8906 SBOTR1(1,1) = SIGT1(1)
8907 SBOTR1(1,2) = SIGT1(2)
8908 SBOTR2(1,1) = SIGT2(1)
8909 SBOTR2(1,2) = SIGT2(2)
8911 SBODPO(1,1) = SIGDP(1)
8912 SBODPO(1,2) = SIGDP(2)
8913 SBODPO(1,3) = SIGDP(3)
8914 SBODPO(1,4) = SIGDP(4)
8916 C low mass single diffractive scattering 1
8917 CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,RMASS1,XMASS2)
8926 ZXT1A(1,2) = ZIGT1(1)
8927 BXT1A(1,2) = BTR1(1)
8928 ZXT1B(1,2) = ZIGT1(2)
8929 BXT1B(1,2) = BTR1(2)
8930 ZXT2A(1,2) = ZIGT2(1)
8931 BXT2A(1,2) = BTR2(1)
8932 ZXT2B(1,2) = ZIGT2(2)
8933 BXT2B(1,2) = BTR2(2)
8936 ZXDPE(1,2) = ZIGDP(1)
8938 ZXDPA(1,2) = ZIGDP(2)
8940 ZXDPB(1,2) = ZIGDP(3)
8942 ZXDPD(1,2) = ZIGDP(4)
8948 SBOTR1(2,1) = SIGT1(1)
8949 SBOTR1(2,2) = SIGT1(2)
8950 SBOTR2(2,1) = SIGT2(1)
8951 SBOTR2(2,2) = SIGT2(2)
8953 SBODPO(2,1) = SIGDP(1)
8954 SBODPO(2,2) = SIGDP(2)
8955 SBODPO(2,3) = SIGDP(3)
8956 SBODPO(2,4) = SIGDP(4)
8958 C low mass single diffractive scattering 2
8959 CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,XMASS1,RMASS2)
8968 ZXT1A(1,3) = ZIGT1(1)
8969 BXT1A(1,3) = BTR1(1)
8970 ZXT1B(1,3) = ZIGT1(2)
8971 BXT1B(1,3) = BTR1(2)
8972 ZXT2A(1,3) = ZIGT2(1)
8973 BXT2A(1,3) = BTR2(1)
8974 ZXT2B(1,3) = ZIGT2(2)
8975 BXT2B(1,3) = BTR2(2)
8978 ZXDPE(1,3) = ZIGDP(1)
8980 ZXDPA(1,3) = ZIGDP(2)
8982 ZXDPB(1,3) = ZIGDP(3)
8984 ZXDPD(1,3) = ZIGDP(4)
8990 SBOTR1(3,1) = SIGT1(1)
8991 SBOTR1(3,2) = SIGT1(2)
8992 SBOTR2(3,1) = SIGT2(1)
8993 SBOTR2(3,2) = SIGT2(2)
8995 SBODPO(3,1) = SIGDP(1)
8996 SBODPO(3,2) = SIGDP(2)
8997 SBODPO(3,3) = SIGDP(3)
8998 SBODPO(3,4) = SIGDP(4)
9000 C low mass double diffractive scattering
9001 CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,RMASS1,RMASS2)
9010 ZXT1A(1,4) = ZIGT1(1)
9011 BXT1A(1,4) = BTR1(1)
9012 ZXT1B(1,4) = ZIGT1(2)
9013 BXT1B(1,4) = BTR1(2)
9014 ZXT2A(1,4) = ZIGT2(1)
9015 BXT2A(1,4) = BTR2(1)
9016 ZXT2B(1,4) = ZIGT2(2)
9017 BXT2B(1,4) = BTR2(2)
9020 ZXDPE(1,4) = ZIGDP(1)
9022 ZXDPA(1,4) = ZIGDP(2)
9024 ZXDPB(1,4) = ZIGDP(3)
9026 ZXDPD(1,4) = ZIGDP(4)
9032 SBOTR1(4,1) = SIGT1(1)
9033 SBOTR1(4,2) = SIGT1(2)
9034 SBOTR2(4,1) = SIGT2(1)
9035 SBOTR2(4,2) = SIGT2(2)
9037 SBODPO(4,1) = SIGDP(1)
9038 SBODPO(4,2) = SIGDP(2)
9039 SBODPO(4,3) = SIGDP(3)
9040 SBODPO(4,4) = SIGDP(4)
9042 C calculate Born graph cross sections
9057 SBOPOM(0) = SBOPOM(0) + ELAFAC(I)*SBOPOM(I)
9058 SBOREG(0) = SBOREG(0) + ELAFAC(I)*SBOREG(I)
9059 SBOHAR(0) = SBOHAR(0) + ELAFAC(I)*SBOHAR(I)
9060 SBOHAD(0) = SBOHAD(0) + ELAFAC(I)*SBOHAD(I)
9061 SBOTR1(0,1) = SBOTR1(0,1) + ELAFAC(I)*SBOTR1(I,1)
9062 SBOTR1(0,2) = SBOTR1(0,2) + ELAFAC(I)*SBOTR1(I,2)
9063 SBOTR2(0,1) = SBOTR2(0,1) + ELAFAC(I)*SBOTR2(I,1)
9064 SBOTR2(0,2) = SBOTR2(0,2) + ELAFAC(I)*SBOTR2(I,2)
9065 SBOLPO(0) = SBOLPO(0) + ELAFAC(I)*SBOLPO(I)
9066 SBODPO(0,1) = SBODPO(0,1) + ELAFAC(I)*SBODPO(I,1)
9067 SBODPO(0,2) = SBODPO(0,2) + ELAFAC(I)*SBODPO(I,2)
9068 SBODPO(0,3) = SBODPO(0,3) + ELAFAC(I)*SBODPO(I,3)
9069 SBODPO(0,4) = SBODPO(0,4) + ELAFAC(I)*SBODPO(I,4)
9074 SIGTR1(1) = SBOTR1(0,1)
9075 SIGTR1(2) = SBOTR1(0,2)
9076 SIGTR2(1) = SBOTR2(0,1)
9077 SIGTR2(2) = SBOTR2(0,2)
9079 SIGDPO(1) = SBODPO(0,1)
9080 SIGDPO(2) = SBODPO(0,2)
9081 SIGDPO(3) = SBODPO(0,3)
9082 SIGDPO(4) = SBODPO(0,4)
9087 B24=DCMPLX(B**2,0.D0)/4.D0
9103 IF(ISWMDL(1).LT.3) THEN
9105 AUXP = ZXP(1,1)*EXP(-B24/BXP(1,1))
9107 AUXR = ZXR(1,1)*EXP(-B24/BXR(1,1))
9108 C hard resolved processes
9109 AUXH = ZXH(1,1)*EXP(-B24/BXH(1,1))
9110 C hard direct processes
9111 AUXD = ZXD(1,1)*EXP(-B24/BXD(1,1))
9112 C triple-Pomeron: baryon high mass diffraction
9113 AUXT1 = ZXT1A(1,1)*EXP(-B24/BXT1A(1,1))
9114 & + ZXT1B(1,1)*EXP(-B24/BXT1B(1,1))
9115 C triple-Pomeron: photon/meson high mass diffraction
9116 AUXT2 = ZXT2A(1,1)*EXP(-B24/BXT2A(1,1))
9117 & + ZXT2B(1,1)*EXP(-B24/BXT2B(1,1))
9119 AUXL = ZXL(1,1)*EXP(-B24/BXL(1,1))
9122 IF(ISWMDL(1).EQ.0) THEN
9123 AMPEL = 0.5D0*((VDMQ2F(1)+VDMQ2F(2)+VDMQ2F(3)+VDMQ2F(4))
9124 & *(CONE-EXP(-AUXR-AUXP-AUXH+AUXT1+AUXT2+AUXL))
9125 & +(CONE-(VDMQ2F(1)-VDMQ2F(2)-VDMQ2F(3)-VDMQ2F(4)))*AUXD
9127 AMPR = 0.5D0*SQRT(VDMQ2F(1))*(CONE-EXP(-AUXR-AUXP-AUXH
9128 & +AUXT1+AUXT2+AUXL))
9129 AMPO = 0.5D0*SQRT(VDMQ2F(2))*(CONE-EXP(-AUXR-AUXP-AUXH
9130 & +AUXT1+AUXT2+AUXL))
9131 AMPP = 0.5D0*SQRT(VDMQ2F(3))*(CONE-EXP(-AUXR-AUXP-AUXH
9132 & +AUXT1+AUXT2+AUXL))
9133 AMPQ = 0.5D0*SQRT(VDMQ2F(4))*(CONE-EXP(-AUXR-AUXP-AUXH
9134 & +AUXT1+AUXT2+AUXL))
9136 ELSE IF(ISWMDL(1).EQ.1) THEN
9137 AMPR = 0.5D0*SQRT(VDMQ2F(1))*
9138 & ( CONE-EXP(-AUXR-AUXP-AUXH*VDMQ2F(1)) )
9139 AMPO = 0.5D0*SQRT(VDMQ2F(2))*
9140 & ( CONE-EXP(-3.D0*AUXR-AUXP-AUXH*VDMQ2F(2)) )
9141 AMPP = 0.5D0*SQRT(VDMQ2F(3))*
9142 & ( CONE-EXP(-AUXP-AUXH*VDMQ2F(3)) )
9143 AMPQ = 0.5D0*SQRT(VDMQ2F(4))*
9144 & ( CONE-EXP(-AUXR-AUXP-AUXH*VDMQ2F(4)) )
9145 AMPEL = SQRT(VDMQ2F(1))*AMPR
9146 & + SQRT(VDMQ2F(2))*AMPO
9147 & + SQRT(VDMQ2F(3))*AMPP
9148 & + SQRT(VDMQ2F(4))*AMPQ
9151 C simple analytic two channel model (version A)
9152 ELSE IF(ISWMDL(1).EQ.3) THEN
9156 WRITE(LO,'(1X,A,I2)')
9157 & 'EIKON: ERROR: unsupported model ISWMDL(1) ',ISWMDL(1)
9163 *$ CREATE PHO_DSIGDT.FOR
9165 CDECK ID>, PHO_DSIGDT
9166 SUBROUTINE PHO_DSIGDT(EE,XTA,NFILL)
9167 C*********************************************************************
9169 C calculation of unitarized amplitude
9170 C and differential cross section
9172 C input: EE cm energy (GeV)
9173 C XTA(1,*) t values (GeV**2)
9174 C NFILL entries in t table
9176 C output: XTA(2,*) DSIG/DT g p --> g h/V (mub/GeV**2)
9177 C XTA(3,*) DSIG/DT g p --> rho0 h/V
9178 C XTA(4,*) DSIG/DT g p --> omega0 h/V
9179 C XTA(5,*) DSIG/DT g p --> phi h/V
9180 C XTA(6,*) DSIG/DT g p --> pi+ pi- h/V (continuum)
9182 C*********************************************************************
9183 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9191 DIMENSION XTA(6,NFILL)
9193 C input/output channels
9195 COMMON /POINOU/ LI,LO
9197 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
9198 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
9199 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
9200 C integration precision for hard cross sections (obsolete)
9201 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9202 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9203 C event debugging information
9205 PARAMETER (NMAXD=100)
9206 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9207 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9208 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9209 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9210 C global event kinematics and particle IDs
9212 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
9213 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
9214 C complex Born graph amplitudes used for unitarization
9215 COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
9217 COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
9218 & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
9220 COMPLEX*16 XT,AMP,CZERO
9221 DIMENSION AMP(5),XPNT(96),WGHT(96),XT(5,100)
9224 CDABS(AMPEL) = ABS(AMPEL)
9225 DCMPLX(X,Y) = CMPLX(X,Y)
9227 CZERO=DCMPLX(0.D0,0.D0)
9232 IF(NFILL.GT.100) THEN
9233 WRITE(LO,'(1X,A,I4)')
9234 & 'PHO_DSIGDT:ERROR: too many entries in table',NFILL
9244 C impact parameter integration
9245 C BMAX=12.D0*SQRT(MAX(BPOM,BREG))
9247 CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
9249 IF((IFPAP(1).EQ.22).AND.(IFPAP(2).NE.22)) THEN
9252 ELSE IF((IFPAP(1).NE.22).AND.(IFPAP(2).EQ.22)) THEN
9255 ELSE IF((IFPAP(1).EQ.22).AND.(IFPAP(2).EQ.22)) THEN
9272 C calculate amplitudes
9274 CALL PHO_EIKON(1,-1,XPNT(I))
9276 CALL PHO_EIKON(1,1,XPNT(I))
9279 AMP(2) = AMPVM(I1,I2)
9280 AMP(3) = AMPVM(J1,J2)
9281 AMP(4) = AMPVM(K1,K2)
9282 AMP(5) = AMPVM(L1,L2)
9285 XX=XPNT(I)*SQRT(XTA(1,J)/GEV2MB)
9286 FAC = PHO_BESSJ0(XX)*WG
9288 XT(1,J)=XT(1,J)+AMP(K)*FAC
9293 C change units to mb/GeV**2
9294 FAC = 4.D0*PI/GEV2MB
9295 FNA = '(mb/GeV**2) '
9298 FNA = '(mub/GeV**2)'
9299 ELSE IF(I1+I2.EQ.2) THEN
9300 FAC = FAC*THOUS*THOUS
9301 FNA = '(nb/GeV**2) '
9303 IF(IDEB(56).GE.5) THEN
9304 WRITE(LO,'(1X,A,A12,/1X,A)') 'table: -T (GeV**2) DSIG/DT ',
9305 & FNA,'------------------------------------------'
9309 XTA(K+1,J)=CDABS(XT(K,J))**2*FAC
9311 IF(IDEB(56).GE.5) THEN
9312 WRITE(LO,'(5X,6E12.3)') (XTA(I,J),I=1,IAMP+1)
9319 *$ CREATE PHO_XSECT.FOR
9321 CDECK ID>, PHO_XSECT
9322 SUBROUTINE PHO_XSECT(IP,IFHARD,EE)
9323 C*********************************************************************
9325 C calculation of physical cross sections
9327 C input: IP particle combination
9328 C IFHARD -1 reset Born graph cross section tables
9329 C 0 calculate hard cross sections or take them
9330 C from interpolation table (if available)
9331 C 1 assume that hard cross sections are already
9332 C calculated and stored in /POSBRN/
9333 C EE cms energy (GeV)
9335 C output: /POSBRN/ input cross sections
9336 C /POZBRN/ scaled input cross values
9337 C /POCSEC/ physical cross sections and slopes
9339 C slopes in GeV**-2, cross sections in mb
9341 C*********************************************************************
9342 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9345 PARAMETER(ONEM=-1.D0,
9349 C input/output channels
9351 COMMON /POINOU/ LI,LO
9353 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
9354 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
9355 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
9356 C event debugging information
9358 PARAMETER (NMAXD=100)
9359 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9360 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9361 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9362 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9363 C integration precision for hard cross sections (obsolete)
9364 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9365 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9366 C model switches and parameters
9368 INTEGER ISWMDL,IPAMDL
9369 DOUBLE PRECISION PARMDL
9370 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
9371 C Born graph cross sections and slopes
9373 PARAMETER ( Max_pro_3 = 16 )
9374 COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
9376 COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
9377 & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
9379 INTEGER IPFIL,IFAFIL,IFBFIL
9380 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
9381 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
9382 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
9383 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
9384 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
9385 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
9386 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
9387 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
9388 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
9389 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
9390 & IPFIL,IFAFIL,IFBFIL
9391 C global event kinematics and particle IDs
9393 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
9394 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
9396 CHARACTER*15 PHO_PNAME
9398 C complex Born graph amplitudes used for unitarization
9399 COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
9401 COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
9402 & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
9404 DIMENSION XPNT(96),WGHT(96),SLVM1(4,4),SLVM2(4,4)
9405 CHARACTER*8 VMESA(0:4),VMESB(0:4)
9406 DATA VMESA / 'vmeson ','rho ','omega ','phi ',
9408 DATA VMESB / 'vmeson ','rho ','omega ','phi ',
9411 CDABS(AMPEL) = ABS(AMPEL)
9414 IF(EE.LT.0.D0) GOTO 500
9417 C impact parameter integration
9418 C BMAX=12.D0*SQRT(MAX(BPOM,BREG))
9420 CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
9447 WG = WGHT(I)*XPNT(I)
9450 C calculate impact parameter amplitude, results in /POINT4/
9452 CALL PHO_EIKON(IP,IFHARD,XPNT(I))
9454 CALL PHO_EIKON(IP,1,XPNT(I))
9457 SIGTOT = SIGTOT + DREAL(AMPEL)*WG
9458 SIGELA = SIGELA + CDABS(AMPEL)**2*WG
9459 SLEL1 = SLEL1 + AMPEL*WGB
9460 SLEL2 = SLEL2 + AMPEL*WG
9464 SIGVM(J,K) = SIGVM(J,K) + CDABS(AMPVM(J,K))**2*WG
9465 SLVM1(J,K) = SLVM1(J,K) + AMPVM(J,K)*WGB
9466 SLVM2(J,K) = SLVM2(J,K) + AMPVM(J,K)*WG
9468 SIGCDF(J) = SIGCDF(J) + DREAL(AMPDP(J))*WG
9471 SIGLSD(1) = SIGLSD(1) + CDABS(AMLMSD(1))**2*WG
9472 SIGLSD(2) = SIGLSD(2) + CDABS(AMLMSD(2))**2*WG
9473 SIGLDD = SIGLDD + CDABS(AMLMDD)**2*WG
9474 SIG1SO = SIG1SO + DREAL(AMPSOF)*WG
9475 SIG1HA = SIG1HA + DREAL(AMPHAR)*WG
9476 SIGHSD(1) = SIGHSD(1) + DREAL(AMHMSD(1))*WG
9477 SIGHSD(2) = SIGHSD(2) + DREAL(AMHMSD(2))*WG
9478 SIGHDD = SIGHDD + DREAL(AMHMDD)*WG
9482 SIGDIR = DREAL(SIGHD)
9486 FACSL = 0.5D0/GEV2MB
9487 SLOEL = SLEL1/MAX(DEPS,SLEL2)*FACSL
9489 IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22)) THEN
9492 SIGVM(I,J) = SIGVM(I,J)*FAC
9493 SLOVM(I,J) = SLVM1(I,J)/MAX(DEPS,SLVM2(I,J))*FACSL
9501 SIGVM(0,I) = SIGVM(0,I) + SIGVM(J,I)
9502 SIGVM(I,0) = SIGVM(I,0) + SIGVM(I,J)
9504 SIGVM(0,0) = SIGVM(0,0) + SIGVM(I,0)
9508 C diffractive cross sections
9510 SIGLSD(1) = SIGLSD(1)*FAC*PARMDL(40)
9511 SIGLSD(2) = SIGLSD(2)*FAC*PARMDL(41)
9512 SIGLDD = SIGLDD *FAC*PARMDL(42)
9513 SIGHSD(1) = (SIGHSD(1)-2.D0*(SIGCDF(1)+SIGCDF(2)))*FAC*PARMDL(40)
9514 SIGHSD(2) = (SIGHSD(2)-2.D0*(SIGCDF(1)+SIGCDF(3)))*FAC*PARMDL(41)
9515 SIGHDD = (SIGHDD-2.D0*(SIGCDF(2)+SIGCDF(3)+2.D0*SIGCDF(4)))
9518 C double pomeron scattering
9522 SIGCDF(I) = SIGCDF(I)*FAC
9523 SIGCDF(0) = SIGCDF(0)+SIGCDF(I)
9526 SIG1SO = SIG1SO *FAC
9527 SIG1HA = SIG1HA *FAC
9529 SIGINE = SIGTOT - SIGELA
9531 C user-forced change of diffractive cross section
9533 IF((IP.EQ.1).AND.(ISWMDL(30).GE.1)) THEN
9535 C use optional explicit parametrization for single-diffraction
9537 SIGSD1 = SIGLSD(1)+SIGHSD(1)
9538 SIGSD2 = SIGLSD(2)+SIGHSD(2)
9541 XI_MAX = PARMDL(45)**2
9542 CALL PHO_CSDIFF(IFPAP(1),IFPAP(2),SS,XI_MIN,XI_MAX,
9543 & SIG_SD1,SIG_SD2,SIG_DD)
9544 SIG_SD1 = SIG_SD1*PARMDL(40)
9545 SIG_SD2 = SIG_SD2*PARMDL(41)
9547 C DEL_SD1 = SIG_SD1-SIGSD1
9548 DEL_SD1 = PARMDL(200)*(SIG_SD1-SIGSD1)
9550 FAC = SIGLSD(1)/SIGSD1
9551 SIGLSD(1) = SIGLSD(1)+FAC*DEL_SD1
9552 SIGHSD(1) = SIGHSD(1)+(1.D0-FAC)*DEL_SD1
9553 C DEL_SD2 = SIG_SD2-SIGSD2
9554 DEL_SD2 = PARMDL(200)*(SIG_SD2-SIGSD2)
9555 FAC = SIGLSD(2)/SIGSD2
9556 SIGLSD(2) = SIGLSD(2)+FAC*DEL_SD2
9557 SIGHSD(2) = SIGHSD(2)+(1.D0-FAC)*DEL_SD2
9559 IF(ISWMDL(30).GE.2) THEN
9561 C use explicit parametrization also for double diffraction diss.
9562 SIGDD = SIGLDD+SIGHDD
9563 SIG_DD = SIG_DD*PARMDL(42)
9564 DEL_DD = SIG_DD-SIGDD
9566 SIGLDD = SIGLDD+FAC*DEL_DD
9567 SIGHDD = SIGHDD+(1.D0-FAC)*DEL_DD
9568 SIGCOR = DEL_SD1 + DEL_SD2 + DEL_DD
9572 C rescale double diffraction cross sections
9573 SIGLDD = SIGLDD *PARMDL(42)
9574 SIGHDD = SIGHDD *PARMDL(42)
9575 SIGCOR = DEL_SD1 + DEL_SD2
9576 & +(SIGLDD+SIGHDD)*(PARMDL(42)-1.D0)
9582 C rescale unitarized cross sections for diffraction dissociation
9584 SIGLSD(1) = SIGLSD(1)*PARMDL(40)
9585 SIGHSD(1) = SIGHSD(1)*PARMDL(40)
9586 SIGLSD(2) = SIGLSD(2)*PARMDL(41)
9587 SIGHSD(2) = SIGHSD(2)*PARMDL(41)
9588 SIGLDD = SIGLDD *PARMDL(42)
9589 SIGHDD = SIGHDD *PARMDL(42)
9590 SIGCOR = (SIGLSD(1)+SIGHSD(1))*(PARMDL(40)-1.D0)
9591 & +(SIGLSD(2)+SIGHSD(2))*(PARMDL(41)-1.D0)
9592 & +(SIGLDD+SIGHDD)*(PARMDL(42)-1.D0)
9596 C non-diffractive inelastic cross section
9598 SIGNDF = SIGTOT-SIGELA-SIGVM(0,0)-SIGCDF(0)-SIGDIR
9599 & -SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
9602 C specify elastic scattering channel
9605 IF(IFPAP(1).NE.22) THEN
9606 VMESA(1) = PHO_PNAME(IFPAB(1),0)
9610 IF(IFPAP(2).NE.22) THEN
9611 VMESB(1) = PHO_PNAME(IFPAB(2),0)
9616 C write out physical cross sections
9618 IF(IDEB(57).GE.5) THEN
9619 WRITE(LO,'(/1X,A,I3,/1X,A)')
9620 & 'PHO_XSECT: cross sections (mb) for combination',IP,
9621 & '----------------------------------------------'
9622 WRITE(LO,'(5X,A,E12.3,2E11.3)')'energy,virtualities',ECM,PVIRT
9623 WRITE(LO,'(5X,A,E12.3)') ' total ',SIGTOT
9624 WRITE(LO,'(5X,A,E12.3)') ' purely elastic ',SIGELA
9625 WRITE(LO,'(5X,A,E12.3)') ' inelastic ',SIGINE
9626 WRITE(LO,'(5X,A,E12.3)') ' s-diff.particle 1 ',
9627 & SIGLSD(1)+SIGHSD(1)
9628 IF(IDEB(57).GE.7) THEN
9629 WRITE(LO,'(5X,A,E12.3)') ' low-mass part ',SIGLSD(1)
9630 WRITE(LO,'(5X,A,E12.3)') ' high-mass part ',SIGHSD(1)
9632 WRITE(LO,'(5X,A,E12.3)') ' s-diff.particle 2 ',
9633 & SIGLSD(2)+SIGHSD(2)
9634 IF(IDEB(57).GE.7) THEN
9635 WRITE(LO,'(5X,A,E12.3)') ' low-mass part ',SIGLSD(2)
9636 WRITE(LO,'(5X,A,E12.3)') ' high-mass part ',SIGHSD(2)
9638 WRITE(LO,'(5X,A,E12.3)') ' double diff ',SIGLDD+SIGHDD
9639 IF(IDEB(57).GE.7) THEN
9640 WRITE(LO,'(5X,A,E12.3)') ' low-mass part ',SIGLDD
9641 WRITE(LO,'(5X,A,E12.3)') ' high-mass part ',SIGHDD
9643 WRITE(LO,'(5X,A,E12.3)') ' double pomeron ',SIGCDF(0)
9644 IF(IDEB(57).GE.7) THEN
9645 WRITE(LO,'(5X,A,E12.3)') ' purely elastic ',SIGCDF(1)
9646 WRITE(LO,'(5X,A,E12.3)') ' excitation part.1 ',SIGCDF(2)
9647 WRITE(LO,'(5X,A,E12.3)') ' excitation part.2 ',SIGCDF(3)
9648 WRITE(LO,'(5X,A,E12.3)') ' excitation both ',SIGCDF(4)
9650 WRITE(LO,'(5X,A,E12.3)') ' elastic slope ',SLOEL
9653 IF(SIGVM(I,J).GT.DEPS) THEN
9654 WRITE(LO,'(1X,3A)') 'q-elastic production of ',
9656 WRITE(LO,'(10X,A,E12.3)') 'cross section ',SIGVM(I,J)
9657 IF((I.NE.0).AND.(J.NE.0))
9658 & WRITE(LO,'(18X,A,E12.3)') 'slope ',SLOVM(I,J)
9662 IF(IDEB(57).GE.7) THEN
9663 WRITE(LO,'(5X,A,E12.3)') ' vmeson production ',SIGVM(0,0)
9664 WRITE(LO,'(5X,A,E12.3)') ' one-pomeron soft ',SIG1SO
9665 WRITE(LO,'(5X,A,E12.3)') ' one-pomeron hard ',SIG1HA
9666 WRITE(LO,'(5X,A,E12.3)') ' pomeron exchange ',SIGPOM
9667 WRITE(LO,'(5X,A,E12.3)') ' reggeon exchange ',SIGREG
9668 WRITE(LO,'(5X,A,E12.3)') ' hard resolved QCD ',DREAL(DSIGH(9))
9669 WRITE(LO,'(5X,A,E12.3/)')' hard direct QCD ',
9678 *$ CREATE PHO_IMPAMP.FOR
9680 CDECK ID>, PHO_IMPAMP
9681 SUBROUTINE PHO_IMPAMP(EE,BMIN,BMAX,NSTEP)
9682 C*********************************************************************
9684 C calculation of physical impact parameter amplitude
9686 C input: EE cm energy (GeV)
9687 C BMIN lower bound in B
9688 C BMAX upper bound in B
9689 C NSTEP number of values (linear)
9691 C output: values written to output unit
9693 C*********************************************************************
9694 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9697 PARAMETER(ONEM=-1.D0,
9701 C input/output channels
9703 COMMON /POINOU/ LI,LO
9704 C event debugging information
9706 PARAMETER (NMAXD=100)
9707 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9708 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9709 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9710 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9711 C model switches and parameters
9713 INTEGER ISWMDL,IPAMDL
9714 DOUBLE PRECISION PARMDL
9715 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
9716 C global event kinematics and particle IDs
9718 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
9719 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
9720 C complex Born graph amplitudes used for unitarization
9721 COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
9723 COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
9724 & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
9727 BSTEP = (BMAX-BMIN)/DBLE(NSTEP-1)
9729 WRITE(LO,'(3(/,1X,A))')
9730 & 'impact parameter amplitudes:',
9731 & ' B AMP-EL AMP-LMSD(1,2) AMP-HMSD(1,2) AMP-LMDD AMP-HMDD',
9732 & '-------------------------------------------------------------'
9736 C calculate impact parameter amplitudes
9738 CALL PHO_EIKON(1,-1,BMIN)
9740 CALL PHO_EIKON(1,1,BB)
9742 WRITE(LO,'(1X,8E12.4)') BB,DREAL(AMPEL),
9743 & DREAL(AMLMSD(1)),DREAL(AMLMSD(2)),
9744 & DREAL(AMHMSD(1)),DREAL(AMHMSD(2)),DREAL(AMLMDD),DREAL(AMHMDD)
9750 *$ CREATE PHO_PRBDIS.FOR
9752 CDECK ID>, PHO_PRBDIS
9753 SUBROUTINE PHO_PRBDIS(IP,ECM,IE)
9754 C*********************************************************************
9756 C calculation of multi interactions probabilities
9758 C input: IP particle combination to scatter
9760 C IE index for weight storing
9762 C IMAX max. number of soft pomeron interactions
9763 C KMAX max. number of hard pomeron interactions
9766 C PROB field of probabilities
9768 C*********************************************************************
9769 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9772 PARAMETER ( EPS=1.D-10 )
9774 C input/output channels
9776 COMMON /POINOU/ LI,LO
9777 C event debugging information
9779 PARAMETER (NMAXD=100)
9780 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9781 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9782 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9783 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9784 C Reggeon phenomenology parameters
9785 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
9786 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
9787 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
9788 & ALREG,ALREGP,GR(2),B0REG(2),
9789 & GPPP,GPPR,B0PPP,B0PPR,
9790 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
9791 C parameters of 2x2 channel model
9792 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
9793 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
9794 C Born graph cross sections and slopes
9796 PARAMETER ( Max_pro_3 = 16 )
9797 COMPLEX*16 SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
9799 COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
9800 & SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
9801 C obsolete cut-off information
9802 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
9803 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
9804 C Born graph cross sections after applying diffraction model
9805 DOUBLE PRECISION SBOPOM,SBOREG,SBOHAR,SBOHAD,SBOTR1,SBOTR2,
9807 COMMON /POINT1/ SBOPOM(0:4),SBOREG(0:4),SBOHAR(0:4),SBOHAD(0:4),
9808 & SBOTR1(0:4,2),SBOTR2(0:4,2),SBOLPO(0:4),
9811 INTEGER IPFIL,IFAFIL,IFBFIL
9812 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
9813 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
9814 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
9815 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
9816 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
9817 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
9818 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
9819 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
9820 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
9821 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
9822 & IPFIL,IFAFIL,IFBFIL
9823 C cut probability distribution
9824 INTEGER IEETA1,IIMAX,KKMAX
9825 PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
9826 INTEGER IEEMAX,IMAX,KMAX
9828 DOUBLE PRECISION EPTAB
9829 COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
9831 C energy-interpolation table
9833 PARAMETER ( IEETA2 = 20 )
9835 DOUBLE PRECISION SIGTAB,SIGECM
9836 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
9837 C average number of cut soft and hard ladders (obsolete)
9838 DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
9839 COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
9841 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
9842 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
9843 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
9844 C integration precision for hard cross sections (obsolete)
9845 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9846 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9847 C model switches and parameters
9849 INTEGER ISWMDL,IPAMDL
9850 DOUBLE PRECISION PARMDL
9851 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
9852 C unitarized amplitudes for different diffraction channels
9853 DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
9854 & ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
9855 & ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
9857 COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
9858 & ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
9859 & ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
9860 & ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
9861 & ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
9862 & ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
9866 DIMENSION AB(4,4),CHI2(4),ABSUM2(4,4),ABSTMP(4),CHITMP(4)
9867 PARAMETER (ICHMAX=40)
9868 DIMENSION CHIFAC(4,4),AMPCOF(4)
9869 DIMENSION PCHAIN(2,ICHMAX),XPNT(96),WGHT(96)
9870 DIMENSION FACLOG(0:30),PSOFT(0:30),PHARD(0:30)
9872 C combinatorical factors
9873 DATA CHIFAC / 1.D0, 1.D0,-1.D0,-1.D0,
9874 & 1.D0,-1.D0, 1.D0,-1.D0,
9875 & 1.D0,-1.D0,-1.D0, 1.D0,
9876 & 1.D0, 1.D0, 1.D0, 1.D0 /
9878 DATA FACLOG / .000000000000000D+00,
9879 & .000000000000000D+00, .693147180559945D+00,
9880 & .109861228866811D+01, .138629436111989D+01,
9881 & .160943791243410D+01, .179175946922805D+01,
9882 & .194591014905531D+01, .207944154167984D+01,
9883 & .219722457733622D+01, .230258509299405D+01,
9884 & .239789527279837D+01, .248490664978800D+01,
9885 & .256494935746154D+01, .263905732961526D+01,
9886 & .270805020110221D+01, .277258872223978D+01,
9887 & .283321334405622D+01, .289037175789616D+01,
9888 & .294443897916644D+01, .299573227355399D+01,
9889 & .304452243772342D+01, .309104245335832D+01,
9890 & .313549421592915D+01, .317805383034795D+01,
9891 & .321887582486820D+01, .325809653802148D+01,
9892 & .329583686600433D+01, .333220451017520D+01,
9893 & .336729582998647D+01, .340119738166216D+01 /
9898 C test for redundant calculation: skip cs calculation
9899 IF((ECM.NE.ELAST).OR.(IP.NE.IPLAST)) THEN
9902 CALL PHO_XSECT(IP,0,ELAST)
9905 SIGTAB(IP,1,IE) = SIGTOT
9906 SIGTAB(IP,2,IE) = SIGELA
9911 SIGTAB(IP,J,IE) = SIGVM(I,K)
9914 SIGTAB(IP,28,IE) = SIGINE
9915 SIGTAB(IP,29,IE) = SIGDIR
9916 SIGTAB(IP,30,IE) = SIGLSD(1)
9917 SIGTAB(IP,31,IE) = SIGLSD(2)
9918 SIGTAB(IP,32,IE) = SIGHSD(1)
9919 SIGTAB(IP,33,IE) = SIGHSD(2)
9920 SIGTAB(IP,34,IE) = SIGLDD
9921 SIGTAB(IP,35,IE) = SIGHDD
9922 SIGTAB(IP,36,IE) = SIGCDF(0)
9923 SIGTAB(IP,37,IE) = SIG1SO
9924 SIGTAB(IP,38,IE) = SIG1HA
9925 SIGTAB(IP,39,IE) = SLOEL
9930 SIGTAB(IP,J,IE) = SLOVM(I,K)
9933 SIGTAB(IP,56,IE) = SIGPOM
9934 SIGTAB(IP,57,IE) = SIGREG
9935 SIGTAB(IP,58,IE) = SIGHAR
9936 SIGTAB(IP,59,IE) = SIGDIR
9937 SIGTAB(IP,60,IE) = SIGTR1(1)
9938 SIGTAB(IP,61,IE) = SIGTR1(2)
9939 SIGTAB(IP,62,IE) = SIGTR2(1)
9940 SIGTAB(IP,63,IE) = SIGTR2(2)
9941 SIGTAB(IP,64,IE) = SIGLOO
9942 SIGTAB(IP,65,IE) = SIGDPO(1)
9943 SIGTAB(IP,66,IE) = SIGDPO(2)
9944 SIGTAB(IP,67,IE) = SIGDPO(3)
9945 SIGTAB(IP,68,IE) = SIGDPO(4)
9948 SIGNDF = SIGTOT-SIGELA-SIGVM(0,0)-SIGCDF(0)-SIGDIR
9949 & -SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
9952 IF(SIGNDF.LE.0.D0) THEN
9953 WRITE(LO,'(//1X,A,/)')
9954 & 'PHO_PRBDIS:ERROR: neg.cross section for unitarization!'
9955 WRITE(LO,'(1X,A,I3,1P,2E12.4)')
9956 & 'PHO_PRBDIS: IP,ECM,SIGNDF:',IP,ECM,SIGNDF
9957 WRITE(LO,'(4X,A,/1P,8E10.3)')
9958 &'(SIGTOT,SIGELA,SIGVM,SIGCDF,SIGDIR,SIGLSD(1),SIGLSD(2),SIGLDD):',
9959 & SIGTOT,SIGELA,SIGVM(0,0),SIGCDF(0),SIGDIR,SIGLSD(1),
9964 IF((IDEB(55).GE.2).AND.(IP.EQ.1)) THEN
9965 WRITE(LO,*) '------------------------------------------------'
9966 WRITE(LO,*) 'IP,ECM:',IP,ECM
9967 WRITE(LO,*) 'SIGTOT:',SIGTOT
9968 WRITE(LO,*) 'SIGELA:',SIGELA
9969 WRITE(LO,*) 'SIGVM :',SIGVM(0,0)
9970 WRITE(LO,*) 'SIGCDF:',SIGCDF(0)
9971 WRITE(LO,*) 'SIGDIR:',SIGDIR
9972 WRITE(LO,*) 'SIGLSD:',SIGLSD
9973 WRITE(LO,*) 'SIGHSD:',SIGHSD
9974 WRITE(LO,*) 'SIGLDD:',SIGLDD
9975 WRITE(LO,*) 'SIGHDD:',SIGHDD
9976 WRITE(LO,*) 'SIGNDF:',SIGNDF
9978 WRITE(LO,*) 'SIGPOM:',SIGPOM
9979 WRITE(LO,*) 'SIGREG:',SIGREG
9980 WRITE(LO,*) 'SIGHAR:',SIGHAR
9981 WRITE(LO,*) 'SIGDIR:',SIGDIR
9982 WRITE(LO,*) 'SIGTR1:',SIGTR1
9983 WRITE(LO,*) 'SIGTR2:',SIGTR2
9984 WRITE(LO,*) 'SIGLOO:',SIGLOO
9985 WRITE(LO,*) 'SIGDPO:',SIGDPO
9986 WRITE(LO,*) 'SIG1SO:',SIG1SO
9987 WRITE(LO,*) 'SIG1HA:',SIG1HA
9990 SIGTAB(IP,77,IE) = PTCUT(IP)
9991 SIGTAB(IP,78,IE) = SIGNDF
9994 IF(ISWMDL(1).EQ.3) THEN
9998 AMPCOF(I) = AMPCOF(I) + 0.25D0*ELAFAC(K)*CHIFAC(K,I)
10000 AMPCOF(I) = AMPCOF(I)*AUXFAC
10004 * BMAX=5.D0*SQRT(DBLE(BPOM))
10007 CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
10013 PROB(IP,IE,I,K) = 0.D0
10021 C main cross section loop
10022 C**********************************************************
10023 DO 5000 IB=1,NGAUSO
10024 B24=XPNT(IB)**2/4.D0
10025 FAC = XPNT(IB)*WGHT(IB)
10027 IF((ISWMDL(1).EQ.3).OR.(ISWMDL(1).EQ.4)) THEN
10029 C amplitude construction
10031 AB(1,I)=ZXP(1,I)*EXP(-B24/BXP(1,I))
10032 & +ZXR(1,I)*EXP(-B24/BXR(1,I))
10033 AB(2,I)=ZXH(1,I)*EXP(-B24/BXH(1,I))
10034 AB(3,I)=-ZXT1A(1,I)*EXP(-B24/BXT1A(1,I))
10035 & -ZXT1B(1,I)*EXP(-B24/BXT1B(1,I))
10036 & -ZXT2A(1,I)*EXP(-B24/BXT2A(1,I))
10037 & -ZXT2B(1,I)*EXP(-B24/BXT2B(1,I))
10038 & -ZXL(1,I)*EXP(-B24/BXL(1,I))
10039 AB(4,I)=ZXDPE(1,I)*EXP(-B24/BXDPE(1,I))
10040 & +ZXDPA(1,I)*EXP(-B24/BXDPA(1,I))
10041 & +ZXDPB(1,I)*EXP(-B24/BXDPB(1,I))
10042 & +ZXDPD(1,I)*EXP(-B24/BXDPD(1,I))
10043 AB(1,I) = AB(1,I)+AB(3,I)+AB(4,I)
10054 ABSUM2(I,K) = ABSUM2(I,K) + CHIFAC(L,K)*AB(I,L)
10056 ABSUM2(I,K) = 2.D0*ABSUM2(I,K)
10062 CHI2(I) = CHI2(I) + ABSUM2(K,I)
10065 C sums instead of products
10068 DTMP = ABS(ABSUM2(I,KD))
10069 IF(DTMP.LT.1.D-30) THEN
10070 ABSUM2(I,KD) = -50.D0
10072 ABSUM2(I,KD) = LOG(DTMP)
10077 IF(MAX(IMAX,KMAX).GT.30) THEN
10078 WRITE(LO,'(1X,2A,3I6)') 'PHO_PRBDIS: internal field ',
10079 & 'dimension too small (IMAX,KMAX,int):',IMAX,KMAX,30
10084 ABSTMP(I) = ABSUM2(I,KD)
10087 CHITMP(1) = -ABSUM2(1,KD)
10089 CHITMP(1) = CHITMP(1)+ABSTMP(1)-FACLOG(I)
10090 CHITMP(2) = -ABSTMP(2)
10092 CHITMP(2) = CHITMP(2)+ABSTMP(2)-FACLOG(K)
10093 C calculation of elastic part
10094 DTMP = -CHI2(KD)+CHITMP(1)+CHITMP(2)
10095 IF(DTMP.LT.-30.D0) THEN
10098 DTMP = EXP(DTMP)*FAC*AMPCOF(KD)
10100 PROB(IP,IE,I,K) = PROB(IP,IE,I,K) + DTMP
10104 PROB(IP,IE,0,0) = 0.D0
10106 C**********************************************************
10108 WRITE(LO,'(1X,A,I3)')
10109 & 'PHO_PRBDIS:ERROR: invalid setting of ISWMDL(1)',ISWMDL(1)
10115 IF(IDEB(55).GE.15) THEN
10116 WRITE(LO,'(/,1X,A,I3,E11.4)')
10117 & 'PHO_PRBDIS: list of probabilities (uncorrected,IP,ECM)',
10119 DO 905 I=0,MIN(IMAX,5)
10120 DO 915 K=0,MIN(KMAX,5)
10121 IF(ABS(PROB(IP,IE,I,K)).GT.1.D-10)
10122 & WRITE(LO,'(10X,2I3,5X,E12.3)') I,K,PROB(IP,IE,I,K)
10126 C string probability (uncorrected)
10127 IF(IDEB(55).GE.5) THEN
10131 IF((INDX.LE.ICHMAX).AND.(INDX.GT.0)) THEN
10132 PCHAIN(1,INDX) = PCHAIN(1,INDX) + PROB(IP,IE,I,K)
10136 WRITE(LO,'(/1X,2A,E11.4)') 'PHO_PRBDIS: ',
10137 & 'list of selected probabilities (uncorr,ECM)',ECM
10138 WRITE(LO,'(10X,A)') 'I, 0HPOM, 1HPOM, 2HPOM'
10140 IF(ABS(PROB(IP,IE,I,0)).GT.1.D-10)
10141 & WRITE(LO,'(5X,I4,3E12.4)') I,PROB(IP,IE,I,0),
10142 & PROB(IP,IE,I,1),PROB(IP,IE,I,2)
10145 C substract high-mass single and double diffraction
10146 PROB(IP,IE,1,0) = PROB(IP,IE,1,0)
10147 & -(SIGHSD(1)+SIGHSD(2)+SIGHDD+SIGCDF(0))/SIGNDF
10148 PROB(IP,IE,1,0) = MAX(0.01,PROB(IP,IE,1,0))
10150 C probability check
10170 TMP = PROB(IP,IE,I,K)
10171 IF(TMP.LT.0.D0) THEN
10172 IF((IDEB(55).GE.0).AND.(TMP.LT.-EPS)) THEN
10173 WRITE(LO,'(1X,A,4I4,E14.4)')
10174 & 'PHO_PRBDIS: neg.probability:',
10175 & IP,IE,I,K,PROB(IP,IE,I,K)
10177 PRONEG = PRONEG+TMP
10180 CHKSUM = CHKSUM+TMP
10181 AVERI = AVERI+DBLE(I)*TMP
10182 AVERK = AVERK+DBLE(K)*TMP
10183 SIGMI = SIGMI+DBLE(I**2)*TMP
10184 SIGMK = SIGMK+DBLE(K**2)*TMP
10185 PSOFT(I) = PSOFT(I)+PROB(IP,IE,I,K)
10186 PHARD(K) = PHARD(K)+PROB(IP,IE,I,K)
10187 PROB(IP,IE,I,K) = CHKSUM
10191 IF(IDEB(55).GE.1) WRITE(LO,'(/,1X,A,2E15.6)')
10192 & 'PHO_PRBDIS: first sum of probabilities',CHKSUM,PRONEG
10193 C cut probabilites output
10194 IF(IDEB(55).GE.5) THEN
10195 WRITE(LO,'(/1X,A)') 'list of cut probabilities (uncorr/corr)'
10197 IF(ABS(PCHAIN(1,I)).GT.1.D-10)
10198 & WRITE(LO,'(5X,I4,2E12.3)') I,PCHAIN(1,I),PCHAIN(1,I)/CHKSUM
10201 C rescaling necessary
10202 IF(ABS(CHKSUM-1.D0).GT.1.D-15) THEN
10204 IF(IDEB(55).GE.1) WRITE(LO,'(/,1X,A,E15.6)')
10205 & 'PHO_PRBDIS: rescaling of probabilities with factor',FAC
10208 PROB(IP,IE,I,K) = PROB(IP,IE,I,K)*FAC
10215 SIGMI = SIGMI*FAC**2
10216 SIGMK = SIGMK*FAC**2
10217 SIGML = SIGML*FAC**2
10218 SIGMM = SIGMM*FAC**2
10221 C probability to find Reggeon/Pomeron
10222 PROB(IP,IE,0,0) = -SIGREG/(SIGPOM+SIGREG)
10223 AVERJ = -PROB(IP,IE,0,0)*AVERI
10224 AVERII = AVERI-AVERJ
10226 SIGTAB(IP,74,IE) = AVERII
10227 SIGTAB(IP,75,IE) = AVERK
10228 SIGTAB(IP,76,IE) = AVERJ
10230 SIGTAB(IP,79,IE) = PROB(IP,IE,IMAX,0)*SIGNDF
10231 SIGTAB(IP,80,IE) = SIGNDF-SIGTAB(IP,79,IE)
10233 IF(IDEB(55).GE.1) THEN
10235 C average interaction probabilities
10236 WRITE(LO,'(/1X,A,/1X,A)')
10237 & 'PHO_PRBDIS: expected interaction statistics',
10238 & '-------------------------------------------'
10239 WRITE(LO,'(1X,A,E12.4,2I3)')
10240 & 'energy,IP,table index:',EPTAB(IP,IE),IP,IE
10241 WRITE(LO,'(1X,A,2I4)') 'current limitations (soft,hard):',
10243 WRITE(LO,'(1X,A,E12.4/,4X,A,/,1X,6E11.3)')
10244 & 'averaged number of cuts per event (eff. cs):',SIGNDF,
10245 & ' (Pom / Pom-h / Reg / enh-tri-loop / enh-dble / sum):',
10246 & AVERII,AVERK,AVERJ,AVERL,AVERM,
10247 & AVERI+AVERK+AVERL+AVERM
10248 WRITE(LO,'(1X,A,/,4X,A,/,1X,4E11.3)')
10249 & 'standard deviation ( sqrt(sigma) ):',
10250 & ' (Pomeron / Pomeron-h / enh-tri-loop / enh-dble):',
10251 & SQRT(ABS(SIGMI-AVERI**2)),SQRT(ABS(SIGMK-AVERK**2)),
10252 & SQRT(ABS(SIGML-AVERL**2)),SQRT(ABS(SIGMM-AVERM**2))
10253 WRITE(LO,'(1X,A)') 'cross section / probability soft, hard'
10254 DO I=0,MIN(IMAX,KMAX)
10255 WRITE(LO,'(I5,2E12.4,3X,2E12.4)')
10256 & I,PSOFT(I)*SIGNDF,PSOFT(I),PHARD(I)*SIGNDF,PHARD(I)
10259 C cross check of probability distribution and inclusive cross section
10265 PSsum_1 = PSsum_1+PSOFT(i)*FAC
10266 PSsum_2 = PSsum_2+PSOFT(i)*FAC*dble(i)
10269 PHsum_1 = PHsum_1+PHARD(k)
10270 PHsum_2 = PHsum_2+PHARD(k)*FAC*dble(k)
10272 WRITE(LO,'(1x,a,2E12.4,3X,2E12.4)') 'sum:',
10273 & PSsum_2*SIGNDF,PSsum_1,PHsum_2*SIGNDF,PHsum_1
10279 *$ CREATE PHO_SAMPRO.FOR
10281 CDECK ID>, PHO_SAMPRO
10282 SUBROUTINE PHO_SAMPRO(IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB,IPROC)
10283 C***********************************************************************
10285 C routine to sample kind of process
10287 C input: IP particle combination
10288 C IFP1/2 PDG number of particle 1/2
10289 C ECM c.m. energy (GeV)
10290 C PVIR1/2 virtuality of particle 1/2 (GeV**2, positive)
10291 C SPROB suppression factor for processes 1-7
10292 C due to rapidity gap survival probability
10294 C -2 output of statistics
10295 C -1 initialization
10296 C 0 sampling of process
10298 C output: IPROC kind of interaction process:
10299 C 1 non-diffractive resolved process
10300 C 2 elastic scattering
10301 C 3 quasi-elastic rho/omega/phi production
10302 C 4 central diffraction
10303 C 5 single diffraction according to IDIFF1
10304 C 6 single diffraction according to IDIFF2
10305 C 7 double diffraction
10306 C 8 single-resolved / direct processes
10308 C***********************************************************************
10312 INTEGER IP,IFP1,IFP2,IPROC
10313 DOUBLE PRECISION ECM,PVIR1,PVIR2,SPROB
10315 C input/output channels
10317 COMMON /POINOU/ LI,LO
10318 C event debugging information
10320 PARAMETER (NMAXD=100)
10321 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
10322 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10323 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
10324 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10326 INTEGER IPFIL,IFAFIL,IFBFIL
10327 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
10328 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
10329 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
10330 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
10331 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
10332 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
10333 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
10334 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
10335 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
10336 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
10337 & IPFIL,IFAFIL,IFBFIL
10338 C model switches and parameters
10340 INTEGER ISWMDL,IPAMDL
10341 DOUBLE PRECISION PARMDL
10342 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
10343 C general process information
10344 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
10345 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
10346 C event weights and generated cross section
10347 INTEGER IPOWGC,ISWCUT,IVWGHT
10348 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
10349 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
10350 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
10352 DOUBLE PRECISION PRO,XPROB,SIGSDI,CALLS,SIGSUM,ECMSUM
10353 DIMENSION PRO(8,4),XPROB(8),SIGSDI(2)
10354 DIMENSION CALLS(4),SIGSUM(4),ECMSUM(4)
10357 DOUBLE PRECISION DT_RNDM
10358 DOUBLE PRECISION SIGDDI,SIGHD,SIGHR,SIGNDR,XI
10360 IF(IDEB(11).GE.15) WRITE(LO,'(/,1X,A,/5X,I3,2I6,1P4E11.3)')
10361 & 'PHO_SAMPRO: called with IP,IFP1/2,ECM,PVIR1/2,SPROB',
10362 & IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB
10364 IF(IPROC.GE.0) THEN
10366 C interpolate cross sections
10367 CALL PHO_CSINT(IP,IFP1,IFP2,-1,-1,ECM,PVIR1,PVIR2)
10370 IF((IP.EQ.1).and.((SPROB.gt.1.D0).or.(SPROB.lt.0.D0))) THEN
10371 WRITE(LO,'(/,1X,A,/5X,I12,I3,2I6,1P4E11.3)')
10372 & 'PHO_SAMPRO: inconsistent gap survival probability',
10373 & 'EVENT,IP,IFP1/2,ECM,PVIR1/2,SPROB:',
10374 & KEVENT,IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB
10377 C calculate cumulative probabilities
10378 IF(ISWMDL(1).EQ.3) THEN
10379 IF(ISWMDL(2).GE.1) THEN
10380 SIGSDI(1) = SIGLSD(1)+SIGHSD(1)
10381 SIGSDI(2) = SIGLSD(2)+SIGHSD(2)
10382 SIGDDI = SIGLDD+SIGHDD
10383 SIGNDR = SIGINE-SIGVM(0,0)-SIGCDF(0)-SIGDIR
10384 & - SIGSDI(1)-SIGSDI(2)-SIGDDI
10385 XPROB(1) = SIGNDR*SPROB*DBLE(IPRON(1,IP))
10386 XPROB(2) = XPROB(1)+SIGELA*SPROB*DBLE(IPRON(2,IP))
10387 XPROB(3) = XPROB(2)+SIGVM(0,0)*SPROB*DBLE(IPRON(3,IP))
10388 XPROB(4) = XPROB(3)+SIGCDF(0)*SPROB*DBLE(IPRON(4,IP))
10389 XPROB(5) = XPROB(4)+SIGSDI(1)*SPROB*DBLE(IPRON(5,IP))
10390 XPROB(6) = XPROB(5)+SIGSDI(2)*SPROB*DBLE(IPRON(6,IP))
10391 XPROB(7) = XPROB(6)+SIGDDI*SPROB*DBLE(IPRON(7,IP))
10392 XPROB(8) = XPROB(7)+SIGDIR*DBLE(IPRON(8,IP))
10395 IF(IPRON(1,IP).EQ.1) SIGHR = SIGHAR
10397 IF(IPRON(8,IP).EQ.1) SIGHD = SIGDIR
10398 XPROB(1) = SIGHR/(SIGHR+SIGHD)
10399 XPROB(2) = XPROB(1)
10400 XPROB(3) = XPROB(1)
10401 XPROB(4) = XPROB(1)
10402 XPROB(5) = XPROB(1)
10403 XPROB(6) = XPROB(1)
10404 XPROB(7) = XPROB(1)
10405 XPROB(8) = XPROB(1)+SIGHD/(SIGHR+SIGHD)
10408 IF(IDEB(11).GE.15) THEN
10409 WRITE(LO,'(1X,A,I3)')
10410 & 'PHO_SAMPRO: partial cross sections for IP',IP
10411 WRITE(LO,'(5X,I3,2X,1PE12.4)') 1,XPROB(1)
10413 WRITE(LO,'(5X,I3,2X,1PE12.4)') I,XPROB(I)-XPROB(I-1)
10418 WRITE(LO,'(/,1X,A,I4)') 'PHO_SAMPRO:ERROR: unsupported model',
10423 IF(XPROB(8).LT.1.D-20) THEN
10425 & WRITE(LO,'(1X,2A,/10X,A,1P3E11.3)') 'PHO_SAMPRO:ERROR: ',
10426 & 'activated processes have vanishing cross section sum',
10427 & 'IP,ECM,SIG_sum:',IP,ECM,XPROB(8)
10433 XI = DT_RNDM(XI)*XPROB(8)
10435 IF(XI.LE.XPROB(I)) GOTO 110
10440 CALLS(IP) = CALLS(IP)+1.D0
10441 PRO(IPROC,IP) = PRO(IPROC,IP)+1.D0
10442 ECMSUM(IP) = ECMSUM(IP)+ECM
10443 IF(ISWMDL(2).GE.1) THEN
10444 SIGSUM(IP) = SIGSUM(IP)+XPROB(8)
10446 SIGSUM(IP) = SIGSUM(IP)+SIGGEN(3)
10450 IF(IDEB(11).GE.5) WRITE(LO,'(1X,A,I3,I12,I4)')
10451 & 'PHO_SAMPRO: IP,CALL,PROC-ID',
10452 & IP,INT(CALLS(IP)+0.1D0),IPROC
10454 C statistics initialization
10455 ELSE IF(IPROC.EQ.-1) THEN
10465 C write out statistics
10466 ELSE IF(IPROC.EQ.-2) THEN
10468 IF(ISWMDL(2).EQ.0) KMAX=1
10470 IF(CALLS(K).GT.0.5D0) THEN
10471 SIGSUM(K) = SIGSUM(K)/CALLS(K)**2
10472 ECMSUM(K) = ECMSUM(K)/CALLS(K)
10473 IF(IDEB(11).GE.0) THEN
10474 WRITE(LO,'(/,1X,2A,I4,1PE12.3,/,1X,A)')
10475 & 'PHO_SAMPRO: internal process statistics ',
10476 & '(IP,<Ecm>)',K,ECMSUM(K),
10477 & '---------------------------------------'
10479 & ' process sampled cross section'
10480 IF(ISWMDL(2).GE.1) THEN
10481 WRITE(LO,'(9(/5X,A,0PF12.0,5X,1PE12.3))')
10482 & ' all processes',CALLS(K),CALLS(K)*SIGSUM(K),
10483 & ' nondif.inelastic',PRO(1,K),PRO(1,K)*SIGSUM(K),
10484 & ' elastic',PRO(2,K),PRO(2,K)*SIGSUM(K),
10485 & 'vmeson production',PRO(3,K),PRO(3,K)*SIGSUM(K),
10486 & ' double pomeron',PRO(4,K),PRO(4,K)*SIGSUM(K),
10487 & ' single diffr.(1)',PRO(5,K),PRO(5,K)*SIGSUM(K),
10488 & ' single diffr.(2)',PRO(6,K),PRO(6,K)*SIGSUM(K),
10489 & ' double diffract.',PRO(7,K),PRO(7,K)*SIGSUM(K),
10490 & ' direct processes',PRO(8,K),PRO(8,K)*SIGSUM(K)
10492 WRITE(LO,'(3(/5X,A,0PF12.0,5X,1PE12.3))')
10493 & ' all processes',CALLS(K),CALLS(K)*SIGSUM(K),
10494 & ' double resolved',PRO(1,K),PRO(1,K)*SIGSUM(K),
10495 & ' single res + dir',PRO(8,K),PRO(8,K)*SIGSUM(K)
10504 *$ CREATE PHO_SAMPRB.FOR
10506 CDECK ID>, PHO_SAMPRB
10507 SUBROUTINE PHO_SAMPRB(ECMI,IP,ISAM,JSAM,KSAM)
10508 C********************************************************************
10510 C routine to sample number of cut graphs of different kind
10512 C input: IP scattering particle combination
10514 C IP -1 initialization
10515 C -2 output of statistics
10516 C others sampling of cuts
10518 C output: ISAM number of soft Pomerons cut
10519 C JSAM number of soft Reggeons cut
10520 C KSAM number of hard Pomerons cut
10522 C PHO_PRBDIS has to be called before
10524 C********************************************************************
10525 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10528 C input/output channels
10530 COMMON /POINOU/ LI,LO
10531 C event debugging information
10533 PARAMETER (NMAXD=100)
10534 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
10535 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10536 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
10537 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10538 C model switches and parameters
10540 INTEGER ISWMDL,IPAMDL
10541 DOUBLE PRECISION PARMDL
10542 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
10543 C general process information
10544 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
10545 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
10546 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
10547 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
10548 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
10549 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
10550 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
10551 C obsolete cut-off information
10552 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
10553 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10554 C cut probability distribution
10555 INTEGER IEETA1,IIMAX,KKMAX
10556 PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
10557 INTEGER IEEMAX,IMAX,KMAX
10559 DOUBLE PRECISION EPTAB
10560 COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
10562 C global event kinematics and particle IDs
10563 INTEGER IFPAP,IFPAB
10564 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
10565 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
10567 INTEGER IPFIL,IFAFIL,IFBFIL
10568 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
10569 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
10570 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
10571 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
10572 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
10573 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
10574 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
10575 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
10576 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
10577 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
10578 & IPFIL,IFAFIL,IFBFIL
10579 C table of particle indices for recursive PHOJET calls
10581 PARAMETER ( MAXIPX = 100 )
10582 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
10583 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
10584 & IPOIX1,IPOIX2,IPOIX3
10586 DIMENSION ECMS1(4),ECMS2(4),AVERB(0:3,4),AVERC(0:3,4)
10588 C sample number of interactions
10594 IF((IPAMDL(13).GT.0).AND.(IPROCE.EQ.1).AND.(IPOIX3.EQ.0)) THEN
10595 IF(IPAMDL(16).EQ.0) ECMC = SECM
10599 C sample up to kinematic limits only
10600 IMAX1 = MIN(IMAX,INT(0.4D0*ECMC/PARMDL(161)))
10601 IF(IMAX1.LT.1) THEN
10602 IF(IPAMDL(2).EQ.1) THEN
10607 AVERB(3,IP) = AVERB(3,IP)+1.D0
10609 C only pomeron even at very low energies
10613 AVERB(1,IP) = AVERB(1,IP)+1.D0
10615 AVERB(0,IP) = AVERB(0,IP)+1.D0
10618 C find interpolation factors
10619 IF(ECMX.LE.EPTAB(IP,1)) THEN
10622 ELSE IF(ECMX.LT.EPTAB(IP,IEEMAX)) THEN
10624 IF(ECMX.LE.EPTAB(IP,I)) GOTO 200
10630 WRITE(LO,'(/1X,A,2E12.3)')
10631 & 'PHO_SAMPRB:too high energy',ECMX,EPTAB(IP,IEEMAX)
10632 CALL PHO_PREVNT(-1)
10638 & FAC2=LOG(ECMX/EPTAB(IP,I1))/LOG(EPTAB(IP,I2)/EPTAB(IP,I1))
10640 C reggeon probability
10641 PREG = -(PROB(IP,I1,0,0)*FAC1+PROB(IP,I2,0,0)*FAC2)
10642 C calculate soft suppression factor
10643 IF(IP.EQ.1) FSUPP = PARMDL(35)**2
10644 & /((PVIRT(1)+PARMDL(35))*(PVIRT(2)+PARMDL(35)))
10651 PRO = PROB(IP,I1,ISAM,KSAM)*FAC1
10652 & +PROB(IP,I2,ISAM,KSAM)*FAC2
10653 IF(PRO.GT.XI) GOTO 100
10656 ISAM = MIN(IMAX,ISAM)
10657 KSAM = MIN(KMAX,KSAM)
10661 IF(ITER.GT.100) THEN
10666 IF(IDEB(12).GE.3) WRITE(LO,'(1X,A,I10,E11.3,I6)')
10667 & 'PHO_SAMPRB: rejection (EV,ECM,ITER)',KEVENT,ECMX,ITER
10671 C reggeon contribution
10673 IF(IPAMDL(2).EQ.1) THEN
10675 IF(DT_RNDM(PRO).LT.PREG) JSAM = JSAM+1
10679 C statistics of bare cuts
10681 AVERB(0,IP) = AVERB(0,IP)+1.D0
10682 AVERB(1,IP) = AVERB(1,IP)+DBLE(ISAM)
10683 AVERB(2,IP) = AVERB(2,IP)+DBLE(KSAM)
10684 AVERB(3,IP) = AVERB(3,IP)+DBLE(JSAM)
10686 C limitation given by field dimensions
10687 IF((2*ISAM+JSAM+3*KSAM).GT.50) GOTO 10
10691 C reweight according to virtualities and PDF treatment
10692 IF(IPAMDL(115).GE.1) THEN
10694 IF(FSUP(1)*FSUP(2).LT.DT_RNDM(ECMI)) GOTO 10
10698 C reduce number of cuts according to photon virtualities
10699 IF(IPAMDL(114).GE.1) THEN
10703 IF(DT_RNDM(WGX).GT.WGX) THEN
10704 IF(ISAM+JSAM+KSAM.GT.1) THEN
10708 ELSE IF(ISAM.GT.0) THEN
10718 C phase space limitation
10720 XM = DBLE(2*ISAM+JSAM)*PARMDL(160+IP)
10721 & +DBLE(2*KSAM)*PTCUT(IP)
10722 PACC = EXP(PARMDL(9)*(PARMDL(160+IP)-XM)/ECMC)
10723 IF(DT_RNDM(XM).GT.PACC) THEN
10724 IF(ISAM+JSAM+KSAM.GT.1) THEN
10728 ELSE IF(ISAM.GT.0) THEN
10731 ELSE IF(KSAM.GT.KLIM) THEN
10742 C collect statistics
10744 ECMS1(IP) = ECMS1(IP)+ECMX
10745 ECMS2(IP) = ECMS2(IP)+ECMC
10746 AVERC(0,IP) = AVERC(0,IP)+1.D0
10747 AVERC(1,IP) = AVERC(1,IP)+DBLE(ISAM)
10748 AVERC(2,IP) = AVERC(2,IP)+DBLE(KSAM)
10749 AVERC(3,IP) = AVERC(3,IP)+DBLE(JSAM)
10751 IF(IDEB(12).GE.10) WRITE(LO,'(1X,A,2E11.4,3I4)')
10752 & 'PHO_SAMPRB: ECM,I,J,K',ECM,ECMX,ISAM,JSAM,KSAM
10754 C initialize statistics
10755 ELSE IF(IP.EQ.-1) THEN
10766 C write out statistics
10767 ELSE IF(IP.EQ.-2) THEN
10768 WRITE(LO,'(2(/1X,A))') 'PHO_SAMPRB: interaction statistics',
10769 & '----------------------------------'
10771 IF(AVERB(0,I).LT.2.D0) GOTO 75
10772 WRITE(LO,'(1X,A,I3,1P,2E13.3)')
10773 & 'statistics for IP,<Ecm_1>,<Ecm_2>',I,
10774 & ECMS1(I)/MAX(AVERB(0,I),1.D0),ECMS2(I)/MAX(AVERB(0,I),1.D0)
10776 & 'average number of s-pom,h-pom,reg cuts (bare)'
10777 WRITE(LO,'(5X,F12.0,1P3E12.4)') AVERB(0,I),
10778 & (AVERB(K,I)/AVERB(0,I),K=1,3)
10780 & 'average (with energy/virtuality corrections)'
10781 WRITE(LO,'(5X,F12.0,1P3E12.4)') AVERC(0,I),
10782 & (AVERC(K,I)/AVERC(0,I),K=1,3)
10790 *$ CREATE PHO_TRIREG.FOR
10792 CDECK ID>, PHO_TRIREG
10793 SUBROUTINE PHO_TRIREG(S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP,VIR2A,
10795 C**********************************************************************
10797 C calculation of triple-Pomeron total cross section
10798 C according to Gribov's Regge theory
10800 C input: S squared cms energy
10801 C GA coupling constant to diffractive line
10802 C AA slope related to GA (GeV**-2)
10803 C GB coupling constant to elastic line
10804 C BB slope related to GB (GeV**-2)
10805 C DELTA effective pomeron delta (intercept-1)
10806 C ALPHAP slope of pomeron trajectory (GeV**-2)
10807 C GPPP triple-Pomeron coupling
10808 C BPPP slope related to B0PPP (GeV**-2)
10809 C VIR2A virtuality of particle a (GeV**2)
10810 C note: units of all coupling constants are mb**1/2
10812 C output: SIGTR total triple-Pomeron cross section
10813 C BTR effective triple-Pomeron slope
10814 C (differs from diffractive slope!)
10816 C uses E_i (Exponential-Integral function)
10818 C**********************************************************************
10819 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10822 PARAMETER (EPS =0.0001D0)
10824 C input/output channels
10826 COMMON /POINOU/ LI,LO
10827 C event debugging information
10829 PARAMETER (NMAXD=100)
10830 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
10831 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10832 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
10833 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10835 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
10836 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
10837 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
10839 C integration cut-off Sigma_U ( see Nucl.Phys.B97(1975)493 )
10841 C integration cut-off Sigma_L (min. squared mass of diff. blob)
10844 IF(IDEB(50).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
10845 & 'PHO_TRIREG: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP ',
10846 & S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
10853 C change units of ALPHAP to mb
10854 ALSCA = ALPHAP*GEV2MB
10857 PART1=GA*GB**2*GPPP/(16.*PI*2.*ALSCA)*S**DELTA*
10858 & EXP(-(BB+BPPP)/(2.*ALPHAP)*DELTA)
10859 PART2=PHO_EXPINT(((BB+BPPP)/(2.*ALPHAP)+LOG(S/SIGL))*DELTA)
10860 PART3=PHO_EXPINT(((BB+BPPP)/(2.*ALPHAP)+LOG(SIGU))*DELTA)
10862 SIGTR=PART1*(PART2-PART3)
10865 PART1 = (BB+BPPP+2.*ALPHAP*LOG(S/SIGL))/
10866 & (BB+BPPP+2.*ALPHAP*LOG(SIGU))
10868 PART1 = 0.5D0*ALPHAP*LOG(1.D0+S/(SIGU*SIGL))/PART2
10869 BTR = (AA+BB/2.D0)/2.D0+BPPP+ALPHAP*LOG(S/4.D0)
10872 IF(SIGTR.LT.EPS) SIGTR = 0.D0
10873 IF(BTR.LT.BB) BTR = BB
10875 IF(IDEB(50).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
10876 & 'PHO_TRIREG: ENERGY,SIGTR,BTR ',SQRT(S),SIGTR,BTR
10879 *$ CREATE PHO_LOOREG.FOR
10881 CDECK ID>, PHO_LOOREG
10882 SUBROUTINE PHO_LOOREG(S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP,
10883 & VIR2A,VIR2B,SIGLO,BLO)
10884 C**********************************************************************
10886 C calculation of loop-Pomeron total cross section
10887 C according to Gribov's Regge theory
10889 C input: S squared cms energy
10890 C GA coupling constant to diffractive line
10891 C AA slope related to GA (GeV**-2)
10892 C GB coupling constant to elastic line
10893 C BB slope related to GB (GeV**-2)
10894 C DELTA effective pomeron delta (intercept-1)
10895 C ALPHAP slope of pomeron trajectory (GeV**-2)
10896 C GPPP triple-Pomeron coupling
10897 C BPPP slope related to B0PPP (GeV**-2)
10898 C VIR2A virtuality of particle a (GeV**2)
10899 C VIR2B virtuality of particle b (GeV**2)
10900 C note: units of all coupling constants are mb**1/2
10902 C output: SIGLO total loop-Pomeron cross section
10903 C BLO effective loop-Pomeron slope
10904 C (differs from double diffractive slope!)
10906 C uses E_i (Exponential-Integral function)
10908 C**********************************************************************
10909 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10912 PARAMETER (EPS =0.0001D0)
10914 C input/output channels
10916 COMMON /POINOU/ LI,LO
10917 C event debugging information
10919 PARAMETER (NMAXD=100)
10920 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
10921 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10922 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
10923 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10925 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
10926 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
10927 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
10929 C integration cut-off Sigma_U ( see Nucl.Phys.B97(1975)493 )
10931 C integration cut-off Sigma_L (min. squared mass of diff. blob)
10932 SIGL = 5.+VIR2A+VIR2B
10934 IF(IDEB(51).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
10935 & 'PHO_LOOREG: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP ',
10936 & S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
10945 C change units of ALPHAP to mb
10946 ALSCA = ALPHAP*GEV2MB
10949 PART1=GA*GB*GPPP**2/(16.*PI*2.*ALSCA)*S**DELTA*
10950 & EXP(-DELTA*BPPP/ALPHAP)
10951 PARTA=BPPP/ALPHAP+LOG(S/SIGL**2)
10952 PARTB=BPPP/ALPHAP+LOG(SIGU)
10953 SIGLO=PART1*(PARTA*(PHO_EXPINT(PARTA*DELTA)
10954 & -PHO_EXPINT(PARTB*DELTA))
10955 & +EXP(PARTA*DELTA)/DELTA-EXP(PARTB*DELTA)/DELTA
10959 PART1 = LOG(ABS(PARTA/PARTB))
10960 & *(PARTA-LOG(1.D0+S/(SIGL**2*SIGU)))
10961 PART1 = 0.25*ALPHAP*LOG(1.D0+S/(SIGU*SIGL))**2/PART1
10962 BLO = (AA+BB)/2.+2.*BPPP+ALPHAP*LOG(S/4.D0)
10965 IF(SIGLO.LT.EPS) SIGLO = 0.D0
10966 IF(BLO.LT.2.D0*BPPP) BLO = 2.D0*BPPP
10968 IF(IDEB(51).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
10969 & 'PHO_LOOREG: ENERGY,SIGLO,BLO',SQRT(S),SIGLO,BLO
10972 *$ CREATE PHO_TRXPOM.FOR
10974 CDECK ID>, PHO_TRXPOM
10975 SUBROUTINE PHO_TRXPOM(S,GA,AA,GB,BB,DELTA,ALPHAP,
10976 & GPPP,BPPP,SIGDP,BDP)
10977 C**********************************************************************
10979 C calculation of total cross section of two tripe-Pomeron
10980 C graphs in X configuration according to Gribov's Reggeon field
10983 C input: S squared cms energy
10984 C GA coupling constant to elastic line 1
10985 C AA slope related to GA (GeV**-2)
10986 C GB coupling constant to elastic line 2
10987 C BB slope related to GB (GeV**-2)
10988 C DELTA effective pomeron delta (intercept-1)
10989 C ALPHAP slope of pomeron trajectory (GeV**-2)
10990 C BPPP triple-Pomeron coupling
10991 C BTR slope related to B0PPP (GeV**-2)
10992 C note: units of all coupling constants are mb**1/2
10994 C output: SIGDP total cross section for double-Pomeron
10996 C BDP effective double-Pomeron slope
10998 C**********************************************************************
10999 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11002 PARAMETER (EPS =0.0001D0)
11004 C input/output channels
11006 COMMON /POINOU/ LI,LO
11007 C event debugging information
11009 PARAMETER (NMAXD=100)
11010 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11011 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11012 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11013 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11014 C model switches and parameters
11016 INTEGER ISWMDL,IPAMDL
11017 DOUBLE PRECISION PARMDL
11018 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11020 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
11021 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
11022 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
11024 DIMENSION XWGH1(96),XPOS1(96)
11026 C lower integration cut-off Sigma_L
11027 SIGL = PARMDL(71)**2
11028 C upper integration cut-off Sigma_U
11029 C = 1.D0-1.D0/PARMDL(70)**2
11030 C = MAX(PARMDL(72),C)
11031 SIGU = (1.D0-C)**2*S
11032 C integration precision
11036 IF(IDEB(52).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
11037 & 'PHO_TRXPOM: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP',
11038 & S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
11040 IF(SIGU.LE.SIGL) THEN
11051 FAC = (GPPP*GA*GB)**2/(256.D0*PI2)/ALPHAP/GEV2MB**2
11052 ALPHA2 = 2.D0*ALPHAP
11053 ALOC = LOG(1.D0/(1.D0-C))
11054 CALL PHO_GAUSET(XIL,XIU,NGAUS1,XPOS1,XWGH1)
11057 AMXSQ = EXP(XPOS1(I1))
11058 ALOSMX = LOG(S/AMXSQ)
11059 ALCSMX = LOG((1.D0-C)*S/AMXSQ)
11060 W = LOG((AA+BPPP+ALPHA2*ALCSMX)/(BB+BPPP+ALPHA2*ALOC))
11062 WN=(AA+BB+2.D0*BPPP+ALPHA2*ALOSMX)
11063 C supercritical part
11064 WSC = AMXSQ**DELTA*(S/AMXSQ)**(2.D0*DELTA)
11065 XSUM = XSUM + W*XWGH1(I1)/WN*WSC
11070 BDP = 0.5*(AA+BB+BPPP+ALPHAP*XI)
11072 IF(IDEB(52).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
11073 & 'PHO_TRXPOM: ENERGY,SIGDP,BDP',SQRT(S),SIGDP,BDP
11076 *$ CREATE PHO_CHAN2A.FOR
11078 CDECK ID>, PHO_CHAN2A
11079 SUBROUTINE PHO_CHAN2A(BB)
11080 C***********************************************************************
11082 C simple two channel model to realize low mass diffraction
11083 C (version A, iteration of triple- and loop-Pomeron)
11085 C input: BB impact parameter (mb**1/2)
11088 C AMPEL elastic amplitude
11089 C AMPVM(4,4) q-elastic VM production
11090 C AMLMSD(2) low mass single diffraction amplitude
11091 C AMHMSD(2) high mass single diffraction amplitude
11092 C AMLMDD low mass double diffraction amplitude
11093 C AMHMDD high mass double diffraction amplitude
11094 C AMPDP(4) central diffraction amplitude
11096 C***********************************************************************
11097 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11100 PARAMETER (DEPS = 1.D-5,
11103 C input/output channels
11105 COMMON /POINOU/ LI,LO
11106 C event debugging information
11108 PARAMETER (NMAXD=100)
11109 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11110 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11111 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11112 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11113 C model switches and parameters
11115 INTEGER ISWMDL,IPAMDL
11116 DOUBLE PRECISION PARMDL
11117 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11119 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
11120 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
11121 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
11122 C complex Born graph amplitudes used for unitarization
11123 COMPLEX*16 AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
11125 COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
11126 & AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
11127 C unitarized amplitudes for different diffraction channels
11128 DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
11129 & ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
11130 & ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
11132 COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
11133 & ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
11134 & ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
11135 & ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
11136 & ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
11137 & ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
11138 & ZXL(4,4),BXL(4,4)
11139 C Reggeon phenomenology parameters
11140 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
11141 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
11142 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
11143 & ALREG,ALREGP,GR(2),B0REG(2),
11144 & GPPP,GPPR,B0PPP,B0PPR,
11145 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
11146 C parameters of 2x2 channel model
11147 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
11148 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
11149 C global event kinematics and particle IDs
11150 INTEGER IFPAP,IFPAB
11151 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
11152 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
11155 DIMENSION AB(9,4),CHI(4),CHDS(4),CHDH(4),CHDA(4),CHDB(4),
11156 & CHDD(4),CHDPE(4),CHDPA(4),CHDPB(4),CHDPD(4),
11157 & AMPCHA(4),EX1CHI(4),EX2CHI(4),ABSUM(4),AMPELA(4,0:9)
11158 DIMENSION CHIFAC(4,4),EXPFAC(4,4),IELTAB(4,4)
11160 C combinatorical factors
11161 DATA CHIFAC / 1.D0, 1.D0,-1.D0,-1.D0,
11162 & 1.D0,-1.D0, 1.D0,-1.D0,
11163 & 1.D0,-1.D0,-1.D0, 1.D0,
11164 & 1.D0, 1.D0, 1.D0, 1.D0 /
11165 DATA EXPFAC / 1.D0, 1.D0, 1.D0, 1.D0,
11166 & 1.D0,-1.D0,-1.D0, 1.D0,
11167 & -1.D0, 1.D0,-1.D0, 1.D0,
11168 & -1.D0,-1.D0, 1.D0, 1.D0 /
11169 DATA IELTAB / 1, 2, 3, 4,
11174 IF(IDEB(86).GE.20) WRITE(LO,'(1X,A,E12.3)')
11175 & 'PHO_CHAN2A: impact parameter B',BB
11179 AB(1,I) = ZXP(1,I)*EXP(-B24/BXP(1,I))
11180 & +ZXR(1,I)*EXP(-B24/BXR(1,I))
11181 AB(2,I) = ZXH(1,I)*EXP(-B24/BXH(1,I))
11182 AB(3,I) =-ZXT1A(1,I)*EXP(-B24/BXT1A(1,I))
11183 AB(4,I) =-ZXT2A(1,I)*EXP(-B24/BXT2A(1,I))
11184 AB(5,I) =-ZXL(1,I)*EXP(-B24/BXL(1,I))
11185 & -ZXT1B(1,I)*EXP(-B24/BXT1B(1,I))
11186 & -ZXT2B(1,I)*EXP(-B24/BXT2B(1,I))
11187 AB(6,I) = ZXDPE(1,I)*EXP(-B24/BXDPE(1,I))
11188 AB(7,I) = ZXDPA(1,I)*EXP(-B24/BXDPA(1,I))
11189 AB(8,I) = ZXDPB(1,I)*EXP(-B24/BXDPB(1,I))
11190 AB(9,I) = ZXDPD(1,I)*EXP(-B24/BXDPD(1,I))
11196 ABSUM(I) = ABSUM(I) + AB(II,I)
11199 IF(IDEB(86).GE.20) WRITE(LO,'(1X,A,4E12.3)')
11200 & 'PHO_CHAN2A: ABSUM',ABSUM
11217 AMPELA(I,K+4) = 0.D0
11219 CHI(I) = CHI(I) + CHIFAC(K,I)*ABSUM(K)
11220 CHDS(I) = CHDS(I) + CHIFAC(K,I)*AB(1,K)
11221 CHDH(I) = CHDH(I) + CHIFAC(K,I)*AB(2,K)
11222 CHDA(I) = CHDA(I) + CHIFAC(K,I)*AB(3,K)
11223 CHDB(I) = CHDB(I) + CHIFAC(K,I)*AB(4,K)
11224 CHDD(I) = CHDD(I) + CHIFAC(K,I)*AB(5,K)
11225 CHDPE(I) = CHDPE(I) + CHIFAC(K,I)*AB(6,K)
11226 CHDPA(I) = CHDPA(I) + CHIFAC(K,I)*AB(7,K)
11227 CHDPB(I) = CHDPB(I) + CHIFAC(K,I)*AB(8,K)
11228 CHDPD(I) = CHDPD(I) + CHIFAC(K,I)*AB(9,K)
11230 IF(CHI(I).LT.-DEPS) THEN
11231 IF(IDEB(86).GE.0) THEN
11232 WRITE(LO,'(1X,A,I3,2E12.3)')
11233 & 'PHO_CHAN2A: neg.eigenvalue (I,B,CHI)',I,BB,CHI(I)
11234 WRITE(LO,'(5X,A,5E12.3)') 'E,CHIs:',ECM,(ABSUM(K),K=1,4)
11237 IF(ABS(CHI(I)).GT.200.D0) THEN
11243 EX2CHI(I) = TMP*TMP
11246 IF(IDEB(86).GE.20) THEN
11247 WRITE(LO,'(1X,A,4E12.3)') 'PHO_CHAN2A: EX1CHI',EX1CHI
11253 CFAC = 2.D0*EXPFAC(J,K)*EX2CHI(J)
11254 AMPELA(K,0) = AMPELA(K,0) - EXPFAC(J,K)*EX1CHI(J)
11255 AMPELA(K,1) = AMPELA(K,1) + CFAC*CHDS(J)
11256 AMPELA(K,2) = AMPELA(K,2) + CFAC*CHDH(J)
11257 AMPELA(K,3) = AMPELA(K,3) - CFAC*CHDA(J)
11258 AMPELA(K,4) = AMPELA(K,4) - CFAC*CHDB(J)
11259 AMPELA(K,5) = AMPELA(K,5) - CFAC*CHDD(J)
11260 AMPELA(K,6) = AMPELA(K,6) + CFAC*CHDPE(J)
11261 AMPELA(K,7) = AMPELA(K,7) + CFAC*CHDPA(J)
11262 AMPELA(K,8) = AMPELA(K,8) + CFAC*CHDPB(J)
11263 AMPELA(K,9) = AMPELA(K,9) + CFAC*CHDPD(J)
11267 IF(IDEB(86).GE.25) THEN
11269 WRITE(LO,'(1X,A,I3,4E10.3)') 'PHO_CHAN2A: AMPELA(1-4,I)',I,
11270 & (AMPELA(K,1),K=1,4)
11274 C VDM factors --> amplitudes
11275 C low mass excitations
11279 AMPCHA(I) = AMPCHA(I) + AMPFAC(K)*AMPELA(IELTAB(K,I),0)
11282 AMPVME = AMPCHA(1)/EIGHT
11283 AMLMSD(1) = AMPCHA(2)/EIGHT
11284 AMLMSD(2) = AMPCHA(3)/EIGHT
11285 AMLMDD = AMPCHA(4)/EIGHT
11286 C elastic part, high mass diffraction
11287 AMPEL = 0.5D0*ZXD(1,1)*EXP(-B24/BXD(1,1))
11298 AMPEL = AMPEL + ELAFAC(I)*AMPELA(I,0)/8.D0
11299 AMPSOF = AMPSOF + ELAFAC(I)*AMPELA(I,1)
11300 AMPHAR = AMPHAR + ELAFAC(I)*AMPELA(I,2)
11301 AMHMSD(1) = AMHMSD(1) + ELAFAC(I)*AMPELA(I,3)
11302 AMHMSD(2) = AMHMSD(2) + ELAFAC(I)*AMPELA(I,4)
11303 AMHMDD = AMHMDD + ELAFAC(I)*AMPELA(I,5)
11304 AMPDP(1) = AMPDP(1) + ELAFAC(I)*AMPELA(I,6)
11305 AMPDP(2) = AMPDP(2) + ELAFAC(I)*AMPELA(I,7)
11306 AMPDP(3) = AMPDP(3) + ELAFAC(I)*AMPELA(I,8)
11307 AMPDP(4) = AMPDP(4) + ELAFAC(I)*AMPELA(I,9)
11309 AMPSOF = AMPSOF/16.D0
11310 AMPHAR = AMPHAR/16.D0
11311 AMHMSD(1) = AMHMSD(1)/16.D0
11312 AMHMSD(2) = AMHMSD(2)/16.D0
11313 AMHMDD = AMHMDD/16.D0
11314 AMPDP(1) = AMPDP(1)/16.D0
11315 AMPDP(2) = AMPDP(2)/16.D0
11316 AMPDP(3) = AMPDP(3)/16.D0
11317 AMPDP(4) = AMPDP(4)/16.D0
11318 IF(DREAL(AMHMSD(1)).LE.0.D0) AMHMSD(1) = 0.D0
11319 IF(DREAL(AMHMSD(2)).LE.0.D0) AMHMSD(2) = 0.D0
11320 IF(DREAL(AMHMDD).LE.0.D0) AMHMDD = 0.D0
11321 IF(DREAL(AMPDP(1)).LE.0.D0) AMPDP(1) = 0.D0
11322 IF(DREAL(AMPDP(2)).LE.0.D0) AMPDP(2) = 0.D0
11323 IF(DREAL(AMPDP(3)).LE.0.D0) AMPDP(3) = 0.D0
11324 IF(DREAL(AMPDP(4)).LE.0.D0) AMPDP(4) = 0.D0
11326 C vector-meson production, weight factors
11327 IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22)) THEN
11328 IF(IFPAP(1).EQ.22) THEN
11329 IF(IFPAP(2).EQ.22) THEN
11332 AMPVM(I,J) = PARMDL(9+I)*PARMDL(9+J)*AMPVME
11336 AMPVM(1,1) = PARMDL(10)*AMPVME
11337 AMPVM(2,1) = PARMDL(11)*AMPVME
11338 AMPVM(3,1) = PARMDL(12)*AMPVME
11339 AMPVM(4,1) = PARMDL(13)*AMPVME
11341 ELSE IF(IFPAP(2).EQ.22) THEN
11342 AMPVM(1,1) = PARMDL(10)*AMPVME
11343 AMPVM(1,2) = PARMDL(11)*AMPVME
11344 AMPVM(1,3) = PARMDL(12)*AMPVME
11345 AMPVM(1,4) = PARMDL(13)*AMPVME
11349 IF(IDEB(86).GE.5) THEN
11350 WRITE(LO,'(/,1X,A)')
11351 & 'PHO_CHAN2A: impact parameter amplitudes'
11352 WRITE(LO,'(1X,A,1P,2E12.3)') ' AMPEL',AMPEL
11353 WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(1,1-4)',(AMPVM(1,K),K=1,4)
11354 WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(2,1-4)',(AMPVM(2,K),K=1,4)
11355 WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(3,1-4)',(AMPVM(3,K),K=1,4)
11356 WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(4,1-4)',(AMPVM(4,K),K=1,4)
11357 WRITE(LO,'(1X,A,1P,4E12.3)') ' AMPSOF/HAR',AMPSOF,AMPHAR
11358 WRITE(LO,'(1X,A,1P,4E12.3)') ' AMLMSD',AMLMSD
11359 WRITE(LO,'(1X,A,1P,4E12.3)') ' AMHMSD',AMHMSD
11360 WRITE(LO,'(1X,A,1P,2E12.3)') ' AMLMDD',AMLMDD
11361 WRITE(LO,'(1X,A,1P,2E12.3)') ' AMHMDD',AMHMDD
11362 WRITE(LO,'(1X,A,1P,8E10.3)') ' AMPDP(1-4)',AMPDP
11367 *$ CREATE PHO_EVENT.FOR
11369 CDECK ID>, PHO_EVENT
11370 SUBROUTINE PHO_EVENT(NEV,P1,P2,FAC,IREJ)
11371 C********************************************************************
11373 C main subroutine to manage simulation processes
11375 C input: NEV -1 initialization
11376 C 1 generation of events
11377 C 2 generation of events without rejection
11378 C due to energy dependent cross section
11379 C 3 generation of events without rejection
11380 C using initialization energy
11381 C -2 output of event generation statistics
11382 C P1(4) momentum of particle 1 (internal TARGET)
11383 C P2(4) momentum of particle 2 (internal PROJECTILE)
11384 C FAC used for initialization:
11385 C contains cross section the events corresponds to
11386 C during generation: current cross section
11388 C output: IREJ 0: event accepted
11389 C 1: event rejected
11391 C********************************************************************
11392 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11395 PARAMETER ( TINY = 1.D-10 )
11397 DIMENSION P1(4),P2(4)
11399 C input/output channels
11401 COMMON /POINOU/ LI,LO
11402 C event debugging information
11404 PARAMETER (NMAXD=100)
11405 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11406 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11407 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11408 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11409 C model switches and parameters
11411 INTEGER ISWMDL,IPAMDL
11412 DOUBLE PRECISION PARMDL
11413 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11414 C general process information
11415 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
11416 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
11417 C internal rejection counters
11419 PARAMETER (NMXJ=60)
11420 CHARACTER*10 REJTIT
11422 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
11423 C gamma-lepton or gamma-hadron vertex information
11424 INTEGER IGHEL,IDPSRC,IDBSRC
11425 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
11426 & RADSRC,AMSRC,GAMSRC
11427 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
11428 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
11429 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
11430 C global event kinematics and particle IDs
11431 INTEGER IFPAP,IFPAB
11432 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
11433 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
11435 INTEGER IPFIL,IFAFIL,IFBFIL
11436 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
11437 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
11438 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
11439 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
11440 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
11441 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
11442 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
11443 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
11444 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
11445 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
11446 & IPFIL,IFAFIL,IFBFIL
11447 C event weights and generated cross section
11448 INTEGER IPOWGC,ISWCUT,IVWGHT
11449 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
11450 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
11451 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
11452 C names of hard scattering processes
11454 PARAMETER ( Max_pro_1 = 16 )
11456 COMMON /POHPRO/ PROC(0:Max_pro_1)
11457 C hard cross sections and MC selection weights
11459 PARAMETER ( Max_pro_2 = 16 )
11460 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
11461 & MH_acc_1,MH_acc_2
11462 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
11463 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
11464 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
11465 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
11466 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
11467 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
11468 C table of particle indices for recursive PHOJET calls
11470 PARAMETER ( MAXIPX = 100 )
11471 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
11472 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
11473 & IPOIX1,IPOIX2,IPOIX3
11475 DIMENSION IPRSAM(10),IPRACC(10),IENACC(10),IDNS(4),IDNA(4)
11481 WRITE(LO,'(/3(/1X,A))')
11482 & '=======================================================',
11483 & ' ------- initialization of event generation --------',
11484 & '======================================================='
11485 CALL PHO_SETMDL(0,0,-2)
11486 C amplitude parameters
11488 CALL PHO_REJSTA(-1)
11489 C initialize MC package
11490 CALL PHO_EVEINI(1,P1,P2,JM1,JM2)
11492 CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
11494 CALL PHO_PARTON(-1,0,0,P1,P2,IREJ)
11528 ELSE IF(NEV.GT.0) THEN
11530 C -------------- begin event generation ---------------
11533 IF(NEV.EQ.3) IPAMDL(13) = 1
11536 CALL PHO_TRACE(0,0,0)
11537 IF(IDEB(68).GE.2) THEN
11538 IF((MOD(KEVENT,50).EQ.0).OR.(IDEB(68).GE.3))
11539 & WRITE(LO,'(1X,A,2I12)') 'call to PHO_EVENT no',KEVENT,KACCEP
11541 CALL PHO_EVEINI(0,P1,P2,JM1,JM2)
11542 C cross section calculation
11545 IF(IVWGHT(1).EQ.1) THEN
11546 WG = EVWGHT(1)*SIGGEN(3)/SIGGEN(4)
11548 WG = SIGGEN(3)/SIGGEN(4)
11550 IF(DT_RNDM(FAC).GT.WG) THEN
11552 IF(IDEB(68).GE.6) THEN
11553 WRITE(LO,'(1X,2A,/5X,2I10,6X,1P3E10.3)')
11554 & 'PHO_EVENT: rejection due to cross section',
11555 & ' (CALL/ACC/EVWGHT(1)/SIG/SIGMAX)',
11556 & KEVENT,KACCEP,EVWGHT(1),SIGGEN(3),SIGGEN(4)
11557 CALL PHO_PREVNT(-1)
11563 SIGGEN(1) = SIGGEN(4)*DBLE(KEVGEN)/DBLE(KEVENT)
11564 HSWGHT(0) = MAX(1.D0,WG)
11569 IF(ITRY1.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
11573 CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
11575 IF(IPROCE.EQ.0) THEN
11576 IF(IDEB(68).GE.4) WRITE(LO,'(1X,A)') 'PHO_EVENT: ',
11577 & 'rejection by PHO_SAMPRO (call,Ecm)',KEVENT,ECM
11581 C sampling statistics
11582 IPRSAM(IPROCE) = IPRSAM(IPROCE)+1
11587 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
11588 C sample number of cut graphs according to IPROCE and
11589 C generate parton configurations+strings
11590 CALL PHO_PARTON(IPROCE,JM1,JM2,P1,P2,IREJ)
11591 C collect statistics
11595 ISTS = ISTS+KSTRG+KHTRG
11596 ISLS = ISLS+KSLOO+KHLOO
11597 IDIS = IDIS+MIN(KHDIR,1)
11598 IDPS = IDPS+KHDPO+KSDPO
11599 IF((IDIFR1+IDIFR2+IDDPOM.EQ.0).AND.(KHDIR.GT.0))
11600 & IDNS(KHDIR) = IDNS(KHDIR)+1
11603 IF(IDEB(68).GE.4) THEN
11604 WRITE(LO,'(/1X,A,2I5)')
11605 & 'PHO_EVENT: rejection by PHO_PARTON',ITRY2,IREJ
11606 CALL PHO_PREVNT(-1)
11608 IF((IREJ.EQ.50).AND.(NEV.EQ.1)) THEN
11611 IFAIL(1) = IFAIL(1)+1
11612 IF(ITRY1.GT.5) RETURN
11614 IF(ISWMDL(2).EQ.0) RETURN
11617 IF(ITRY2.LT.5) GOTO 60
11620 C fragmentation of strings
11621 C FSR and string fragmentation is done separately by DPMJET routines
11622 C CALL PHO_STRFRA(IREJ)
11625 IFAIL(23) = IFAIL(23)+1
11626 IF(IDEB(68).GE.4) THEN
11627 WRITE(LO,'(/1X,A,2I5)')
11628 & 'PHO_EVENT: rejection by PHO_STRFRA',ITRY2,IREJ
11629 CALL PHO_PREVNT(-1)
11633 C check of conservation of quantum numbers
11634 IF(IDEB(68).GE.-5) THEN
11635 CALL PHO_CHECK(-1,IREJ)
11636 IF(IREJ.NE.0) GOTO 50
11638 C event now completely processed and accepted
11639 C acceptance statistics
11640 IPRACC(IPROCE) = IPRACC(IPROCE)+1
11644 ISTA = ISTA+(KSTRG+KHTRG)
11645 ISLA = ISLA+(KSLOO+KHLOO)
11646 IDIA = IDIA+MIN(KHDIR,1)
11647 IDPA = IDPA+KHDPO+KSDPO
11648 IF((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GT.0))
11649 & IDNA(KHDIR) = IDNA(KHDIR)+1
11651 IENACC(IPORES(I)) = IENACC(IPORES(I))+1
11655 C debug output (partial / full event listing)
11656 if((IDEB(68).eq.1).and.(MOD(KACCEP,50).EQ.0))
11657 & WRITE(LO,'(1X,A,2I12)') 'call to PHO_EVENT no',KEVENT,KACCEP
11658 IF(IDEB(67).GE.10) THEN
11659 IF(IDEB(67).LE.15) THEN
11660 CALL PHO_PREVNT(-1)
11661 ELSE IF(IDEB(67).LE.20) THEN
11663 ELSE IF(IDEB(67).LE.25) THEN
11672 IF(IPOWGC(I).GT.0) THEN
11673 HSWGHT(0) = HSWGHT(0)*HSWGHT(I)
11676 IF(IVWGHT(1).EQ.1) THEN
11678 IF(WG.GT.1.01D0) THEN
11679 IF(EVWGHT(1).LT.1.01D0) THEN
11680 WRITE(LO,'(1X,A,2I12,1PE12.3)')
11681 & 'PHO_EVENT: cross section weight > 1',
11683 WRITE(LO,'(5X,A,1P3E11.3)') 'SIGCUR,SIGMAX,EVWGHT(1):',
11684 & SIGGEN(3),SIGGEN(4),EVWGHT(1)
11686 EVWGHT(1) = HSWGHT(0)
11693 C effective cross section
11694 SIGGEN(2) = SIGGEN(4)*DBLE(KACCEP)/DBLE(KEVENT)
11695 ECMSUM = ECMSUM+ECM
11696 SIGGEN(3) = SIGGEN(3)*HSWGHT(0)
11697 ELSE IF(NEV.EQ.-2) THEN
11699 C ---------------- end of event generation ----------------------
11701 WRITE(LO,'(/3(/1X,A),//1X,A,3I12,/1X,A,F12.1)')
11702 & '====================================================',
11703 & ' --------- summary of event generation ----------',
11704 & '====================================================',
11705 & 'called,generated,accepted events:',KEVENT,KEVGEN,KACCEP,
11706 & 'average CMS energy:',ECMSUM/DBLE(MAX(1,KACCEP))
11708 C write out statistics
11709 IF(KACCEP.GT.0) THEN
11711 FAC1 = SIGGEN(4)/DBLE(KEVENT)
11712 FAC2 = FAC/DBLE(KACCEP)
11713 WRITE(LO,'(/1X,A,/1X,A)')
11714 & 'PHO_EVENT: generated and accepted events',
11715 & '----------------------------------------'
11717 & 'process, sampled, accepted, cross section (internal/external)'
11718 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'non.diff.',IPRSAM(1),
11719 & IPRACC(1),DBLE(IPRACC(1))*FAC1,DBLE(IPRACC(1))*FAC2
11720 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'elas sca.',IPRSAM(2),
11721 & IPRACC(2),DBLE(IPRACC(2))*FAC1,DBLE(IPRACC(2))*FAC2
11722 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'qela sca.',IPRSAM(3),
11723 & IPRACC(3),DBLE(IPRACC(3))*FAC1,DBLE(IPRACC(3))*FAC2
11724 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.pom.',IPRSAM(4),
11725 & IPRACC(4),DBLE(IPRACC(4))*FAC1,DBLE(IPRACC(4))*FAC2
11726 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'diff.par1',IPRSAM(5),
11727 & IPRACC(5),DBLE(IPRACC(5))*FAC1,DBLE(IPRACC(5))*FAC2
11728 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'diff.par2',IPRSAM(6),
11729 & IPRACC(6),DBLE(IPRACC(6))*FAC1,DBLE(IPRACC(6))*FAC2
11730 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.dif.',IPRSAM(7),
11731 & IPRACC(7),DBLE(IPRACC(7))*FAC1,DBLE(IPRACC(7))*FAC2
11732 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir all ',IPRSAM(8),
11733 & IPRACC(8),DBLE(IPRACC(8))*FAC1,DBLE(IPRACC(8))*FAC2
11734 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir X res',IDNS(1),IDNA(1),
11735 & DBLE(IDNA(1))*FAC1,DBLE(IDNA(1))*FAC2
11736 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'res X dir',IDNS(2),IDNA(2),
11737 & DBLE(IDNA(2))*FAC1,DBLE(IDNA(2))*FAC2
11738 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir X dir',IDNS(3),IDNA(3),
11739 & DBLE(IDNA(3))*FAC1,DBLE(IDNA(3))*FAC2
11740 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'soft pom.',ISPS,ISPA,
11741 & DBLE(ISPA)*FAC1,DBLE(ISPA)*FAC2
11742 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'hard pom.',IHPS,IHPA,
11743 & DBLE(IHPA)*FAC1,DBLE(IHPA)*FAC2
11744 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'soft reg.',ISRS,ISRA,
11745 & DBLE(ISRA)*FAC1,DBLE(ISRA)*FAC2
11746 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'enh. trg.',ISTS,ISTA,
11747 & DBLE(ISTA)*FAC1,DBLE(ISTA)*FAC2
11748 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'enh. log.',ISLS,ISLA,
11749 & DBLE(ISLA)*FAC1,DBLE(ISLA)*FAC2
11750 WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.pom.',IDPS,IDPA,
11751 & DBLE(IDPA)*FAC1,DBLE(IDPA)*FAC2
11752 IF(ISWMDL(14).GT.0) THEN
11753 WRITE(LO,'(3X,A,I3)') 'recursive pomeron splitting:',
11755 WRITE(LO,'(5X,A,I12)') '1->2pom-cut :',IENACC(8)
11756 WRITE(LO,'(5X,A,I12)') '1->doub-pom :',IENACC(4)
11757 WRITE(LO,'(5X,A,I12)') '1->diff-dis1:',IENACC(5)
11758 WRITE(LO,'(5X,A,I12)') '1->diff-dis2:',IENACC(6)
11759 WRITE(LO,'(5X,A,I12)') '1->doub-diff:',IENACC(7)
11761 WRITE(LO,'(2(/1X,A,1PE12.3)/)') ' sampled cross section (mb)',
11762 & SIGGEN(1),'accepted cross section (mb)',SIGGEN(2)
11764 CALL PHO_REJSTA(-2)
11765 CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
11767 CALL PHO_PARTON(-2,0,0,P1,P2,IREJ)
11768 C statistics of hard scattering processes
11769 WRITE(LO,'(2(/1X,A))')
11770 & 'PHO_EVENT: statistics of hard scattering processes',
11771 & '--------------------------------------------------'
11773 IF(MH_tried(0,K).GT.0) THEN
11774 WRITE(LO,'(/5X,A,I3)')
11775 & 'process (accepted,x-section internal/external) for IP:',K
11776 DO 47 M=0,Max_pro_2
11777 WRITE(LO,'(1X,I3,1X,A,2X,2I12,1P2E13.3)') M,PROC(M),
11778 & MH_tried(M,K),MH_acc_1(M,K),DBLE(MH_acc_1(M,K))*FAC1,
11779 & DBLE(MH_acc_2(M,K))*FAC2
11785 WRITE(LO,'(/1X,A,I4,/)') 'no output of statistics',KEVENT
11787 WRITE(LO,'(/3(/1X,A)/)')
11788 & '======================================================',
11789 & ' ------- end of event generation summary --------',
11790 & '======================================================'
11792 WRITE(LO,'(/1X,A,I7)') 'PHO_EVENT:ERROR: unsupported NEV',NEV
11797 *$ CREATE PHO_PARTON.FOR
11799 CDECK ID>, PHO_PARTON
11800 SUBROUTINE PHO_PARTON(IPROC,JM1,JM2,P1,P2,IREJ)
11801 C********************************************************************
11803 C calculation of complete parton configuration
11805 C input: IPROC process ID 1 nondiffractive
11807 C 3 quasi-ela. rho,omega,phi prod.
11811 C 7 double diff diss.
11812 C 8 single-resolved / direct photon
11813 C JM1,2 index of mother particles in /POEVT1/
11816 C output: complete parton configuration in /POEVT1/
11819 C 50 rejection due to user cutoffs
11821 C********************************************************************
11822 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11825 DIMENSION P1(4),P2(4)
11827 PARAMETER ( TINY = 1.D-10 )
11829 C input/output channels
11831 COMMON /POINOU/ LI,LO
11832 C event debugging information
11834 PARAMETER (NMAXD=100)
11835 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11836 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11837 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11838 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11839 PARAMETER (NMXHEP=4000)
11840 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
11841 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
11842 & VHEP(4,NMXHEP), NSD1, NSD2, NDD
11844 C model switches and parameters
11846 INTEGER ISWMDL,IPAMDL
11847 DOUBLE PRECISION PARMDL
11848 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11849 C table of particle indices for recursive PHOJET calls
11851 PARAMETER ( MAXIPX = 100 )
11852 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
11853 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
11854 & IPOIX1,IPOIX2,IPOIX3
11855 C general process information
11856 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
11857 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
11858 C global event kinematics and particle IDs
11859 INTEGER IFPAP,IFPAB
11860 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
11861 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
11863 INTEGER IPFIL,IFAFIL,IFBFIL
11864 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
11865 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
11866 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
11867 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
11868 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
11869 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
11870 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
11871 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
11872 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
11873 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
11874 & IPFIL,IFAFIL,IFBFIL
11875 C event weights and generated cross section
11876 INTEGER IPOWGC,ISWCUT,IVWGHT
11877 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
11878 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
11879 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
11880 C internal rejection counters
11882 PARAMETER (NMXJ=60)
11883 CHARACTER*10 REJTIT
11885 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
11888 C clear event statistics
11902 C-------------------------------------------------------------------
11903 C nondiffractive resolved processes
11905 IF(IPROC.EQ.1) THEN
11906 C sample number of interactions
11910 C generate only hard events
11911 IF(ISWMDL(2).EQ.0) THEN
11918 C minimum bias events
11921 CALL PHO_SAMPRB(ECM,IP,IINT,JINT,KINT)
11922 IPOWGC(1) = IPOWGC(1)+1
11928 C resolved soft processes: pomeron and reggeon
11931 C resolved hard process: hard pomeron
11933 C resolved absorptive corrections
11936 C restrictions given by user
11937 IF(MSPOM.LT.ISWCUT(1)) GOTO 10
11938 IF(MSREG.LT.ISWCUT(2)) GOTO 10
11939 IF(MHPOM.LT.ISWCUT(3)) GOTO 10
11940 HSWGHT(1) = 1.D0/DBLE(IPOWGC(1))
11941 C ----------------------------
11942 IF(ISWMDL(15).EQ.0) THEN
11944 IF(MSREG.GT.0) THEN
11951 ELSE IF(ISWMDL(15).EQ.1) THEN
11952 IF(MHPOM.GT.0) THEN
11956 ELSE IF(MSPOM.GT.0) THEN
11962 ELSE IF(ISWMDL(15).EQ.2) THEN
11963 MHPOM = MIN(1,MHPOM)
11964 ELSE IF(ISWMDL(15).EQ.3) THEN
11965 MSPOM = MIN(1,MSPOM)
11968 C ----------------------------
11977 IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,I7,6I4)')
11978 & 'PHO_PARTON: EV,SP,SR,HP,HD,ET,EL',
11979 & KEVENT,MSPOM,MSREG,MHPOM,MHDIR,MPTRI,MPLOO
11984 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
11992 CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
11994 IF(IREJ.EQ.50) RETURN
11995 IF(IDEB(3).GE.2) THEN
11996 WRITE(LO,'(/1X,A,I5)')
11997 & 'PHO_PARTON: rejection by PHO_STDPAR ',ITRY2
11998 CALL PHO_PREVNT(-1)
12002 IF(MHPOM.GT.0) THEN
12004 ELSE IF(MSPOM.GT.0) THEN
12009 C check of quantum numbers of parton configurations
12010 IF(IDEB(3).GE.0) THEN
12011 CALL PHO_CHECK(1,IREJ)
12012 IF(IREJ.NE.0) GOTO 50
12014 C sample strings to prepare fragmentation
12015 CALL PHO_STRING(1,IREJ)
12017 IF(IREJ.EQ.50) RETURN
12018 IFAIL(30) = IFAIL(30)+1
12019 IF(IDEB(3).GE.2) THEN
12020 WRITE(LO,'(/1X,A,I5)')
12021 & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
12022 CALL PHO_PREVNT(-1)
12024 IF(ITRY2.LT.20) GOTO 50
12025 IF(IDEB(3).GE.1) THEN
12026 WRITE(LO,'(/1X,A,I5)')
12027 & 'PHO_PARTON: rejection',ITRY2
12028 CALL PHO_PREVNT(-1)
12040 C-------------------------------------------------------------------
12041 C elastic scattering / quasi-elastic rho/omega/phi production
12043 ELSE IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
12044 IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,I4)')
12045 & 'PHO_PARTON: ela./q-ela.sca:(EV,IPROC)',KEVENT,IPROC
12047 C DPMJET call with special projectile / target: transform into CMS
12048 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12049 & CALL PHO_DFWRAP(1,JM1,JM2)
12051 CALL PHO_QELAST(IPROC,JM1,JM2,IREJ)
12054 C DPMJET call with special projectile / target: clean up
12055 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12056 & CALL PHO_DFWRAP(-2,JM1,JM2)
12057 IF(IDEB(3).GE.2) THEN
12058 WRITE(LO,'(/1X,A,I5)')
12059 & 'PHO_PARTON: rejection by PHO_QELAST',IREJ
12060 CALL PHO_PREVNT(-1)
12065 C DPMJET call with special projectile / target: transform back
12066 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12067 & CALL PHO_DFWRAP(2,JM1,JM2)
12069 C prepare possible decays
12070 CALL PHO_STRING(1,IREJ)
12072 IF(IREJ.EQ.50) RETURN
12073 IFAIL(30) = IFAIL(30)+1
12077 C---------------------------------------------------------------------
12078 C double Pomeron scattering
12080 ELSE IF(IPROC.EQ.4) THEN
12083 IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10)')
12084 & 'PHO_PARTON: EV,double-pomeron scattering',KEVENT
12089 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12091 CALL PHO_CDIFF(JM1,JM2,MSOFT,MHARD,1,IREJ)
12093 IF(IDEB(3).GE.2) THEN
12094 WRITE(LO,'(/1X,A,I5)')
12095 & 'PHO_PARTON: rejection by PHO_CDIFF',IREJ
12096 CALL PHO_PREVNT(-1)
12100 C check of quantum numbers of parton configurations
12101 IF(IDEB(3).GE.0) THEN
12102 CALL PHO_CHECK(1,IREJ)
12103 IF(IREJ.NE.0) GOTO 60
12105 C sample strings to prepare fragmentation
12106 CALL PHO_STRING(1,IREJ)
12108 IF(IREJ.EQ.50) RETURN
12109 IFAIL(30) = IFAIL(30)+1
12110 IF(IDEB(3).GE.2) THEN
12111 WRITE(LO,'(/1X,A,I5)')
12112 & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
12113 CALL PHO_PREVNT(-1)
12115 IF(ITRY2.LT.10) GOTO 60
12116 WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
12117 CALL PHO_PREVNT(-1)
12122 C-----------------------------------------------------------------------
12123 C single / double diffraction dissociation
12125 ELSE IF((IPROC.GE.5).AND.(IPROC.LE.7)) THEN
12128 IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,2I4)')
12129 & 'PHO_PARTON: EV,diffraction',KEVENT,IPAR1,IPAR2
12130 IF(IPROC.EQ.5) ID1S = ID1S+1
12131 IF(IPROC.EQ.6) ID2S = ID2S+1
12132 IF(IPROC.EQ.7) ID3S = ID3S+1
12136 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12139 IF(IPROC.EQ.5) IPAR2 = 0
12140 IF(IPROC.EQ.6) IPAR1 = 0
12141 C calculate rapidity gap survival probability
12143 IF(ECM.GT.10.D0) THEN
12144 IF((IPAR1.GE.1).AND.(IPAR2.EQ.0)) THEN
12145 IF(SIGTR1(1).LT.1.D-10) THEN
12148 SPROB = SIGHSD(1)/(SIGTR1(1)-2.D0*(SIGDPO(1)+SIGDPO(2)))
12150 ELSE IF((IPAR1.EQ.0).AND.(IPAR2.GE.1)) THEN
12151 IF(SIGTR2(1).LT.1.D-10) THEN
12154 SPROB = SIGHSD(2)/(SIGTR2(1)-2.D0*(SIGDPO(1)+SIGDPO(3)))
12156 ELSE IF((IPAR1.GE.1).AND.(IPAR2.GE.1)) THEN
12157 IF(SIGLOO.LT.1.D-10) THEN
12160 SPROB = SIGHDD/SIGLOO
12165 * temporary patch, r.e. 8.6.99
12169 C DPMJET call with special projectile / target: transform into CMS
12170 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12171 & CALL PHO_DFWRAP(1,JM1,JM2)
12173 CALL PHO_DIFDIS(IPAR1,IPAR2,JM1,JM2,SPROB,0,MSOFT,MHARD,IREJ)
12176 C DPMJET call with special projectile / target: clean up
12177 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12178 & CALL PHO_DFWRAP(-2,JM1,JM2)
12179 IF(IDEB(3).GE.2) THEN
12180 WRITE(LO,'(/1X,A,I5)')
12181 & 'PHO_PARTON: rejection by PHO_DIFDIS',IREJ
12182 CALL PHO_PREVNT(-1)
12187 C DPMJET call with special projectile / target: transform back
12188 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12189 & CALL PHO_DFWRAP(2,JM1,JM2)
12191 C check of quantum numbers of parton configurations
12192 IF(IDEB(3).GE.0) THEN
12193 CALL PHO_CHECK(1,IREJ)
12194 IF(IREJ.NE.0) GOTO 70
12196 C sample strings to prepare fragmentation
12197 CALL PHO_STRING(1,IREJ)
12199 IF(IREJ.EQ.50) RETURN
12200 IFAIL(30) = IFAIL(30)+1
12201 IF(IDEB(3).GE.2) THEN
12202 WRITE(LO,'(/1X,A,I5)')
12203 & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
12204 CALL PHO_PREVNT(-1)
12206 IF(ITRY2.LT.10) GOTO 70
12207 WRITE(LO,'(/1X,A,I5)')
12208 & 'PHO_PARTON: rejection',ITRY2
12209 CALL PHO_PREVNT(-1)
12212 IF(IPROC.EQ.5) THEN
12216 IF(IPROC.EQ.6) THEN
12220 IF(IPROC.EQ.7) THEN
12224 C-----------------------------------------------------------------------
12225 C single / double direct processes
12227 ELSE IF(IPROC.EQ.8) THEN
12232 IF(IDEB(3).GE.5) THEN
12233 WRITE(LO,'(1X,A,I10)') 'PHO_PARTON: EV,direct proc',KEVENT
12239 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12245 CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
12247 IF(IREJ.EQ.50) RETURN
12248 IF(IDEB(3).GE.2) THEN
12249 WRITE(LO,'(/1X,A,I5)')
12250 & 'PHO_PARTON: rejection by PHO_STDPAR',ITRY2
12251 CALL PHO_PREVNT(-1)
12256 C check of quantum numbers of parton configurations
12257 IF(IDEB(3).GE.0) THEN
12258 CALL PHO_CHECK(1,IREJ)
12259 IF(IREJ.NE.0) GOTO 80
12261 C sample strings to prepare fragmentation
12262 CALL PHO_STRING(1,IREJ)
12264 IF(IREJ.EQ.50) RETURN
12265 IFAIL(30) = IFAIL(30)+1
12266 IF(IDEB(3).GE.2) THEN
12267 WRITE(LO,'(/1X,A,I5)')
12268 & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
12269 CALL PHO_PREVNT(-1)
12271 IF(ITRY2.LT.10) GOTO 80
12272 WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
12273 CALL PHO_PREVNT(-1)
12276 IF(IPROC.EQ.5) THEN
12280 IF(IPROC.EQ.6) THEN
12284 IF(IPROC.EQ.7) THEN
12290 C-----------------------------------------------------------------------
12291 C initialize control statistics
12293 ELSE IF(IPROC.EQ.-1) THEN
12294 CALL PHO_SAMPRB(ECM,-1,0,0,0)
12295 CALL PHO_STDPAR(-1,0,0,0,0,0,0,IREJ)
12296 CALL PHO_SEAFLA(-1,0,0,DUM)
12297 IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
12298 & CALL PHO_QELAST(-1,1,2,0)
12319 CALL PHO_STRING(-1,IREJ)
12320 CALL PHO_DIFDIS(0,0,0,0,0.D0,-1,0,0,IREJ)
12323 C-----------------------------------------------------------------------
12324 C produce statistics summary
12326 ELSE IF(IPROC.EQ.-2) THEN
12327 IF(ISWMDL(2).NE.0) CALL PHO_SAMPRB(ECM,-2,0,0,0)
12328 IF(IDEB(3).GE.0) THEN
12329 WRITE(LO,'(/1X,A,/1X,A)')
12330 & 'PHO_PARTON: internal statistics on parton configurations',
12331 & '--------------------------------------------------------'
12332 WRITE(LO,'(5X,A)') 'process sampled accepted'
12333 WRITE(LO,'(5X,A,2I12)') 'soft pom.',ISPS,ISPA
12334 WRITE(LO,'(5X,A,2I12)') 'hard pom.',IHPS,IHPA
12335 WRITE(LO,'(5X,A,2I12)') 'soft reg.',ISRS,ISRA
12336 WRITE(LO,'(5X,A,2I12)') 'enh. tri.',ISTS,ISTA
12337 WRITE(LO,'(5X,A,2I12)') 'enh. loo.',ISLS,ISLA
12338 WRITE(LO,'(5X,A,2I12)') 'diff.pa1.',ID1S,ID1A
12339 WRITE(LO,'(5X,A,2I12)') 'diff.pa2.',ID2S,ID2A
12340 WRITE(LO,'(5X,A,2I12)') 'doub.dif.',ID3S,ID3A
12341 WRITE(LO,'(5X,A,2I12)') 'doub.pom.',IDPS,IDPA
12342 WRITE(LO,'(5X,A,2I12/)') 'dir.phot.',IDIS,IDIA
12344 CALL PHO_STDPAR(-2,0,0,0,0,0,0,IREJ)
12345 IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
12346 & CALL PHO_QELAST(-2,1,2,0)
12347 CALL PHO_STRING(-2,IREJ)
12348 CALL PHO_DIFDIS(0,0,0,0,0.D0,-2,0,0,IREJ)
12349 CALL PHO_SEAFLA(-2,0,0,DUM)
12352 WRITE(LO,'(1X,A,I2)')
12353 & 'PARTON:ERROR: unknown process ID ',IPROC
12359 *$ CREATE PHO_MCINI.FOR
12361 CDECK ID>, PHO_MCINI
12362 SUBROUTINE PHO_MCINI
12363 C********************************************************************
12365 C initialization of MC event generation
12367 C********************************************************************
12368 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12371 PARAMETER ( PIMASS = 0.13D0,
12374 C input/output channels
12376 COMMON /POINOU/ LI,LO
12377 C event debugging information
12379 PARAMETER (NMAXD=100)
12380 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12381 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12382 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12383 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12384 C model switches and parameters
12386 INTEGER ISWMDL,IPAMDL
12387 DOUBLE PRECISION PARMDL
12388 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
12389 C general process information
12390 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
12391 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
12393 INTEGER IPFIL,IFAFIL,IFBFIL
12394 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
12395 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
12396 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
12397 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
12398 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
12399 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
12400 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
12401 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
12402 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
12403 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
12404 & IPFIL,IFAFIL,IFBFIL
12405 C hard cross sections and MC selection weights
12407 PARAMETER ( Max_pro_2 = 16 )
12408 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
12409 & MH_acc_1,MH_acc_2
12410 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
12411 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
12412 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
12413 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
12414 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
12415 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
12416 C interpolation tables for hard cross section and MC selection weights
12417 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
12418 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
12419 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
12420 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
12421 & HQ2a_tab,HQ2b_tab,HEcm_tab
12423 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12424 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12425 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12426 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12427 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
12428 & HEcm_tab(1:Max_tab_E,0:4),
12429 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
12430 C global event kinematics and particle IDs
12431 INTEGER IFPAP,IFPAB
12432 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
12433 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
12434 C obsolete cut-off information
12435 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
12436 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
12437 C event weights and generated cross section
12438 INTEGER IPOWGC,ISWCUT,IVWGHT
12439 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
12440 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
12441 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
12442 C cut probability distribution
12443 INTEGER IEETA1,IIMAX,KKMAX
12444 PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
12445 INTEGER IEEMAX,IMAX,KMAX
12447 DOUBLE PRECISION EPTAB
12448 COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
12450 C energy-interpolation table
12452 PARAMETER ( IEETA2 = 20 )
12454 DOUBLE PRECISION SIGTAB,SIGECM
12455 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
12457 CHARACTER*15 PHO_PNAME
12460 DATA XMPOM / 0.766D0 /
12462 C initialize fragmentation
12463 CALL PHO_FRAINI(ISWMDL(6))
12465 C reset interpolation tables
12469 SIGTAB(I,K,J) = 0.D0
12475 C max. number of allowed colors (large N expansion)
12478 CALL PHO_SELCOL(IC1,IC2,0,0,0,0,-1)
12480 C lower energy limit of initialization
12481 ETABLO = PARMDL(19)
12482 IF(ECM.LE.5.D0) ETABLO = MIN(2.5D0,ETABLO)
12484 WRITE(LO,'(/,1X,A,2F12.1)')
12485 & 'PHO_MCINI: selected energy range (SQRT(S))',ETABLO,ECM
12486 WRITE(LO,'(5X,A,A,F7.3,E15.4)')
12487 & 'particle 1 (name,mass,virtuality): ',PHO_PNAME(IFPAP(1),1),
12488 & PMASS(1),PVIRT(1)
12489 WRITE(LO,'(5X,A,A,F7.3,E15.4)')
12490 & 'particle 2 (name,mass,virtuality): ',PHO_PNAME(IFPAP(2),1),
12491 & PMASS(2),PVIRT(2)
12493 C cuts on probabilities of multiple interactions
12494 IMAX = MIN(IPAMDL(32),IIMAX)
12495 KMAX = MIN(IPAMDL(33),KKMAX)
12496 AH = 2.D0*PTCUT(1)/ECM
12497 IMAX = MAX(5,MIN(IMAX,INT(ECM/2.0D0)))
12498 KMAX = MIN(KMAX,1+INT(0.9*1.D0/AH))
12500 C hard interpolation table
12502 ECMF(2) = 0.9D0*ECMF(1)
12506 IH_Ecm_up(k) = MIN(IPAMDL(30),Max_tab_E)
12507 IF(ECMF(k).LT.100.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),15)
12508 IF(ECMF(k).LT.50.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),10)
12509 IF(ECMF(k).LT.10.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),5)
12512 C initialization of hard scattering for all channels and cutoffs
12513 IF(HSWCUT(5).GT.PARMDL(36)) CALL PHO_HARMCI(-1,ECMF(1))
12515 IF(ISWMDL(2).EQ.0) I0 = 1
12517 CALL PHO_HARMCI(I,ECMF(I))
12520 C dimension of interpolation table of cut probabilities
12521 IEEMAX = MIN(IPAMDL(31),IEETA1)
12522 IF(ECM.LT.100.D0) IEEMAX = MIN(IEEMAX,15)
12523 IF(ECM.LT.50.D0) IEEMAX = MIN(IEEMAX,10)
12524 IF(ECM.LT.10.D0) IEEMAX = MIN(IEEMAX,5)
12527 C calculate probability distribution
12535 IF(ISWMDL(2).EQ.0) I0 = 1
12537 ECMPRO = ECMF(IP)*1.001D0
12545 ELSE IF(IP.EQ.3) THEN
12552 ELSE IF(IP.EQ.2) THEN
12567 IF(IEEMAX.GT.1) THEN
12569 ELMIN = LOG(ETABLO)
12573 EDELTA = (LOG(ECMPRO)-ELMIN)/DBLE(MAX(1,IEEMAX-1))
12575 ECMPRO = EXP(ELMIN+DBLE(I-1)*EDELTA)
12576 CALL PHO_PRBDIS(IP,ECMPRO,I)
12579 CALL PHO_PRBDIS(IP,ECMPRO,1)
12582 C debug output of cross section tables
12583 IF(((IDEB(62).GE.0).AND.(IP.EQ.1)).OR.(IDEB(62).GE.3)) THEN
12584 IF((PVIRT(1)+PVIRT(2).GT.0.01D0).AND.(IDEB(62).EQ.0)) GOTO 201
12585 WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12586 &'Table of total cross sections (mb) for particle combination',IP,
12587 &' Ecm SIGtot SIGela SIGine SIGqel SIGsd1 SIGsd2 SIGdd',
12588 &'-------------------------------------------------------------'
12590 WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,1,I),
12591 & SIGTAB(IP,2,I),SIGTAB(IP,28,I),SIGTAB(IP,3,I),
12592 & SIGTAB(IP,30,I)+SIGTAB(IP,32,I),
12593 & SIGTAB(IP,31,I)+SIGTAB(IP,33,I),
12594 & SIGTAB(IP,34,I)+SIGTAB(IP,35,I)
12597 IF(IDEB(62).GE.2) THEN
12598 WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12599 &'Table of partial x-sections (mb) for particle combination',IP,
12600 &' Ecm SIGSD1L SIGSD1H SIGSD2L SIGSD2H SIGDDL SIGDDH SIGCDF',
12601 &'--------------------------------------------------------------'
12603 WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,30,I),
12604 & SIGTAB(IP,32,I),SIGTAB(IP,31,I),SIGTAB(IP,33,I),
12605 & SIGTAB(IP,34,I),SIGTAB(IP,35,I),SIGTAB(IP,36,I)
12608 IF(IDEB(62).GE.2) THEN
12609 WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12610 &'Table of born graph x-sections (mb) for particle combination',IP,
12611 &' Ecm SIGSVDM SIGHRES SIGHDIR SIGTR1 SIGTR2 SIGLOO SIGDPO',
12612 &'-------------------------------------------------------------'
12614 WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),
12615 & SIGTAB(IP,56,I)+SIGTAB(IP,57,I),SIGTAB(IP,58,I),
12616 & SIGTAB(IP,59,I),SIGTAB(IP,60,I)+SIGTAB(IP,61,I),
12617 & SIGTAB(IP,62,I)+SIGTAB(IP,63,I),SIGTAB(IP,64,I),
12618 & SIGTAB(IP,65,I)+SIGTAB(IP,66,I)+SIGTAB(IP,67,I)
12621 WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12622 &'Table of unitarized x-sections (mb) for particle combination',IP,
12623 &' Ecm SIGSVDM SIGHVDM SIGTR1 SIGTR2 SIGLOO SIGDPO SLOPE',
12624 &'-------------------------------------------------------------'
12626 WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,79,I),
12627 & SIGTAB(IP,80,I),SIGTAB(IP,32,I),SIGTAB(IP,33,I),
12628 & SIGTAB(IP,35,I),SIGTAB(IP,36,I),SIGTAB(IP,39,I)
12631 IF(IDEB(62).GE.1) THEN
12632 WRITE(LO,'(/1X,A,/1X,A,2I4,/1X,A,/1X,A)')
12633 &'Table of expected average number of cuts in non-diff events:',
12634 &' for max. number of cuts soft/hard:',IMAX,KMAX,
12635 &' Ecm PTCUT SIGNDF POM-S POM-H REG-S',
12636 &'---------------------------------------------'
12638 WRITE(LO,'(1X,1P,6E10.3)') SIGECM(IP,I),SIGTAB(IP,77,I),
12639 & SIGTAB(IP,78,I),SIGTAB(IP,74,I),SIGTAB(IP,75,I),
12643 WRITE(LO,'(/1X,A,/1X,A,/1X,A)')
12644 & 'Table of rapidity gap survival probability (high-mass diff.):',
12645 & ' Ecm Spro-sd1 Spro-sd2 Spro-dd Spro-cd',
12646 & '---------------------------------------------------'
12648 IF(SIGECM(IP,I).GT.10.D0) THEN
12649 SPRSD1 = SIGTAB(IP,32,I)/(SIGTAB(IP,60,I)
12650 & -2.D0*(SIGTAB(IP,65,I)+SIGTAB(IP,66,I)))
12651 SPRSD2 = SIGTAB(IP,33,I)/(SIGTAB(IP,62,I)
12652 & -2.D0*(SIGTAB(IP,65,I)+SIGTAB(IP,67,I)))
12653 SPRDD = SIGTAB(IP,35,I)/(SIGTAB(IP,64,I)+SIGTAB(IP,61,I)
12654 & +SIGTAB(IP,63,I)-2.D0*(SIGTAB(IP,66,I)
12655 & +SIGTAB(IP,67,I)+2.D0*SIGTAB(IP,68,I)))
12656 SPRCDF = SIGTAB(IP,36,I)/(SIGTAB(IP,65,I)+SIGTAB(IP,66,I)
12657 & +SIGTAB(IP,67,I)+SIGTAB(IP,68,I))
12658 WRITE(LO,'(1X,1P,5E10.3)') SIGECM(IP,I),
12659 & SPRSD1,SPRSD2,SPRDD,SPRCDF
12667 C simulate only hard scatterings
12668 IF(ISWMDL(2).EQ.0) THEN
12669 WRITE(LO,'(2(/1X,A))')
12670 & 'WARNING: generation of hard scatterings only!',
12671 & '============================================='
12683 IF(IPRON(1,1).EQ.1) SIGMAX = SIGTAB(1,58,I)
12684 IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGTAB(1,59,I)
12685 IF(SIGMAX.GT.SIGGEN(4)) THEN
12691 WRITE(LO,'(2(/1X,A))')
12692 & 'activated processes, cross section',
12693 & '----------------------------------'
12694 WRITE(LO,'(5X,A,I3,2X,3I3)')
12695 & ' nondiffr. resolved processes',(IPRON(1,K),K=1,4)
12696 WRITE(LO,'(5X,A,I3,2X,3I3)')
12697 & ' elastic scattering',(IPRON(2,K),K=1,4)
12698 WRITE(LO,'(5X,A,I3,2X,3I3)')
12699 & 'qelast. vectormeson production',(IPRON(3,K),K=1,4)
12700 WRITE(LO,'(5X,A,I3,2X,3I3)')
12701 & ' double pomeron processes',(IPRON(4,K),K=1,4)
12702 WRITE(LO,'(5X,A,I3,2X,3I3)')
12703 & ' single diffract. particle (1)',(IPRON(5,K),K=1,4)
12704 WRITE(LO,'(5X,A,I3,2X,3I3)')
12705 & ' single diffract. particle (2)',(IPRON(6,K),K=1,4)
12706 WRITE(LO,'(5X,A,I3,2X,3I3)')
12707 & ' double diffract. processes',(IPRON(7,K),K=1,4)
12708 WRITE(LO,'(5X,A,I3,2X,3I3)')
12709 & ' direct photon processes',(IPRON(8,K),K=1,4)
12711 C calculate effective cross section
12714 CALL PHO_CSINT(1,IFPAP(1),IFPAP(2),-1,-1,SIGECM(1,I),
12715 & PVIRT(1),PVIRT(2))
12717 if(iswmdl(2).ge.1) then
12718 IF(IPRON(1,1).EQ.1) SIGMAX = SIGTOT-SIGELA-SIGVM(0,0)
12719 & -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
12720 & -SIGLDD-SIGHDD-SIGDIR
12721 IF(IPRON(2,1).EQ.1) SIGMAX = SIGMAX+SIGELA
12722 IF(IPRON(3,1).EQ.1) SIGMAX = SIGMAX+SIGVM(0,0)
12723 IF(IPRON(4,1).EQ.1) SIGMAX = SIGMAX+SIGCDF(0)
12724 IF(IPRON(5,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(1)+SIGHSD(1)
12725 IF(IPRON(6,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(2)+SIGHSD(2)
12726 IF(IPRON(7,1).EQ.1) SIGMAX = SIGMAX+SIGLDD+SIGHDD
12727 IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
12729 IF(IPRON(1,1).EQ.1) SIGMAX = SIGHAR
12730 IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
12732 IF(SIGMAX.GT.SIGGEN(4)) THEN
12740 IF(SIGGEN(4).LT.1.D-20) THEN
12741 WRITE(LO,'(//1X,A)')
12742 & 'PHO_MCINI:ERROR: selected processes have vanishing x-section'
12745 WRITE(LO,'(3X,A,1P3E11.4)') 'maximum search (Elow/Eup/Epeak)',
12746 & SIGECM(1,1),SIGECM(1,IEEMAX),SIGECM(1,ISIGM)
12747 WRITE(LO,'(11X,A,1PE12.4,/)') 'max. cross section (mb)',SIGGEN(4)
12751 *$ CREATE PHO_REJSTA.FOR
12753 CDECK ID>, PHO_REJSTA
12754 SUBROUTINE PHO_REJSTA(IMODE)
12755 C********************************************************************
12757 C MC rejection counting
12759 C input IMODE -1 initialization
12760 C -2 output of statistics
12762 C********************************************************************
12766 C input/output channels
12768 COMMON /POINOU/ LI,LO
12769 C event debugging information
12771 PARAMETER (NMAXD=100)
12772 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12773 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12774 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12775 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12776 C internal rejection counters
12778 PARAMETER (NMXJ=60)
12779 CHARACTER*10 REJTIT
12781 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
12788 IF(IMODE.EQ.-1) THEN
12793 REJTIT(1) = 'PARTON ALL'
12794 REJTIT(2) = 'STDPAR ALL'
12795 REJTIT(3) = 'STDPAR DPO'
12796 REJTIT(4) = 'POMSCA ALL'
12797 REJTIT(5) = 'POMSCA INT'
12798 REJTIT(6) = 'POMSCA KIN'
12799 REJTIT(7) = 'DIFDIS ALL'
12800 REJTIT(8) = 'POSPOM ALL'
12801 REJTIT(9) = 'HRES.DIF.1'
12802 REJTIT(10) = 'HDIR.DIF.1'
12803 REJTIT(11) = 'HRES.DIF.2'
12804 REJTIT(12) = 'HDIR.DIF.2'
12805 REJTIT(13) = 'DIFDIS INT'
12806 REJTIT(14) = 'HADRON SP2'
12807 REJTIT(15) = 'HADRON SP3'
12808 REJTIT(16) = 'HARDIR ALL'
12809 REJTIT(17) = 'HARDIR INT'
12810 REJTIT(18) = 'HARDIR KIN'
12811 REJTIT(19) = 'MCHECK BAR'
12812 REJTIT(20) = 'MCHECK MES'
12813 REJTIT(21) = 'DIF.DISS.1'
12814 REJTIT(22) = 'DIF.DISS.2'
12815 REJTIT(23) = 'STRFRA ALL'
12816 REJTIT(24) = 'MSHELL CHA'
12817 REJTIT(25) = 'PARTPT SOF'
12818 REJTIT(26) = 'PARTPT HAR'
12819 REJTIT(27) = 'INTRINS KT'
12820 REJTIT(28) = 'HACHEK DIR'
12821 REJTIT(29) = 'HACHEK RES'
12822 REJTIT(30) = 'STRING ALL'
12823 REJTIT(31) = 'POMSCA INT'
12824 REJTIT(32) = 'DIFF SLOPE'
12825 REJTIT(33) = 'GLU2QU ALL'
12826 REJTIT(34) = 'MASCOR ALL'
12827 REJTIT(35) = 'PARCOR ALL'
12828 REJTIT(36) = 'MSHELL PAR'
12829 REJTIT(37) = 'MSHELL ALL'
12830 REJTIT(38) = 'POMCOR ALL'
12831 REJTIT(39) = 'DB-POM KIN'
12832 REJTIT(40) = 'DB-POM ALL'
12833 REJTIT(41) = 'SOFTXX ALL'
12834 REJTIT(42) = 'SOFTXX PSP'
12837 ELSE IF(IMODE.EQ.-2) THEN
12838 WRITE(LO,'(/,1X,A,/,1X,A)') 'PHO_REJSTA: rejection statistics',
12839 & '--------------------------------'
12842 & WRITE(LO,'(1X,I3,1X,A,5X,I15)') I,REJTIT(I),IFAIL(I)
12845 WRITE(LO,'(1X,A,I3)') 'PHO_REJSTA: invalid mode ',IMODE
12850 *$ CREATE PHO_POSPOM.FOR
12852 CDECK ID>, PHO_POSPOM
12853 SUBROUTINE PHO_POSPOM(IP,IND1,IND2,IGEN,IPOM,KCUT,ISWAP,IREJ)
12854 C***********************************************************************
12856 C registration of one cut pomeron (soft/semihard)
12858 C input: IP particle combination the pomeron belongs to
12859 C IND1,2 position of X values in /POSOFT/
12860 C 1 corresponds to a valence-pomeron
12861 C IGEN production process of mother particles
12862 C IPOM pomeron number
12863 C KCUT total number of cut pomerons and reggeons
12865 C output: ISWAP exchange of x values
12866 C IND1,2 increased by the number of partons belonging
12867 C to the generated pomeron cut
12868 C IREJ success/failure
12870 C**********************************************************************
12871 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12874 PARAMETER ( DEPS = 1.D-8 )
12876 C input/output channels
12878 COMMON /POINOU/ LI,LO
12879 C event debugging information
12881 PARAMETER (NMAXD=100)
12882 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12883 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12884 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12885 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12886 C internal rejection counters
12888 PARAMETER (NMXJ=60)
12889 CHARACTER*10 REJTIT
12891 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
12892 C model switches and parameters
12894 INTEGER ISWMDL,IPAMDL
12895 DOUBLE PRECISION PARMDL
12896 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
12897 C general process information
12898 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
12899 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
12900 C global event kinematics and particle IDs
12901 INTEGER IFPAP,IFPAB
12902 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
12903 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
12904 C data of c.m. system of Pomeron / Reggeon exchange
12905 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
12906 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
12907 & SIDP,CODP,SIFP,COFP
12908 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
12909 & SIDP,CODP,SIFP,COFP,NPOSP(2),
12910 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
12911 C obsolete cut-off information
12912 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
12913 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
12914 C energy-interpolation table
12916 PARAMETER ( IEETA2 = 20 )
12918 DOUBLE PRECISION SIGTAB,SIGECM
12919 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
12920 C light-cone x fractions and c.m. momenta of soft cut string ends
12922 PARAMETER ( MAXSOF = 50 )
12923 INTEGER IJSI2,IJSI1
12924 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
12925 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
12926 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
12927 & IJSI1(MAXSOF),IJSI2(MAXSOF)
12928 C standard particle data interface
12930 PARAMETER (NMXHEP=4000)
12931 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
12932 DOUBLE PRECISION PHEP,VHEP
12933 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
12934 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
12936 C extension to standard particle data interface (PHOJET specific)
12937 INTEGER IMPART,IPHIST,ICOLOR
12938 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
12939 C table of particle indices for recursive PHOJET calls
12941 PARAMETER ( MAXIPX = 100 )
12942 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
12943 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
12944 & IPOIX1,IPOIX2,IPOIX3
12946 DIMENSION P1(4),P2(4),WGXHSD(2),WGX(6)
12954 EA1 = XS1(IND1)*ECMP/2.D0
12955 EA2 = XS1(IND1+1)*ECMP/2.D0
12956 EB1 = XS2(IND2)*ECMP/2.D0
12957 EB2 = XS2(IND2+1)*ECMP/2.D0
12958 CMASS1 = MIN(EA1,EA2)
12959 CMASS2 = MIN(EB1,EB2)
12962 IF(IDEB(9).GE.20) THEN
12963 WRITE(LO,'(1X,2A,5I4)') 'PHO_POSPOM: ',
12964 & 'IP,IND1,IND2,KCUT,IPOIX1',IP,IND1,IND2,KCUT,IPOIX1
12965 WRITE(LO,'(1X,A,2I4,1P2E12.4)') 'MOTHER1/2,MASS1/2',JM1,JM2,
12971 CALL PHO_VALFLA(JM1,IFLA1,IFLA2,EA1,EA2)
12973 CALL PHO_SEAFLA(JM1,IFLA1,IFLA2,CMASS1)
12976 CALL PHO_VALFLA(JM2,IFLB1,IFLB2,EB1,EB2)
12978 CALL PHO_SEAFLA(JM2,IFLB1,IFLB2,CMASS2)
12981 P1(I) = PSOFT1(I,IND1)+PSOFT1(I,IND1+1)
12982 P2(I) = PSOFT2(I,IND2)+PSOFT2(I,IND2+1)
12985 C pomeron resolved?
12986 IF((ISWMDL(14).GT.0).AND.(IPOIX1.GT.0)) THEN
12987 C find energy for cross section calculation
12988 IF(IPAMDL(16).EQ.2) THEN
12990 ELSE IF(IPAMDL(16).EQ.3) THEN
12991 IF(IPROCE.EQ.1) THEN
12997 ESUB = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2
12998 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2)
13000 C load cross sections from interpolation table
13001 IF(ESUB.LE.SIGECM(IP,1)) THEN
13004 ELSE IF(ESUB.LT.SIGECM(IP,ISIMAX)) THEN
13006 IF(ESUB.LE.SIGECM(IP,I)) GOTO 200
13012 WRITE(LO,'(/1X,A,2E12.3)')
13013 & 'PHO_POSPOM: energy too high',ESUB,SIGECM(IP,ISIMAX)
13014 CALL PHO_PREVNT(-1)
13019 IF(I1.NE.I2) FAC2=LOG(ESUB/SIGECM(IP,I1))
13020 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
13022 C calculate weights
13023 * WGXHSD(1) = FAC2*SIGTAB(IP,32,I2)+FAC1*SIGTAB(IP,32,I1)
13024 * WGXHSD(2) = FAC2*SIGTAB(IP,33,I2)+FAC1*SIGTAB(IP,33,I1)
13025 * WGXHDD = FAC2*SIGTAB(IP,35,I2)+FAC1*SIGTAB(IP,35,I1)
13026 * WGXCDF = FAC2*SIGTAB(IP,36,I2)+FAC1*SIGTAB(IP,36,I1)
13027 * WGXPOM = FAC2*SIGTAB(IP,37,I2)+FAC1*SIGTAB(IP,37,I1)
13028 * WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
13030 WGXPOM = FAC2*(SIGTAB(IP,56,I2)+SIGTAB(IP,57,I2))
13031 & +FAC1*(SIGTAB(IP,56,I1)+SIGTAB(IP,57,I1))
13032 WGXHSD(1) = FAC2*SIGTAB(IP,60,I2)+FAC1*SIGTAB(IP,60,I1)
13033 WGXHSD(2) = FAC2*SIGTAB(IP,62,I2)+FAC1*SIGTAB(IP,62,I1)
13034 WGXHDD = FAC2*(SIGTAB(IP,61,I2)+SIGTAB(IP,63,I2)
13035 & +SIGTAB(IP,64,I2))
13036 & +FAC1*(SIGTAB(IP,61,I1)+SIGTAB(IP,63,I1)
13037 & +SIGTAB(IP,64,I1))
13038 WGXCDF = FAC2*(SIGTAB(IP,65,I2)+SIGTAB(IP,66,I2)
13039 & +SIGTAB(IP,67,I2)+SIGTAB(IP,68,I2))
13040 & +FAC1*(SIGTAB(IP,65,I1)+SIGTAB(IP,66,I1)
13041 & +SIGTAB(IP,67,I1)+SIGTAB(IP,68,I1))
13044 WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
13045 C central diff. cut
13047 C diff. diss. of particle 1
13049 C diff. diss. of particle 2
13051 C double diff. dissociation
13054 WGX(6) = 2.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)
13056 * IF((WGX(1).LT.0.D0).AND.((IP.EQ.1).OR.(IDEB(9).GE.1))) THEN
13057 * WRITE(LO,'(1X,A,/1X,A,I3,1P,2E11.3)') ' PHO_POSPOM: ',
13058 * & ' unitarity bound reached for ',IP,ESUB,WGX(1)
13059 * WRITE(LO,'(5X,A)') 'WGXHSD(1),WGXHSD(2),WGXHDD,WGXCDF,WGXPOM:'
13060 * WRITE(LO,'(5X,1P5E11.3)') WGXHSD,WGXHDD,WGXCDF,WGXPOM
13061 * WRITE(LO,'(5X,A,/,5X,1P,6E11.3)') 'weight factors WG(1-6)',WGX
13064 SUM = WGX(1)+WGX(2)+WGX(3)+WGX(4)+WGX(5)+WGX(6)
13068 XI = DT_RNDM(SUM)*SUM
13074 IF((XI.GT.SUM).AND.(I.LT.6)) GOTO 210
13075 C phase space correction
13078 IF(I.EQ.6) ISAM = 8
13079 PACC = EXP(-PARMDL(8)*DBLE(ISAM*PARMDL(160+IP))/ESUB)
13080 * IF(DT_RNDM(SUM).GT.PACC) I=1
13081 IF(DT_RNDM(SUM).GT.PACC) GOTO 205
13084 C do not generate diffraction for events with only one cut pomeron
13085 IF((KCUT.EQ.1).AND.(I.LT.6)) I = 1
13087 C do not generate recursive calls for remants with
13088 C diquark-anti-diquark flavour contents
13089 if((abs(IFLA1).gt.1000).and.(IFLA1+IFLA2.eq.0)) I = 1
13090 if((abs(IFLB1).gt.1000).and.(IFLB1+IFLB2.eq.0)) I = 1
13093 IF(IDEB(9).GE.20) WRITE(LO,'(1X,A,/1X,I2,1P7E11.3)')
13094 & 'PHO_POSPOM: IPRO,ESUB,WGX(1-6)',I,ESUB,WGX
13097 C second scattering needed
13098 CALL PHO_HACODE(IFLA1,IFLA2,IDHA1,IDUM)
13099 CALL PHO_HACODE(IFLB1,IFLB2,IDHA2,IDUM)
13100 IDPD1 = IPHO_ID2PDG(IDHA1)
13101 IDPD2 = IPHO_ID2PDG(IDHA2)
13103 if(INDX1.eq.1) then
13104 if((IPHIST(2,JM1).GE.0).and.(IDHEP(JM1).NE.990))
13109 CALL PHO_REGPAR(1,IDPD1,IDHA1,JM1,JM2,P1(1),P1(2),P1(3),P1(4),
13110 & IPOM,IGEN_had,0,0,IPOS1,1)
13112 if(INDX2.eq.1) then
13113 if((IPHIST(2,JM2).GE.0).and.(IDHEP(JM2).NE.990))
13118 CALL PHO_REGPAR(1,IDPD2,IDHA2,JM2,JM1,P2(1),P2(2),P2(3),P2(4),
13119 & IPOM,IGEN_had,0,0,IPOS1,1)
13125 IF(IPOIX2.GT.MAXIPX) THEN
13126 WRITE(LO,'(1X,2A,2I5)') 'PHO_POSPOM: no space left in ',
13127 & '/PORECU/ (IPOIX2,MAXIPX):',IPOIX2,MAXIPX
13131 IPORES(IPOIX2) = I+2
13132 IPOPOS(1,IPOIX2) = IPOS1-1
13133 IPOPOS(2,IPOIX2) = IPOS1
13139 IF(ISWMDL(12).EQ.0) THEN
13141 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
13142 CALL PHO_SELCOL(0,0,ICC1,ICC2,ICD1,ICD2,1)
13144 C purely gluonic pomeron or sea strings formed by gluons
13146 IF( ((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0))
13147 & .OR.((IPAMDL(19).EQ.1).AND.(IND1.NE.1))) THEN
13151 IF( ((IDHEP(JM2).EQ.990).AND.(IPAMDL(20).GT.0))
13152 & .OR.((IPAMDL(19).EQ.1).AND.(IND2.NE.1))) THEN
13158 IF(IFLA1.NE.21) THEN
13159 IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
13160 & .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
13161 & CALL PHO_SWAPI(ICA1,ICD1)
13163 IF(IFLB1.NE.21) THEN
13164 IF(((ABS(IFLB1).GT.6).AND.(IFLB1.LT.0))
13165 & .OR.((ABS(IFLB1).LE.6).AND.(IFLB1.GT.0)))
13166 & CALL PHO_SWAPI(ICB1,ICC1)
13169 IF(ICA1*ICB1.GT.0) THEN
13170 IF((IND1.NE.1).AND.(IND2.NE.1)) THEN
13171 IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
13172 CALL PHO_SWAPI(IFLA1,IFLA2)
13173 CALL PHO_SWAPI(ICA1,ICD1)
13175 CALL PHO_SWAPI(IFLB1,IFLB2)
13176 CALL PHO_SWAPI(ICB1,ICC1)
13178 ELSE IF(IND1.NE.1) THEN
13179 CALL PHO_SWAPI(IFLA1,IFLA2)
13180 CALL PHO_SWAPI(ICA1,ICD1)
13181 ELSE IF(IND2.NE.1) THEN
13182 CALL PHO_SWAPI(IFLB1,IFLB2)
13183 CALL PHO_SWAPI(ICB1,ICC1)
13184 ELSE IF((IFLA1.EQ.-IFLA2).AND.(IFLB1.EQ.-IFLB2)) THEN
13185 IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
13186 CALL PHO_SWAPI(IFLA1,IFLA2)
13187 CALL PHO_SWAPI(ICA1,ICD1)
13189 CALL PHO_SWAPI(IFLB1,IFLB2)
13190 CALL PHO_SWAPI(ICB1,ICC1)
13192 ELSE IF(IFLA1.EQ.-IFLA2) THEN
13193 CALL PHO_SWAPI(IFLA1,IFLA2)
13194 CALL PHO_SWAPI(ICA1,ICD1)
13195 ELSE IF(IFLB1.EQ.-IFLB2) THEN
13196 CALL PHO_SWAPI(IFLB1,IFLB2)
13197 CALL PHO_SWAPI(ICB1,ICC1)
13200 IF(IDEB(9).GE.5) THEN
13201 WRITE(LO,'(1X,A,I12)')
13202 & 'PHO_POSPOM: string end swap (KEVENT)',KEVENT
13203 WRITE(LO,'(5X,A,4I7)')
13204 & 'flavors:',IFLA1,IFLA2,IFLB1,IFLB2
13205 WRITE(LO,'(5X,A,4I7)') 'colors :',ICA1,ICD1,ICB1,ICC1
13212 C purely gluonic pomeron or sea strings formed by gluons
13213 IF(IFLA1.EQ.21) THEN
13214 CALL PHO_REGPAR(-1,21,0,JM1,JM2,P1(1),P1(2),P1(3),P1(4),
13215 & IPOM,IGEN,ICA1,ICD1,IPOS1,1)
13218 C strings formed by quarks
13220 C valence quark labels
13221 IF((INDX1.EQ.1).and.(IPHIST(2,JM1).GE.0)
13222 & .and.(IDHEP(JM1).NE.990)) THEN
13227 CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
13228 & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICA1,
13231 CALL PHO_REGPAR(-1,IFLA2,0,JM1,JM2,PSOFT1(1,IND1),
13232 & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICD1,
13237 C purely gluonic pomeron or sea strings formed by gluons
13238 IF(IFLB1.EQ.21) THEN
13239 CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,P2(1),P2(2),P2(3),P2(4),
13240 & IPOM,IGEN,ICB1,ICC1,IPOS2,1)
13243 C strings formed by quarks
13245 C valence quark labels
13246 IF((INDX2.EQ.1).and.(IPHIST(2,JM2).GE.0)
13247 & .and.(IDHEP(JM2).NE.990)) THEN
13252 CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
13253 & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICB1,
13256 CALL PHO_REGPAR(-1,IFLB2,0,JM2,JM1,PSOFT2(1,IND2),
13257 & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICC1,
13262 C soft pt assignment
13263 IF(ISWMDL(18).EQ.0) THEN
13264 CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(IP),IREJ)
13266 IFAIL(25) = IFAIL(25)+1
13271 * CALL PHO_BFKL(P1,P2,IPART,IREJ)
13272 * IF(IREJ.NE.0) RETURN
13277 *$ CREATE PHO_HADSP2.FOR
13279 CDECK ID>, PHO_HADSP2
13280 SUBROUTINE PHO_HADSP2(IFLB,XS1,XMAX,XSOFT1,IREJ)
13281 C***********************************************************************
13283 C split hadron momentum XMAX into two partons using
13284 C lower cut-off: AS
13286 C input: IFLB compressed particle code of particle to split
13287 C XS1 sum of x values already selected
13288 C XMAX maximal x possible
13290 C output: XS1 new sum of x values (without first one)
13291 C XSOFT1 field of selected x values
13293 C**********************************************************************
13294 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13297 PARAMETER ( DEPS = 1.D-8 )
13299 DIMENSION XSOFT1(50)
13301 C input/output channels
13303 COMMON /POINOU/ LI,LO
13304 C event debugging information
13306 PARAMETER (NMAXD=100)
13307 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13308 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13309 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13310 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13311 C internal rejection counters
13313 PARAMETER (NMXJ=60)
13314 CHARACTER*10 REJTIT
13316 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13317 C data on most recent hard scattering
13318 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13319 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13320 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13321 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13322 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13323 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13324 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13325 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13326 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13329 DATA PVMES1 /-0.5D0/
13330 DATA PVMES2 /-0.5D0/
13331 DATA PVBAR1 / 1.5D0/
13332 DATA PVBAR2 /-0.5D0/
13338 IF(ipho_bar3(IFLB,0).EQ.0) THEN
13339 XPOT1 = PVMES1+1.D0
13340 XPOT2 = PVMES2+1.D0
13341 C baryonic particle
13343 XPOT1 = PVBAR1+1.D0
13344 XPOT2 = PVBAR2+1.D0
13351 IF(ITER.GE.ITMAX) THEN
13352 IF(IDEB(39).GE.3) THEN
13353 WRITE(LO,'(1X,A,I8)')
13354 & 'PHO_HADSP2: REJECTION (ITER)',ITER
13355 WRITE(LO,'(5X,A,3E12.3)') 'XS1,XMAX,AS:',XS1,XMAX,AS
13357 IFAIL(14) = IFAIL(14)+1
13361 ZZ = XREST*PHO_RNDBET(XPOT2,XPOT1)
13362 IF((ZZ.GT.XMAX).OR.(ZZ.LT.AS)) GOTO 100
13364 IF((1.D0-XSS1).LT.AS) GOTO 100
13367 XSOFT1(1) = 1.D0-XSS1
13370 IF(IDEB(39).GE.10) THEN
13371 WRITE(LO,'(1X,A,2I8)') 'PHO_HADSP2: ITMAX,ITER',ITMAX,ITER
13372 WRITE(LO,'(5X,A,3E10.3,5X,2E11.4)') 'XS1,XMAX,AS X1,X2:',
13373 & XS1,XMAX,AS,XSOFT1(1),XSOFT1(2)
13377 *$ CREATE PHO_HADSP3.FOR
13379 CDECK ID>, PHO_HADSP3
13380 SUBROUTINE PHO_HADSP3(IFLB,XS1,XMAX,XSOFT1,IREJ)
13381 C***********************************************************************
13383 C split hadron momentum XMAX into diquark & quark pair
13384 C using lower cut-off: AS
13386 C input: IFLB compressed particle code of particle to split
13387 C XS1 sum of x values already selected
13388 C XMAX maximal x possible
13390 C output: XS1 new sum of x values
13391 C XSOFT1 field of selected x values
13394 C**********************************************************************
13395 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13397 PARAMETER ( DEPS = 1.D-8 )
13399 DIMENSION XSOFT1(50),XSOFT2(50)
13401 C input/output channels
13403 COMMON /POINOU/ LI,LO
13404 C event debugging information
13406 PARAMETER (NMAXD=100)
13407 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13408 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13409 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13410 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13411 C internal rejection counters
13413 PARAMETER (NMXJ=60)
13414 CHARACTER*10 REJTIT
13416 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13417 C data of c.m. system of Pomeron / Reggeon exchange
13418 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
13419 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
13420 & SIDP,CODP,SIFP,COFP
13421 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
13422 & SIDP,CODP,SIFP,COFP,NPOSP(2),
13423 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
13425 DIMENSION XPOT1(3),XPOT2(3),XMIN(2,3)
13428 DATA PVMES1 /-0.5D0/
13429 DATA PVMES2 /-0.5D0/
13430 DATA PSMES /-0.99D0/
13431 DATA PVBAR1 / 1.5D0/
13432 DATA PVBAR2 /-0.5D0/
13433 DATA PSBAR /-0.99D0/
13437 C determine exponents
13443 IF(ipho_bar3(IFLB,0).EQ.0) THEN
13450 C baryonic particle
13470 CALL PHO_SELSXS(3,3,XPOT1,XPOT2,XMIN,XS1,XDUM1,XMAX,XDUM2,
13471 & XSOFT1,XSOFT2,IREJ)
13474 IF(IDEB(74).GE.3) WRITE(LO,'(1X,A,I6,2E12.4)')
13475 & 'PHO_HADSP3: rejection (IFLB,XS1,XMAX)',IFLB,XS1,XMAX
13476 IFAIL(15) = IFAIL(15)+1
13481 IF(IDEB(74).GE.10) THEN
13482 WRITE(LO,'(1X,A,I6,2E12.4)')
13483 & 'PHO_HADSP3: IFLB,XS1,XMAX',IFLB,XS1,XMAX
13485 WRITE(LO,'(10X,I4,2E12.4)') I,XSOFT1(I),XSOFT2(I)
13491 *$ CREATE PHO_SOFTXX.FOR
13493 CDECK ID>, PHO_SOFTXX
13494 SUBROUTINE PHO_SOFTXX(JM1,JM2,MSPAR1,MSPAR2,IVAL1,IVAL2,MSM1,MSM2,
13495 & XSUM1,XSUM2,XMAX1,XMAX2,XS1,XS2,IREJ)
13496 C***********************************************************************
13498 C select soft x values
13500 C input: JM1,JM2 mother particle index in POEVT1
13501 C (0 flavour not known before)
13502 C MSPAR1,2 number of x values to select
13503 C IVAL1,2 number valence quarks involved in hard
13504 C scattering (0,1,2)
13505 C MSM1,2 minimum number of soft x to get sampled
13506 C XSUM1,2 sum of all x values samples up this call
13507 C XMAX1,2 max. x value
13509 C output XSUM1,2 new sum of x-values sampled
13510 C XS1,2 field containing sampled x values
13512 C x values of valence partons are first given
13514 C***********************************************************************
13515 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13518 C input/output channels
13520 COMMON /POINOU/ LI,LO
13521 C event debugging information
13523 PARAMETER (NMAXD=100)
13524 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13525 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13526 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13527 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13528 C internal rejection counters
13530 PARAMETER (NMXJ=60)
13531 CHARACTER*10 REJTIT
13533 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13534 C model switches and parameters
13536 INTEGER ISWMDL,IPAMDL
13537 DOUBLE PRECISION PARMDL
13538 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
13539 C data of c.m. system of Pomeron / Reggeon exchange
13540 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
13541 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
13542 & SIDP,CODP,SIFP,COFP
13543 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
13544 & SIDP,CODP,SIFP,COFP,NPOSP(2),
13545 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
13546 C standard particle data interface
13548 PARAMETER (NMXHEP=4000)
13549 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
13550 DOUBLE PRECISION PHEP,VHEP
13551 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
13552 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
13554 C extension to standard particle data interface (PHOJET specific)
13555 INTEGER IMPART,IPHIST,ICOLOR
13556 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
13557 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
13558 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
13559 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
13560 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
13561 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
13562 C obsolete cut-off information
13563 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
13564 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
13565 C data on most recent hard scattering
13566 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13567 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13568 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13569 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13570 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13571 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13572 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13573 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13574 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13576 DIMENSION XS1(*),XS2(*)
13579 PARAMETER ( MAXPOT = 50 )
13580 DIMENSION XPOT1(MAXPOT),XPOT2(MAXPOT),XMIN(2,MAXPOT)
13584 MSMAX = MAX(MSPAR1,MSPAR2)
13585 MSMIN = MAX(MSM1,MSM2)
13586 IF(MSMAX.GT.MAXPOT) THEN
13587 WRITE(LO,'(1X,2A,2I4)') 'PHO_SOFTXX: no space left in ',
13588 & 'local fields XPOT1/2 (MSMAX,MAXPOT):',MSMAX,MAXPOT
13592 C determine exponents
13593 IBAR1 = ipho_bar3(JM1,2)
13594 IBAR2 = ipho_bar3(JM2,2)
13596 IF((IBAR1*IBAR2).LT.0) ISWAP = 1
13597 C meson-baryon scattering (asymmetric sea)
13598 IF((ABS(IBAR1)+ABS(IBAR2)).EQ.1) THEN
13606 C lower limits for x sampling
13607 XMMINA = 2.D0*PARMDL(157)/ECMP
13608 XBMINA = 2.D0*PARMDL(158)/ECMP
13609 XSMINA = 2.D0*PARMDL(159)/ECMP
13610 XMIN1 = MAX(XSOMIN,AS/XMAX2)
13611 XMIN2 = MAX(XSOMIN,AS/XMAX1)
13612 XMAXP1 = MIN(1.D0-XMIN1*MSMAX,XMAX1)
13613 XMAXP2 = MIN(1.D0-XMIN2*MSMAX,XMAX2)
13614 XMIN1 = MAX(AS/XMAX2,XMIN1)
13615 XMIN2 = MAX(AS/XMAX1,XMIN2)
13618 XMMIN1 = MAX(XMIN1,XMMINA)
13619 XBMIN1 = MAX(XMIN1,XBMINA)
13620 XSMIN1 = MAX(XMIN1,XSMINA)
13622 IF(IBAR1.EQ.0) THEN
13623 IF(IHFLS(1).EQ.0) THEN
13624 XPOT1(1) = PARMDL(62)
13626 XPOT1(2) = PARMDL(63)
13629 XPOT1(1) = PARMDL(54)
13631 XPOT1(2) = PARMDL(55)
13634 DO 100 I=3-IVAL1,MSMAX
13638 C baryonic particle
13640 IF(IHFLS(1).EQ.0) THEN
13641 XPOT1(1) = PARMDL(62)
13643 XPOT1(2) = PARMDL(63)
13646 XPOT1(1) = PARMDL(50)
13648 XPOT1(2) = PARMDL(51)
13651 DO 200 I=3-IVAL1,MSMAX
13658 XMMIN2 = MAX(XMIN2,XMMINA)
13659 XBMIN2 = MAX(XMIN2,XBMINA)
13660 XSMIN2 = MAX(XMIN2,XSMINA)
13662 IF(IBAR2.EQ.0) THEN
13663 IF(IHFLS(2).EQ.0) THEN
13664 XPOT2(1) = PARMDL(62)
13666 XPOT2(2) = PARMDL(63)
13669 XPOT2(1) = PARMDL(54)
13671 XPOT2(2) = PARMDL(55)
13674 DO 300 I=3-IVAL2,MSMAX
13678 C baryonic particle
13680 IF(IHFLS(2).EQ.0) THEN
13681 XPOT2(1) = PARMDL(62)
13683 XPOT2(2) = PARMDL(63)
13686 XPOT2(1) = PARMDL(50)
13688 XPOT2(2) = PARMDL(51)
13691 DO 400 I=3-IVAL2,MSMAX
13701 C check limits (important for valences)
13702 IF((XMIN(1,1).GE.XMAXP1).OR.(XMIN(1,2).GE.XMAXP1)) GOTO 1000
13703 IF((XMIN(2,1).GE.XMAXP2).OR.(XMIN(2,2).GE.XMAXP2)) GOTO 1000
13706 IF(IHFLS(1).NE.0) XMINS1 = XMINS1+(PARMDL(166)/ECMP)**2
13708 IF(IHFLS(2).NE.0) XMINS2 = XMINS2+(PARMDL(166)/ECMP)**2
13710 XMINS1 = XMINS1+XMIN(1,I)
13711 XMINS2 = XMINS2+XMIN(2,I)
13713 IF((XMINS1.GE.1.D0).OR.(XMINS2.GE.1.D0)) GOTO 1000
13715 C try to sample x values
13716 IF(IPAMDL(14).EQ.0) THEN
13717 IF(MSOFT.EQ.2) THEN
13718 CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13720 ELSE IF(MSOFT.LT.5) THEN
13721 CALL PHO_SELSXR(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13722 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13724 CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13725 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13727 ELSE IF(IPAMDL(14).EQ.1) THEN
13728 IF(MSOFT.EQ.2) THEN
13729 CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13732 CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13733 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13735 ELSE IF(IPAMDL(14).EQ.2) THEN
13736 CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13737 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13738 ELSE IF(IPAMDL(14).EQ.3) THEN
13739 IF(MSOFT.EQ.2) THEN
13740 CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13742 ELSE IF(IVAL1+IVAL2.EQ.0) THEN
13743 CALL PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13744 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13746 CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13747 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13750 WRITE(LO,'(/,1X,A,I3)')
13751 & 'PHO_SOFTXX:ERROR: unsupported IPAMDL(14)',IPAMDL(14)
13755 IFAIL(41) = IFAIL(41)+1
13756 IF(IDEB(60).GE.2) THEN
13757 WRITE(LO,'(1X,A,I12,4I3)')
13758 & 'PHO_SOFTXX: rejection: EVE,MSP1/2,MSM1/2',
13759 & KEVENT,MSPAR1,MSPAR2,MSM1,MSM2
13760 WRITE(LO,'(1X,A,1P4E11.3)') 'XSUM1/2,XMAX1/2',
13761 & XSUM1,XSUM2,XMAX1,XMAX2
13765 IF(MSOFT.NE.MSMAX) THEN
13766 MSDIFF = MSMAX-MSOFT
13767 MSPAR1 = MSPAR1-MSDIFF
13768 MSPAR2 = MSPAR2-MSDIFF
13771 C correct for different MSPAR numbers
13772 IF(MSOFT.NE.MSPAR1) THEN
13773 IF(MSPAR1.GT.1) THEN
13775 DO 500 I=MSPAR1+1,MSOFT
13778 XFAC = (1.D0-XSUM1)/(1.D0-XDEL-XSUM1)
13780 XS1(I) = XS1(I)*XFAC
13782 XSS1 = (XSS1-XDEL-XSUM1)*XFAC+XSUM1
13787 IF(MSOFT.NE.MSPAR2) THEN
13788 IF(MSPAR2.GT.1) THEN
13790 DO 600 I=MSPAR2+1,MSOFT
13793 XFAC = (1.D0-XSUM2)/(1.D0-XDEL-XSUM2)
13795 XS2(I) = XS2(I)*XFAC
13797 XSS2 = (XSS2-XDEL-XSUM2)*XFAC+XSUM2
13804 XS1(1) = 1.D0 - XSS1
13805 XS2(1) = 1.D0 - XSS2
13810 IF(IDEB(60).GE.10) THEN
13811 WRITE(LO,'(1X,A,I8,2I4,2E12.4)')
13812 & 'PHO_SOFTXX: EVE,MSPAR1/2,XSUM1/2:',
13813 & KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
13814 WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I XS1/2 XPOT1/2 XMIN1/2'
13816 WRITE(LO,'(5X,I3,6E12.4)') I,XS1(I),XS2(I),XPOT1(I),XPOT2(I),
13817 & XMIN(1,I),XMIN(2,I)
13823 C not enough phase space
13826 IFAIL(42) = IFAIL(42)+1
13830 IF(IDEB(60).GE.1) THEN
13831 WRITE (6,'(1X,A,1P,2E11.3,/1X,A,/5X,6E11.3)')
13832 & 'PHO_SOFTXX: Xmin>Xmax or sum(Xmin)>1 (ECM,AS)',
13833 & ECMP,AS,'PHO_SOFTXX: Xmin1/2,Xmaxp1/2,sum(Xmin1/2)',
13834 & XMIN1,XMIN2,XMAXP1,XMAXP2,XMINS1,XMINS2
13835 WRITE(LO,'(1X,A,1P,3E11.3)')
13836 & 'PHO_SOFTXX: Xmmina,Xbmina,Xsmina:',XMMINA,XBMINA,XSMINA
13837 WRITE(LO,'(1X,A,1P,3E11.3)')
13838 & 'PHO_SOFTXX: Xmmin1,Xbmin1,Xsmin1:',XMMIN1,XBMIN1,XSMIN1
13839 WRITE(LO,'(1X,A,1P,3E11.3)')
13840 & 'PHO_SOFTXX: Xmmin2,Xbmin2,Xsmin2:',XMMIN2,XBMIN2,XSMIN2
13842 & 'PHO_SOFTXX: Table of lower x limits (I,Xmin(1,I),Xmin(2,I))'
13844 WRITE(LO,'(5X,I3,1P,2E11.3)') I,XMIN(1,I),XMIN(2,I)
13846 WRITE(LO,'(1X,A,I10,2I4,2E11.3)')
13847 & 'PHO_SOFTXX: KEVENT,MSPAR1/2,XSUM1/2:',
13848 & KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
13849 WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I XPOT1/2 XMIN1/2'
13851 WRITE(LO,'(5X,I3,4E12.4)') I,XPOT1(I),XPOT2(I),
13852 & XMIN(1,I),XMIN(2,I)
13858 *$ CREATE PHO_SELSXR.FOR
13860 CDECK ID>, PHO_SELSXR
13861 SUBROUTINE PHO_SELSXR(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
13862 & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
13863 C***********************************************************************
13865 C select x values of soft string ends (rejection method)
13867 C***********************************************************************
13868 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13871 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
13873 C input/output channels
13875 COMMON /POINOU/ LI,LO
13876 C event debugging information
13878 PARAMETER (NMAXD=100)
13879 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13880 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13881 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13882 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13883 C model switches and parameters
13885 INTEGER ISWMDL,IPAMDL
13886 DOUBLE PRECISION PARMDL
13887 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
13888 C data on most recent hard scattering
13889 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13890 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13891 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13892 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13893 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13894 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13895 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13896 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13897 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13898 C global event kinematics and particle IDs
13899 INTEGER IFPAP,IFPAB
13900 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
13901 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
13902 C obsolete cut-off information
13903 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
13904 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
13906 DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
13908 IF(IDEB(13).GE.10) THEN
13909 WRITE(LO,'(1X,A)') 'PHO_SELSXR:'
13910 WRITE(LO,'(5X,A,I4,5E11.3)') 'MSOFT,XS1,XS2,XMAX1,2',
13911 & MSOFT,XS1,XS2,XMAX1,XMAX2
13913 WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
13919 XMINK = MAX(PSOMIN/ECM*2.D0,XSOMIN)
13920 XMIN1 = MAX(AS/XMAX1,XMINK)
13921 XMIN2 = MAX(AS/XMAX2,XMINK)
13923 IF(MSOFT.EQ.1) THEN
13928 XWMAX = MAX(XMAX1**XPOT1(1),XMIN1**XPOT1(1))
13929 & *MAX(XMAX2**XPOT2(1),XMIN2**XPOT2(1))
13934 POT(1,I) = XPOT1(I)+1.D0
13935 POT(2,I) = XPOT2(I)+1.D0
13936 REVP(1,I) = 1.D0/POT(1,I)
13937 REVP(2,I) = 1.D0/POT(2,I)
13938 XLMIN(1,I) = XMIN(1,I)**POT(1,I)
13939 XLMAX = XMAX1**POT(1,I)
13940 XLDIF(1,I) = XLMAX-XLMIN(1,I)
13941 XLMIN(2,I) = XMIN(2,I)**POT(2,I)
13942 XLMAX = XMAX2**POT(2,I)
13943 XLDIF(2,I) = XLMAX-XLMIN(2,I)
13949 IF(ITRY0.GE.IPAMDL(181)) THEN
13950 IF(MSOFT-MSMIN.GE.2) THEN
13962 Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
13963 Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
13964 XSOFT1(I) = Z1**REVP(1,I)
13965 XSOFT2(I) = Z2**REVP(2,I)
13967 IF(ITRY1.GE.50) GOTO 1000
13968 IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
13970 XREST1 = XREST1-XSOFT1(I)
13971 IF(XREST1.LT.XMIN1) GOTO 5
13972 IF(XREST1.LT.XMIN(1,1)) GOTO 5
13973 XREST2 = XREST2-XSOFT2(I)
13974 IF(XREST2.LT.XMIN2) GOTO 5
13975 IF(XREST2.LT.XMIN(2,1)) GOTO 5
13976 IF(XREST1*XREST2.LT.AS) GOTO 5
13984 * XX = XX*XSOFT1(I)**XPOT1(I)*XSOFT2(I)**XPOT2(I)
13986 XX = XSOFT1(1)**XPOT1(1)*XSOFT2(1)**XPOT2(1)
13987 IF((XX-DT_RNDM(XX)*XWMAX).LT.0.D0) GOTO 5
13995 IF(IDEB(13).GE.2) THEN
13996 WRITE(LO,'(1X,A,2I4)')
13997 & 'PHO_SELSXR: REJECTION(ITRY0/1)',ITRY0,ITRY1
13998 WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
14003 *$ CREATE PHO_SELSX2.FOR
14005 CDECK ID>, PHO_SELSX2
14006 SUBROUTINE PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
14008 C***********************************************************************
14010 C select x values of soft string ends using PHO_RNDBET
14012 C***********************************************************************
14013 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14016 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XS1(*),XS2(*)
14018 C input/output channels
14020 COMMON /POINOU/ LI,LO
14021 C event debugging information
14023 PARAMETER (NMAXD=100)
14024 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14025 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14026 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14027 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14028 C model switches and parameters
14030 INTEGER ISWMDL,IPAMDL
14031 DOUBLE PRECISION PARMDL
14032 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14033 C data on most recent hard scattering
14034 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14035 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14036 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14037 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14038 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14039 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14040 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14041 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14042 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14043 C obsolete cut-off information
14044 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14045 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14049 IF(IDEB(32).GE.10) THEN
14050 WRITE(LO,'(1X,A)') 'PHO_SELSX2:'
14051 WRITE(LO,'(5X,A,5E11.3)') 'AS,XSUM1,2,XMAX1,2',
14052 & AS,XSUM1,XSUM2,XMAX1,XMAX2
14054 WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
14061 GAM1 = XPOT1(1)+1.D0
14062 GAM2 = XPOT2(1)+1.D0
14063 BET1 = XPOT1(2)+1.D0
14064 BET2 = XPOT2(2)+1.D0
14067 DO 100 I=1,IPAMDL(182)
14071 X1 = PHO_RNDBET(GAM1,BET1)
14073 IF(ITRY1.GE.50) GOTO 1000
14074 IF((X1.LE.XMIN(1,1)).OR.((1.D0-X1).LE.XMIN(1,2))) GOTO 10
14078 X2 = PHO_RNDBET(GAM2,BET2)
14080 IF(ITRY2.GE.50) GOTO 1000
14081 IF((X2.LE.XMIN(2,1)).OR.((1.D0-X2).LE.XMIN(2,2))) GOTO 11
14085 IF(X1*X2*FAC.GT.AS) THEN
14086 IF(X3*X4*FAC.GT.AS) THEN
14091 IF(XS1(1).GT.XMIN(1,1)) THEN
14092 IF(XS2(1).GT.XMIN(2,1)) THEN
14093 IF(XS1(2).GT.XMIN(1,2)) THEN
14094 IF(XS2(2).GT.XMIN(2,2)) THEN
14095 XSUM1 = XSUM1+XS1(2)
14096 XSUM2 = XSUM2+XS2(2)
14110 IF(IDEB(32).GE.2) THEN
14111 WRITE(LO,'(1X,A,3I4)')
14112 & 'PHO_SELSX2: REJECTION(ITRY0/1/2)',ITRY0,ITRY1,ITRY2
14113 WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
14120 *$ CREATE PHO_SELSXS.FOR
14122 CDECK ID>, PHO_SELSXS
14123 SUBROUTINE PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
14124 & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
14125 C***********************************************************************
14127 C select x values of soft string ends (rescaling method)
14129 C***********************************************************************
14130 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14133 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
14135 C input/output channels
14137 COMMON /POINOU/ LI,LO
14138 C event debugging information
14140 PARAMETER (NMAXD=100)
14141 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14142 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14143 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14144 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14145 C model switches and parameters
14147 INTEGER ISWMDL,IPAMDL
14148 DOUBLE PRECISION PARMDL
14149 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14150 C data on most recent hard scattering
14151 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14152 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14153 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14154 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14155 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14156 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14157 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14158 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14159 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14160 C obsolete cut-off information
14161 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14162 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14164 DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
14170 IF(MSOFT.EQ.1) THEN
14171 XSOFT1(1) = 1.D0-XS1
14173 XSOFT2(1) = 1.D0-XS2
14179 POT(1,I) = XPOT1(I)+1.D0
14180 POT(2,I) = XPOT2(I)+1.D0
14181 REVP(1,I) = 1.D0/POT(1,I)
14182 REVP(2,I) = 1.D0/POT(2,I)
14183 XLMIN(1,I) = XMIN(1,I)**POT(1,I)
14184 XLMAX = XMAX1**POT(1,I)
14185 XLDIF(1,I) = XLMAX-XLMIN(1,I)
14186 XLMIN(2,I) = XMIN(2,I)**POT(2,I)
14187 XLMAX = XMAX2**POT(2,I)
14188 XLDIF(2,I) = XLMAX-XLMIN(2,I)
14194 IF(ITRY0.GE.IPAMDL(180)) THEN
14195 IF(MSOFT-MSMIN.GE.2) THEN
14206 Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
14207 Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
14208 XSOFT1(I) = Z1**REVP(1,I)
14209 XSOFT2(I) = Z2**REVP(2,I)
14211 IF(ITRY1.GE.50) GOTO 1000
14212 IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
14213 XSUM1 = XSUM1+XSOFT1(I)
14214 XSUM2 = XSUM2+XSOFT2(I)
14216 FAC1 = (1.D0-XS1)/XSUM1
14217 FAC2 = (1.D0-XS2)/XSUM2
14219 XSOFT1(I) = XSOFT1(I)*FAC1
14220 XSOFT2(I) = XSOFT2(I)*FAC2
14221 IF(XSOFT1(I).LT.XMIN(1,I)) GOTO 5
14222 IF(XSOFT2(I).LT.XMIN(2,I)) GOTO 5
14223 IF(XSOFT1(I)*XSOFT2(I).LT.AS) GOTO 5
14226 XS1 = 1.D0-XSOFT1(1)
14227 XS2 = 1.D0-XSOFT2(1)
14232 IF(IDEB(14).GE.2) THEN
14233 WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXS: ',
14234 & 'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
14236 WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
14242 *$ CREATE PHO_SELSXI.FOR
14244 CDECK ID>, PHO_SELSXI
14245 SUBROUTINE PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
14246 & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
14247 C***********************************************************************
14249 C select x values of soft string ends (sea independent from valence)
14251 C***********************************************************************
14252 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14255 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
14257 C input/output channels
14259 COMMON /POINOU/ LI,LO
14260 C event debugging information
14262 PARAMETER (NMAXD=100)
14263 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14264 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14265 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14266 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14267 C model switches and parameters
14269 INTEGER ISWMDL,IPAMDL
14270 DOUBLE PRECISION PARMDL
14271 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14272 C data on most recent hard scattering
14273 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14274 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14275 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14276 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14277 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14278 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14279 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14280 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14281 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14282 C obsolete cut-off information
14283 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14284 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14286 DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
14293 POT(1,I) = XPOT1(I)+1.D0
14294 POT(2,I) = XPOT2(I)+1.D0
14295 REVP(1,I) = 1.D0/POT(1,I)
14296 REVP(2,I) = 1.D0/POT(2,I)
14297 XLMIN(1,I) = XMIN(1,I)**POT(1,I)
14298 XLMAX = XMAX1**POT(1,I)
14299 XLDIF(1,I) = XLMAX-XLMIN(1,I)
14300 XLMIN(2,I) = XMIN(2,I)**POT(2,I)
14301 XLMAX = XMAX2**POT(2,I)
14302 XLDIF(2,I) = XLMAX-XLMIN(2,I)
14310 IF(ITRY0.GE.IPAMDL(183)) THEN
14311 IF(MSOFT-MSMIN.GE.2) THEN
14322 Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
14323 Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
14324 XSOFT1(I) = Z1**REVP(1,I)
14325 XSOFT2(I) = Z2**REVP(2,I)
14327 IF(ITRY1.GE.50) GOTO 1000
14328 IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
14329 XSUM1 = XSUM1+XSOFT1(I)
14330 XSUM2 = XSUM2+XSOFT2(I)
14333 IF(XSUM1.GT.1.D0-XMIN(1,1)-XMIN(1,2)) GOTO 5
14334 IF(XSUM2.GT.1.D0-XMIN(2,1)-XMIN(2,2)) GOTO 5
14336 C selection of valence
14337 CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
14338 & XSOFT1,XSOFT2,IREJ)
14340 IF(MSOFT-MSMIN.GE.2) THEN
14344 IF(IDEB(31).GE.2) WRITE(LO,'(1X,A,1P,4E11.4)')
14345 & 'PHO_SELSXI: rejection by PHO_SELSX2 (XSUM1/2,XMAX1/2)',
14346 & XSUM1,XSUM2,XMAX1,XMAX2
14350 XS1 = 1.D0-XSOFT1(1)
14351 XS2 = 1.D0-XSOFT2(1)
14356 IF(IDEB(14).GE.2) THEN
14357 WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXI: ',
14358 & 'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
14360 WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
14366 *$ CREATE PHO_SELCOL.FOR
14368 CDECK ID>, PHO_SELCOL
14369 SUBROUTINE PHO_SELCOL(ICO1,ICO2,ICOA1,ICOA2,ICOB1,ICOB2,IMODE)
14370 C********************************************************************
14372 C color combinatorics
14374 C input: ICO1,2 colors of incoming particle
14375 C IMODE -2 output of initialization status
14376 C -1 initialization
14377 C ICINP(1) selection mode
14379 C 1 large N_c expansion
14380 C ICINP(2) max. allowed color
14381 C 0 clear internal color counter
14382 C 1 hadron into two colored objects
14383 C 2 quark into quark gluon
14384 C 3 gluon into gluon gluon
14385 C 4 gluon into quark antiquark
14387 C output: ICOA1,2 colors of first outgoing particle
14388 C ICOB1,2 colors of second outgoing particle
14390 C********************************************************************
14391 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14394 C input/output channels
14396 COMMON /POINOU/ LI,LO
14397 C event debugging information
14399 PARAMETER (NMAXD=100)
14400 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14401 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14402 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14403 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14405 DATA METHOD /0/, II /0/
14409 IF(METHOD.EQ.0) THEN
14411 IF(IMODE.EQ.1) THEN
14414 & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14419 ELSE IF(IMODE.EQ.2) THEN
14422 & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14433 ELSE IF(IMODE.EQ.3) THEN
14436 & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14437 IF(DT_RNDM(DUM).GT.0.5D0) THEN
14448 ELSE IF(IMODE.EQ.4) THEN
14453 ELSE IF(IMODE.EQ.0) THEN
14455 ELSE IF(IMODE.EQ.-1) THEN
14458 ELSE IF(IMODE.EQ.-2) THEN
14459 WRITE(LO,'(1X,A,2I5)') 'PHO_SELCOL: METHOD,MAXCOL',
14462 WRITE(LO,'(1X,A,I5)')
14463 & 'PHO_SELCOL:ERROR: unsupported mode',IMODE
14468 WRITE(LO,'(1X,A,I5)')
14469 & 'PHO_SELCOL:ERROR:unsupported method selected',METHOD
14474 IF(IDEB(75).GE.10) THEN
14475 WRITE(LO,'(1X,A,I5,I12,I5)') 'PHO_SELCOL: IMODE,MAXCOL,II',
14477 WRITE(LO,'(10X,A,2I5)') 'input colors',ICI1,ICI2
14478 WRITE(LO,'(10X,A,4I5)') 'output colors',ICOA1,ICOA2,ICOB1,ICOB2
14483 *$ CREATE ipho_diqu.FOR
14485 CDECK ID>, ipho_diqu
14486 INTEGER FUNCTION ipho_diqu(iq1,iq2)
14487 C***********************************************************************
14489 C selection of diquark number (PDG convention)
14491 C***********************************************************************
14497 C input/output channels
14499 COMMON /POINOU/ LI,LO
14500 C event debugging information
14502 PARAMETER (NMAXD=100)
14503 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14504 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14505 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14506 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14507 C model switches and parameters
14509 INTEGER ISWMDL,IPAMDL
14510 DOUBLE PRECISION PARMDL
14511 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14513 C external functions
14514 double precision DT_RNDM
14518 double precision dum
14526 i0 = max(i1,i2)*1000+min(i1,i2)*100
14527 if(DT_RNDM(dum).gt.PARMDL(135)) then
14534 ipho_diqu = sign(i0,iq1)
14538 *$ CREATE PHO_PARREM.FOR
14540 CDECK ID>, PHO_PARREM
14541 SUBROUTINE PHO_PARREM(INDX,IOUT,IREM,IREJ)
14542 C**********************************************************************
14544 C selection of particle remnant flavour(s) (quark or diquark)
14546 C input: INDX index of particle in /POEVT1/
14547 C IOUT parton which was taken out
14549 C output: IREM remnant according to valence flavours
14550 C IREJ 0 flavour combination possible
14551 C 1 flavour combination impossible
14553 C all particle ID are given according to PDG conventions
14555 C**********************************************************************
14559 integer INDX,IOUT,IREM,IREJ
14561 C input/output channels
14563 COMMON /POINOU/ LI,LO
14564 C event debugging information
14566 PARAMETER (NMAXD=100)
14567 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14568 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14569 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14570 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14571 C standard particle data interface
14573 PARAMETER (NMXHEP=4000)
14574 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14575 DOUBLE PRECISION PHEP,VHEP
14576 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14577 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14579 C extension to standard particle data interface (PHOJET specific)
14580 INTEGER IMPART,IPHIST,ICOLOR
14581 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14582 C general particle data
14583 double precision xm_list,tau_list,gam_list,
14584 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
14585 & xm_bb82_list,xm_bb102_list
14586 integer ich3_list,iba3_list,iq_list,
14587 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
14588 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
14589 & xm_psm2_list(6,6),xm_vem2_list(6,6),
14590 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
14591 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
14592 & ich3_list(300),iba3_list(300),iq_list(3,300),
14593 & id_psm_list(6,6),id_vem_list(6,6),
14594 & id_b8_list(6,6,6),id_b10_list(6,6,6)
14596 C external functions
14600 integer ID,IS,ID1,ID2,i,k,K1,K2,IQUA,IDQ
14601 dimension IQUA(3),IDQ(2)
14608 WRITE(LO,'(1X,A,I6)') 'PHO_PARREM: no CPC ID available for',INDX
14612 C particle with flavour mixing
14617 else if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
14618 C pi0, rho0, and omega
14619 IF(ABS(IOUT).LE.2) THEN
14625 else if((abs(ID1).eq.311).or.(ID1.eq.310).or.(ID1.eq.130)) then
14626 C neutral kaons (K0,K0-bar)
14627 if(abs(IOUT).eq.1) then
14628 IREM = sign(3,-IOUT)
14630 else if(abs(IOUT).eq.3) then
14631 IREM = sign(1,-IOUT)
14636 else if((ID1.eq.990).or.(ID1.eq.110)) then
14637 C pomeron and reggeon
14645 IQUA(1) = iq_list(1,ID)*IS
14646 IQUA(2) = iq_list(2,ID)*IS
14647 IQUA(3) = iq_list(3,ID)*IS
14649 C compare to flavour content
14650 IF(ABS(IOUT).LT.1000) THEN
14651 C single quark requested
14652 IF(IQUA(1).EQ.IOUT) THEN
14655 ELSE IF(IQUA(2).EQ.IOUT) THEN
14658 ELSE IF(IQUA(3).EQ.IOUT) THEN
14664 IF(IQUA(3).EQ.0) THEN
14667 IREM = ipho_diqu(IQUA(K1),IQUA(K2))
14669 ELSE IF(IQUA(3).NE.0) THEN
14670 C diquark requested from baryon
14672 IDQ(2) = (IOUT-IDQ(1)*1000)/100
14675 if(IDQ(i).eq.IQUA(k)) then
14683 IREM = IQUA(1)+IQUA(2)+IQUA(3)
14688 IF(IDEB(72).GE.10) WRITE(LO,'(1X,A,5I6)')
14689 & 'PHO_PARREM: INDX,ID-PDG,ID-BAM,IOUT,IREM',
14690 & INDX,ID1,ID2,IOUT,IREM
14696 IF(IDEB(72).GE.2) WRITE(LO,'(1X,A,5I7)')
14697 & 'PHO_PARREM: rejection IDPDG,Q1-3,IOUT',IDHEP(INDX),IQUA,IOUT
14701 *$ CREATE PHO_VALFLA.FOR
14703 CDECK ID>, PHO_VALFLA
14704 SUBROUTINE PHO_VALFLA(IPAR,IFL1,IFL2,E1,E2)
14705 C***********************************************************************
14707 C selection of valence flavour decomposition of particle IPAR
14709 C input: IPAR particle index in /POEVT1/
14710 C -1 initialization
14711 C -2 output of statistics
14712 C XMASS mass of particle
14713 C (important for pomeron:
14714 C mass dependent flavour sampling)
14716 C output: IFL1,IFL2
14717 C baryon: IFL1 diquark flavour
14718 C (valence flavours according to PDG conventions)
14720 C***********************************************************************
14721 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14724 PARAMETER ( EPS = 0.1D0,
14727 C input/output channels
14729 COMMON /POINOU/ LI,LO
14730 C event debugging information
14732 PARAMETER (NMAXD=100)
14733 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14734 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14735 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14736 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14737 C model switches and parameters
14739 INTEGER ISWMDL,IPAMDL
14740 DOUBLE PRECISION PARMDL
14741 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14742 C standard particle data interface
14744 PARAMETER (NMXHEP=4000)
14745 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14746 DOUBLE PRECISION PHEP,VHEP
14747 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14748 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14750 C extension to standard particle data interface (PHOJET specific)
14751 INTEGER IMPART,IPHIST,ICOLOR
14752 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14753 C general particle data
14754 double precision xm_list,tau_list,gam_list,
14755 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
14756 & xm_bb82_list,xm_bb102_list
14757 integer ich3_list,iba3_list,iq_list,
14758 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
14759 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
14760 & xm_psm2_list(6,6),xm_vem2_list(6,6),
14761 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
14762 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
14763 & ich3_list(300),iba3_list(300),iq_list(3,300),
14764 & id_psm_list(6,6),id_vem_list(6,6),
14765 & id_b8_list(6,6,6),id_b10_list(6,6,6)
14771 C select particle code
14773 ID = abs(IMPART(K))
14774 IBAR = IPHO_BAR3(K,2)
14782 if(ITER.GT.ITMX) then
14783 WRITE(LO,'(1x,2a,i10,1p,2e11.3)') 'PHO_VALFLA: ',
14784 & 'no valences found for (IPAR,E1,E2)',IPAR,E1,E2
14793 C charge dependent flavour sampling
14795 K = INT(DT_RNDM(E1)*6.D0)+1
14799 ELSE IF(K.EQ.5) THEN
14806 C optional strangeness suppression
14807 IF((IFL1.EQ.3).AND.(DT_RNDM(E2).GT.PARMDL(160))) GOTO 15
14808 IF(DT_RNDM(DUM).LT.0.5D0) THEN
14815 ELSE IF((ID1.EQ.990).or.(ID1.eq.110)) THEN
14816 IF(ISWMDL(19).EQ.0) THEN
14817 C SU(3) symmetric valences
14818 K = INT(DT_RNDM(E1)*3.D0)+1
14819 IF(DT_RNDM(DUM).LT.0.5D0) THEN
14825 ELSE IF(ISWMDL(19).EQ.1) THEN
14826 C mass dependent flavour sampling
14828 CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
14830 WRITE(LO,'(/1X,2A,I5)') 'PHO_VALFLA: ',
14831 & 'invalid flavour selection mode ISWMDL(19)',ISWMDL(19)
14835 C meson with flavour mixing
14836 ELSE if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
14837 K = INT(2.D0*DT_RNDM(E1))+1
14842 K = INT(2.D0*DT_RNDM(E1))+1
14843 IFL1 = iq_list(K,ID)
14845 IFL2 = iq_list(K,ID)
14848 CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
14854 K = INT(2.999999D0*DT_RNDM(E2))+1
14857 IFL1 = ipho_diqu(iq_list(K1,ID),iq_list(K2,ID))
14858 IFL2 = iq_list(K,ID)
14861 C change sign for antiparticles
14867 ************************************************************************
14868 C check kinematic constraints
14869 * IF((PHO_PMASS(IFL1,3).GT.E1)
14870 * & .OR.(PHO_PMASS(IFL2,3).GT.E2)) GOTO 10
14871 ************************************************************************
14874 IF(IDEB(46).GE.10) WRITE(LO,'(1X,A,I5,2E12.4,2I7)')
14875 & 'PHO_VALFLA: IPAR,MASS1/2,FL1/2',IPAR,E1,E2,IFL1,IFL2
14877 ELSE IF(IPAR.EQ.-1) THEN
14880 ELSE IF(IPAR.EQ.-2) THEN
14881 C output of final statistics
14884 WRITE(LO,'(1X,A,I10)')
14885 & 'PHO_VALFLA:ERROR: invalid input particle (IPAR)',IPAR
14891 *$ CREATE PHO_REGFLA.FOR
14893 CDECK ID>, PHO_REGFLA
14894 SUBROUTINE PHO_REGFLA(JM1,JM2,IFLR1,IFLR2,IREJ)
14895 C**********************************************************************
14897 C selection of reggeon flavours
14899 C input: JM1,JM2 position index of mother hadrons
14901 C output: IFLR1,IFLR2 valence flavours according to
14902 C PDG conventions and JM1,JM2
14903 C IREJ 0 reggeon possible
14904 C 1 reggeon impossible
14906 C**********************************************************************
14907 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14910 PARAMETER ( EPS = 0.1D0,
14913 C input/output channels
14915 COMMON /POINOU/ LI,LO
14916 C event debugging information
14918 PARAMETER (NMAXD=100)
14919 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14920 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14921 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14922 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14923 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
14924 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
14925 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
14926 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
14927 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
14928 C standard particle data interface
14930 PARAMETER (NMXHEP=4000)
14931 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14932 DOUBLE PRECISION PHEP,VHEP
14933 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14934 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14936 C extension to standard particle data interface (PHOJET specific)
14937 INTEGER IMPART,IPHIST,ICOLOR
14938 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14944 E1 = SQRT((PHEP(4,JM1)+PHEP(4,JM2))**2
14945 & -(PHEP(1,JM1)+PHEP(1,JM2))**2
14946 & -(PHEP(2,JM1)+PHEP(2,JM2))**2
14947 & -(PHEP(3,JM1)+PHEP(3,JM2))**2)/2.D0
14950 IF(ITER.GT.50) THEN
14953 IF(IDEB(41).GE.2) WRITE(LO,'(/1X,A,2I7,1P,E12.4)')
14954 & 'PHO_REGFLA: rejection, no reggeon found for',
14955 & IDHEP(JM1),IDHEP(JM2),E1
14959 CALL PHO_VALFLA(JM1,IFLA1,IFLA2,E1,E1)
14960 CALL PHO_VALFLA(JM2,IFLB1,IFLB2,E1,E1)
14961 IF(IFLA1.EQ.-IFLB1) THEN
14964 ELSE IF(IFLA1.EQ.-IFLB2) THEN
14967 ELSE IF(IFLA2.EQ.-IFLB1) THEN
14970 ELSE IF(IFLA2.EQ.-IFLB2) THEN
14975 IF(IDEB(41).GE.25) WRITE(LO,'(/1X,A,3I4)')
14976 & 'PHO_REGFLA: int.rejection JM1,JM2,ITRY',JM1,JM2,ITER
14980 IF(IDEB(41).GE.10) WRITE(LO,'(1X,A,/5X,2I4,2I6,2I5,1PE10.3)')
14981 & 'PHO_REGFLA: JM1/2,PDG-ID1/2,IFLR1/2,MASS',
14982 & JM1,JM2,IDHEP(JM1),IDHEP(JM2),IFLR1,IFLR2,E1
14983 ELSE IF(JM1.EQ.-1) THEN
14985 ELSE IF(JM1.EQ.-2) THEN
14986 C output of statistics
14988 WRITE(LO,'(1X,A,I10)')
14989 & 'PHO_REGFLA: invalid mother particle (JM1)',JM1
14995 *$ CREATE PHO_SEAFLA.FOR
14997 CDECK ID>, PHO_SEAFLA
14998 SUBROUTINE PHO_SEAFLA(IPAR,IFL1,IFL2,CHMASS)
14999 C**********************************************************************
15001 C selection of sea flavour content of particle IPAR
15003 C input: IPAR particle index in /POEVT1/
15004 C CHMASS available invariant string mass
15005 C positive mass --> use BAMJET method
15006 C negative mass --> SU(3) symmetric sea according
15007 C to values given in PARMDL(1-6)
15008 C IPAR -1 initialization
15009 C -2 output of statistics
15011 C output: sea flavours according to PDG conventions
15013 C**********************************************************************
15014 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15017 PARAMETER ( EPS = 0.1D0,
15020 C input/output channels
15022 COMMON /POINOU/ LI,LO
15023 C event debugging information
15025 PARAMETER (NMAXD=100)
15026 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15027 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15028 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15029 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15030 C model switches and parameters
15032 INTEGER ISWMDL,IPAMDL
15033 DOUBLE PRECISION PARMDL
15034 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15035 C some hadron information, will be deleted in future versions
15037 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
15038 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
15041 IF((ISWMDL(20).EQ.1).OR.(CHMASS.LT.0.D0)) THEN
15042 C constant weights for sea
15046 SUM = SUM + PARMDL(K)
15048 XI = DT_RNDM(SUM)*SUM
15051 SUM = SUM + PARMDL(K)
15052 IF(XI.LE.SUM) GOTO 55
15055 IF(K.GT.NFSEA) GOTO 15
15057 C mass dependent flavour sampling
15059 CALL PHO_FLAUX(CHMASS,K)
15060 IF(K.GT.NFSEA) GOTO 10
15062 IF(DT_RNDM(CHMASS).GT.0.5D0) K = -K
15065 IF(IDEB(46).GE.10) THEN
15066 WRITE(LO,'(1X,A,3I5,E12.4)') 'PHO_SEAFLA:IPAR,IFL1,IFL2,MASS',
15067 & IPAR,IFL1,IFL2,CHMASS
15069 ELSE IF(IPAR.EQ.-1) THEN
15072 ELSE IF(IPAR.EQ.-2) THEN
15073 C output of statistics
15075 WRITE(LO,'(1X,A,I10)') 'PHO_SEAFLA:ERROR:INVALID IPAR',IPAR
15081 *$ CREATE PHO_FLAUX.FOR
15083 CDECK ID>, PHO_FLAUX
15084 SUBROUTINE PHO_FLAUX(EQUARK,K)
15085 C***********************************************************************
15087 C auxiliary subroutine to select flavours
15089 C********************************************************************
15090 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15093 PARAMETER ( DEPS = 1.D-14 )
15095 C input/output channels
15097 COMMON /POINOU/ LI,LO
15098 C event debugging information
15100 PARAMETER (NMAXD=100)
15101 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15102 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15103 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15104 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15105 C some hadron information, will be deleted in future versions
15107 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
15108 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
15112 C calculate weights for given energy
15113 IF(EQUARK.LT.QMASS(1)) THEN
15115 & WRITE(LO,'(1X,A,E12.3)') 'PHO_FLAUX: VERY SMALL MASS',
15125 IF(EQUARK.GT.QMASS(K)) THEN
15126 WGHT(K) = PHO_BETAF(EQUARK,QMASS(K),BET)
15130 SUM = SUM + WGHT(K)
15134 XI = SUM*(DT_RNDM(SUM)-DEPS)
15139 SUM = SUM + WGHT(K)
15140 IF(XI.GT.SUM) GOTO 400
15142 IF(IDEB(16).GE.20) THEN
15143 WRITE(LO,'(1X,A,I5)') 'PHO_FLAUX: selected flavour',K
15147 *$ CREATE PHO_BETAF.FOR
15149 CDECK ID>, PHO_BETAF
15150 DOUBLE PRECISION FUNCTION PHO_BETAF(X1,X2,BET)
15151 C********************************************************************
15153 C weights of different quark flavours
15155 C********************************************************************
15156 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15161 IF(BETX1.LT.70.D0) AX=-1.D0/BET**2*(BETX1+1.D0)*EXP(-BETX1)
15162 AY=1.D0/BET**2*(BET*X2+1.D0)*EXP(-BET*X2)
15168 *$ CREATE PHO_MCHECK.FOR
15170 CDECK ID>, PHO_MCHECK
15171 SUBROUTINE PHO_MCHECK(J1,IREJ)
15172 C********************************************************************
15174 C check parton momenta for fragmentation
15176 C input: J1 first string number
15182 C IREJ 0 successful
15185 C in case of very small string mass:
15186 C NNCH mass label of string
15188 C -1 octett baryon / pseudo scalar meson
15189 C 1 decuplett baryon / vector meson
15190 C IBHAD hadron number according to CPC,
15191 C string will be treated as resonance
15192 C (sometimes far off mass shell)
15194 C constant WIDTH ( 0.01GeV ) determines range of acceptance
15196 C********************************************************************
15197 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15200 PARAMETER ( WIDTH = 0.01D0,
15203 C input/output channels
15205 COMMON /POINOU/ LI,LO
15206 C event debugging information
15208 PARAMETER (NMAXD=100)
15209 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15210 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15211 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15212 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15213 C model switches and parameters
15215 INTEGER ISWMDL,IPAMDL
15216 DOUBLE PRECISION PARMDL
15217 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15218 C standard particle data interface
15220 PARAMETER (NMXHEP=4000)
15221 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15222 DOUBLE PRECISION PHEP,VHEP
15223 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15224 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15226 C extension to standard particle data interface (PHOJET specific)
15227 INTEGER IMPART,IPHIST,ICOLOR
15228 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15229 C color string configurations including collapsed strings and hadrons
15231 PARAMETER (MSTR=500)
15232 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15233 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15234 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15235 & NNCH(MSTR),IBHAD(MSTR),ISTR
15236 C internal rejection counters
15238 PARAMETER (NMXJ=60)
15239 CHARACTER*10 REJTIT
15241 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
15244 C quark antiquark jet
15245 STRM = PHEP(5,NPOS(1,J1))
15246 IF(NCODE(J1).EQ.3) THEN
15247 CALL PHO_MEMASS(IPAR1(J1),IPAR2(J1),
15248 & AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
15250 & WRITE(LO,'(1X,A,/3X,I3,5E12.3)')
15251 & 'PHO_MCHECK:1.STRING NO, CHMASS,AMPS,AMPS2,AMVE,AMVE2 ',
15252 & J1,STRM,AMPS,AMPS2,AMVE,AMVE2
15253 IF(STRM.LT.AMPS) THEN
15255 IFAIL(20) = IFAIL(20) + 1
15257 ELSE IF(STRM.LT.AMPS2) THEN
15258 IF(STRM.LT.(AMVE-WIDTH)) THEN
15269 C quark diquark or v.s. jet
15270 ELSE IF((NCODE(J1).EQ.4).OR.(NCODE(J1).EQ.6)) THEN
15271 CALL PHO_BAMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),
15272 & AM8,AM82,AM10,AM102,I8,I10)
15274 & WRITE(LO,'(1X,A,/5X,I3,5E12.3)')
15275 & 'PHO_MCHECK:1.STRING NO, CHMASS,AM8,AM82,AM10,AM102 ',
15276 & J1,STRM,AM8,AM82,AM10,AM102
15277 IF(STRM.LT.AM8) THEN
15279 IFAIL(19) = IFAIL(19) + 1
15281 ELSE IF(STRM.LT.AM82) THEN
15282 IF(STRM.LT.(AM10-WIDTH)) THEN
15293 C diquark a-diquark string
15294 ELSE IF(NCODE(J1).EQ.5) THEN
15295 CALL PHO_DQMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),IPAR4(J1),
15298 & WRITE(LO,'(1X,A,/5X,I3,3E12.3)')
15299 & 'PHO_MCHECK:1.STRING NO, CHMASS,AM82,AM102 ',
15300 & J1,STRM,AM82,AM102
15301 IF(STRM.LT.AM82) THEN
15303 IFAIL(19) = IFAIL(19) + 1
15309 ELSE IF(NCODE(J1).LT.0) THEN
15312 WRITE(LO,'(/,1X,2A,2I8)') 'PHO_MCHECK: ',
15313 & 'inconsistent flavours for string (NO,NCODE)',J1,NCODE(J1)
15318 *$ CREATE PHO_POMCOR.FOR
15320 CDECK ID>, PHO_POMCOR
15321 SUBROUTINE PHO_POMCOR(IREJ)
15322 C********************************************************************
15324 C join quarks to gluons in case of too small masses
15328 C IREJ -1 initialization
15329 C -2 output of statistics
15333 C IREJ 0 successful
15337 C********************************************************************
15338 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15341 PARAMETER ( EPS = 1.D-10 )
15343 C input/output channels
15345 COMMON /POINOU/ LI,LO
15346 C event debugging information
15348 PARAMETER (NMAXD=100)
15349 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15350 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15351 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15352 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15353 C model switches and parameters
15355 INTEGER ISWMDL,IPAMDL
15356 DOUBLE PRECISION PARMDL
15357 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15358 C standard particle data interface
15360 PARAMETER (NMXHEP=4000)
15361 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15362 DOUBLE PRECISION PHEP,VHEP
15363 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15364 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15366 C extension to standard particle data interface (PHOJET specific)
15367 INTEGER IMPART,IPHIST,ICOLOR
15368 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15369 C color string configurations including collapsed strings and hadrons
15371 PARAMETER (MSTR=500)
15372 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15373 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15374 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15375 & NNCH(MSTR),IBHAD(MSTR),ISTR
15379 IF(IREJ.EQ.-1) THEN
15383 ELSE IF(IREJ.EQ.-2) THEN
15384 WRITE(LO,'(/1X,A,2I8)')
15385 & 'PHO_POMCOR: total/joined strings',ICTOT,ICCOR
15394 IF(ISWMDL(25).LE.0) RETURN
15395 C debug string entries
15396 IF(IDEB(83).GE.25) CALL PHO_PRSTRG
15400 IF(ITER.GE.NITER) THEN
15402 IF(IDEB(83).GE.2) THEN
15403 WRITE(LO,'(1X,A,2I5)') 'PHO_POMCOR: rejection',ITER,NITER
15404 IF(IDEB(83).GE.10) CALL PHO_PREVNT(0)
15409 C check mass limits
15412 IF(NCODE(I).LT.0) GOTO 99
15414 NRPOM = IPHIST(2,J1)
15415 IF(NRPOM.GE.100) GOTO 99
15416 CMASS0 = PHEP(5,J1)
15418 IF(NCODE(I).EQ.3) THEN
15419 CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
15420 ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
15421 CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
15422 & AM1,AM2,AM3,AM4,IP1,IP2)
15423 ELSE IF(NCODE(I).EQ.5) THEN
15424 CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
15430 ELSE IF(NCODE(I).EQ.7) THEN
15432 ELSE IF(NCODE(I).LT.0) THEN
15435 WRITE(LO,'(/,1X,A,2I5)') 'ERROR:PHO_POMCOR:STRING NO,NCODE ',
15440 & WRITE(LO,'(1X,A,/3X,2I4,5E11.3,2I5)')
15441 & 'PHO_POMCOR: STRING,POM,CHMASS,AM1,AM2,AM3,AM4,IP1,IP2',
15442 & I,NRPOM,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
15443 C select masses to correct
15444 IF(CMASS0.LT.MAX(AM2,AM4)) THEN
15446 IF((K.NE.I).AND.(NCODE(K).GE.0)) THEN
15448 C join quarks to gluon
15449 IF(NRPOM.EQ.IPHIST(2,J2)) THEN
15457 IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
15458 CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
15459 & -(PHEP(1,KK1)+PHEP(1,KK2))**2
15460 & -(PHEP(2,KK1)+PHEP(2,KK2))**2
15461 & -(PHEP(2,KK1)+PHEP(2,KK2))**2
15462 IFL1 = ABS(IDHEP(KK1))
15464 PROB1 = 0.1D0/MAX(CMASS,EPS)
15466 PROB1 = 0.9D0/MAX(CMASS,EPS)
15469 KK1 = ABS(NPOS(3,I))
15470 KK2 = ABS(NPOS(3,K))
15471 IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
15472 CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
15473 & -(PHEP(1,KK1)+PHEP(1,KK2))**2
15474 & -(PHEP(2,KK1)+PHEP(2,KK2))**2
15475 & -(PHEP(2,KK1)+PHEP(2,KK2))**2
15476 IFL2 = ABS(IDHEP(KK1))
15478 PROB2 = 0.1D0/MAX(CMASS,EPS)
15480 PROB2 = 0.9D0/MAX(CMASS,EPS)
15483 IF(IFL1+IFL2.EQ.0) GOTO 99
15486 IF((DT_RNDM(CMASS)*(PROB1+PROB2)).LT.PROB1) THEN
15493 KK1 = ABS(NPOS(JJ,I))
15494 KK2 = ABS(NPOS(JJ,K))
15495 I1 = ABS(NPOS(JE,I))
15500 K2 = ABS(NPOS(JE,K))
15504 C copy mother partons of string I
15506 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
15507 & PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
15508 & ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
15512 PJ(II) = PHEP(II,KK1)+PHEP(II,KK2)
15514 CALL PHO_REGPAR(-1,21,0,J1,J2,PJ(1),PJ(2),PJ(3),PJ(4),
15515 & I,IPHIST(2,KK2),ICOLOR(1,KK1),ICOLOR(1,KK2),IPOS,1)
15516 C copy mother partons of string K
15518 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
15519 & PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
15520 & ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
15522 C create new string entry
15524 PJ(II) = PHEP(II,J1)+PHEP(II,J2)
15527 CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PJ(1),PJ(2),PJ(3),
15528 & PJ(4),I,IPHIST(2,J1),ICOLOR(1,J1)+ICOLOR(1,J2),
15529 & ICOLOR(2,J1)+ICOLOR(2,J2),IPOS,1)
15530 C delete string K in /POSTRG/
15532 C update string I in /POSTRG/
15536 C calculate new CPC string codes
15537 CALL PHO_ID2STR(IDHEP(IP1),IDHEP(IP2),NCODE(I),IPAR1(I),
15538 & IPAR2(I),IPAR3(I),IPAR4(I))
15546 IF(IDEB(83).GE.20) THEN
15547 WRITE(LO,'(1X,A)') 'PHO_POMCOR: after string recombination'
15548 IF(IDEB(83).GE.22) THEN
15556 *$ CREATE PHO_MASCOR.FOR
15558 CDECK ID>, PHO_MASCOR
15559 SUBROUTINE PHO_MASCOR(IREJ)
15560 C********************************************************************
15562 C check and adjust parton momenta for fragmentation
15566 C IREJ -1 initialization
15567 C -2 output of statistics
15571 C IREJ 0 successful
15574 C in case of very small string mass:
15575 C - direct manipulation of /POEVT1/ and /POEVT2/
15576 C - string will be deleted from /POSTRG/ (label -99)
15578 C********************************************************************
15579 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15582 PARAMETER ( EPS = 1.D-10,
15586 C input/output channels
15588 COMMON /POINOU/ LI,LO
15589 C event debugging information
15591 PARAMETER (NMAXD=100)
15592 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15593 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15594 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15595 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15596 C internal rejection counters
15598 PARAMETER (NMXJ=60)
15599 CHARACTER*10 REJTIT
15601 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
15602 C model switches and parameters
15604 INTEGER ISWMDL,IPAMDL
15605 DOUBLE PRECISION PARMDL
15606 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15607 C standard particle data interface
15609 PARAMETER (NMXHEP=4000)
15610 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15611 DOUBLE PRECISION PHEP,VHEP
15612 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15613 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15615 C extension to standard particle data interface (PHOJET specific)
15616 INTEGER IMPART,IPHIST,ICOLOR
15617 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15618 C color string configurations including collapsed strings and hadrons
15620 PARAMETER (MSTR=500)
15621 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15622 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15623 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15624 & NNCH(MSTR),IBHAD(MSTR),ISTR
15626 DIMENSION PC1(4),PC2(4),P1(4),PTR(4),GAM(3),GAMB(3)
15628 IF(IREJ.EQ.-1) THEN
15632 ELSE IF(IREJ.EQ.-2) THEN
15633 WRITE(LO,'(/1X,A,2I8/)')
15634 & 'PHO_MASCOR: total/converted strings',ICTOT,ICCOR
15642 IF(ISWMDL(7).EQ.-1) RETURN
15644 IF(IDEB(42).GE.25) CALL PHO_PRSTRG
15649 IF(ITER.GE.NITER) THEN
15651 IF(IDEB(42).GE.2) THEN
15652 WRITE(LO,'(1X,A,2I5)') 'PHO_MASCOR: rejection',ITER,NITER
15653 IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
15658 C check mass limits
15659 IF(DT_RNDM(CMASS0).LT.0.5D0) THEN
15668 DO 100 I=IM1,IM2,IST
15670 CMASS0 = PHEP(5,J1)
15672 IF(NCODE(I).EQ.3) THEN
15673 CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
15674 ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
15675 CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
15676 & AM1,AM2,AM3,AM4,IP1,IP2)
15677 ELSE IF(NCODE(I).EQ.5) THEN
15678 CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
15684 ELSE IF(NCODE(I).EQ.7) THEN
15689 *??????????????????????????????????
15692 *??????????????????????????????????
15693 ELSE IF(NCODE(I).LT.0) THEN
15696 WRITE(LO,'(/,1X,A,2I5)') 'PHO_MASCOR:ERROR: string no,NCODE ',
15700 IF(IDEB(42).GE.20) WRITE(LO,'(1X,A,/3X,I3,5E11.3,2I5)')
15701 & 'PHO_MASCOR: string no CHMASS,AM1,AM2,AM3,AM4,IP1,IP2:',
15702 & I,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
15703 C select masses to correct
15706 C correction needed?
15707 C no resonances for diquark-antidiquark and gluon-gluon strings
15708 IF(NCODE(I).EQ.5) THEN
15709 IF(CMASS0.LT.1.3D0*AM1) THEN
15710 IF(ISWMDL(7).LE.2) THEN
15721 C resonances possible
15722 IF(ISWMDL(7).EQ.0) THEN
15723 IF(CMASS0.LT.AM1*0.99D0) THEN
15728 ELSE IF(CMASS0.LT.MIN(AM2,AM4)*1.2D0) THEN
15729 DELM1 = 1.D0/((CMASS0-AM1)**2+EPS)
15730 DELM2 = 1.D0/((CMASS0-AM3)**2+EPS)
15731 IF(DT_RNDM(DELM1).LT.DELM1/(DELM1+DELM2)) THEN
15741 ELSE IF((ISWMDL(7).EQ.1).OR.(ISWMDL(7).EQ.2)) THEN
15742 IF(CMASS0.LT.AM1*0.99) THEN
15748 ELSE IF(ISWMDL(7).EQ.3) THEN
15749 IF(CMASS0.LT.AM1) THEN
15754 WRITE(LO,'(/1X,A,I5)')
15755 & 'PHO_MASCOR:ERROR:UNSUPPORTED ISWMDL(7)',ISWMDL(7)
15760 C correction necessary?
15761 IF(IBHAD(I).NE.0) THEN
15762 C find largest invar. mass
15765 DO 200 J2=NHEP,3,-1
15766 IF(ABS(ISTHEP(J2)).EQ.1) THEN
15767 IF((IPHIST(1,J2).LE.0).OR.(IPHIST(1,J2).GT.ISTR)) THEN
15768 WRITE(LO,'(1X,2A,I7,I12)') 'PHO_MASCOR: ',
15769 & 'inconsistent IPHIST(1,J2) entry (J2,KEV):',J2,KEVENT
15771 ELSE IF(NCODE(IPHIST(1,J2)).GT.0) THEN
15772 CMASS2= (PHEP(4,J1)+PHEP(4,J2))**2
15773 & -(PHEP(1,J1)+PHEP(1,J2))**2
15774 & -(PHEP(2,J1)+PHEP(2,J2))**2
15775 & -(PHEP(3,J1)+PHEP(3,J2))**2
15776 IF(CMASS2.GT.CMASS1) THEN
15784 IF((J1.EQ.J2).OR.(CMASS1.LE.EMIN)) THEN
15785 IF(INEED.EQ.1) THEN
15796 CMASS1 = SQRT(CMASS1)
15797 CMASS2 = PHEP(5,J2)
15798 IF(CMASS1.LT.(CMASS2+CHMASS)) CMASS2 = CMASS1-1.1D0*CHMASS
15800 IF(CMASS2.GT.0.D0) CALL PHO_MSHELL(PHEP(1,J1),PHEP(1,J2),
15801 & CHMASS,CMASS2,PC1,PC2,IREJ)
15803 IFAIL(24) = IFAIL(24)+1
15804 IF(IDEB(42).GE.2) THEN
15805 WRITE(LO,'(1X,A,2I4)')
15806 & 'PHO_MASCOR: rejection by PHO_MSHELL (J1,J2):',J1,J2
15807 IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
15812 C momentum transfer
15814 PTR(II) = PHEP(II,J2)-PC2(II)
15816 IF(IDEB(42).GE.10) WRITE(LO,'(1X,A,/5X,2I3,4E12.3)')
15817 & 'PHO_MASCOR: J1,J2,transfer',J1,J2,PTR
15818 C copy parents of strings
15819 C register partons belonging to first string
15820 IF(IDHEP(J1).EQ.90) THEN
15822 K2 = MAX(JMOHEP(1,J1),-JMOHEP(2,J1))
15825 ESUM = ESUM+PHEP(4,II)
15827 IF(JMOHEP(2,J1).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J1))
15829 FAC = PHEP(4,II)/ESUM
15831 P1(K) = PHEP(K,II)+FAC*PTR(K)
15833 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15834 & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15835 & ICOLOR(2,II),IPOS,1)
15838 IF(JMOHEP(2,J1).GT.0) THEN
15840 FAC = PHEP(4,II)/ESUM
15842 P1(K) = PHEP(K,II)+FAC*PTR(K)
15844 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15845 & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15846 & ICOLOR(2,II),IPOS,1)
15853 C register partons belonging to second string
15854 IF(IDHEP(J2).EQ.90) THEN
15855 CALL PHO_GETLTR(PHEP(1,J2),PC2,GAM,GAMB,DELE,IREJL)
15857 K2 = MAX(JMOHEP(1,J2),-JMOHEP(2,J2))
15860 ESUM = ESUM+PHEP(4,II)
15862 IF(JMOHEP(2,J2).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J2))
15864 **sr 28.12.2006 fix adopted from FLUKA
15865 C FAC = PHEP(4,II)/ESUM
15866 IF (ABS(ESUM).GT.0.D0) THEN
15867 FAC = PHEP(4,II)/ESUM
15872 IF(IREJL.EQ.0) THEN
15873 CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
15874 P1(4) = P1(4)+FAC*DELE
15877 P1(K) = PHEP(K,II)-FAC*PTR(K)
15880 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15881 & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15882 & ICOLOR(2,II),IPOS,1)
15885 IF(JMOHEP(2,J2).GT.0) THEN
15887 FAC = PHEP(4,II)/ESUM
15888 IF(IREJL.EQ.0) THEN
15889 CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
15890 P1(4) = P1(4)+FAC*DELE
15893 P1(K) = PHEP(K,II)-FAC*PTR(K)
15896 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15897 & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15898 & ICOLOR(2,II),IPOS,1)
15905 C register first string/collapsed to hadron
15906 IF((ISWMDL(7).EQ.0).OR.(ISWMDL(7).EQ.1)) THEN
15907 IF(NCODE(I).NE.5) THEN
15908 CALL PHO_REGPAR(1,0,IBHAD(I),K1A,K2A,PC1(1),PC1(2),PC1(3),
15909 & PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
15910 C label string as collapsed to hadron/resonance
15914 CALL PHO_REGPAR(-1,90,0,K1A,K2A,PC1(1),PC1(2),PC1(3),
15915 & PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
15922 CALL PHO_REGPAR(ISTA,IDHEP(J1),IMPART(J1),K1A,K2A,PC1(1),
15923 & PC1(2),PC1(3),PC1(4),IPHIST(1,J1),IPHIST(2,J1),
15924 & ICOLOR(1,J1),ICOLOR(2,J1),IPOS,1)
15925 IF(IDHEP(J1).EQ.90) THEN
15926 NPOS(1,IPHIST(1,J1)) = IPOS
15927 NPOS(2,IPHIST(1,J1)) = K1A
15928 NPOS(3,IPHIST(1,J1)) = K2A
15929 C label string as collapsed to resonance-string
15931 ELSE IF((IPHIST(1,J1).GE.1).AND.(IPHIST(1,J1).LE.ISTR)) THEN
15932 IF(NPOS(1,IPHIST(1,J1)).EQ.J1) NPOS(1,IPHIST(1,J1))=IPOS
15935 C register second string/hadron/parton
15936 CALL PHO_REGPAR(ISTB,IDHEP(J2),IMPART(J2),K1B,K2B,PC2(1),
15937 & PC2(2),PC2(3),PC2(4),IPHIST(1,J2),IPHIST(2,J2),ICOLOR(1,J2),
15938 & ICOLOR(2,J2),IPOS,1)
15939 IF(IDHEP(J2).EQ.90) THEN
15940 NPOS(1,IPHIST(1,J2))=IPOS
15941 NPOS(2,IPHIST(1,J2))=K1B
15942 NPOS(3,IPHIST(1,J2))=K2B
15943 C label string touched by momentum transfer
15945 ELSE IF((IPHIST(1,J2).GE.1).AND.(IPHIST(1,J2).LE.ISTR)) THEN
15946 IF(NPOS(1,IPHIST(1,J2)).EQ.J2) NPOS(1,IPHIST(1,J2))=IPOS
15950 C consistency checks
15951 IF(IDEB(42).GE.5) THEN
15952 CALL PHO_CHECK(-1,IDEV)
15953 IF(IDEB(42).GE.25) CALL PHO_PREVNT(0)
15955 C jump to next iteration
15961 IF(IDEB(42).GE.15) THEN
15962 IF((ITOUCH.GT.0).OR.(IDEB(42).GE.25)) THEN
15963 WRITE(LO,'(1X,A,I5)') 'PHO_MASCOR: iterations:',ITER
15969 *$ CREATE PHO_PARCOR.FOR
15971 CDECK ID>, PHO_PARCOR
15972 SUBROUTINE PHO_PARCOR(MODE,IREJ)
15973 C********************************************************************
15975 C conversion of string partons (using JETSET masses)
15977 C input: MODE >0 position index of corresponding string
15978 C -1 initialization
15979 C -2 output of statistics
15982 C IREJ 1 combination of strings impossible
15983 C 0 successful combination
15985 C********************************************************************
15986 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15989 PARAMETER ( DELM = 0.005D0,
15993 C input/output channels
15995 COMMON /POINOU/ LI,LO
15996 C event debugging information
15998 PARAMETER (NMAXD=100)
15999 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16000 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16001 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16002 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16003 C internal rejection counters
16005 PARAMETER (NMXJ=60)
16006 CHARACTER*10 REJTIT
16008 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
16009 C model switches and parameters
16011 INTEGER ISWMDL,IPAMDL
16012 DOUBLE PRECISION PARMDL
16013 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16014 C standard particle data interface
16016 PARAMETER (NMXHEP=4000)
16017 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16018 DOUBLE PRECISION PHEP,VHEP
16019 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16020 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16022 C extension to standard particle data interface (PHOJET specific)
16023 INTEGER IMPART,IPHIST,ICOLOR
16024 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16025 C color string configurations including collapsed strings and hadrons
16027 PARAMETER (MSTR=500)
16028 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16029 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16030 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16031 & NNCH(MSTR),IBHAD(MSTR),ISTR
16033 DIMENSION PP1(4),PP2(4),PB1(4),PB2(4),GAM(3),GAMB(3),
16034 & PL(4,100),XMP(100),XML(100)
16036 DOUBLE PRECISION PYMASS
16041 IF(IMODE.GT.0) THEN
16043 I1 = JMOHEP(1,IMODE)
16044 I2 = ABS(JMOHEP(2,IMODE))
16045 C copy to local field
16050 PL(K,L) = PHEP(K,I)
16053 XML(L) = PYMASS(IDHEP(I))
16056 XMC = PHEP(5,IMODE)
16057 IF(IDEB(82).GE.20) THEN
16058 WRITE(LO,'(1X,A,I7,2I4)')
16059 & 'PHO_PARCOR: ini.momenta,masses(C/L),EV,ICH,L',
16062 WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16067 C two parton configurations
16068 C -----------------------------------------
16072 IF((XM1+XM2).GE.XMC) THEN
16073 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,/,5X,I3,3E12.4)')
16074 & 'PHO_PARCOR: REJECTION I,XM1,XM2,XMC',
16075 & IMODE,XM1,XM2,XMC
16078 C conversion possible
16079 CALL PHO_MSHELL(PL(1,1),PL(1,2),XM1,XM2,PP1,PP2,IREJ)
16081 IFAIL(36) = IFAIL(36)+1
16082 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,I4,E12.4)')
16083 & 'PHO_PARCOR: rejection by PHO_MSHELL EV,STRING,MASS',
16095 C multi parton configurations
16096 C ---------------------------------
16099 C random selection of string side to start with
16100 IF(DT_RNDM(XMC).LT.0.5D0) THEN
16122 IF(ITER.GT.2) GOTO 230
16124 C conversion according to color flow method
16126 DO 210 II=K1,K2-KS,KS
16127 DO 215 IK=II+KS,K2,KS
16130 * IF(IDEB(82).GE.10) WRITE(LO,'(1X,A,2I3,4E12.4)')
16131 * & 'PHO_PARCOR:I,K,XM(1-4)',II,IK,XM1,XMP(II),XM2,XMP(IK)
16132 IF((ABS(XM1-XMP(II)).GT.DELM)
16133 & .OR.(ABS(XM2-XMP(IK)).GT.DELM)) THEN
16134 CALL PHO_MSHELL(PL(1,II),PL(1,IK),XM1,XM2,PP1,PP2,IREJ)
16136 IFAIL(36) = IFAIL(36)+1
16137 IF(IDEB(82).GE.6) WRITE(LO,'(1X,2A,I8,3I4)')
16139 & 'int.rej. by PHO_MSHELL EV,IC,I1,I2',
16140 & KEVENT,IMODE,II,IK
16145 PL(KK,II) = PP1(KK)
16146 PL(KK,IK) = PP2(KK)
16159 IF(IFAI.NE.0) GOTO 300
16164 C conversion according to remainder method
16167 IF(ABS(XM1-XMP(I)).GT.DELM) THEN
16170 C conversion necessary
16173 PB2(K) = PHEP(K,IMODE)-PB1(K)
16175 XM2 = PB2(4)**2-PB2(1)**2-PB2(2)**2-PB2(3)**2
16176 IF(XM2.LT.0.D0) THEN
16177 IF(IDEB(82).GE.10) WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
16179 & 'int.rej. I,IPA,ICH,XML,XMP,XM2**2,MCHAIN',
16180 & I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
16184 IF((XM1+XM2).GE.XMC) THEN
16185 IF(IDEB(82).GE.10) WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
16187 & 'int.rej. I,IPA,ICH,XML,XMP,XM2,XMC',
16188 & I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
16191 C conversion possible
16192 CALL PHO_MSHELL(PB1,PB2,XM1,XM2,PP1,PP2,IREJ)
16194 IFAIL(36) = IFAIL(36)+1
16195 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,3I4)')
16196 & 'PHO_PARCOR: PHO_MSHELL rej. ITER,STRING,PARTON',
16200 C calculate Lorentz transformation
16201 CALL PHO_GETLTR(PB2,PP2,GAM,GAMB,DELE,IREJ)
16203 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,3I4)')
16204 & 'PHO_PARCOR: PHO_GETLTR rej. ITER,STRING,PARTON',
16209 C transform remaining partons
16212 CALL PHO_MKSLTR(PL(1,L),PP2,GAM,GAMB)
16227 C register transformed partons
16235 CALL PHO_REGPAR(-1,IDHEP(I),0,IMODE,0,PL(1,L),PL(2,L),
16236 & PL(3,L),PL(4,L),IPHIST(1,I),IPHIST(2,I),ICOLOR(1,I),
16237 & ICOLOR(2,I),IPOS,1)
16241 CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PHEP(1,IMODE),
16242 & PHEP(2,IMODE),PHEP(3,IMODE),PHEP(4,IMODE),IPHIST(1,IMODE),
16243 & IPHIST(2,IMODE),ICOLOR(1,IMODE),ICOLOR(2,IMODE),IPOS,1)
16245 I = IPHIST(1,IMODE)
16251 IF(IDEB(82).GE.20) THEN
16252 WRITE(LO,'(1X,A,I7,2I4)')
16253 & 'PHO_PARCOR: fin.momenta,masses(C/L),(EV,ICH,L)',
16256 WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16259 WRITE(LO,'(1X,A,2I5)')
16260 & 'PHO_PARCOR: conversion done (old/new ICH)',IMODE,IPOS
16266 IF(IDEB(82).GE.3) THEN
16267 WRITE(LO,'(/1X,A,/,5X,3I5,E12.4)')
16268 & 'PHO_PARCOR: rejection I,IPAR,ICHAIN,MCHAIN',
16269 & IFAI,IPAR,IMODE,XMC
16270 IF(IDEB(82).GE.5) THEN
16271 WRITE(LO,'(1X,A,I7,2I4)')
16272 & 'PHO_PARCOR: momenta,masses(C/L),(EV,ICH,L)',
16273 & KEVENT,IMODE,IPAR
16275 WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16282 ELSE IF(IMODE.EQ.-1) THEN
16286 ELSE IF(IMODE.EQ.-2) THEN
16292 *$ CREATE PHO_STRING.FOR
16294 CDECK ID>, PHO_STRING
16295 SUBROUTINE PHO_STRING(IMODE,IREJ)
16296 C********************************************************************
16298 C calculation of string combinatorics, Lorentz boosts and
16301 C - splitting of gluons
16302 C - strings will be built up from pairs of partons
16303 C according to their color labels
16304 C with IDHEP(..) = -1
16305 C - there can be other particles between to string partons
16306 C (these will be unchanged by string construction)
16307 C - string mass fine correction
16309 C input: IMODE 1 complete string processing
16310 C -1 initialization
16311 C -2 output of statistics
16314 C IREJ 1 combination of strings impossible
16315 C 0 successful combination
16316 C 50 rejection due to user cutoffs
16318 C********************************************************************
16319 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16322 PARAMETER ( DEPS = 1.D-15,
16325 C input/output channels
16327 COMMON /POINOU/ LI,LO
16328 C event debugging information
16330 PARAMETER (NMAXD=100)
16331 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16332 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16333 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16334 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16335 C general process information
16336 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
16337 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
16338 C internal rejection counters
16340 PARAMETER (NMXJ=60)
16341 CHARACTER*10 REJTIT
16343 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
16344 C model switches and parameters
16346 INTEGER ISWMDL,IPAMDL
16347 DOUBLE PRECISION PARMDL
16348 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16349 C hard cross sections and MC selection weights
16351 PARAMETER ( Max_pro_2 = 16 )
16352 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
16353 & MH_acc_1,MH_acc_2
16354 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
16355 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
16356 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
16357 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
16358 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
16359 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
16360 C standard particle data interface
16362 PARAMETER (NMXHEP=4000)
16363 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16364 DOUBLE PRECISION PHEP,VHEP
16365 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16366 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16368 C extension to standard particle data interface (PHOJET specific)
16369 INTEGER IMPART,IPHIST,ICOLOR
16370 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16371 C color string configurations including collapsed strings and hadrons
16373 PARAMETER (MSTR=500)
16374 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16375 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16376 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16377 & NNCH(MSTR),IBHAD(MSTR),ISTR
16378 C table of particle indices for recursive PHOJET calls
16380 PARAMETER ( MAXIPX = 100 )
16381 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
16382 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
16383 & IPOIX1,IPOIX2,IPOIX3
16385 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
16386 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
16387 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
16390 IF(IMODE.EQ.-1) THEN
16391 CALL PHO_POMCOR(-1)
16392 CALL PHO_MASCOR(-1)
16393 CALL PHO_PARCOR(-1,IREJ)
16395 ELSE IF(IMODE.EQ.-2) THEN
16396 CALL PHO_POMCOR(-2)
16397 CALL PHO_MASCOR(-2)
16398 CALL PHO_PARCOR(-2,IREJ)
16402 C generate enhanced graphs
16403 IF(IPOIX2.GT.0) THEN
16407 IF(ISWMDL(14).EQ.1) IPOIX1 = 0
16421 IF(IPORES(I).EQ.8) THEN
16427 IGEN = abs(IPHIST(2,IPOPOS(1,I)))
16428 CALL PHO_STDPAR(IPOPOS(1,I),IPOPOS(2,I),IGEN,
16429 & LSPOM,LSREG,LHPOM,LHDIR,IREJ)
16431 IF(IDEB(4).GE.2) THEN
16432 WRITE(LO,'(/1X,A,I5)')
16433 & 'PHO_STRING: sec.rejection by PHO_STDPAR',IREJ
16434 CALL PHO_PREVNT(-1)
16438 KSPOM = KSPOMS+LSPOM
16439 KSREG = KSREGS+LSREG
16440 KHPOM = KHPOMS+LHPOM
16441 KHDIR = KHDIRS+LHDIR
16442 ELSE IF(IPORES(I).EQ.4) THEN
16445 CALL PHO_CDIFF(IPOPOS(1,I),IPOPOS(2,I),MSOFT,MHARD,1,IREJ)
16448 IF(IDEB(4).GE.2) THEN
16449 WRITE(LO,'(/1X,A,I5)')
16450 & 'PHO_STRING: sec.rejection by PHO_CDIFF',IREJ
16451 CALL PHO_PREVNT(-1)
16456 KSPOM = KSPOMS+KSPOM
16457 KSREG = KSREGS+KSREG
16458 KHPOM = KHPOMS+KHPOM
16459 KHDIR = KHDIRS+KHDIR
16463 IF(IPORES(I).EQ.5) THEN
16466 ELSE IF(IPORES(I).EQ.6) THEN
16475 CALL PHO_DIFDIS(IDIF1,IDIF2,IPOPOS(1,I),IPOPOS(2,I),SPROB,
16476 & 0,MSOFT,MHARD,IREJ)
16479 IF(IDEB(4).GE.2) THEN
16480 WRITE(LO,'(/1X,A,I5)')
16481 & 'PHO_STRING: sec.rejection by PHO_DIFDIS',IREJ
16482 CALL PHO_PREVNT(-1)
16486 KSPOM = KSPOMS+KSPOM
16487 KSREG = KSREGS+KSREG
16488 KHPOM = KHPOMS+KHPOM
16489 KHDIR = KHDIRS+KHDIR
16495 IF(IPOIX2.GT.I2) THEN
16501 C optional: split gluons to q-qbar pairs
16502 IF(ISWMDL(9).GT.0) THEN
16505 IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).EQ.21)) THEN
16511 IF(ICOLOR(1,K).EQ.-ICG1) THEN
16513 IF(IQ1*IQ2.NE.0) GOTO 45
16514 ELSE IF(ICOLOR(1,K).EQ.-ICG2) THEN
16516 IF(IQ1*IQ2.NE.0) GOTO 45
16519 WRITE(LO,'(/1X,2A,3I6)') 'PHO_STRING:ERROR:(1) ',
16520 & 'no matching color found (IG,ICG1,ICG2)',I,ICG1,ICG2
16523 CALL PHO_GLU2QU(I,IQ1,IQ2,IREJ)
16525 IF(IDEB(19).GE.5) THEN
16526 WRITE(LO,'(/,1X,A)')
16527 & 'PHO_STRING: no gluon splitting possible'
16536 C construct strings and write entries sorted by strings
16541 IF(ISTR.GT.MSTR) THEN
16542 WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
16543 & 'event has too many strings (ISTR,MSTR):',ISTR,MSTR
16548 IF(ISTHEP(I).EQ.1) THEN
16549 C hadrons / resonances / clusters
16553 NPOS(4,ISTR) = abs(IPHIST(2,I))
16557 ELSE IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).NE.21)) THEN
16558 C quark /diquark terminated strings
16559 ICOL1 = -ICOLOR(1,I)
16564 ICH1 = IPHO_CHR3(I,2)
16565 IBA1 = IPHO_BAR3(I,2)
16566 CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
16567 & P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
16568 & ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
16574 IF(ISTHEP(K).EQ.-1)THEN
16575 IF(IDHEP(K).EQ.21) THEN
16576 IF(ICOLOR(1,K).EQ.ICOL1) THEN
16577 ICOL1 = -ICOLOR(2,K)
16579 ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
16580 ICOL1 = -ICOLOR(1,K)
16583 ELSE IF(ICOLOR(1,K).EQ.ICOL1) THEN
16589 WRITE(LO,'(/1X,A,I5)')
16590 & 'PHO_STRING:ERROR:(2) no matching color found for',-ICOL1
16597 NRPOM = MAX(NRPOM,IPHIST(1,K))
16598 ICH1 = ICH1+IPHO_CHR3(K,2)
16599 IBA1 = IBA1+IPHO_BAR3(K,2)
16600 CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
16601 & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
16602 & IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
16603 C further parton involved?
16604 IF(ICOL1.NE.0) GOTO 65
16608 CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
16609 & ISTR,IGEN,ICH1,IBA1,IPOS,1)
16610 C store additional string information
16611 NPOS(1,ISTR) = IPOS
16613 NPOS(3,ISTR) = -JM2
16614 NPOS(4,ISTR) = abs(IPHIST(2,K))
16615 C calculate CPC string codes
16616 CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
16617 & IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
16623 IF(ISTR.GT.MSTR) THEN
16624 WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
16625 & 'event has too many strings (ISTR,MSTR):',ISTR,MSTR
16630 IF(ISTHEP(I).EQ.-1) THEN
16631 C gluon loop-strings
16632 ICOL1 = -ICOLOR(1,I)
16639 CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
16640 & P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
16641 & ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
16646 IF(ICOLOR(2,I).EQ.ICOL1) GOTO 170
16648 IF(ISTHEP(K).EQ.-1)THEN
16649 IF(ICOLOR(1,K).EQ.ICOL1) THEN
16650 ICOL1 = -ICOLOR(2,K)
16652 ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
16653 ICOL1 = -ICOLOR(1,K)
16658 WRITE(LO,'(/1X,A,I5)')
16659 & 'PHO_STRING:ERROR:(3) no matching color found for',-ICOL1
16666 NRPOM = MAX(NRPOM,IPHIST(1,K))
16667 CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
16668 & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
16669 & IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
16670 C further parton involved?
16671 IF(ICOL1.NE.0) GOTO 165
16676 CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
16677 & ISTR,IGEN,ICH1,IBA1,IPOS,1)
16678 C store additional string information
16679 NPOS(1,ISTR) = IPOS
16681 NPOS(3,ISTR) = -JM2
16682 NPOS(4,ISTR) = abs(IPHIST(2,K))
16683 C calculate CPC string codes
16684 CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
16685 & IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
16692 IF(IDEB(19).GE.17) THEN
16693 WRITE(LO,'(1X,A)') 'PHO_STRING: after string construction'
16697 C pomeron corrections
16698 CALL PHO_POMCOR(IREJ)
16700 IFAIL(38) = IFAIL(38)+1
16701 IF(IDEB(19).GE.3) THEN
16702 WRITE(LO,'(1X,A,I6)')
16703 & 'PHO_STRING: rejection by PHO_POMCOR (IREJ)',IREJ
16704 CALL PHO_PREVNT(-1)
16709 C string mass corrections
16710 CALL PHO_MASCOR(IREJ)
16712 IFAIL(34) = IFAIL(34)+1
16713 IF(IDEB(19).GE.3) THEN
16714 WRITE(LO,'(1X,A,I6)')
16715 & 'PHO_STRING: rejection by PHO_MASCOR (IREJ)',IREJ
16716 CALL PHO_PREVNT(-1)
16721 C parton mass corrections
16723 IF(NCODE(I).GE.0) THEN
16724 CALL PHO_PARCOR(NPOS(1,I),IREJ)
16726 IFAIL(35) = IFAIL(35)+1
16727 IF(IDEB(19).GE.3) THEN
16728 WRITE(LO,'(1X,A,I6)')
16729 & 'PHO_STRING: rejection by PHO_PARCOR (IREJ)',IREJ
16730 CALL PHO_PREVNT(-1)
16737 C statistics of hard processes
16739 IF(ISTHEP(I).EQ.25) THEN
16742 MH_acc_2(K,II) = MH_acc_2(K,II)+1
16746 C debug: write out strings
16747 IF(IDEB(19).GE.5) THEN
16749 & CALL PHO_CHECK(1,IDEV)
16750 IF(IDEB(19).GE.15) THEN
16759 *$ CREATE PHO_STRFRA.FOR
16761 CDECK ID>, PHO_STRFRA
16762 SUBROUTINE PHO_STRFRA(IREJ)
16763 C********************************************************************
16765 C do all fragmentation of strings
16767 C output: IREJ 0 successful
16769 C 50 rejection due to user cutoffs
16771 C********************************************************************
16775 C input/output channels
16777 COMMON /POINOU/ LI,LO
16779 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
16780 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
16781 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
16782 C event debugging information
16784 PARAMETER (NMAXD=100)
16785 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16786 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16787 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16788 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16789 C general process information
16790 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
16791 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
16792 C model switches and parameters
16794 INTEGER ISWMDL,IPAMDL
16795 DOUBLE PRECISION PARMDL
16796 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16797 C global event kinematics and particle IDs
16798 INTEGER IFPAP,IFPAB
16799 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
16800 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
16801 C standard particle data interface
16803 PARAMETER (NMXHEP=4000)
16804 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16805 DOUBLE PRECISION PHEP,VHEP
16806 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16807 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16809 C extension to standard particle data interface (PHOJET specific)
16810 INTEGER IMPART,IPHIST,ICOLOR
16811 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16812 C color string configurations including collapsed strings and hadrons
16814 PARAMETER (MSTR=500)
16815 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16816 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16817 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16818 & NNCH(MSTR),IBHAD(MSTR),ISTR
16822 DOUBLE PRECISION PX,PY,PZ,HE,XMB,PT1,PT2,DUM
16823 INTEGER I,II,IJ,IFOUND,IP,IP_old,IPMOTH,IPOS,IBAM,IJOIN,
16824 & IGEN,IS,ISH,ISTR,J,K1,K2,NHEP1,NLINES
16826 integer indx(500),indx_max
16828 DOUBLE PRECISION DT_RNDM
16829 INTEGER ipho_pdg2id
16830 EXTERNAL DT_RNDM,ipho_pdg2id
16832 DOUBLE PRECISION PYP,RQLUN
16836 DOUBLE PRECISION PARU,PARJ
16837 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16839 DOUBLE PRECISION P,V
16840 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16842 DIMENSION IJOIN(100)
16845 IF(ABS(ISWMDL(6)).GT.3) THEN
16846 WRITE(LO,'(/1X,2A,I3)') 'PHO_STRFRA:ERROR: ',
16847 & 'invalid value of ISWMDL(6)',ISWMDL(6)
16851 C popcorn suppression
16852 IF(PARMDL(134).GT.0.D0) THEN
16853 IF(DT_RNDM(DUM).LT.PARMDL(134)) THEN
16860 C copy partons to fragmentation code JETSET
16866 C select partons with common production process
16868 if(IGEN.lt.0) goto 299
16872 if((IGEN.eq.NPOS(4,I)).or.(IPAMDL(17).eq.0)) then
16874 C write final particles/resonances to JETSET
16875 IF(NCODE(I).EQ.-99) THEN
16878 P(IP,1) = PHEP(1,II)
16879 P(IP,2) = PHEP(2,II)
16880 P(IP,3) = PHEP(3,II)
16881 P(IP,4) = PHEP(4,II)
16882 P(IP,5) = PHEP(5,II)
16884 K(IP,2) = IDHEP(II)
16889 if(indx_max.eq.500) then
16890 WRITE(LO,'(1x,2a,i8,I12)') 'PHO_STRFRA: ',
16891 & 'no space left in index vector (indx,Kevent)',
16896 indx_max = indx_max+1
16897 indx(indx_max) = II
16898 C write partons to JETSET
16899 ELSE IF(NCODE(I).GE.0) THEN
16900 K1 = JMOHEP(1,NPOS(1,I))
16901 K2 = MAX(JMOHEP(1,NPOS(1,I)),-JMOHEP(2,NPOS(1,I)))
16905 P(IP,1) = PHEP(1,II)
16906 P(IP,2) = PHEP(2,II)
16907 P(IP,3) = PHEP(3,II)
16908 P(IP,4) = PHEP(4,II)
16909 P(IP,5) = PHEP(5,II)
16911 K(IP,2) = IDHEP(II)
16918 indx_max = indx_max+1
16919 indx(indx_max) = II
16921 II = JMOHEP(2,NPOS(1,I))
16922 IF((II.GT.0).AND.(II.NE.K1)) THEN
16924 P(IP,1) = PHEP(1,II)
16925 P(IP,2) = PHEP(2,II)
16926 P(IP,3) = PHEP(3,II)
16927 P(IP,4) = PHEP(4,II)
16928 P(IP,5) = PHEP(5,II)
16930 K(IP,2) = IDHEP(II)
16937 indx_max = indx_max+1
16938 indx(indx_max) = II
16941 C connect partons to strings
16942 CALL PYJOIN(IJ,IJOIN)
16945 NPOS(4,I) = -NPOS(4,I)
16951 if(IP.eq.0) goto 299
16953 C hard final state evolution
16954 IF((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
16956 do 125 k1=1,indx_max
16958 IF(IPHIST(1,I).LE.-100) THEN
16965 IF(IJOIN(K1).EQ.0) GOTO 130
16967 IF((IPAMDL(102).EQ.1)
16968 & .AND.(IPHIST(1,I).NE.-100)) GOTO 130
16970 IF(IJOIN(K2).EQ.0) GOTO 135
16972 IF(IPHIST(1,I).EQ.IPHIST(1,II)) THEN
16973 PT1 = SQRT(PHEP(1,II)**2+PHEP(2,II)**2)
16974 PT2 = SQRT(PHEP(1,I)**2+PHEP(2,I)**2)
16975 RQLUN = MIN(PT1,PT2)
16976 IF(IDEB(22).GE.10) WRITE(LO,'(1X,A,2I5,E12.4)')
16977 & 'PHO_STRFRA: PYSHOW called',I,II,RQLUN
16978 CALL PYSHOW(IPHIST(2,I),IPHIST(2,II),RQLUN)
16988 C fragment parton / hadron configuration (hadronization & decay)
16990 IF(ISWMDL(6).NE.0) THEN
16996 if(MSTU(28).ne.0) then
16997 IF(IDEB(22).GE.10) THEN
16998 WRITE(LO,'(1X,A,I12,I3)')
16999 & 'PHO_STRFRA:(1) Lund code warning (EV/code)',
17005 IF(MSTU(24).NE.0) THEN
17006 IF(IDEB(22).GE.2) THEN
17007 WRITE(LO,'(1X,A,I12,I3)')
17008 & 'PHO_STRFRA:(1) rejection by Lund code (EV/code)',
17018 C change particle status in JETSET to avoid internal adjustments
17020 K(k1,1) = K(k1,1)+1000
17027 C restore original JETSET particle status codes
17029 K(i,1) = K(i,1)-1000
17032 * IF(IDEB(22).GE.25) THEN
17033 * WRITE(LO,'(//1X,2A)') 'PHO_STRFRA: ',
17034 * & 'particle/string system before fragmentation'
17035 * CALL PHO_PREVNT(2)
17038 C copy hadrons back to POEVT1 / POEVT2
17043 C copy hadrons back with full history information
17044 IF(IPAMDL(178).EQ.1) THEN
17046 IF(NCODE(II).GE.0) THEN
17047 K1 = IPHIST(2,NPOS(2,II))
17048 K2 = IPHIST(2,-NPOS(3,II))
17049 ELSE IF(NCODE(II).EQ.-99) THEN
17050 K1 = IPHIST(2,NPOS(1,II))
17057 IF(PYK(J,7).EQ.1) THEN
17059 IF((IPMOTH.GE.K1).AND.(IPMOTH.LE.K2)) THEN
17060 IBAM = ipho_pdg2id(PYK(J,8))
17061 IF((IBAM.EQ.0).AND.(ISWMDL(6).NE.0)) THEN
17062 IF(IDEB(22).GE.2) THEN
17063 WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
17064 & 'LUND interface (1) rejection'
17076 C register parton/hadron
17079 IF(ISWMDL(6).EQ.0) THEN
17082 IF(IDEB(22).GE.2) THEN
17083 WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
17084 & 'LUND interface (2) rejection'
17091 CALL PHO_REGPAR(IS,PYK(J,8),IBAM,NPOS(1,II),0,
17092 & PX,PY,PZ,HE,J,0,0,0,IPOS,1)
17097 IF(IFOUND.EQ.0) THEN
17098 IF(IDEB(2).GE.2) THEN
17099 WRITE(LO,'(2A,I12,I3)') 'PHO_STRFRA: ',
17100 & 'no particles found for string (EVE,ISTR):',KEVENT,II
17102 ISTHEP(NPOS(1,II)) = 2
17107 C copy hadrons back without history information
17108 JDAHEP(1,1) = NHEP1
17109 JDAHEP(1,2) = NHEP1
17111 IF(PYK(J,7).EQ.1) THEN
17112 IBAM = ipho_pdg2id(PYK(J,8))
17113 IF((IBAM.EQ.99999).AND.(ISWMDL(6).NE.0)) THEN
17114 IF(IDEB(22).GE.2) THEN
17115 WRITE(LO,'(/1X,A)')
17116 & 'PHO_STRFRA: LUND interface (3) rejection'
17127 C register parton/hadron
17130 IF(ISWMDL(6).EQ.0) THEN
17133 IF(IDEB(22).GE.2) THEN
17134 WRITE(LO,'(/1X,A)')
17135 & 'PHO_STRFRA: LUND interface (4) rejection'
17142 CALL PHO_REGPAR(IS,PYK(J,8),IBAM,1,2,PX,PY,PZ,
17143 & HE,J,0,0,0,IPOS,1)
17148 IF((NCODE(II).GE.0).OR.(NCODE(II).EQ.-99))
17149 & ISTHEP(NPOS(1,II)) = 2
17154 C debug event status
17155 IF(IDEB(22).GE.15) THEN
17156 WRITE(LO,'(//1X,A)')
17157 & 'PHO_STRFRA: particle system after fragmentation'
17163 *$ CREATE PHO_EVEINI.FOR
17165 CDECK ID>, PHO_EVEINI
17166 SUBROUTINE PHO_EVEINI(IMODE,P1,P2,IP1,IP2)
17167 C********************************************************************
17169 C prepare /POEVT1/ for new event
17171 C first subroutine called for each event
17173 C input: P1(4) particle 1
17175 C IMODE 0 general initialization
17176 C 1 initialization of particles and kinematics
17177 C 2 initialization after internal rejection
17179 C output: IP1,IP2 index of interacting particles
17181 C********************************************************************
17182 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17185 DIMENSION P1(4),P2(4)
17187 PARAMETER ( EPS = 1.D-5,
17190 C input/output channels
17192 COMMON /POINOU/ LI,LO
17193 C event debugging information
17195 PARAMETER (NMAXD=100)
17196 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17197 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17198 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17199 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17200 C model switches and parameters
17202 INTEGER ISWMDL,IPAMDL
17203 DOUBLE PRECISION PARMDL
17204 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17205 C general process information
17206 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
17207 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
17208 C gamma-lepton or gamma-hadron vertex information
17209 INTEGER IGHEL,IDPSRC,IDBSRC
17210 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
17211 & RADSRC,AMSRC,GAMSRC
17212 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
17213 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
17214 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
17215 C global event kinematics and particle IDs
17216 INTEGER IFPAP,IFPAB
17217 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
17218 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
17219 C energy-interpolation table
17221 PARAMETER ( IEETA2 = 20 )
17223 DOUBLE PRECISION SIGTAB,SIGECM
17224 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
17226 INTEGER IPFIL,IFAFIL,IFBFIL
17227 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
17228 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
17229 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
17230 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
17231 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
17232 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
17233 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
17234 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
17235 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
17236 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
17237 & IPFIL,IFAFIL,IFBFIL
17238 C color string configurations including collapsed strings and hadrons
17240 PARAMETER (MSTR=500)
17241 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
17242 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
17243 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
17244 & NNCH(MSTR),IBHAD(MSTR),ISTR
17245 C standard particle data interface
17247 PARAMETER (NMXHEP=4000)
17248 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
17249 DOUBLE PRECISION PHEP,VHEP
17250 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
17251 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
17253 C extension to standard particle data interface (PHOJET specific)
17254 INTEGER IMPART,IPHIST,ICOLOR
17255 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
17256 C table of particle indices for recursive PHOJET calls
17258 PARAMETER ( MAXIPX = 100 )
17259 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
17260 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
17261 & IPOIX1,IPOIX2,IPOIX3
17262 C event weights and generated cross section
17263 INTEGER IPOWGC,ISWCUT,IVWGHT
17264 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
17265 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
17266 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
17270 C reset debug variables
17289 IF(ISWMDL(14).GT.0) IPOIX1 = 1
17292 C reset /POEVT1/ and /POEVT2/
17293 CALL PHO_REGPAR(0,0,0,0,0,0.D0,0.D0,0.D0,0.D0,
17295 CALL PHO_SELCOL(0,0,0,0,0,0,0)
17300 C initialization of particle kinematics
17302 C lepton-photon/hadron-photon vertex and initial particles
17305 IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
17306 CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),0,0,PINI(1,1),PINI(2,1),
17307 & PINI(3,1),PINI(4,1),0,0,0,0,IM(1),1)
17309 CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
17310 & P1(4),0,0,0,0,IP1,1)
17312 IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
17313 CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),0,0,PINI(1,2),PINI(2,2),
17314 & PINI(3,2),PINI(4,2),0,0,0,0,IM(2),1)
17316 CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
17317 & P2(4),0,0,0,0,IP2,1)
17319 IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
17320 CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),IM(1),0,PFIN(1,1),
17321 & PFIN(2,1),PFIN(3,1),PFIN(4,1),0,10,0,0,IPOS,1)
17322 CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
17323 & P1(4),0,0,0,0,IP1,1)
17325 IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
17326 CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),IM(2),0,PFIN(1,2),
17327 & PFIN(2,2),PFIN(3,2),PFIN(4,2),0,10,0,0,IPOS,1)
17328 CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
17329 & P2(4),0,0,0,0,IP2,1)
17333 IF(IMODE.LE.1) THEN
17335 ECM = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
17336 & -(P1(3)+P2(3))**2)
17337 * CALL PHO_PECMS(1,PMASS(1),PMASS(2),ECM,PCM,EE)
17338 PMASS(1) = PHEP(5,IP1)
17340 IF(IFPAP(1).EQ.22) PVIRT(1) = PMASS(1)**2
17341 PMASS(2) = PHEP(5,IP2)
17343 IF(IFPAP(2).EQ.22) PVIRT(2) = PMASS(2)**2
17346 C cross section calculations
17348 IF(IMODE.NE.1) THEN
17350 CALL PHO_CSINT(IP,IFPAP(1),IFPAP(2),IGHEL(1),IGHEL(2),
17351 & ECM,PVIRT(1),PVIRT(2))
17354 IF(IMODE.LE.0) THEN
17355 C effective cross section
17357 IF(ISWMDL(2).ge.1) THEN
17358 IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGTOT-SIGELA-SIGVM(0,0)
17359 & -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)-SIGLDD
17361 IF(IPRON(2,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGELA
17362 IF(IPRON(3,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGVM(0,0)
17363 IF(IPRON(4,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGCDF(0)
17364 IF(IPRON(5,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(1)+SIGHSD(1)
17365 IF(IPRON(6,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(2)+SIGHSD(2)
17366 IF(IPRON(7,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLDD+SIGHDD
17367 IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
17368 C simulate only hard scatterings
17370 IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGHAR
17371 IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
17376 C reset of mother/daughter relations only (IMODE = 2)
17379 IF(IDEB(63).GE.15) THEN
17380 WRITE(LO,'(/1X,2A,I12,I3)') 'PHO_EVEINI: ',
17381 & '/POEVT1/ initialized (event/mode)',KEVENT,IMODE
17382 IF(IMODE.LE.0) THEN
17383 WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)') 'PHO_EVEINI: ',
17384 & 'current suppression factors total-1/2 hard-1/2 diff-1/2:',
17388 IDEB(57) = MAX(5,ITMP)
17389 CALL PHO_XSECT(1,0,ONEM)
17397 *$ CREATE PHO_CSINT.FOR
17399 CDECK ID>, PHO_CSINT
17400 SUBROUTINE PHO_CSINT(IP,IFPA,IFPB,IHLA,IHLB,ECM,PVIR2A,PVIR2B)
17401 C********************************************************************
17403 C calculate cross sections by interpolation
17405 C input: IP particle combination
17406 C IFPA/B particle PDG number
17407 C IHLA/B particle helicity (photons only)
17408 C ECM c.m. energy (GeV)
17409 C PVIR2A virtuality of particle A (GeV**2, positive)
17410 C PVIR2B virtuality of particle B (GeV**2, positive)
17412 C output: cross sections stored in /POCSEC/
17414 C********************************************************************
17415 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17418 PARAMETER ( EPS = 1.D-5,
17421 C input/output channels
17423 COMMON /POINOU/ LI,LO
17425 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
17426 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
17427 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
17428 C event debugging information
17430 PARAMETER (NMAXD=100)
17431 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17432 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17433 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17434 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17435 C model switches and parameters
17437 INTEGER ISWMDL,IPAMDL
17438 DOUBLE PRECISION PARMDL
17439 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17440 C energy-interpolation table
17442 PARAMETER ( IEETA2 = 20 )
17444 DOUBLE PRECISION SIGTAB,SIGECM
17445 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
17447 INTEGER IPFIL,IFAFIL,IFBFIL
17448 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
17449 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
17450 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
17451 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
17452 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
17453 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
17454 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
17455 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
17456 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
17457 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
17458 & IPFIL,IFAFIL,IFBFIL
17459 C hard cross sections and MC selection weights
17461 PARAMETER ( Max_pro_2 = 16 )
17462 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
17463 & MH_acc_1,MH_acc_2
17464 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
17465 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
17466 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
17467 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
17468 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
17469 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
17471 DIMENSION PVIRT(2),SIGSRH(2),FSUT(2),FSUL(2),IFPAP(2),IHEL(2)
17473 dimension PD(-6:6),FH_T(2),FH_L(2)
17476 IF(IDEB(15).GE.10) WRITE(LO,'(1X,A,/10X,I3,2I6,1P3E12.4)')
17477 & 'PHO_CSINT: called with IP, IFP1, IFP2, ECM, PVIR1, PVIR2',
17478 & IP,IFPA,IFPB,ECM,PVIR2A,PVIR2B
17480 C check currently stored cross sections
17481 IF((IP.EQ.IPFIL).AND.(ECM.EQ.ECMFIL)
17482 & .AND.(PVIR2A.EQ.P2AFIL).AND.(PVIR2B.EQ.P2BFIL)
17483 & .AND.(IFPA.EQ.IFAFIL).AND.(IFPB.EQ.IFBFIL)) THEN
17484 C nothing to calculate
17486 & WRITE(LO,'(1X,A)') 'PHO_CSINT: nothing done'
17490 C copy to local fields
17498 C load cross sections from interpolation table
17499 IF(ECM.LE.SIGECM(IP,1)) THEN
17502 ELSE IF(ECM.LE.SIGECM(IP,ISIMAX)) THEN
17504 IF(ECM.LE.SIGECM(IP,I)) GOTO 200
17510 WRITE(LO,'(/1X,A,2E12.3)')
17511 & 'PHO_CSINT: too high energy',ECM,SIGECM(IP,ISIMAX)
17512 CALL PHO_PREVNT(-1)
17517 IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
17518 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
17521 C cross section dependence on photon virtualities
17526 IF(IFPAP(K).EQ.22) THEN
17527 IF(ISWMDL(10).GE.1) THEN
17532 C GVDM factors for transverse/longitudinal photons
17534 FSUT(K) = FSUT(K)+PARMDL(26+I)
17535 & /(1.D0+PVIRT(K)/PARMDL(30+I))**2
17537 & +PARMDL(26+I)*PVIRT(K)/(4.D0*PARMDL(30+I))
17538 & /(1.D0+PVIRT(K)/PARMDL(30+I))**2
17540 FSUT(K) = FSUT(K)+PARMDL(30)/(1.D0+PVIRT(K)/PARMDL(34))
17542 IF((ABS(IHEL(K)).EQ.1).OR.(ISWMDL(10).EQ.1)) THEN
17544 FSUH(K) = FSUT(K)/(FSUT(K)+FSUL(K))
17545 C diffraction of trans. photons corresponds mainly to leading twist
17548 C longitudinal (scalar) part
17549 IF((IHEL(K).LE.0).OR.(ISWMDL(10).EQ.1)) THEN
17550 FSUP(K) = FSUP(K)+FSUL(K)
17551 FSUH(K) = FSUH(K)+FSUL(K)/(FSUT(K)+FSUL(K))
17552 C diffraction of long. photons corresponds mainly to higher twist
17553 FSUD(K) = 0.5D0*LOG(((ECM*PARMDL(45))**2+PVIRT(K))
17554 & /((0.765D0+PARMDL(46))**2+PVIRT(K)))
17555 & /LOG(ECM*PARMDL(45)/(0.765D0+PARMDL(46)))
17558 if(ideb(15).ge.10) then
17559 WRITE(LO,'(1x,2a,2i3,/,5x,1p5e12.4)') 'PHO_CSINT: ',
17560 & 'side,helicity,F_tran,F_long,F_eff,F_hard,F_diff',
17561 & K,IHEL(K),FSUT(K),FSUL(K),FSUP(K),FSUH(K),FSUD(K)
17567 FACP = FSUP(1)*FSUP(2)
17568 FACH = FSUH(1)*FSUH(2)
17569 FACD = FSUD(1)*FSUD(2)
17571 C matching of model cross section to F2(x,Q2,P2) in limit of Q2 >> P2
17573 if((IFPAP(1).eq.22).and.(IFPAP(2).eq.22)
17574 & .and.(IPAMDL(117).gt.0)) then
17575 C check kinematic limit
17576 Q2_max = max(PVIRT(1),PVIRT(2))
17577 Q2_min = min(PVIRT(1),PVIRT(2))
17578 if((Q2_max.gt.1.D0).and.(Q2_min.lt.1.D0)) then
17580 C calculate F2 from current parton density
17581 if(PVIRT(1).gt.PVIRT(2)) then
17588 X = Q2/(ECM**2+Q2+P2)
17589 call pho_actpdf(IFPAP(K),K)
17590 call pho_pdf(K,X,Q2,P2,PD)
17591 C light quark contribution
17594 F2_light = F2_light+Q_ch2(j)*(PD(j)+PD(-j))
17596 C heavy quark contribution
17597 call pho_qpmpdf(4,X,Q2,0.D0,P2,xpdf_c)
17598 F2_c = 2.D0*4.D0/9.D0*xpdf_c
17599 F2 = (F2_light+F2_c)
17601 C calculate model prediction
17602 SIGTOT = FAC2*SIGTAB(IP,1,I2)+FAC1*SIGTAB(IP,1,I1)
17603 SIGINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
17604 CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17606 if(ISWMDL(10).ge.2) then
17608 C calculate all helicity combinations
17609 if(IPAMDL(115).eq.0) then
17611 SIGSRH(1) = HSig(10)+HSig(11)
17612 SIGSRH(2) = HSig(12)+HSig(13)
17613 SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
17614 C photon helicity factors
17615 FH_T(1) = FSUT(1)/(FSUT(1)+FSUL(1))
17616 FH_L(1) = 1.D0-FH_T(1)
17617 FH_T(2) = FSUT(2)/(FSUT(2)+FSUL(2))
17618 FH_L(2) = 1.D0-FH_T(2)
17619 SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
17620 & + SIGDIH*FH_T(1)*FH_T(2)
17621 & + SIGSRH(1)*FH_T(1)*FSUT(2)
17622 & + SIGSRH(2)*FSUT(1)*FH_T(2)
17623 SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
17624 & + SIGDIH*FH_T(1)*FH_L(2)
17625 & + SIGSRH(1)*FH_T(1)*FSUL(2)
17626 & + SIGSRH(2)*FSUT(1)*FH_L(2)
17627 SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
17628 & + SIGDIH*FH_L(1)*FH_T(2)
17629 & + SIGSRH(1)*FH_L(1)*FSUT(2)
17630 & + SIGSRH(2)*FSUL(1)*FH_T(2)
17631 SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
17632 & + SIGDIH*FH_L(1)*FH_L(2)
17633 & + SIGSRH(1)*FH_L(1)*FSUL(2)
17634 & + SIGSRH(2)*FSUL(1)*FH_L(2)
17636 C use explicit PDF virtuality dependence (pre-tabulated)
17638 SIGSRH(1) = HSig(10)+HSig(11)
17639 SIGSRH(2) = HSig(12)+HSig(13)
17640 SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
17641 WRITE(LO,*) ' PHO_CSINT: invalid option for F2 matching'
17643 * CALL PHO_HARINT(IP,ECM,PVIRT(1),PVIRT(2),0,
17644 * & Max_pro_2,3,4,1)
17645 * SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
17646 * & + HSig(10)+HSig(12)+HSig(14)+HSig(16)+HSig(18)
17647 * SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
17648 * & + HSig(10)+HSig(12)+HSig(14)+HSig(16)+HSig(19)
17649 * SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
17650 * & + HSig(11)+HSig(13)+HSig(15)+HSig(17)+HSig(20)
17651 * SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
17652 * & + HSig(11)+HSig(13)+HSig(15)+HSig(17)+HSig(21)
17654 Xnu = Ecm*Ecm+Q2+P2
17655 F2_fac = Q2*Xnu/sqrt(Xnu*Xnu-Q2*P2)/(4.D0*Pi*Pi)
17658 F2m = F2_fac*(SIG_TT+SIG_LT-0.5D0*SIG_TL-0.5D0*SIG_LL)
17659 F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUL(1)*FSUT(2)
17660 & -0.5D0*FSUT(1)*FSUL(2)-0.5D0*FSUL(1)*FSUL(2))
17662 F2m = F2_fac*(SIG_TT+SIG_TL-0.5D0*SIG_LT-0.5D0*SIG_LL)
17663 F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUT(1)*FSUL(2)
17664 & -0.5D0*FSUL(1)*FSUT(2)-0.5D0*FSUL(1)*FSUL(2))
17669 C assume sig_eff = sigtot
17671 SIGSRH(1) = HSig(10)+HSig(11)
17672 SIGSRH(2) = HSig(12)+HSig(13)
17673 SIGtmp = SIGTOT-SIGSRH(1)-SIGSRH(2)-SIGDIH
17674 SIGeff = SIGtmp*FSUP(1)*FSUP(2)
17675 & +SIGSRH(1)*FSUP(2)+SIGSRH(2)*FSUP(1)+SIGDIH
17676 Xnu = Ecm*Ecm+Q2+P2
17677 F2_fac = Q2*Xnu/sqrt(Xnu*Xnu-Q2*P2)/(4.D0*Pi*Pi)
17679 F2m = F2_fac*SIGeff
17680 F2s = F2_fac*SIGtmp*FSUP(1)*FSUP(2)
17682 * WRITE(LO,*) ' PHO_CSINT: Q2_1,Q2_2,W ',PVIRT(1),PVIRT(2),Ecm
17683 * WRITE(LO,*) ' PHO_CSINT: F2_mod,F2_pdf,mod/pdf ',F2m,F2,F2m/F2
17685 C global factor to re-scale suppression of soft contributions
17686 Fcorr = (F2-F2m+F2s)/F2s
17687 * WRITE(LO,*) ' PHO_CSINT: re-scaling factor: ',Fcorr,FACP*Fcorr
17693 SIGTOT = (FAC2*SIGTAB(IP,1,I2)+FAC1*SIGTAB(IP,1,I1))*FACP
17694 SIGINE = (FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1))*FACP
17695 SIGELA = (FAC2*SIGTAB(IP,2,I2)+FAC1*SIGTAB(IP,2,I1))*FACP
17700 SIGVM(I,K) = (FAC2*SIGTAB(IP,J,I2)+FAC1*SIGTAB(IP,J,I1))
17705 SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
17706 SIGHAR = FAC2*SIGTAB(IP,58,I2)+FAC1*SIGTAB(IP,58,I1)
17707 C suppression of multi-pomeron graphs (diffraction)
17708 SIGLSD(1) = (FAC2*SIGTAB(IP,30,I2)+FAC1*SIGTAB(IP,30,I1))
17709 & *FACP*FSUP(2)*FSUD(1)
17710 SIGLSD(2) = (FAC2*SIGTAB(IP,31,I2)+FAC1*SIGTAB(IP,31,I1))
17711 & *FACP*FSUP(1)*FSUD(2)
17712 SIGHSD(1) = (FAC2*SIGTAB(IP,32,I2)+FAC1*SIGTAB(IP,32,I1))
17713 & *FACP*FSUP(2)*FSUD(1)
17714 SIGHSD(2) = (FAC2*SIGTAB(IP,33,I2)+FAC1*SIGTAB(IP,33,I1))
17715 & *FACP*FSUP(1)*FSUD(2)
17716 SIGLDD = (FAC2*SIGTAB(IP,34,I2)+FAC1*SIGTAB(IP,34,I1))
17718 SIGHDD = (FAC2*SIGTAB(IP,35,I2)+FAC1*SIGTAB(IP,35,I1))*FACP
17719 SIGCDF(0) = (FAC2*SIGTAB(IP,36,I2)+FAC1*SIGTAB(IP,36,I1))
17721 SIGTR1(1) = (FAC2*SIGTAB(IP,60,I2)+FAC1*SIGTAB(IP,60,I1))
17722 & *FACP*FSUP(2)*FSUD(1)
17723 SIGTR1(2) = (FAC2*SIGTAB(IP,61,I2)+FAC1*SIGTAB(IP,61,I1))
17724 & *FACP*FSUP(2)*FSUD(1)
17725 SIGTR2(1) = (FAC2*SIGTAB(IP,62,I2)+FAC1*SIGTAB(IP,62,I1))
17726 & *FACP*FSUP(1)*FSUD(2)
17727 SIGTR2(2) = (FAC2*SIGTAB(IP,63,I2)+FAC1*SIGTAB(IP,63,I1))
17728 & *FACP*FSUP(1)*FSUD(2)
17729 SIGLOO = (FAC2*SIGTAB(IP,64,I2)+FAC1*SIGTAB(IP,64,I1))*FACP
17730 SIGDPO(1) = (FAC2*SIGTAB(IP,65,I2)+FAC1*SIGTAB(IP,65,I1))
17732 SIGDPO(2) = (FAC2*SIGTAB(IP,66,I2)+FAC1*SIGTAB(IP,66,I1))
17734 SIGDPO(3) = (FAC2*SIGTAB(IP,67,I2)+FAC1*SIGTAB(IP,67,I1))
17736 SIGDPO(4) = (FAC2*SIGTAB(IP,68,I2)+FAC1*SIGTAB(IP,68,I1))
17739 C corrections due to photon virtuality dependence of PDFs
17740 if(iswmdl(2).eq.1) then
17741 CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17742 C minimum bias event generation
17743 IF(IPAMDL(115).GE.1) THEN
17744 C all the virtuality dependence is given by PDF parametrization
17745 SIGHIN = FAC2*SIGTAB(IP,80,I2)+FAC1*SIGTAB(IP,80,I1)
17746 IF(IPAMDL(116).GE.2) THEN
17747 C direct interaction according to full QPM calculation
17749 SIGSRH(1) = HSig(10)+HSig(11)
17750 SIGSRH(2) = HSig(12)+HSig(13)
17752 C direct interaction suppressed according to helicity factor
17753 SIGDIH = HSig(14)*FACH
17754 SIGSRH(1) = (HSig(10)+HSig(11))*FSUH(1)
17755 SIGSRH(2) = (HSig(12)+HSig(13))*FSUH(2)
17757 WRITE(LO,*) ' PHO_CSINT: option not supported yet'
17760 C rescale relevant hard processes
17762 SIGSRH(1) = HSig(10)+HSig(11)
17763 SIGSRH(2) = HSig(12)+HSig(13)
17764 SIGtmp = SIGINE-(SIGDIH+SIGSRH(1)+SIGSRH(2))*FACP
17765 SIGDIR = HSig(14)*FACH+SIGSRH(1)*FSUH(1)*FSUP(2)
17766 & +SIGSRH(2)*FSUP(1)*FSUH(2)
17767 SIGINE = SIGtmp+SIGDIR
17768 SIGTOT = SIGINE+SIGELA
17771 C only hard interactions
17772 CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17773 SIGSRH(1) = (HSig(10)+HSig(11))*FSUH(1)
17774 SIGSRH(2) = (HSig(12)+HSig(13))*FSUH(2)
17775 SIGDIR = HSig(14)+SIGSRH(1)+SIGSRH(2)
17776 SIGHAR = HSig(9)*FACH
17779 SIG1SO = (FAC2*SIGTAB(IP,37,I2)+FAC1*SIGTAB(IP,37,I1))*FACP
17780 SIG1HA = (FAC2*SIGTAB(IP,38,I2)+FAC1*SIGTAB(IP,38,I1))*FACH
17781 SLOEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
17786 SLOVM(I,K) = FAC2*SIGTAB(IP,J,I2)+FAC1*SIGTAB(IP,J,I1)
17789 SIGPOM = (FAC2*SIGTAB(IP,56,I2)+FAC1*SIGTAB(IP,56,I1))*FACP
17790 SIGREG = (FAC2*SIGTAB(IP,57,I2)+FAC1*SIGTAB(IP,57,I1))*FACP
17800 & WRITE(LO,'(1X,A)') 'PHO_CSINT: cross sections calculated'
17806 *$ CREATE PHO_PRIMKT.FOR
17808 CDECK ID>, PHO_PRIMKT
17809 SUBROUTINE PHO_PRIMKT(IMODE,IF,IL,PTCUT,IREJ)
17810 C***********************************************************************
17812 C give primordial kt to partons entering hard scatterings and
17813 C remants connected to hard parton-parton interactions by color flow
17815 C input: IMODE -2 output of statistics
17816 C -1 initialization
17817 C 1 sampling of primordial kt
17818 C IF first entry in /POEVT1/ to check
17819 C IL last entry in /POEVT1/ to check
17820 C PTCUT current value of PTCUT to distinguish
17821 C between soft and hard
17823 C output: IREJ 0 success
17826 C***********************************************************************
17830 DOUBLE PRECISION DEPS
17831 PARAMETER ( DEPS = 1.D-15 )
17833 INTEGER IMODE,IF,IL,IREJ
17834 DOUBLE PRECISION PTCUT
17836 C input/output channels
17838 COMMON /POINOU/ LI,LO
17839 C event debugging information
17841 PARAMETER (NMAXD=100)
17842 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17843 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17844 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17845 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17846 C model switches and parameters
17848 INTEGER ISWMDL,IPAMDL
17849 DOUBLE PRECISION PARMDL
17850 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17852 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
17853 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
17854 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
17855 C data of c.m. system of Pomeron / Reggeon exchange
17856 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
17857 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
17858 & SIDP,CODP,SIFP,COFP
17859 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
17860 & SIDP,CODP,SIFP,COFP,NPOSP(2),
17861 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
17862 C hard scattering data
17864 PARAMETER ( MSCAHD = 50 )
17865 INTEGER LSCAHD,LSC1HD,LSIDX,
17866 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
17867 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
17868 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
17869 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
17870 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
17871 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
17872 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
17873 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
17874 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
17875 C standard particle data interface
17877 PARAMETER (NMXHEP=4000)
17878 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
17879 DOUBLE PRECISION PHEP,VHEP
17880 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
17881 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
17883 C extension to standard particle data interface (PHOJET specific)
17884 INTEGER IMPART,IPHIST,ICOLOR
17885 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
17887 DOUBLE PRECISION PTS,XP,XP2,POLD,PNEW,GA,PP
17888 DIMENSION PTS(0:2,5),XP(5),
17889 & XP2(5,2),POLD(2,2),PNEW(4,2),GA(4),PP(4)
17891 INTEGER IROTT,IBALT,IBAL,IV,IV2,IRMAX
17893 PARAMETER (IRMAX=200)
17894 DIMENSION IROTT(IRMAX),IBALT(5,2),IBAL(2),IV(5),IV2(5,2)
17896 DOUBLE PRECISION SI,EI,SF,EF,PTOT,EE,XX,YY,ZZ,ANORF,FAC,DEL,PT2,
17897 & DEL2,GAE,GAZ,SID,COD,SIF,COF,ESUM
17898 INTEGER IROT,I,J,K,NHD,ISTART,INEXT,ICOM
17901 IF(IDEB(10).GE.10) WRITE(LO,'(1X,A,3I4,1P,E11.3)')
17902 & 'PHO_PRIMKT: called with IMODE,IF,IL,PTCUT',
17903 & IMODE,IF,IL,PTCUT
17905 C give primordial kt to partons engaged in a hard scattering
17907 IF(IMODE.EQ.1) THEN
17919 IF(ISTHEP(I).EQ.25) THEN
17920 C hard scattering number
17921 NHD = IPHIST(1,I+1)
17924 C calculate momenta of incoming partons
17925 POLD(1,1) = XHD(K,1)*ECMP/2.D0
17926 POLD(2,1) = POLD(1,1)
17927 POLD(1,2) = -XHD(K,2)*ECMP/2.D0
17928 POLD(2,2) = -POLD(1,2)
17937 C search for partons involved in hard interaction
17941 IF(ABS(ISTHEP(I)).EQ.1) THEN
17942 C hard scatterd partons (including ISR)
17943 IF((IPHIST(1,I).EQ.-NHD)
17944 & .OR.(IPHIST(1,I).EQ.NHD+1)
17945 & .OR.(IPHIST(1,I).EQ.NHD+2)) THEN
17947 IF(IROT.GT.IRMAX) THEN
17948 WRITE(LO,'(1X,/,2A,2I5)') 'PHO_PRIMKT: ',
17949 & 'no memory left in IROTT, event rejected (max/IROT)',
17957 ELSE IF(IPHIST(1,I).EQ.NHD) THEN
17958 IF(PHEP(3,I).GT.0.D0) THEN
17963 IBAL(J) = IBAL(J)+1
17964 IBALT(IBAL(J),J) = I
17965 XP2(IBAL(J),J) = PHEP(3,I)/ECMP
17966 IF(ISWMDL(24).EQ.0) THEN
17968 IF(IDHEP(I).NE.21) IV2(IBAL(J),J) = ICOLOR(2,I)
17969 ELSE IF(ISWMDL(24).EQ.1) THEN
17970 IV2(IBAL(J),J) = -1
17975 C possibly further hard scattering
17976 ELSE IF(ISTHEP(I).EQ.25) THEN
17985 if(IDEB(10).ge.15) then
17986 WRITE(LO,'(1X,2A,I4)') 'PHO_PRIMKT: ',
17987 & 'hard scattering number: ',NHD/100
17988 WRITE(LO,'(1X,2A,I5)') 'PHO_PRIMKT: ',
17989 & 'number of entries to rotate: ',IROT
17991 WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
17992 & 'entries to rotate: ',I,IROTT(I)
17994 WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
17995 & 'number of entries to balance: ',IBAL
17998 WRITE(LO,'(1X,2A,I2,2I5)')
17999 & 'PHO_PRIMKT: entries to balance (side,no,line)',
18005 C incoming partons (comment lines), skip direct interacting particles
18007 IF((IDHEP(ICOM+K).NE.22).AND.(IDHEP(ICOM+K).NE.990)) THEN
18008 IF(PHEP(3,ICOM+K).GT.0.D0) THEN
18013 IBAL(J) = IBAL(J)+1
18014 IBALT(IBAL(J),J) = -ICOM-K
18015 XP2(IBAL(J),J) = POLD(1,J)/ECMP
18016 IV2(IBAL(J),J) = -1
18020 C check consistency
18021 IF((IBAL(1).GT.4).OR.(IBAL(2).GT.4)) THEN
18022 WRITE(LO,'(1X,2A,I10)') 'PHO_PRIMKT: ',
18023 & 'inconsistent hard scattering remnant for event: ',KEVENT
18024 WRITE(LO,'(1X,A,3I4,1P,E11.3)')
18025 & 'PHO_PRIMKT called with IMODE,IF,IL,PTCUT',
18026 & IMODE,IF,IL,PTCUT
18027 WRITE(LO,'(1X,A,I4)') 'hard scattering number: ',NHD/100
18029 WRITE(LO,'(1X,A,2I5)') 'entries to rotate',I,IROTT(I)
18033 WRITE(LO,'(1X,A,I2,2I5)')
18034 & 'entries to balance (side,no,line)',J,I,IBALT(I,J)
18037 IF(IBAL(1)+IBAL(2).GT.0) CALL PHO_PREVNT(0)
18040 C calculate primordial kt
18043 IF((IBAL(1).GT.1).OR.(IBAL(2).GT.1)) THEN
18045 C add transverse momentum (overwrite /POEVT1/ entries)
18047 IF(IBAL(J).GT.1) THEN
18048 C sample from truncated distribution
18055 CALL PHO_SOFTPT(K,PTCUT,PTCUT,XP,IV,PTS)
18056 IF(PTS(0,K).GE.PARMDL(100)) GOTO 190
18057 C transform incoming partons of hard scattering
18058 DEL = ABS(POLD(1,J))+POLD(2,J)
18061 PNEW(1,J) = PTS(1,K)
18062 PNEW(2,J) = PTS(2,K)
18063 PNEW(3,J) = (-1)**J*(PT2 - DEL2)/(2.D0*DEL)
18064 PNEW(4,J) = (DEL2 + PT2)/(2.D0*DEL)
18065 C spectator partons
18067 DO 220 I=1,IBAL(J)-1
18069 PHEP(1,K) = PHEP(1,K)+PTS(1,I)
18070 PHEP(2,K) = PHEP(2,K)+PTS(2,I)
18071 ESUM = ESUM+PHEP(4,K)
18073 C long. momentum transfer
18074 PP(3) = PNEW(3,J) - POLD(1,J)
18075 PP(4) = PNEW(4,J) - POLD(2,J)
18076 DO 230 I=1,IBAL(J)-1
18078 FAC = PHEP(4,K)/ESUM
18079 PHEP(3,K) = PHEP(3,K) - FAC*PP(3)
18080 PHEP(4,K) = PHEP(4,K) - FAC*PP(4)
18084 IF(IDEB(10).GE.15) THEN
18085 WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
18086 & 'old incoming:',J,0.D0,0.D0,(POLD(I,J),I=1,2)
18087 WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
18088 & 'new incoming:',J,(PNEW(I,J),I=1,4)
18094 PNEW(3,J) = POLD(1,J)
18095 PNEW(4,J) = POLD(2,J)
18099 C transformation of hard scattering final states (including ISR)
18101 C old parton c.m. energy
18102 SI = (POLD(2,1)+POLD(2,2))**2-(POLD(1,1)+POLD(1,2))**2
18104 C new parton c.m. energy
18105 SF = (PNEW(4,1)+PNEW(4,2))**2-(PNEW(1,1)+PNEW(1,2))**2
18106 & -(PNEW(2,1)+PNEW(2,2))**2-(PNEW(3,1)+PNEW(3,2))**2
18110 IF(IDEB(10).GE.25) WRITE(LO,'(1X,A,1P,E12.4)')
18111 & 'PHO_PRIMKT: scaling factor (E-final/E-initial): ',FAC
18113 C calculate Lorentz transformation
18114 GAZ = -(POLD(1,1)+POLD(1,2))/EI
18115 GAE = (POLD(2,1)+POLD(2,2))/EI
18117 GA(I) = (PNEW(I,1)+PNEW(I,2))/EF
18119 CALL PHO_ALTRA(GA(4),-GA(1),-GA(2),-GA(3),PNEW(1,1),PNEW(2,1),
18120 & PNEW(3,1),PNEW(4,1),PTOT,PP(1),PP(2),PP(3),PP(4))
18121 PTOT = MAX(DEPS,PTOT)
18123 SID= SQRT(PP(1)**2+PP(2)**2)/PTOT
18126 IF(PTOT*SID.GT.1.D-5) THEN
18127 COF=PP(1)/(SID*PTOT)
18128 SIF=PP(2)/(SID*PTOT)
18129 ANORF=SQRT(COF*COF+SIF*SIF)
18135 C check consistency initial/final configuration before rotation
18136 IF(IDEB(10).GE.25) THEN
18137 WRITE(LO,'(1X,A,1P,4E11.3)') 'PHO_PRIMKT: ini. momentum (1):',
18138 & 0.D0,0.D0,(POLD(I,1)+POLD(I,2),I=1,2)
18145 PP(J) = PP(J)+PHEP(J,K)
18148 WRITE(LO,'(1X,A,1P,4E11.3)')
18149 & 'PHO_PRIMKT: fin. momentum (1):',PP
18152 C apply rotation/boost to scattered particles
18156 PP(J) = FAC*PHEP(J,K)
18158 CALL PHO_ALTRA(GAE,0.D0,0.D0,GAZ,PP(1),PP(2),PP(3),
18159 & PP(4),PTOT,PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
18160 CALL PHO_TRANS(PHEP(1,K),PHEP(2,K),PHEP(3,K),
18161 & COD,SID,COF,SIF,XX,YY,ZZ)
18163 CALL PHO_ALTRA(GA(4),GA(1),GA(2),GA(3),XX,YY,ZZ,EE,PTOT,
18164 & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
18168 C check consistency initial/final configuration after rotation
18169 IF(IDEB(10).GE.25) THEN
18171 PP(I) = PNEW(I,1)+PNEW(I,2)
18173 WRITE(LO,'(1X,A,1P,4E11.3)')
18174 & 'PHO_PRIMKT: ini. momentum (2):',PP
18181 PP(J) = PP(J)+PHEP(J,K)
18184 WRITE(LO,'(1X,A,1P,4E11.3)')
18185 & 'PHO_PRIMKT: fin. momentum (2):',PP
18190 IF(INEXT.EQ.1) GOTO 100
18194 ELSE IF(IMODE.EQ.-1) THEN
18196 C output of statistics etc.
18198 ELSE IF(IMODE.EQ.-2) THEN
18203 WRITE(LO,'(/1X,A,I4)')
18204 & 'PHO_PRIMKT:ERROR: invalid value of IMODE:',IMODE
18210 *$ CREATE PHO_PARTPT.FOR
18212 CDECK ID>, PHO_PARTPT
18213 SUBROUTINE PHO_PARTPT(IMODE,IF,IL,PTCUT,IREJ)
18214 C********************************************************************
18216 C assign to soft partons
18218 C input: IMODE -2 output of statistics
18219 C -1 initialization
18220 C 0 sampling of pt for soft partons belonging to
18222 C 1 sampling of pt for soft partons belonging to
18224 C IF first entry in /POEVT1/ to check
18225 C IL last entry in /POEVT1/ to check
18226 C PTCUT current value of PTCUT to distinguish
18227 C between soft and hard
18229 C output: IREJ 0 success
18232 C (soft pt is sampled by call to PHO_SOFTPT)
18234 C********************************************************************
18235 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18238 PARAMETER ( DEPS = 1.D-15 )
18240 INTEGER IMODE,IF,IL,IREJ
18241 DOUBLE PRECISION PTCUT
18243 C input/output channels
18245 COMMON /POINOU/ LI,LO
18246 C event debugging information
18248 PARAMETER (NMAXD=100)
18249 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18250 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18251 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18252 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18253 C model switches and parameters
18255 INTEGER ISWMDL,IPAMDL
18256 DOUBLE PRECISION PARMDL
18257 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18259 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
18260 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
18261 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
18262 C data of c.m. system of Pomeron / Reggeon exchange
18263 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18264 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18265 & SIDP,CODP,SIFP,COFP
18266 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18267 & SIDP,CODP,SIFP,COFP,NPOSP(2),
18268 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
18269 C standard particle data interface
18271 PARAMETER (NMXHEP=4000)
18272 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
18273 DOUBLE PRECISION PHEP,VHEP
18274 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
18275 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
18277 C extension to standard particle data interface (PHOJET specific)
18278 INTEGER IMPART,IPHIST,ICOLOR
18279 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
18281 DOUBLE PRECISION PTS,PB,XP,XPB,PC
18282 DIMENSION PTS(0:2,50),PB(0:2,2),XP(50),XPB(2),PC(4)
18284 INTEGER MODIFY,IV,IVB
18285 DIMENSION MODIFY(50),IV(50),IVB(2)
18288 IF(IDEB(6).GE.10) WRITE(LO,'(1X,A,3I4,1P,E11.3)')
18289 & 'PHO_PARTPT: called with IMODE,IF,IL,PTCUT',
18290 & IMODE,IF,IL,PTCUT
18292 IF(IMODE.LT.0) GOTO 1000
18295 IF((ISWMDL(3).EQ.10).AND.(ISWMDL(4).EQ.10)) RETURN
18297 C count entries to modify
18306 IF(IMODE.EQ.0) THEN
18308 IF((ISTHEP(I).EQ.-1).AND.(ABS(IPHIST(1,I)).LT.100)) THEN
18311 XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
18313 IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
18314 IF(PHEP(4,I).LT.EMIN) THEN
18321 C hard Pomeron associated remnants (IPHIST(1,)=100,200,...)
18323 ELSE IF(IMODE.EQ.1) THEN
18326 IF((ISTHEP(I).EQ.-1).AND.(IPHIST(1,I).GE.100)) THEN
18327 IF(MOD(IPHIST(1,I),100).EQ.0) THEN
18330 XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
18331 IF(ISWMDL(24).EQ.0) THEN
18333 IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
18334 ELSE IF(ISWMDL(24).EQ.1) THEN
18339 IF(PHEP(4,I).LT.EMIN) THEN
18350 WRITE(LO,'(/1X,A,I5)') 'PHO_PARTPT:ERROR: invalid mode',IMODE
18355 IF(IDEB(6).GE.5) THEN
18356 WRITE(LO,'(1X,2A,3I4)') 'PHO_PARTPT: ',
18357 & 'number of partons, IPEAK,MODE',IENTRY,IPEAK,IMODE
18358 IF(IDEB(6).GE.20) CALL PHO_PREVNT(0)
18362 IF(IENTRY.LE.1) RETURN
18364 C sample pt of soft partons
18366 IF(ISWMDL(5).LE.1) THEN
18368 IPEAK = DT_RNDM(DUM)*IENTRY+1
18369 CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
18370 CALL PHO_SWAPD(XP(IPEAK),XP(1))
18371 CALL PHO_SWAPI(IV(IPEAK),IV(1))
18373 C energy limited sampling
18377 IF(ITER.GE.1000) THEN
18378 IF(IDEB(6).GE.3) THEN
18379 WRITE(LO,'(1X,A,3I5)')
18380 & 'PHO_PARTPT: rejection for MODE,ENTRY,ITER',
18381 & IMODE,IENTRY,ITER
18382 WRITE(LO,'(8X,A,I5)') 'I II IV XP EP',
18386 WRITE(LO,'(5X,3I5,1P,2E13.4)')
18387 & I,II,IV(I),XP(I),PHEP(4,II)
18389 IF(IDEB(6).GE.5) CALL PHO_PREVNT(0)
18396 PTMX = MIN(PHEP(4,II),PTCUT)
18399 IF(ISWMDL(5).EQ.0) THEN
18400 CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
18402 CALL PHO_SOFTPT(1,PTMX,PTMX,XPB,IVB,PB)
18407 PSUMX = PSUMX+PB(1,1)
18408 PSUMY = PSUMY+PB(2,1)
18410 PTREM = SQRT(PSUMX**2+PSUMY**2)
18411 IF(PTREM.GT.MIN(PHEP(4,MODIFY(1)),PTCUT)) GOTO 400
18414 ELSE IF((ISWMDL(5).EQ.2)
18415 & .OR.((IMODE.EQ.1).AND.(ISWMDL(5).EQ.3))) THEN
18416 C unlimited sampling
18417 IPEAK = DT_RNDM(PSUMX)*IENTRY+1
18418 CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
18419 CALL PHO_SWAPD(XP(IPEAK),XP(1))
18420 CALL PHO_SWAPI(IV(IPEAK),IV(1))
18421 CALL PHO_SOFTPT(IENTRY,PTCUT,PTCUT,XP,IV,PTS)
18422 ELSE IF(ISWMDL(5).EQ.3) THEN
18423 C each string has balanced pt
18425 IF(IV(K).LE.-90) GOTO 499
18427 IC1 = -ICOLOR(1,I1)
18428 DO 510 L=K+1,IENTRY
18429 IF(ICOLOR(1,MODIFY(L)).EQ.IC1) GOTO 511
18431 WRITE(LO,'(//1X,A,I5)')
18432 & 'PHO_PARTPT:ERROR: no color found for (line,color)',I1,-IC1
18436 AMSQR = (PHEP(4,I1)+PHEP(4,I2))**2-(PHEP(1,I1)+PHEP(1,I2))**2
18437 & -(PHEP(2,I1)+PHEP(2,I2))**2-(PHEP(3,I1)+PHEP(3,I2))**2
18440 IVB(1) = MAX(IV(K),IV(L))
18442 CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
18445 PTS(1,L) = -PB(1,1)
18446 PTS(2,L) = -PB(2,1)
18447 GAM = (PHEP(4,I1)+PHEP(4,I2))/AM
18448 GAMBEZ = (PHEP(3,I1)+PHEP(3,I2))/AM
18451 PLONG = SQRT(PTMX**2-PB(0,1)**2+1.D-12)
18452 PC(3) = SIGN(PLONG,PHEP(3,I1))
18454 CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
18455 & PTOT,PHEP(1,I1),PHEP(2,I1),PHEP(3,I1),PHEP(4,I1))
18459 CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
18460 & PTOT,PHEP(1,I2),PHEP(2,I2),PHEP(3,I2),PHEP(4,I2))
18466 WRITE(LO,'(/1X,A,I4)')
18467 & 'PHO_PARTPT:ERROR: invalid value of ISWMDL(5):',ISWMDL(5)
18471 C change partons in /POEVT1/
18473 IF(IV(II).GT.-90) THEN
18475 PHEP(1,I) = PHEP(1,I)+PTS(1,II)
18476 PHEP(2,I) = PHEP(2,I)+PTS(2,II)
18477 AMSQR = PHEP(4,I)**2
18478 & -PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
18479 PHEP(5,I) = SIGN(SQRT(ABS(AMSQR)),AMSQR)
18484 IF(IDEB(6).GE.15) THEN
18485 WRITE(LO,'(1X,A,/,8X,A,I5)') 'PHO_PARTPT: table of momenta',
18486 & 'I II IV XP EP PTS PTX PTY',IPEAK
18489 WRITE(LO,'(2X,3I5,1P,5E12.4)')
18490 & I,II,IV(I),XP(I),PHEP(4,II),PTS(0,I),PTS(1,I),PTS(2,I)
18496 C initialization / output of statistics
18498 CALL PHO_SOFTPT(IMODE,PTM,PTM,XP,IV,PTS)
18502 *$ CREATE PHO_SOFTPT.FOR
18504 CDECK ID>, PHO_SOFTPT
18505 SUBROUTINE PHO_SOFTPT(ISOFT,PTCUT,PTMAX,XV,IV,PTSOF)
18506 C***********************************************************************
18508 C select pt of soft string ends
18510 C input: ISOFT number of soft partons
18511 C -1 initialization
18512 C >=0 sampling of p_t
18513 C -2 output of statistics
18514 C PTCUT cutoff for soft strings
18515 C PTMAX maximal allowed PT
18516 C XV field of x values
18520 C output: /POINT3/ containing parameters AAS,BETAS
18521 C PTSOF filed with soft pt values
18523 C note: ISWMDL(3/4) = 0 dNs/dP_t = P_t ASS * exp(-BETA*P_t**2)
18524 C ISWMDL(3/4) = 1 dNs/dP_t = P_t ASS * exp(-BETA*P_t)
18525 C ISWMDL(3/4) = 2 photon wave function
18526 C ISWMDL(3/4) = 10 no soft P_t assignment
18528 C***********************************************************************
18529 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18532 PARAMETER ( DEPS = 1.D-15)
18534 DIMENSION PTSOF(0:2,*),XV(*)
18537 C input/output channels
18539 COMMON /POINOU/ LI,LO
18540 C event debugging information
18542 PARAMETER (NMAXD=100)
18543 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18544 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18545 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18546 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18547 C model switches and parameters
18549 INTEGER ISWMDL,IPAMDL
18550 DOUBLE PRECISION PARMDL
18551 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18552 C data of c.m. system of Pomeron / Reggeon exchange
18553 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18554 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18555 & SIDP,CODP,SIFP,COFP
18556 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18557 & SIDP,CODP,SIFP,COFP,NPOSP(2),
18558 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
18559 C data on most recent hard scattering
18560 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
18561 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
18562 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
18563 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
18564 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
18565 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
18566 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
18567 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
18568 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
18569 C data needed for soft-pt calculation
18570 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18571 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18573 DIMENSION BETAB(100)
18576 IF(ISOFT.GE.0) THEN
18577 CALLS = CALLS + 1.D0
18578 C sample according to model ISWMDL(3-6)
18579 IF(ISOFT.GT.1) THEN
18586 IF(IV(I).EQ.1) THEN
18588 C photon/pomeron valence part
18589 IF(IPAMDL(5).EQ.1) THEN
18590 IF(XV(I).GE.0.D0) THEN
18591 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
18596 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
18601 ELSE IF(IPAMDL(5).EQ.2) THEN
18603 ELSE IF(IPAMDL(5).EQ.3) THEN
18607 ELSE IF(IV(I).EQ.0) THEN
18609 C hard scattering remnant
18611 IF(IPAMDL(6).EQ.0) THEN
18613 ELSE IF(IPAMDL(6).EQ.1) THEN
18619 BETA = MAX(BETA,0.01D0)
18620 CALL PHO_SELPT(XV(I),0.D0,PTCUT,PTS,BETA,IMODE)
18621 PTS = MIN(PTMAX,PTS)
18622 CALL PHO_SFECFE(SIG,COG)
18624 PTSOF(1,I) = COG*PTS
18625 PTSOF(2,I) = SIG*PTS
18626 PTXS = PTXS+PTSOF(1,I)
18627 PTYS = PTYS+PTSOF(2,I)
18630 C balancing of momenta
18631 PTS = SQRT(PTXS**2+PTYS**2)
18632 IF(PTS.GE.PTMAX) GOTO 210
18640 C single parton only
18644 IF(IV(1).EQ.1) THEN
18646 C photon/Pomeron valence part
18647 IF(IPAMDL(5).EQ.1) THEN
18648 IF(XV(1).GE.0.D0) THEN
18649 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
18654 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
18659 ELSE IF(IPAMDL(5).EQ.2) THEN
18661 ELSE IF(IPAMDL(5).EQ.3) THEN
18665 ELSE IF(IV(1).EQ.0) THEN
18667 C hard scattering remnant
18669 IF(IPAMDL(6).EQ.1) THEN
18675 BETA = MAX(BETA,0.01D0)
18676 CALL PHO_SELPT(XV(1),0.D0,PTCUT,PTS,BETA,IMODE)
18677 PTS = MIN(PTMAX,PTS)
18678 CALL PHO_SFECFE(SIG,COG)
18680 PTSOF(1,1) = COG*PTS
18681 PTSOF(2,1) = SIG*PTS
18685 IF(IDEB(29).GE.10) THEN
18686 WRITE(LO,'(1X,A,I4)') 'PHO_SOFTPT: ISOFT',ISOFT
18687 WRITE(LO,'(6X,A)') 'TABLE OF I, IV, XV, PT, PT-X, PT-Y, BETA'
18689 WRITE(LO,'(10X,2I3,1P,5E12.3)') I,IV(I),XV(I),PTSOF(0,I),
18690 & PTSOF(1,I),PTSOF(2,I),BETAB(I)
18694 C initialization of statistics and parameters
18696 ELSE IF(ISOFT.EQ.-1) THEN
18699 IMODE = -100+ISWMDL(3)
18700 CALL PHO_SELPT(ECMP,PTSMIN,PTSMAX,PTS,BETAS(3),IMODE)
18702 C output of statistics
18704 ELSE IF(ISOFT.EQ.-2) THEN
18706 WRITE(LO,'(1X,2A,I2)') 'PHO_SOFTPT:ERROR: ',
18707 & 'unsupported ISOFT ',ISOFT
18712 *$ CREATE PHO_SELPT.FOR
18714 CDECK ID>, PHO_SELPT
18715 SUBROUTINE PHO_SELPT(EE,PTLOW,PTHIGH,PTS,BETA,IMODE)
18716 C***********************************************************************
18718 C select pt from different distributions
18720 C input: EE energy (for initialization only)
18721 C otherwise x value of corresponding parton
18722 C PTLOW lower pt limit
18723 C PTHIGH upper pt limit
18724 C (PTHIGH > 20 will cause DEXP underflows)
18726 C IMODE = 0 dNs/dP_t = P_t * ASS * exp(-BETA*P_t**2)
18727 C IMODE = 1 dNs/dP_t = P_t * ASS * exp(-BETA*P_t)
18728 C IMODE = 2 dNs/dP_t according photon wave function
18729 C IMODE = 10 no sampling
18731 C IMODE = -100+IMODE initialization according to
18732 C given limitations
18734 C output: PTS sampled pt value
18736 C BETA soft pt slope in central region
18738 C***********************************************************************
18739 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18742 PARAMETER ( PI2 = 6.28318530718D0,
18747 C input/output channels
18749 COMMON /POINOU/ LI,LO
18750 C event debugging information
18752 PARAMETER (NMAXD=100)
18753 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18754 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18755 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18756 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18757 C model switches and parameters
18759 INTEGER ISWMDL,IPAMDL
18760 DOUBLE PRECISION PARMDL
18761 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18762 C data of c.m. system of Pomeron / Reggeon exchange
18763 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18764 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18765 & SIDP,CODP,SIFP,COFP
18766 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18767 & SIDP,CODP,SIFP,COFP,NPOSP(2),
18768 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
18769 C average number of cut soft and hard ladders (obsolete)
18770 DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
18771 COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
18772 C data needed for soft-pt calculation
18773 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18774 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18776 DOUBLE PRECISION PHO_CONN0,PHO_CONN1
18777 EXTERNAL PHO_CONN0,PHO_CONN1
18781 IF(IMODE.LT.0) GOTO 100
18788 IF(PX.LT.AMIN) RETURN
18790 IF((PX-PTLOW).LT.0.01) THEN
18791 IF(IDEB(5).GE.3) WRITE(LO,'(1X,A,2E12.3,I3)')
18792 & 'PHO_SELPT: PTLOW,PTHIGH,IMODE ',PTLOW,PTHIGH,IMODE
18796 C sampling of pt values according to IMODE
18798 IF(IMODE.EQ.0) THEN
18800 FAC1 = EXP(-BETA*PX**2)
18803 XI1 = DT_RNDM(PX)*FAC2 + FAC1
18804 PTS = SQRT(-1.D0/BETA*LOG(XI1))
18805 IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 25
18807 ELSE IF(IMODE.EQ.1) THEN
18809 XIMIN = EXP(-BETA*PTHIGH)
18812 PTS = -LOG((XIDEL*DT_RNDM(XIDEL)+XIMIN)
18813 & *(XIDEL*DT_RNDM(XIMIN)+XIMIN)+DEPS)/BETA
18814 IF(PTS.LT.XMT) GOTO 50
18815 PTS = SQRT(PTS**2-XMT2)
18816 IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 50
18818 ELSE IF(IMODE.EQ.2) THEN
18820 IF(EE.GE.0.D0) THEN
18826 AA = (1.D0-XV)*XV*P2+PARMDL(25)
18828 PTS = SQRT(AA/(DT_RNDM(PX)+EPS)-AA)
18829 IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 75
18833 ELSE IF(IMODE.NE.10) THEN
18834 WRITE(LO,'(/1X,A,I4)') 'PHO_SELPT:ERROR: invalid IMODE',IMODE
18839 IF(IDEB(5).GE.20) THEN
18840 WRITE(LO,'(1X,A,I3,4E10.3)')
18841 & 'PHO_SELPT: MODE,BET,PTMI,PTMA,PT',
18842 & IMODE,BETA,PTLOW,PTHIGH,PTS
18851 C calculation of parameters
18855 C initialization for model 0 (gaussian pt distribution)
18858 BETAS(1) = PARMDL(23)+0.15D0*LOG(EE)*(PARMDL(24)-PARMDL(23))
18861 XTOL = PHO_CONN0(BETLO)*PHO_CONN0(BETUP)
18862 IF(XTOL.LT.0.D0) THEN
18867 BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN0,METHOD)
18868 * IF(BETA.LT.-1.D+10) THEN
18869 * WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
18870 * & '(model 0: Ecm,PTcut)',EE,PTCON
18871 * WRITE(LO,'(1X,A,1P,3E10.3)')
18872 * & 'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
18873 * CALL PHO_PREVNT(-1)
18876 AAS = DSIGHP/PTCON*EXP(-BETA*PTCON**2)
18883 C initialization for model 1 (exponential pt distribution)
18885 ELSE IF(INIT.EQ.1) THEN
18888 BETAS(1) = PARMDL(21)+0.15D0*LOG(EE)*(PARMDL(22)-PARMDL(21))
18891 XTOL = PHO_CONN1(BETLO)*PHO_CONN1(BETUP)
18892 IF(XTOL.LT.0.D0) THEN
18897 BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN1,METHOD)
18898 * IF(BETA.LT.-1.D+10) THEN
18899 * WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
18900 * & '(model 1: Ecm,PTcut)',EE,PTCON
18901 * WRITE(LO,'(1X,A,1P,3E10.3)')
18902 * & 'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
18903 * CALL PHO_PREVNT(-1)
18906 AAS = DSIGHP/PTCON*EXP(-BETA*PTCON)
18912 ELSE IF(INIT.EQ.10) THEN
18914 & WRITE(LO,'(/1X,A)') 'PHO_SELPT: no soft pt sampling'
18917 WRITE(LO,'(1X,A,I4)') 'PHO_SELPT:ERROR: invalid distribution',
18921 BETA = MIN(BETA,BETAS(1))
18923 C hard cross section is too big: neg. beta parameter
18924 IF(BETA.LE.0.D0) THEN
18925 WRITE(LO,'(1X,A,1P,2E12.3)')
18926 & 'PHO_SELPT: parameter BETA negative (BETA,AAS)',BETA,AAS
18927 WRITE(LO,'(1X,A,1P,4E11.3)') 'SIGS,DSIGHP,SIGH,PTCON:',
18928 & SIGS,DSIGHP,SIGH,PTCON
18929 CALL PHO_PREVNT(-1)
18932 C output of initialization parameters
18933 IF(IDEB(5).GE.10) THEN
18934 WRITE(LO,'(1X,A,I3)') 'PHO_SELPT: initialization for model',
18936 WRITE(LO,'(5X,A,1P,2E13.3)')
18937 & 'BETA,AAS ',BETA,AAS
18938 WRITE(LO,'(5X,A,1P,3E13.3)')
18939 & 'ECM,PTMIN,PTMAX ',EE,PTSMIN,PTSMAX
18940 WRITE(LO,'(5X,A,1P,3E13.3)')
18941 & 'SIGS,DSIGHP,SIGH',SIGS,DSIGHP,SIGH
18946 *$ CREATE PHO_CONN0.FOR
18948 CDECK ID>, PHO_CONN0
18949 DOUBLE PRECISION FUNCTION PHO_CONN0(BETA)
18950 C***********************************************************************
18952 C auxiliary function to determine parameters of soft
18953 C pt distribution dNs/dP_t = P_t * AAS * EXP(-BETA*P_t**2)
18955 C internal factors: FS number of soft partons in soft Pomeron
18956 C FH number of soft partons in hard Pomeron
18958 C***********************************************************************
18962 C input/output channels
18964 COMMON /POINOU/ LI,LO
18965 C average number of cut soft and hard ladders (obsolete)
18966 DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
18967 COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
18968 C data needed for soft-pt calculation
18969 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18970 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18972 DOUBLE PRECISION BETA,XX,FF
18975 IF(ABS(XX).LT.1.D-3) THEN
18976 FF = FS*SIGS+FH*SIGH
18977 & - DSIGHP*(PTCON/2.D0+PTCON**3*BETA/4.D0)
18979 FF = FS*SIGS+FH*SIGH
18980 & - DSIGHP/(2.D0*PTCON*BETA)*(EXP(XX)-1.D0)
18984 * WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:BETA,AAS,FF',BETA,AAS,FF
18985 * WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP
18989 *$ CREATE PHO_CONN1.FOR
18991 CDECK ID>, PHO_CONN1
18992 DOUBLE PRECISION FUNCTION PHO_CONN1(BETA)
18993 C***********************************************************************
18995 C auxiliary function to determine parameters of soft
18996 C pt distribution dNs/dP_t = P_t * AAS * EXP(-BETA*P_t)
18998 C internal factors: FS number of soft partons in soft Pomeron
18999 C FH number of soft partons in hard Pomeron
19001 C***********************************************************************
19005 C input/output channels
19007 COMMON /POINOU/ LI,LO
19008 C average number of cut soft and hard ladders (obsolete)
19009 DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
19010 COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
19011 C data needed for soft-pt calculation
19012 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
19013 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
19015 DOUBLE PRECISION BETA,XX,FF
19018 IF(ABS(XX).LT.1.D-3) THEN
19019 FF = FS*SIGS+FH*SIGH
19020 & - DSIGHP*(PTCON/2.D0+PTCON**2*BETA/6.D0)
19022 FF = FS*SIGS+FH*SIGH
19023 & - DSIGHP/(PTCON*BETA**2)*(EXP(XX)-1.D0-BETA*PTCON)
19027 * WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:BETA,AAS,FF',BETA,AAS,FF
19028 * WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP
19032 *$ CREATE PHO_MSHELL.FOR
19034 CDECK ID>, PHO_MSHELL
19035 SUBROUTINE PHO_MSHELL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
19036 C********************************************************************
19038 C rescaling of momenta of two partons to put both
19041 C input: PA1,PA2 input momentum vectors
19042 C XM1,2 desired masses of particles afterwards
19043 C P1,P2 changed momentum vectors
19045 C********************************************************************
19046 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19049 PARAMETER ( DEPS = 1.D-20 )
19051 DIMENSION PA1(*),PA2(*),P1(*),P2(*)
19053 C input/output channels
19055 COMMON /POINOU/ LI,LO
19056 C event debugging information
19058 PARAMETER (NMAXD=100)
19059 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19060 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19061 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19062 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19063 C internal rejection counters
19065 PARAMETER (NMXJ=60)
19066 CHARACTER*10 REJTIT
19068 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19073 IF(IDEB(40).GE.10) THEN
19074 WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
19075 WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
19076 WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
19077 WRITE(LO,'(5X,A,2E12.3)') 'new masses:',XM1,XM2
19080 C Lorentz transformation into system CMS
19085 XMS = EE**2-PX**2-PY**2-PZ**2
19086 IF(XMS.LT.(XM1+XM2)**2) THEN
19088 IFAIL(37) = IFAIL(37)+1
19090 if((xm1.gt.1.D4).or.(xm2.gt.1.D4)) irej = irej/idev
19092 IF(IDEB(40).GE.3) THEN
19093 WRITE(LO,'(/1X,A,I12)')
19094 & 'PHO_MSHELL:reject: too small string mass (KEVENT)',KEVENT
19095 WRITE(LO,'(5X,A,3E12.4)') 'two-part.mass, part.masses:',
19096 & SIGN(SQRT(ABS(XMS)),XMS),XM1,XM2
19097 WRITE(LO,'(5X,A,4E11.4)') 'PX,PY,PZ,EE:',PX,PY,PZ,EE
19099 IF(IDEB(40).GE.3) GOTO 55
19108 CALL PHO_ALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
19109 & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
19111 PTOT1 = MAX(DEPS,PTOT1)
19113 SID = SQRT(P1(1)**2+P1(2)**2)/PTOT1
19116 IF(PTOT1*SID.GT.1.D-5) THEN
19117 COF = P1(1)/(SID*PTOT1)
19118 SIF = P1(2)/(SID*PTOT1)
19119 ANORF = SQRT(COF*COF+SIF*SIF)
19124 C new CM momentum and energies (for masses XM1,XM2)
19128 PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*XMS)
19129 EE1 = SQRT(XM12+PCMP**2)
19132 CALL PHO_TRANS(0.D0,0.D0,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
19133 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
19134 & PTOT1,P1(1),P1(2),P1(3),P1(4))
19135 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
19136 & PTOT2,P2(1),P2(2),P2(3),P2(4))
19138 C check consistency
19140 IF(ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
19142 ELSE IF(ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
19144 ELSE IF(ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
19146 ELSE IF(ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
19152 WRITE(LO,'(1X,A,I3)')
19153 & 'PHO_MSHELL: inconsistent transformation (IDEV)',IDEV
19154 WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
19155 WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
19156 WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
19157 WRITE(LO,'(5X,A,3E12.3)') 'ava.mass,masses:',XMS,XM1,XM2
19158 WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
19159 WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
19160 WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
19161 ELSE IF(IDEB(40).GE.10) THEN
19162 WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
19163 WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
19164 WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
19168 *$ CREATE PHO_GLU2QU.FOR
19170 CDECK ID>, PHO_GLU2QU
19171 SUBROUTINE PHO_GLU2QU(IG,IQ1,IQ2,IREJ)
19172 C********************************************************************
19174 C split gluon with index I in POEVT1
19175 C (massless gluon assumed)
19179 C IQ1 first quark index
19180 C IQ2 second quark index
19182 C output: new quarks in /POEVT1/
19183 C IREJ 1 splitting impossible
19184 C 0 splitting successful
19186 C********************************************************************
19187 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19190 PARAMETER ( DEPS = 1.D-15,
19193 C input/output channels
19195 COMMON /POINOU/ LI,LO
19196 C event debugging information
19198 PARAMETER (NMAXD=100)
19199 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19200 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19201 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19202 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19203 C model switches and parameters
19205 INTEGER ISWMDL,IPAMDL
19206 DOUBLE PRECISION PARMDL
19207 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
19208 C standard particle data interface
19210 PARAMETER (NMXHEP=4000)
19211 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
19212 DOUBLE PRECISION PHEP,VHEP
19213 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
19214 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
19216 C extension to standard particle data interface (PHOJET specific)
19217 INTEGER IMPART,IPHIST,ICOLOR
19218 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
19219 C internal rejection counters
19221 PARAMETER (NMXJ=60)
19222 CHARACTER*10 REJTIT
19224 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19226 DIMENSION P1(4),P2(4)
19231 C calculate string masses max possible
19232 IF(ISWMDL(9).EQ.1) THEN
19233 CMASS1=2.D0*(PHEP(4,IG)*PHEP(4,IQ1)-PHEP(1,IG)*PHEP(1,IQ1)
19234 & -PHEP(2,IG)*PHEP(2,IQ1)-PHEP(3,IG)*PHEP(3,IQ1))
19235 IF(CMASS1.LT.CUTM) THEN
19236 IF(IDEB(73).GE.5) THEN
19237 WRITE(LO,'(1X,A,3I4,4E10.3)')
19238 & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS1',IG,IQ1,IQ2,CMASS1
19240 IFAIL(33) = IFAIL(33) + 1
19244 CMASS2=2.D0*(PHEP(4,IG)*PHEP(4,IQ2)-PHEP(1,IG)*PHEP(1,IQ2)
19245 & -PHEP(2,IG)*PHEP(2,IQ2)-PHEP(3,IG)*PHEP(3,IQ2))
19246 IF(CMASS2.LT.CUTM) THEN
19247 IF(IDEB(73).GE.5) THEN
19248 WRITE(LO,'(1X,A,3I4,4E10.3)')
19249 & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS2',IG,IQ1,IQ2,CMASS2
19251 IFAIL(33) = IFAIL(33) + 1
19256 C calculate minimal z
19257 ZMIN1 = (CUTM-SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))/CMASS1+EPS
19258 ZMIN2 = (CUTM-SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))/CMASS2+EPS
19259 ZMIN = MIN(ZMIN1,ZMIN2)
19260 IF(MAX(ZMIN1,ZMIN2).GE.0.45D0) THEN
19261 IF(IDEB(73).GE.5) THEN
19262 WRITE(LO,'(1X,A,3I3,4E10.3)')
19263 & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,ZMIN1,ZMIN2,P1*PG,P2*PG',
19264 & IG,IQ1,IQ2,ZMIN1,ZMIN2,CMASS1,CMASS2
19266 IFAIL(33) = IFAIL(33) + 1
19271 ZMIN = MIN(0.1D0,0.5D0/PHEP(4,IG))
19274 ZFRAC = PHO_GLUSPL(ZMIN)
19275 IF((ZFRAC.LT.ZMIN1).OR.((1.D0-ZFRAC).LT.ZMIN2)) THEN
19279 P1(I) = PHEP(I,IG)*ZFRAC
19280 P2(I) = PHEP(I,IG)*(1.D0-ZFRAC)
19283 CMASS1 = SQRT(ZFRAC*CMASS1+SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))
19284 CMASS2 = SQRT((1.D0-ZFRAC)*CMASS2
19285 & +SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))
19286 CALL PHO_SEAFLA(IG,K,I,MIN(CMASS1,CMASS2))
19287 IF(ABS(IDHEP(IQ1)).GT.6) THEN
19288 K = SIGN(ABS(K),IDHEP(IQ1))
19290 K = -SIGN(ABS(K),IDHEP(IQ1))
19294 IC1 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
19295 IC2 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
19297 IC1 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
19298 IC2 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
19300 C register new partons
19301 CALL PHO_REGPAR(-1,K,0,IG,0,P1(1),P1(2),P1(3),P1(4),
19302 & IPHIST(1,IG),0,IC1,0,IPOS,1)
19303 CALL PHO_REGPAR(-1,-K,0,IG,0,P2(1),P2(2),P2(3),P2(4),
19304 & IPHIST(1,IG),0,IC2,0,IPOS,1)
19306 IF(IDEB(73).GE.20) THEN
19307 WRITE(LO,'(1X,A,/1X,A,3I3,5E10.3)')
19308 & 'PHO_GLU2QU:',' IG,IQ1,IQ2,ZMIN1,2,Z,P1*PG,P2*PG',
19309 & IG,IQ1,IQ2,ZMIN1,ZMIN2,ZFRAC,CMASS1,CMASS2
19310 WRITE(LO,'(1X,A,4I5)') ' flavours, colors ',
19315 *$ CREATE PHO_GLUSPL.FOR
19317 CDECK ID>, PHO_GLUSPL
19318 DOUBLE PRECISION FUNCTION PHO_GLUSPL(ZMIN)
19319 C*********************************************************************
19321 C calculate quark - antiquark light cone momentum fractions
19322 C according to Altarelli-Parisi g->q aq splitting function
19323 C (symmetric z interval assumed)
19325 C input: ZMIN minimal Z value allowed,
19326 C 1-ZMIN maximal Z value allowed
19328 C********************************************************************
19329 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19332 PARAMETER ( ALEXP= 0.3333333333D0,
19335 C input/output channels
19337 COMMON /POINOU/ LI,LO
19338 C event debugging information
19340 PARAMETER (NMAXD=100)
19341 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19342 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19343 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19344 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19346 IF(ZMIN.GE.0.5D0) THEN
19347 IF(IDEB(69).GT.2) THEN
19348 WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN>=0.5',ZMIN
19352 ELSE IF(ZMIN.LE.0.D0) THEN
19353 IF(IDEB(69).GT.2) THEN
19354 WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN<=0',ZMIN
19363 ZZ = ((1.D0-XI)*ZMINL**3+XI*ZMAX**3)**ALEXP
19364 IF(DT_RNDM(ZZ).LT.0.5D0) ZZ = 1.D0-ZZ
19367 IF(IDEB(69).GE.10) THEN
19368 WRITE(LO,'(1X,A,2E12.4)') 'PHO_GLUSPL: ZMIN,Z ',ZMIN,ZZ
19373 *$ CREATE PHO_STDPAR.FOR
19375 CDECK ID>, PHO_STDPAR
19376 SUBROUTINE PHO_STDPAR(IJM1,IJM2,IGEN,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
19377 C***********************************************************************
19379 C select the initial parton x-fractions and flavors and
19380 C the final parton momenta and flavours
19381 C for standard Pomeron/Reggeon cuts
19383 C input: IJM1 index of mother particle 1 in /POEVT1/
19384 C IJM2 index of mother particle 2 in /POEVT1/
19385 C IGEN production process of mother particles
19386 C MSPOM soft cut Pomerons
19387 C MHPOM hard or semihard cut Pomerons
19388 C MSREG soft cut Reggeons
19389 C MHDIR direct hard processes
19391 C IJM1 -1 initialization of statistics
19392 C -2 output of statistics
19394 C output: partons are directly written to /POEVT1/,/POEVT2/
19396 C structure of /POSOFT/
19397 C XS1(I),XS2(I): x-values of initial partons
19398 C IJSI1(I),IJSI2(I): flavor of initial parton
19401 C negative antiquarks
19402 C IJSF1(I),IJSF2(I): flavor of final state partons
19403 C PSOFT1(I,J),PSOFT2(I,J): final part. momentum and energy
19409 C***********************************************************************
19410 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19413 PARAMETER (RHOMAS = 0.766D0,
19417 C input/output channels
19419 COMMON /POINOU/ LI,LO
19420 C event debugging information
19422 PARAMETER (NMAXD=100)
19423 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19424 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19425 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19426 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19427 C model switches and parameters
19429 INTEGER ISWMDL,IPAMDL
19430 DOUBLE PRECISION PARMDL
19431 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
19433 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
19434 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
19435 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
19436 C general process information
19437 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
19438 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
19439 C global event kinematics and particle IDs
19440 INTEGER IFPAP,IFPAB
19441 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
19442 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
19443 C data of c.m. system of Pomeron / Reggeon exchange
19444 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
19445 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
19446 & SIDP,CODP,SIFP,COFP
19447 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
19448 & SIDP,CODP,SIFP,COFP,NPOSP(2),
19449 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
19450 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
19451 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
19452 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
19453 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
19454 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
19455 C obsolete cut-off information
19456 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
19457 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
19458 C currently activated parton density parametrizations
19460 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
19461 DOUBLE PRECISION PDFLAM,PDFQ2M
19462 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
19463 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
19464 C hard scattering parameters used for most recent hard interaction
19466 DOUBLE PRECISION ALQCD2,BQCD
19467 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
19468 C particles created by initial state evolution
19469 INTEGER MXISR1,MXISR2
19470 PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
19471 INTEGER IFLISR,IPOISR,IMXISR
19472 DOUBLE PRECISION PHISR
19473 COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
19474 & IPOISR(2,2,MXISR2),IMXISR(2)
19475 C light-cone x fractions and c.m. momenta of soft cut string ends
19477 PARAMETER ( MAXSOF = 50 )
19478 INTEGER IJSI2,IJSI1
19479 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
19480 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
19481 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
19482 & IJSI1(MAXSOF),IJSI2(MAXSOF)
19483 C table of particle indices for recursive PHOJET calls
19485 PARAMETER ( MAXIPX = 100 )
19486 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
19487 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
19488 & IPOIX1,IPOIX2,IPOIX3
19489 C hard scattering data
19491 PARAMETER ( MSCAHD = 50 )
19492 INTEGER LSCAHD,LSC1HD,LSIDX,
19493 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
19494 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
19495 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
19496 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
19497 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
19498 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
19499 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
19500 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
19501 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
19502 C standard particle data interface
19504 PARAMETER (NMXHEP=4000)
19505 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
19506 DOUBLE PRECISION PHEP,VHEP
19507 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
19508 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
19510 C extension to standard particle data interface (PHOJET specific)
19511 INTEGER IMPART,IPHIST,ICOLOR
19512 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
19513 C internal rejection counters
19515 PARAMETER (NMXJ=60)
19516 CHARACTER*10 REJTIT
19518 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19519 C internal cross check information on hard scattering limits
19520 DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
19521 COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)
19522 C hard cross sections and MC selection weights
19524 PARAMETER ( Max_pro_2 = 16 )
19525 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
19526 & MH_acc_1,MH_acc_2
19527 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
19528 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
19529 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
19530 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
19531 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
19532 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
19534 double precision pho_alphas
19536 DIMENSION PC(4),IFLA(2),ICI(2,2)
19538 IF(IJM1.EQ.-1) THEN
19541 ETAMA(1,I) = -1.D10
19543 ETAMA(2,I) = -1.D10
19549 CALL PHO_HARSCA(IJM1,1)
19550 CALL PHO_HARCOL(IJM1,0.D0,0,0,0,0,0,0,0,0,0,0,0,0)
19554 ELSE IF(IJM1.EQ.-2) THEN
19556 C output internal statistics
19557 IF(IDEB(23).GE.1) THEN
19558 WRITE(LO,'(/1X,A)')
19559 & 'kinematic limits particle c (ETAMIN,ETAMAX,XMIN,XMAX)'
19561 WRITE(LO,'(5X,I3,4E13.5)')
19562 & I,ETAMI(1,I),ETAMA(1,I),XXMI(1,I),XXMA(1,I)
19565 & 'kinematic limits particle d (ETAMIN,ETAMAX,XMIN,XMAX)'
19567 WRITE(LO,'(5X,I3,4E13.5)')
19568 & I,ETAMI(2,I),ETAMA(2,I),XXMI(2,I),XXMA(2,I)
19571 CALL PHO_HARSCA(IJM1,1)
19572 CALL PHO_HARCOL(IJM1,0.D0,0,0,0,0,0,0,0,0,0,0,0,0)
19579 IF(IDEB(23).GT.5) WRITE(LO,221) IJM1,IJM2,MSPOM,MHPOM,MSREG,MHDIR
19580 221 FORMAT (' PHO_STDPAR: JM1/2,MSPOM,MHPOM,MSREG,MHDIR ',6I5)
19582 C get mother data (exchange if first particle is a pomeron)
19583 IF((IDHEP(IJM1).EQ.990).AND.(IFPAP(1).NE.990)) THEN
19593 IDPDG1 = IDHEP(JM1)
19594 IDBAM1 = IMPART(JM1)
19595 IDPDG2 = IDHEP(JM2)
19596 IDBAM2 = IMPART(JM2)
19598 C store current status of /POEVT1/
19607 C get nominal masses (photons: VDM assumption)
19609 IF(IDHEP(JM1).EQ.22) THEN
19610 PMASSP(1) = RHOMAS+DELMAS
19611 PVIRTP(1) = PHEP(5,JM1)**2
19613 PMASSP(1) = PHO_PMASS(IDBAM1,0)+DELMAS
19616 IF(IDHEP(JM2).EQ.22) THEN
19617 PMASSP(2) = RHOMAS+DELMAS
19618 PVIRTP(2) = PHEP(5,JM2)**2
19620 PMASSP(2) = PHO_PMASS(IDBAM2,0)+DELMAS
19624 C calculate c.m. energy and check kinematics
19625 PC(1) = PHEP(1,JM1)+PHEP(1,JM2)
19626 PC(2) = PHEP(2,JM1)+PHEP(2,JM2)
19627 PC(3) = PHEP(3,JM1)+PHEP(3,JM2)
19628 PC(4) = PHEP(4,JM1)+PHEP(4,JM2)
19629 SS = (PC(4)+PC(3))*(PC(4)-PC(3))-PC(1)**2-PC(2)**2
19631 IF(SS.LE.(PMASSP(1)+PMASSP(2)+DEPS)**2) THEN
19632 WRITE(LO,'(/,1X,2A)') 'PHO_STDPAR: ',
19633 & 'energy smaller than two-particle threshold (event rejected)'
19640 IF(IDEB(23).GE.5) THEN
19641 WRITE(LO,'(1X,2A,2I7,E12.4)') 'PHO_STDPAR: ',
19642 & 'particles, available energy:',IDHEP(JM1),IDHEP(JM2),ECMP
19643 IF(IDEB(23).GE.25) CALL PHO_PREVNT(0)
19646 C Lorentz transformation into c.m. system
19648 GAMBEP(I) = PC(I)/ECMP
19650 CALL PHO_ALTRA(GAMBEP(4),-GAMBEP(1),-GAMBEP(2),-GAMBEP(3),
19651 & PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
19652 & PHEP(4,JM1),PTOT1,PC(1),PC(2),PC(3),PC(4))
19653 C rotation angle: particle 1 moves along +z
19655 SIDP = SQRT(PC(1)**2+PC(2)**2)/PTOT1
19658 IF(PTOT1*SIDP.GT.1.D-5) THEN
19659 COFP = PC(1)/(SIDP*PTOT1)
19660 SIFP = PC(2)/(SIDP*PTOT1)
19661 ANORF = SQRT(COFP*COFP+SIFP*SIFP)
19666 XM12 = PMASSP(1)**2
19667 XM22 = PMASSP(2)**2
19668 PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*ECMP)
19670 C find particle combination
19672 IF(IDPDG2.EQ.IFPAP(2)) THEN
19673 IF(IDPDG1.EQ.IFPAP(1)) II = 1
19674 ELSE IF(IDPDG2.EQ.990) THEN
19675 IF(IDPDG1.EQ.IFPAP(1)) THEN
19677 ELSE IF(IDPDG1.EQ.IFPAP(2)) THEN
19679 ELSE IF(IDPDG1.EQ.990) THEN
19684 IF(ISWMDL(14).GT.0) THEN
19687 WRITE(LO,'(/1X,2A,2I8)') 'PHO_STDPAR:ERROR: ',
19688 & 'invalid particle combination:',IDPDG1,IDPDG2
19693 C select parton distribution functions from tables
19694 IF((MHPOM+MHDIR).GT.0) THEN
19695 CALL PHO_ACTPDF(IDPDG1,1)
19696 CALL PHO_ACTPDF(IDPDG2,2)
19697 C initialize alpha_s calculation
19698 DUMMY = PHO_ALPHAS(0.D0,-4)
19701 C interpolate hard cross sections and rejection weights
19702 CALL PHO_HARINT(II,ECMP,PVIRTP(1),PVIRTP(2),
19703 & -1,Max_pro_2,1,4,MSPOM+MHPOM+MHDIR)
19707 C position of first particle added to /POEVT2/
19710 C ---------------- direct processes -----------------
19712 IF(MHDIR.EQ.1) THEN
19713 CALL PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
19714 IF(IREJ.EQ.50) RETURN
19715 IF(IREJ.NE.0) GOTO 150
19716 C write comments to /POEVT1/
19717 CALL PHO_REGPAR(25,II,NPROHD(1),IDPDG1,IDPDG2,X0HD(1,1),
19718 & X0HD(1,2),PTHD(1),VHD(1),N0INHD(1,1),N0INHD(1,2),
19719 & IPHO_CNV1(NOUTHD(1,1)),IPHO_CNV1(NOUTHD(1,2)),IPOS,1)
19720 CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,1)),IPDF1,JM1,JM2,
19721 & PPH(1,1),PPH(2,1),PPH(3,1),Q2SCA(1,1),100,NBRAHD(1,1),
19722 & ICA1,ICA2,IPOS,1)
19723 CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,2)),IPDF2,JM2,JM1,
19724 & PPH(1,2),PPH(2,2),PPH(3,2),Q2SCA(1,2),100,NBRAHD(1,2),
19725 & ICA1,ICA2,IPOS,1)
19726 CALL PHO_REGPAR(21,NOUTHD(1,1),IPDF1,JM1,JM2,PPH(5,1),
19727 & PPH(6,1),PPH(7,1),PPH(8,1),100,NBRAHD(1,1),ICA1,ICA2,
19729 CALL PHO_REGPAR(21,NOUTHD(1,2),IPDF2,JM2,JM1,PPH(5,2),
19730 & PPH(6,2),PPH(7,2),PPH(8,2),100,NBRAHD(1,2),ICA1,ICA2,
19733 C soft spectator partons
19741 C single resolved: QCD compton scattering
19742 C ------------------------------
19743 IF(NPROHD(1).EQ.10) THEN
19744 C register hadron remnant
19745 CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
19746 IPDF2 = 1000*IGRP(2)+ISET(2)
19747 ELSE IF(NPROHD(1).EQ.12) THEN
19748 C register hadron remnant
19749 CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
19750 IPDF1 = 1000*IGRP(1)+ISET(1)
19752 C single resolved: photon gluon fusion
19753 C ---------------------------
19754 ELSE IF(NPROHD(1).EQ.11) THEN
19755 C register hadron remnant
19756 CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
19757 IPDF2 = 1000*IGRP(2)+ISET(2)
19758 ELSE IF(NPROHD(1).EQ.13) THEN
19759 C register hadron remnant
19760 CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
19761 IPDF1 = 1000*IGRP(1)+ISET(1)
19763 C direct process (no remnant)
19764 C ----------------------------
19765 ELSE IF(NPROHD(1).EQ.14) THEN
19769 C write final high-pt partons to POEVT1
19770 IF((ISWMDL(8).GE.2).AND.(NPROHD(1).NE.14)) THEN
19776 IFLA(1) = NINHD(I,1)
19777 IFLA(2) = NINHD(I,2)
19778 C initial state radiation
19780 DO 135 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
19783 IFLB = IFLISR(K,IPA)
19784 IF(ABS(IFLB).LE.6) THEN
19786 IF(ICI(K,1)*ICI(K,2).NE.0) THEN
19788 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19789 & ICI(K,1),ICI(K,2),3)
19790 ELSE IF(IFLB.GT.0) THEN
19791 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19792 & ICI(K,1),ICI(K,2),4)
19794 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
19798 IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
19799 IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
19800 CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
19806 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
19809 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19810 & ICI(K,1),ICI(K,2),2)
19813 IIFL = IPHO_CNV1(IFLB)
19814 IFLA(K) = IFLA(K)-IFLB
19823 CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
19824 & PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),I*100+K,
19825 & IGEN,IC1,IC2,IPOS,1)
19828 ICOLOR(1,IPOS1-2) = ICI(1,1)
19829 ICOLOR(2,IPOS1-2) = ICI(1,2)
19830 ICOLOR(1,IPOS1-1) = ICI(2,1)
19831 ICOLOR(2,IPOS1-1) = ICI(2,2)
19832 CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
19833 & IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
19834 & NOUTHD(I,2),ICI(2,1),ICI(2,2))
19835 ICOLOR(1,IPOS1) = ICI(1,1)
19836 ICOLOR(2,IPOS1) = ICI(1,2)
19837 ICOLOR(1,IPOS2) = ICI(2,1)
19838 ICOLOR(2,IPOS2) = ICI(2,2)
19840 IPA = IPOISR(K,1,I)
19841 CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
19842 & PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
19843 & PHISR(K,4,IPA),-I*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
19846 ICOLOR(1,IPOS1-2) = ICA1
19847 ICOLOR(2,IPOS1-2) = ICA2
19848 ICOLOR(1,IPOS1-1) = ICB1
19849 ICOLOR(2,IPOS1-1) = ICB2
19850 CALL PHO_HARCOL(NPROHD(1),VHD(1),NINHD(1,1),ICA1,ICA2,
19851 & NINHD(1,2),ICB1,ICB2,NOUTHD(1,1),ICA1,ICA2,
19852 & NOUTHD(1,2),ICB1,ICB2)
19853 ICOLOR(1,IPOS1) = ICA1
19854 ICOLOR(2,IPOS1) = ICA2
19855 ICOLOR(1,IPOS2) = ICB1
19856 ICOLOR(2,IPOS2) = ICB2
19858 IF(ABS(NOUTHD(1,1)).GT.12) I = 1
19859 CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,1)),0,JM1,JM2,PPH(5,1),
19860 & PPH(6,1),PPH(7,1),PPH(8,1),-100,IGEN,ICA1,ICA2,IPOS,1)
19861 CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,2)),0,JM1,JM2,PPH(5,2),
19862 & PPH(6,2),PPH(7,2),PPH(8,2),-100,IGEN,ICB1,ICB2,IPOS,1)
19865 C assign soft pt to spectators
19866 IF(ISWMDL(18).EQ.0) THEN
19868 CALL PHO_PARTPT(0,NLOR1,IPOS2,PTCUT(II),IREJ)
19870 IFAIL(26) = IFAIL(26) + 1
19876 C ----------------- resolved processes -------------------
19878 C single Reggeon exchange
19879 C ----------------------------
19880 ELSE IF((MSREG.EQ.1).AND.(MHPOM+MSPOM.EQ.0)) THEN
19882 CALL PHO_REGFLA(JM1,JM2,IFL1,IFL2,IREJ)
19884 IFAIL(24) = IFAIL(24)+1
19888 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
19889 IF(((ABS(IFL1).GT.6).AND.(IFL1.GT.0))
19890 & .OR.((ABS(IFL1).LE.6).AND.(IFL1.LT.0))) THEN
19891 CALL PHO_SWAPI(ICA1,ICB1)
19897 C DPMJET call with special projectile / target
19898 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
19899 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH*XPSUB,
19900 & ECMH*XPSUB,-1,IGEN,ICA1,0,IPOS1,1)
19901 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH*XTSUB,
19902 & ECMH*XTSUB,-1,IGEN,ICB1,0,IPOS2,1)
19903 C default treatment
19905 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH,ECMH,
19906 & -1,IGEN,ICA1,0,IPOS1,1)
19907 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH,ECMH,
19908 & -1,IGEN,ICB1,0,IPOS2,1)
19911 C soft pt assignment
19912 IF(ISWMDL(18).EQ.0) THEN
19913 CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
19915 IFAIL(25) = IFAIL(25) + 1
19920 C multi Reggeon / Pomeron exchange
19921 C----------------------------------------
19923 C parton configuration
19925 CALL PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,MSPAR1,MSPAR2,
19926 & MHPAR1,MHPAR2,IREJ)
19928 IF(IREJ.EQ.50) RETURN
19929 IF(IREJ.NE.0) GOTO 150
19931 C register particles
19932 IF(IDEB(23).GE.15) WRITE(LO,'(1X,A,/15X,7I5)')
19933 & 'PHO_STDPAR: MSPOM,MHPOM,MSREG,MSPAR1/2,IVAL1/2',
19934 & MSPOM,MHPOM,MSREG,MSPAR1,MSPAR2,IVAL1,IVAL2
19936 C register soft partons
19937 IF(IVAL1.NE.0) THEN
19938 IF(IVAL1.LT.0) THEN
19944 ELSE IF(MSPOM.EQ.0) THEN
19949 IF(IVAL2.NE.0) THEN
19950 IF(IVAL2.LT.0) THEN
19956 ELSE IF(MSPOM.EQ.0) THEN
19962 IF(IDEB(23).GE.20) WRITE(LO,'(1X,A,2I3,2X,2I3)')
19963 & 'PHO_STDPAR: IND1/2,IVAL1/2',IND1,IND2,IVAL1,IVAL2
19965 C soft Pomeron final states
19966 C -----------------------------------
19967 K = MSPOM+MHPOM+MSREG
19970 CALL PHO_POSPOM(II,IND1,IND2,IGEN,I,K,ISWAP,IREJ)
19972 IFAIL(8) = IFAIL(8) + 1
19978 C soft Reggeon final states
19979 C -----------------------------------------
19982 CMASS1 = MIN(PSOFT1(4,IND1),PSOFT2(4,IND2))
19983 IF(DT_RNDM(CMASS1).LT.0.5D0) THEN
19984 CALL PHO_SEAFLA(JM1,IFLA1,IFLB1,CMASS1)
19986 CALL PHO_SEAFLA(JM2,IFLA1,IFLB1,CMASS1)
19989 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
19990 IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
19991 & .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
19992 & CALL PHO_SWAPI(ICA1,ICB1)
19994 CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
19995 & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),
19996 & I,IGEN,ICA1,ICA2,IPOS1,1)
19998 CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
19999 & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),
20000 & I,IGEN,ICB1,ICB2,IPOS2,1)
20003 IF(IDEB(23).GE.20) WRITE(LO,'(1X,A,/15X,6I4)')
20004 & 'PHO_STDPAR: reg.cut: IND1,IND2,IFLA,IFLB,IPOS1,IPOS2',
20005 & IND1-1,IND2-1,IFLA1,IFLB1,IPOS1,IPOS2
20007 C soft pt assignment
20008 IF(ISWMDL(18).EQ.0) THEN
20009 CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
20011 IFAIL(25) = IFAIL(25) + 1
20018 C hard Pomeron final states
20019 C ------------------------------------
20026 IFLI1 = IPHO_CNV1(N0INHD(I,1))
20027 IFLI2 = IPHO_CNV1(N0INHD(I,2))
20028 IFLO1 = IPHO_CNV1(NOUTHD(I,1))
20029 IFLO2 = IPHO_CNV1(NOUTHD(I,2))
20030 C write comments to /POEVT1/
20031 CALL PHO_REGPAR(25,II,NPROHD(I),IDPDG1,IDPDG2,X0HD(I,1),
20032 & X0HD(I,2),PTHD(I),VHD(I),N0INHD(I,1),N0INHD(I,2),
20033 & IFLO1,IFLO2,IPOS,1)
20035 IPDF = 1000*IGRP(1)+ISET(1)
20036 CALL PHO_REGPAR(20,IFLI1,IPDF,JM1,JM2,PPH(I1,1),
20037 & PPH(I1+1,1),PPH(I1+2,1),Q2SCA(I,1),L*100,NBRAHD(I,1),
20038 & ICA1,ICA2,IPOS,1)
20039 IPDF = 1000*IGRP(2)+ISET(2)
20040 CALL PHO_REGPAR(20,IFLI2,IPDF,JM2,JM1,PPH(I1,2),
20041 & PPH(I1+1,2),PPH(I1+2,2),Q2SCA(I,2),L*100,NBRAHD(I,2),
20042 & ICB1,ICB2,IPOS,1)
20044 IPDF = 1000*IGRP(1)+ISET(1)
20045 CALL PHO_REGPAR(21,IFLO1,IPDF,JM1,JM2,PPH(I1,1),
20046 & PPH(I1+1,1),PPH(I1+2,1),PPH(I,1),L*100,NBRAHD(I,1),
20047 & ICA1,ICA2,IPOS1,1)
20048 IPDF = 1000*IGRP(2)+ISET(2)
20049 CALL PHO_REGPAR(21,IFLO2,IPDF,JM2,JM1,PPH(I1,2),
20050 & PPH(I1+1,2),PPH(I1+2,2),PPH(I,2),L*100,NBRAHD(I,2),
20051 & ICB1,ICB2,IPOS2,1)
20053 C spectator partons belonging to hard interaction
20054 IF(IVAL1.EQ.I) THEN
20057 ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL1.EQ.0)) THEN
20064 CALL PHO_HARREM(JM1,JM2,IGEN,L,IVQ,IND,ICA1,ICA2,IUSED,IREJ)
20065 IF(IVQ.LT.0) IND1 = IND1-IUSED
20066 IF(IVAL2.EQ.I) THEN
20069 ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL2.EQ.0)) THEN
20076 CALL PHO_HARREM(JM2,JM1,IGEN,-L,IVQ,IND,ICB1,ICB2,IUSED,IREJ)
20077 IF(IVQ.LT.0) IND2 = IND2-IUSED
20079 C register hard scattered partons
20080 IF((ISWMDL(8).GE.2)
20081 & .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
20086 IFLA(1) = NINHD(I,1)
20087 IFLA(2) = NINHD(I,2)
20088 C initial state radiation
20090 DO 235 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
20093 IFLB = IFLISR(K,IPA)
20094 IF(ABS(IFLB).LE.6) THEN
20096 IF(ICI(K,1)*ICI(K,2).NE.0) THEN
20098 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20099 & ICI(K,1),ICI(K,2),3)
20100 ELSE IF(IFLB.GT.0) THEN
20101 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20102 & ICI(K,1),ICI(K,2),4)
20104 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
20105 & ICI(K,2),IC1,IC2,4)
20108 IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
20109 IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
20110 CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
20116 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
20117 & ICI(K,2),IC1,IC2,2)
20119 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20120 & ICI(K,1),ICI(K,2),2)
20123 IIFL = IPHO_CNV1(IFLB)
20124 IFLA(K) = IFLA(K)-IFLB
20133 CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
20134 & PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),
20135 & L*100+K,IGEN,IC1,IC2,IPOS,1)
20138 ICOLOR(1,IPOS1-2) = ICI(1,1)
20139 ICOLOR(2,IPOS1-2) = ICI(1,2)
20140 ICOLOR(1,IPOS1-1) = ICI(2,1)
20141 ICOLOR(2,IPOS1-1) = ICI(2,2)
20142 CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
20143 & IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
20144 & NOUTHD(I,2),ICI(2,1),ICI(2,2))
20145 ICOLOR(1,IPOS1) = ICI(1,1)
20146 ICOLOR(2,IPOS1) = ICI(1,2)
20147 ICOLOR(1,IPOS2) = ICI(2,1)
20148 ICOLOR(2,IPOS2) = ICI(2,2)
20150 IPA = IPOISR(K,1,I)
20151 CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
20152 & PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
20153 & PHISR(K,4,IPA),-L*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
20156 ICOLOR(1,IPOS1-2) = ICA1
20157 ICOLOR(2,IPOS1-2) = ICA2
20158 ICOLOR(1,IPOS1-1) = ICB1
20159 ICOLOR(2,IPOS1-1) = ICB2
20160 CALL PHO_HARCOL(NPROHD(I),VHD(I),NINHD(I,1),ICA1,ICA2,
20161 & NINHD(I,2),ICB1,ICB2,NOUTHD(I,1),ICA1,ICA2,
20162 & NOUTHD(I,2),ICB1,ICB2)
20163 ICOLOR(1,IPOS1) = ICA1
20164 ICOLOR(2,IPOS1) = ICA2
20165 ICOLOR(1,IPOS2) = ICB1
20166 ICOLOR(2,IPOS2) = ICB2
20168 CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,1)),0,JM1,JM2,
20169 & PPH(I1,1),PPH(I1+1,1),PPH(I1+2,1),PPH(I1+3,1),-L*100,IGEN,
20170 & ICA1,ICA2,IPOS,1)
20171 CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,2)),0,JM1,JM2,
20172 & PPH(I1,2),PPH(I1+1,2),PPH(I1+2,2),PPH(I1+3,2),-L*100,IGEN,
20173 & ICB1,ICB2,IPOS,1)
20176 C end of resolved parton registration
20179 IF(MHDIR+MHPOM.GT.0) THEN
20181 IF(ISWMDL(29).GE.1) THEN
20182 C primordial kt of hard scattering
20183 CALL PHO_PRIMKT(1,NLOR1,NHEP,PTCUT(II),IREJ)
20185 IFAIL(27) = IFAIL(27)+1
20188 ELSE IF(ISWMDL(24).GE.0) THEN
20189 C give "soft" pt only to soft (spectator) partons in hard processes
20190 CALL PHO_PARTPT(1,NLOR1,NHEP,PTCUT(II),IREJ)
20192 IFAIL(26) = IFAIL(26)+1
20199 C give "soft" pt to partons in soft Pomerons
20200 IF((MHDIR.EQ.0).AND.(ISWMDL(18).EQ.1)) THEN
20201 CALL PHO_PARTPT(0,NLOR1,NHEP,PTCUT(II),IREJ)
20203 IFAIL(25) = IFAIL(25) + 1
20208 C boost back to lab frame
20209 CALL PHO_LTRHEP(NLOR1,NHEP,CODP,SIDP,COFP,SIFP,GAMBEP(4),
20210 & GAMBEP(1),GAMBEP(2),GAMBEP(3))
20213 C rejection treatment
20215 IFAIL(2) = IFAIL(2)+1
20221 C reset mother-daugther relations
20232 IF(IDEB(23).GT.2) WRITE(LO,'(/1X,A,4I6)')
20233 & 'PHO_STDPAR: rejection (MSPOM,MHPOM,MSREG,MHDIR)',
20234 & MSPOM,MHPOM,MSREG,MHDIR
20239 *$ CREATE PHO_HARCOL.FOR
20241 CDECK ID>, PHO_HARCOL
20242 SUBROUTINE PHO_HARCOL(MSPR,V,IP1,ICA1,ICA2,IP2,ICB1,ICB2,
20243 & IP3,ICC1,ICC2,IP4,ICD1,ICD2)
20244 C*********************************************************************
20246 C calculate color flow for hard resolved process
20248 C input: IP1..4 flavour of partons (PDG convention)
20249 C V parton subprocess Mandelstam variable V = t/s
20250 C (lightcone momenta assumed)
20251 C ICA,ICB color labels
20252 C MSPR process number
20253 C -1 initialization of statistics
20254 C -2 output of statistics
20256 C output: ICC,ICD color label of final partons
20258 C (it is possible to use the same variables for in and output)
20260 C**********************************************************************
20261 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20264 C input/output channels
20266 COMMON /POINOU/ LI,LO
20267 C event debugging information
20269 PARAMETER (NMAXD=100)
20270 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
20271 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20272 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
20273 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20274 C model switches and parameters
20276 INTEGER ISWMDL,IPAMDL
20277 DOUBLE PRECISION PARMDL
20278 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
20279 C names of hard scattering processes
20281 PARAMETER ( Max_pro_1 = 16 )
20283 COMMON /POHPRO/ PROC(0:Max_pro_1)
20285 DIMENSION PC(3),ICONF(8,5),IRECN(8,2)
20288 IF(MSPR.EQ.-1) THEN
20297 C output of statistics
20298 ELSE IF(MSPR.EQ.-2) THEN
20299 IF(IDEB(26).LT.1) RETURN
20300 WRITE(LO,'(/1X,A,/1X,A)')
20301 & 'PHO_HARCOL: sampled color configurations',
20302 & '----------------------------------------'
20303 WRITE(LO,'(6X,A,15X,A)')
20304 & 'diagram color configurations (1-4)','sum'
20307 ICONF(I,5) = ICONF(I,5) + ICONF(I,K)
20309 WRITE(LO,'(2X,A,4I11,I12)') PROC(I),(ICONF(I,K),K=1,5)
20311 IF(ISWMDL(11).GE.2) THEN
20312 WRITE(LO,'(/6X,A)')
20313 & 'diagram with / without color re-connection'
20315 WRITE(LO,'(2X,A,2I11)') PROC(I),IRECN(I,1),IRECN(I,2)
20321 C gluons: first color positive, quarks second color zero
20344 & WRITE(LO,'(1X,A,I4,/,5X,A,3I5,2X,3I5)')
20345 & 'PHO_HARCOL: process',MSPR,
20346 & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
20349 IF(IPAMDL(21).EQ.1) THEN
20351 C soft color re-connection option
20354 C hard g g final state, only g g --> g g
20355 IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
20356 IF(DT_RNDM(V).LT.PARMDL(140)) THEN
20361 IRECN(MSPR,1) = IRECN(MSPR,1)+1
20366 ELSE IF(MSPR.EQ.3) THEN
20367 C hard q g final state
20368 IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
20369 IF(DT_RNDM(V).LT.PARMDL(141)) THEN
20374 IRECN(MSPR,1) = IRECN(MSPR,1)+1
20379 ELSE IF((MSPR.EQ.5).OR.(MSPR.EQ.7).OR.(MSPR.EQ.8)) THEN
20380 C hard q q final state
20381 IF(ICA1.NE.-ICB1) THEN
20382 IF(DT_RNDM(V).LT.PARMDL(142)) THEN
20387 IRECN(MSPR,1) = IRECN(MSPR,1)+1
20393 IRECN(MSPR,2) = IRECN(MSPR,2)+1
20396 IF((ISWMDL(11).EQ.1).AND.(MSPR.LT.10)) THEN
20398 C large Nc limit of all graphs
20402 IF(DT_RNDM(V).GT.0.5D0) THEN
20407 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20413 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20415 ELSE IF(MSPR.EQ.2) THEN
20417 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20423 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20429 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20431 ELSE IF(MSPR.EQ.3) THEN
20433 IF(DT_RNDM(V).LT.0.5D0) THEN
20434 IF(IP1+IP2.GT.0) THEN
20439 ELSE IF(IP1.LT.0) THEN
20448 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20451 CALL PHO_HARCOR(-ICA1,ICB2)
20455 ELSE IF(IP2.GT.0) THEN
20456 CALL PHO_HARCOR(-ICB1,ICA2)
20460 ELSE IF(IP1.LT.0) THEN
20461 CALL PHO_HARCOR(-ICA1,ICB1)
20465 ELSE IF(IP2.LT.0) THEN
20466 CALL PHO_HARCOR(-ICB1,ICA1)
20471 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20473 ELSE IF(MSPR.EQ.4) THEN
20477 CALL PHO_HARCOR(-ICB1,ICA2)
20478 IF(ICB2.EQ.-ICB1) IC3 = ICA2
20479 IF(IP3*IC1.LT.0) THEN
20484 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20485 ELSE IF(MSPR.EQ.5) THEN
20487 IF(DT_RNDM(V).LT.0.5D0) THEN
20488 IF(ICA1*IP3.LT.0) THEN
20495 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20497 IF(ICA1*IP3.LT.0) THEN
20504 CALL PHO_HARCOR(-ICA1,ICB1)
20505 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20507 ELSE IF(MSPR.EQ.6) THEN
20509 IF(ICA1*IP3.LT.0) THEN
20512 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20516 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20518 ELSE IF(MSPR.EQ.7) THEN
20520 IF(DT_RNDM(V).LT.0.5D0) THEN
20523 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20527 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20529 ELSE IF(MSPR.EQ.8) THEN
20531 IF(IP1*IP2.GT.0) THEN
20532 IF(IP3.EQ.IP1) THEN
20539 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20541 IF(ICA1*IP3.LT.0) THEN
20548 CALL PHO_HARCOR(-ICA1,ICB1)
20549 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20553 WRITE(LO,'(/1X,A,I3)')
20554 & 'PHO_HARCOL:ERROR:invalid process number (MSPR)',MSPR
20560 C color flow according to QCD leading order matrix element
20565 PC(1) = 1/V**2 +2.D0/V +3.D0 +2.D0*V +V**2
20566 PC(2) = 1/U**2 +2.D0/U +3.D0 +2.D0*U +U**2
20567 PC(3) = (V/U)**2+2.D0*(V/U)+3.D0 +2.D0*(U/V)+(U/V)**2
20568 XI = (PC(1)+PC(2)+PC(3))*DT_RNDM(U)
20572 IF(XI.LT.PCS) GOTO 120
20576 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20577 IF(DT_RNDM(V).GT.0.5D0) THEN
20582 CALL PHO_HARCOR(-ICB2,ICA1)
20583 IF(ICB1.EQ.-ICB2) IC3 = ICA1
20589 CALL PHO_HARCOR(-ICB1,ICA2)
20590 IF(ICB2.EQ.-ICB1) IC4 = ICA2
20592 ELSE IF(I.EQ.2) THEN
20593 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20594 IF(DT_RNDM(U).GT.0.5D0) THEN
20599 CALL PHO_HARCOR(-ICB2,ICA1)
20600 IF(ICB1.EQ.-ICB2) IC1 = ICA1
20606 CALL PHO_HARCOR(-ICB1,ICA2)
20607 IF(ICB2.EQ.-ICB1) IC2 = ICA2
20610 IF(DT_RNDM(V).GT.0.5D0) THEN
20622 ICONF(MSPR,I) = ICONF(MSPR,I)+1
20623 ELSE IF(MSPR.EQ.2) THEN
20625 PC(1) = U/V-2.D0*U**2
20626 PC(2) = V/U-2.D0*V**2
20627 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20628 XI = (PC(1)+PC(2))*DT_RNDM(U)
20629 IF(XI.LT.PC(1)) THEN
20635 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20641 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20649 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20655 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20658 ELSE IF(MSPR.EQ.3) THEN
20660 PC(1) = 2.D0*(U/V)**2-U
20661 PC(2) = 2.D0/V**2-1.D0/U
20662 XI = (PC(1)+PC(2))*DT_RNDM(V)
20663 IF(XI.LT.PC(1)) THEN
20664 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20669 CALL PHO_HARCOR(-ICA1,ICB2)
20670 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20671 ELSE IF(IP1.LT.0) THEN
20675 CALL PHO_HARCOR(-ICA1,ICB1)
20676 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20677 ELSE IF(IP2.GT.0) THEN
20681 CALL PHO_HARCOR(-ICB1,ICA2)
20682 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20687 CALL PHO_HARCOR(-ICB1,ICA1)
20688 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20695 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20696 ELSE IF(IP1.LT.0) THEN
20700 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20701 ELSE IF(IP2.GT.0) THEN
20705 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20710 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20713 ELSE IF(MSPR.EQ.4) THEN
20715 PC(1) = U/V-2.D0*U**2
20716 PC(2) = V/U-2.D0*V**2
20717 XI = (PC(1)+PC(2))*DT_RNDM(U)
20718 IF(XI.LT.PC(1)) THEN
20722 CALL PHO_HARCOR(-ICB1,ICA2)
20723 IF(ICB2.EQ.-ICB1) IC3 = ICA2
20724 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20728 CALL PHO_HARCOR(-ICB2,ICA1)
20729 IF(ICB1.EQ.-ICB2) IC3 = ICA1
20730 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20736 CALL PHO_HARCOR(-ICB2,ICA1)
20737 IF(ICB1.EQ.-ICB2) IC1 = ICA1
20738 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20742 CALL PHO_HARCOR(-ICB1,ICA2)
20743 IF(ICB2.EQ.-ICB1) IC1 = ICA2
20744 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20747 ELSE IF(MSPR.EQ.5) THEN
20749 PC(1) = (1.D0+U**2)/V**2
20750 PC(2) = (V**2+U**2)
20751 XI = (PC(1)+PC(2))*DT_RNDM(V)
20752 IF(XI.LT.PC(1)) THEN
20753 CALL PHO_HARCOR(-ICB1,ICA1)
20754 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20758 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20762 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20766 IC1 = MAX(ICA1,ICB1)
20767 IC3 = MIN(ICA1,ICB1)
20768 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20770 IC1 = MIN(ICA1,ICB1)
20771 IC3 = MAX(ICA1,ICB1)
20772 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20775 ELSE IF(MSPR.EQ.6) THEN
20778 IC1 = MAX(ICA1,ICB1)
20779 IC3 = MIN(ICA1,ICB1)
20780 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20782 IC1 = MIN(ICA1,ICB1)
20783 IC3 = MAX(ICA1,ICB1)
20784 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20786 ELSE IF(MSPR.EQ.7) THEN
20788 PC(1) = (1.D0+U**2)/V**2
20789 PC(2) = (1.D0+V**2)/U**2
20790 XI = (PC(1)+PC(2))*DT_RNDM(U)
20791 IF(XI.LT.PC(1)) THEN
20794 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20798 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20800 ELSE IF(MSPR.EQ.8) THEN
20802 IF(IP1*IP2.LT.0) THEN
20803 CALL PHO_HARCOR(-ICB1,ICA1)
20804 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20808 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20812 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20817 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20820 ELSE IF(MSPR.EQ.10) THEN
20822 CALL PHO_SELCOL(ICB1,ICB2,IC1,IC2,IC3,IC4,2)
20824 CALL PHO_SWAPI(IC1,IC3)
20825 CALL PHO_SWAPI(IC2,IC4)
20827 ELSE IF(MSPR.EQ.11) THEN
20831 IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
20832 ELSE IF(MSPR.EQ.12) THEN
20834 CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,2)
20836 CALL PHO_SWAPI(IC1,IC3)
20837 CALL PHO_SWAPI(IC2,IC4)
20839 ELSE IF(MSPR.EQ.13) THEN
20843 IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
20844 ELSE IF(MSPR.EQ.14) THEN
20845 IF(ABS(IP3).GT.12) THEN
20849 CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,1)
20850 IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
20854 WRITE(LO,'(/1X,A,I3)')
20855 & 'PHO_HARCOL:ERROR:invalid process number',MSPR
20862 IF(IDEB(26).GE.10) WRITE(LO,'(5X,A,3I5,2X,3I5)')
20863 & 'final partons and colors',IP3,IC1,IC2,IP4,IC3,IC4
20864 C color connection?
20865 * IF(((IC1.NE.-IC3).AND.(IC1.NE.-IC4)).AND.
20866 * & (((IC2.NE.0).AND.(IC2.NE.-IC3).AND.(IC2.NE.-IC4))
20867 * & .OR.(IC2.EQ.0))) THEN
20869 * IF(((IP1.EQ.IP3).AND.(ICA1.EQ.IC1).AND.(ICA2.EQ.IC2))
20870 * & .OR.((IP1.EQ.IP4).AND.(ICA1.EQ.IC3).AND.(ICA2.EQ.IC4))) THEN
20871 * IF(IRC.NE.1) THEN
20872 * WRITE(LO,'(1X,A,I10,I3)')
20873 * & 'PHO_HARCOL:unexp. re-connection (event/MSPR):',KEVENT,MSPR
20874 * WRITE(LO,'(5X,A,3I5,2X,3I5)')
20875 * & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
20876 * WRITE(LO,'(5X,A,3I5,2X,3I5)')
20877 * & 'final partons and colors ',IP3,IC1,IC2,IP4,IC3,IC4
20882 * IF(IRC.EQ.1) THEN
20883 * WRITE(LO,'(1X,A,I10,I3)')
20884 * & 'PHO_HARCOL:re-conn. failed (event/MSPR):',KEVENT,MSPR
20885 * WRITE(LO,'(5X,A,3I5,2X,3I5)')
20886 * & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
20887 * WRITE(LO,'(5X,A,3I5,2X,3I5)')
20888 * & 'final partons and colors ',IP3,IC1,IC2,IP4,IC3,IC4
20898 *$ CREATE PHO_HARCOR.FOR
20900 CDECK ID>, PHO_HARCOR
20901 SUBROUTINE PHO_HARCOR(ICOLD,ICNEW)
20902 C***********************************************************************
20904 C substituite color in /POEVT2/
20906 C input: ICOLD old color
20909 C***********************************************************************
20910 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20913 C input/output channels
20915 COMMON /POINOU/ LI,LO
20916 C standard particle data interface
20918 PARAMETER (NMXHEP=4000)
20919 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
20920 DOUBLE PRECISION PHEP,VHEP
20921 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
20922 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
20924 C extension to standard particle data interface (PHOJET specific)
20925 INTEGER IMPART,IPHIST,ICOLOR
20926 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
20929 IF(ISTHEP(I).EQ.-1) THEN
20930 IF(ICOLOR(1,I).EQ.ICOLD) THEN
20931 ICOLOR(1,I) = ICNEW
20933 ELSE IF(IDHEP(I).EQ.21) THEN
20934 IF(ICOLOR(2,I).EQ.ICOLD) THEN
20935 ICOLOR(2,I) = ICNEW
20939 * ELSE IF(ISTHEP(I).EQ.20) THEN
20940 * IF(ICOLOR(1,I).EQ.-ICOLD) THEN
20941 * WRITE(LO,*) ' PHO_HARCOR(3): line, old, new:',I,ICOLD,ICNEW
20942 * ICOLOR(1,I) = -ICNEW
20944 * ELSE IF(IDHEP(I).EQ.21) THEN
20945 * IF(ICOLOR(2,I).EQ.-ICOLD) THEN
20946 * WRITE(LO,*) ' PHO_HARCOR(4): line, old, new:',I,ICOLD,ICNEW
20947 * ICOLOR(2,I) = -ICNEW
20955 *$ CREATE PHO_HARREM.FOR
20957 CDECK ID>, PHO_HARREM
20958 SUBROUTINE PHO_HARREM(JM1,JM2,IGEN,IHPOS,IVAL,INDXS,IC1,IC2,
20960 C***********************************************************************
20962 C sample color structure for initial quark/gluon of hard scattering
20963 C and write hadron remnant to /POEVT1/
20965 C input: JM1,2 index of mother particle in POEVT1
20966 C IGEN mother particle production process
20967 C IHPOS hard pomeron number
20968 C INDXH index of hard parton
20969 C positive for labels 1
20970 C negative for labels 2
20971 C IVAL 1 hard valence parton
20972 C 0 hard sea parton connected by color flow with
20974 C -1 hard sea parton independent off valence
20976 C INDXS index of soft partons needed
20978 C output: IC1,IC2 color label of initial parton
20979 C IUSED number of soft X values used
20980 C IREJ rejection flag
20982 C**********************************************************************
20983 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20986 PARAMETER ( TINY = 1.D-10 )
20988 C input/output channels
20990 COMMON /POINOU/ LI,LO
20991 C event debugging information
20993 PARAMETER (NMAXD=100)
20994 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
20995 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20996 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
20997 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20998 C model switches and parameters
21000 INTEGER ISWMDL,IPAMDL
21001 DOUBLE PRECISION PARMDL
21002 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21003 C data of c.m. system of Pomeron / Reggeon exchange
21004 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
21005 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
21006 & SIDP,CODP,SIFP,COFP
21007 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
21008 & SIDP,CODP,SIFP,COFP,NPOSP(2),
21009 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
21010 C obsolete cut-off information
21011 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
21012 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
21013 C light-cone x fractions and c.m. momenta of soft cut string ends
21015 PARAMETER ( MAXSOF = 50 )
21016 INTEGER IJSI2,IJSI1
21017 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
21018 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
21019 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
21020 & IJSI1(MAXSOF),IJSI2(MAXSOF)
21021 C hard scattering data
21023 PARAMETER ( MSCAHD = 50 )
21024 INTEGER LSCAHD,LSC1HD,LSIDX,
21025 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
21026 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
21027 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
21028 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
21029 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
21030 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
21031 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
21032 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
21033 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
21034 C standard particle data interface
21036 PARAMETER (NMXHEP=4000)
21037 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
21038 DOUBLE PRECISION PHEP,VHEP
21039 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
21040 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
21042 C extension to standard particle data interface (PHOJET specific)
21043 INTEGER IMPART,IPHIST,ICOLOR
21044 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
21045 C internal rejection counters
21047 PARAMETER (NMXJ=60)
21048 CHARACTER*10 REJTIT
21050 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
21054 INDXH = SIGN(LSIDX(ABS(IHPOS)),IHPOS)
21056 IF(INDXH.GT.0) THEN
21057 IJH = IPHO_CNV1(NINHD(INDXH,1))
21059 IJH = IPHO_CNV1(NINHD(-INDXH,2))
21061 C direct process (photon or pomeron)
21065 IF((IJH.EQ.22).OR.(IJH.EQ.990)) RETURN
21067 IHP = 100*ABS(IHPOS)
21069 ***************************************
21070 * IF((IDHEP(JM1).EQ.22).OR.(IDHEP(JM1).EQ.990)) IVSW = 0
21071 ***************************************
21073 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,2I3,1X,5I4)')
21074 & 'PHO_HARREM: JM1,JM2,IHPOS,INDXH,IFLH,IVAL,INDXS:',
21075 & JM1,JM2,IHPOS,INDXH,IJH,IVAL,INDXS
21078 C****************************************************************
21082 C valence quark engaged in hard scattering
21084 CALL PHO_PARREM(JM1,IJH,IREM,IREJ)
21086 WRITE(LO,'(/1X,2A,2I6)') 'PHO_HARREM: ',
21087 & 'invalid valence flavour requested JM,IFLA',JM1,IJH
21090 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21091 IF(((ABS(IREM).GT.6).AND.(IREM.GT.0))
21092 & .OR.((ABS(IREM).LE.6).AND.(IREM.LT.0))) THEN
21097 C remnant of hadron
21098 IF(INDXH.GT.0) THEN
21099 P1 = PSOFT1(1,INDXS)
21100 P2 = PSOFT1(2,INDXS)
21101 P3 = PSOFT1(3,INDXS)
21102 P4 = PSOFT1(4,INDXS)
21103 IJSI1(INDXS) = IREM
21105 P1 = PSOFT2(1,INDXS)
21106 P2 = PSOFT2(2,INDXS)
21107 P3 = PSOFT2(3,INDXS)
21108 P4 = PSOFT2(4,INDXS)
21109 IJSI2(INDXS) = IREM
21112 CALL PHO_REGPAR(-1,IREM,0,JM1,JM2,P1,P2,P3,P4,
21113 & IHP,IGEN,ICA1,IVSW,IPOS,1)
21114 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21115 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21116 & IREM,IPOS,SIGN(INDXS,INDXH)
21119 C sea quark engaged in hard scattering, valence quarks treated
21120 ELSE IF(IVAL.EQ.0) THEN
21121 IF(INDXH.GT.0) THEN
21122 E1 = PSOFT1(4,INDXS)
21123 E2 = PSOFT1(4,INDXS+1)
21125 E1 = PSOFT2(4,INDXS)
21126 E2 = PSOFT2(4,INDXS+1)
21128 CALL PHO_VALFLA(JM1,IVFL1,IVFL2,E1,E2)
21129 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21130 IF(DT_RNDM(P1).LT.0.5D0) THEN
21131 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21133 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21135 IF(((ABS(IVFL1).GT.6).AND.(IVFL1.GT.0))
21136 & .OR.((ABS(IVFL1).LE.6).AND.(IVFL1.LT.0))) THEN
21141 IF(INDXH.GT.0) THEN
21142 P1 = PSOFT1(1,INDXS)
21143 P2 = PSOFT1(2,INDXS)
21144 P3 = PSOFT1(3,INDXS)
21145 P4 = PSOFT1(4,INDXS)
21146 IJSI1(INDXS) = IVFL1
21148 P1 = PSOFT2(1,INDXS)
21149 P2 = PSOFT2(2,INDXS)
21150 P3 = PSOFT2(3,INDXS)
21151 P4 = PSOFT2(4,INDXS)
21152 IJSI2(INDXS) = IVFL1
21155 CALL PHO_REGPAR(-1,IVFL1,0,JM1,JM2,P1,P2,P3,P4,
21156 & IHP,IGEN,ICA1,IVSW,IPOS,1)
21157 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21158 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21159 & IVFL1,IPOS,SIGN(INDXS,INDXH)
21161 IF(INDXH.GT.0) THEN
21162 P1 = PSOFT1(1,INDXS+1)
21163 P2 = PSOFT1(2,INDXS+1)
21164 P3 = PSOFT1(3,INDXS+1)
21165 P4 = PSOFT1(4,INDXS+1)
21166 IJSI1(INDXS+1) = IVFL2
21168 P1 = PSOFT2(1,INDXS+1)
21169 P2 = PSOFT2(2,INDXS+1)
21170 P3 = PSOFT2(3,INDXS+1)
21171 P4 = PSOFT2(4,INDXS+1)
21172 IJSI2(INDXS+1) = IVFL2
21175 CALL PHO_REGPAR(-1,IVFL2,0,JM1,JM2,P1,P2,P3,P4,
21176 & IHP,IGEN,ICB1,IVSW,IPOS,1)
21177 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21178 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21179 & IVFL2,IPOS,SIGN(INDXS+1,INDXH)
21188 IF(INDXH.GT.0) THEN
21189 P1 = PSOFT1(1,INDXS+2)
21190 P2 = PSOFT1(2,INDXS+2)
21191 P3 = PSOFT1(3,INDXS+2)
21192 P4 = PSOFT1(4,INDXS+2)
21193 IJSI1(INDXS+2) = -IJH
21195 P1 = PSOFT2(1,INDXS+2)
21196 P2 = PSOFT2(2,INDXS+2)
21197 P3 = PSOFT2(3,INDXS+2)
21198 P4 = PSOFT2(4,INDXS+2)
21199 IJSI2(INDXS+2) = -IJH
21202 CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
21203 & IHP,IGEN,ICA1,0,IPOS,1)
21204 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21205 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21206 & -IJH,IPOS,SIGN(INDXS+2,INDXH)
21209 C sea quark engaged in hard scattering, valences treated separately
21210 ELSE IF(IVAL.EQ.-1) THEN
21211 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21217 IF(INDXH.GT.0) THEN
21218 P1 = PSOFT1(1,INDXS)
21219 P2 = PSOFT1(2,INDXS)
21220 P3 = PSOFT1(3,INDXS)
21221 P4 = PSOFT1(4,INDXS)
21222 IJSI1(INDXS) = -IJH
21224 P1 = PSOFT2(1,INDXS)
21225 P2 = PSOFT2(2,INDXS)
21226 P3 = PSOFT2(3,INDXS)
21227 P4 = PSOFT2(4,INDXS)
21228 IJSI2(INDXS) = -IJH
21231 CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
21232 & IHP,IGEN,ICA1,0,IPOS,1)
21233 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21234 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21235 & -IJH,IPOS,SIGN(INDXS,INDXH)
21238 WRITE(LO,'(1X,A,2I5)')
21239 & 'PHO_HARREM:ERROR:unsupported combination of IVAL,IJH',
21248 C****************************************************************
21250 C gluon from valence quarks
21253 C purely gluonic pomeron remnant
21254 IF((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0)) THEN
21255 IF(INDXH.GT.0) THEN
21256 P1 = PSOFT1(1,INDXS) + PSOFT1(1,INDXS+1)
21257 P2 = PSOFT1(2,INDXS) + PSOFT1(2,INDXS+1)
21258 P3 = PSOFT1(3,INDXS) + PSOFT1(3,INDXS+1)
21259 P4 = PSOFT1(4,INDXS) + PSOFT1(4,INDXS+1)
21262 P1 = PSOFT2(1,INDXS) + PSOFT2(1,INDXS+1)
21263 P2 = PSOFT2(2,INDXS) + PSOFT2(2,INDXS+1)
21264 P3 = PSOFT2(3,INDXS) + PSOFT2(3,INDXS+1)
21265 P4 = PSOFT2(4,INDXS) + PSOFT2(4,INDXS+1)
21269 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21270 IF(DT_RNDM(P2).LT.0.5D0) THEN
21271 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21273 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21276 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21277 & IHP,IGEN,ICA1,ICB1,IPOS,1)
21278 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21279 & 'PHO_HARREM: val.gluon:(IFL,IPOS,INDXS)',
21280 & IFL1,IPOS,SIGN(INDXS,INDXH)
21282 C valence quark remnant
21284 IF(INDXH.GT.0) THEN
21285 E1 = PSOFT1(4,INDXS)
21286 E2 = PSOFT1(4,INDXS+1)
21288 E1 = PSOFT2(4,INDXS)
21289 E2 = PSOFT2(4,INDXS+1)
21291 CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
21292 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21293 IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21294 & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21299 IF(DT_RNDM(P2).LT.0.5D0) THEN
21300 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21302 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21304 C remnant of hadron
21305 IF(INDXH.GT.0) THEN
21306 P1 = PSOFT1(1,INDXS)
21307 P2 = PSOFT1(2,INDXS)
21308 P3 = PSOFT1(3,INDXS)
21309 P4 = PSOFT1(4,INDXS)
21310 IJSI1(INDXS) = IFL1
21312 P1 = PSOFT2(1,INDXS)
21313 P2 = PSOFT2(2,INDXS)
21314 P3 = PSOFT2(3,INDXS)
21315 P4 = PSOFT2(4,INDXS)
21316 IJSI2(INDXS) = IFL1
21319 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21320 & IHP,IGEN,ICA1,IVSW,IPOS,1)
21321 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21322 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21323 & IFL1,IPOS,SIGN(INDXS,INDXH)
21325 IF(INDXH.GT.0) THEN
21326 P1 = PSOFT1(1,INDXS+1)
21327 P2 = PSOFT1(2,INDXS+1)
21328 P3 = PSOFT1(3,INDXS+1)
21329 P4 = PSOFT1(4,INDXS+1)
21330 IJSI1(INDXS+1) = IFL2
21332 P1 = PSOFT2(1,INDXS+1)
21333 P2 = PSOFT2(2,INDXS+1)
21334 P3 = PSOFT2(3,INDXS+1)
21335 P4 = PSOFT2(4,INDXS+1)
21336 IJSI2(INDXS+1) = IFL2
21339 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21340 & IHP,IGEN,ICB1,IVSW,IPOS,1)
21341 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21342 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21343 & IFL2,IPOS,SIGN(INDXS+1,INDXH)
21347 C gluon from sea quarks connected with valence quarks
21348 ELSE IF(IVAL.EQ.0) THEN
21349 IF(INDXH.GT.0) THEN
21350 E1 = PSOFT1(4,INDXS)
21351 E2 = PSOFT1(4,INDXS+1)
21353 E1 = PSOFT2(4,INDXS)
21354 E2 = PSOFT2(4,INDXS+1)
21356 CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
21357 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21358 IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21359 & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21364 IF(DT_RNDM(P3).LT.0.5D0) THEN
21365 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21367 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21369 C remnant of hadron
21370 IF(INDXH.GT.0) THEN
21371 P1 = PSOFT1(1,INDXS)
21372 P2 = PSOFT1(2,INDXS)
21373 P3 = PSOFT1(3,INDXS)
21374 P4 = PSOFT1(4,INDXS)
21375 IJSI1(INDXS) = IFL1
21377 P1 = PSOFT2(1,INDXS)
21378 P2 = PSOFT2(2,INDXS)
21379 P3 = PSOFT2(3,INDXS)
21380 P4 = PSOFT2(4,INDXS)
21381 IJSI2(INDXS) = IFL1
21384 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21385 & IHP,IGEN,ICA1,IVSW,IPOS,1)
21386 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21387 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21388 & IFL1,IPOS,SIGN(INDXS,INDXH)
21390 IF(INDXH.GT.0) THEN
21391 P1 = PSOFT1(1,INDXS+1)
21392 P2 = PSOFT1(2,INDXS+1)
21393 P3 = PSOFT1(3,INDXS+1)
21394 P4 = PSOFT1(4,INDXS+1)
21395 IJSI1(INDXS+1) = IFL2
21397 P1 = PSOFT2(1,INDXS+1)
21398 P2 = PSOFT2(2,INDXS+1)
21399 P3 = PSOFT2(3,INDXS+1)
21400 P4 = PSOFT2(4,INDXS+1)
21401 IJSI2(INDXS+1) = IFL2
21404 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21405 & IHP,IGEN,ICB1,IVSW,IPOS,1)
21406 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21407 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21408 & IFL2,IPOS,SIGN(INDXS+1,INDXH)
21409 IF(IPAMDL(18).EQ.0) THEN
21411 CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
21419 IF(DT_RNDM(P4).LT.0.5D0) THEN
21421 CALL PHO_SELCOL(ICC1,0,ICA1,ICA2,ICC1,ICC2,2)
21424 CALL PHO_SELCOL(ICC2,0,ICB1,ICB2,ICC1,ICC2,2)
21426 IF(INDXH.GT.0) THEN
21427 P1 = PSOFT1(1,INDXS+2)
21428 P2 = PSOFT1(2,INDXS+2)
21429 P3 = PSOFT1(3,INDXS+2)
21430 P4 = PSOFT1(4,INDXS+2)
21431 IJSI1(INDXS+2) = IFL1
21433 P1 = PSOFT2(1,INDXS+2)
21434 P2 = PSOFT2(2,INDXS+2)
21435 P3 = PSOFT2(3,INDXS+2)
21436 P4 = PSOFT2(4,INDXS+2)
21437 IJSI2(INDXS+2) = IFL1
21440 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21441 & IHP,IGEN,ICA1,0,IPOS,1)
21442 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21443 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21444 & IFL1,IPOS,SIGN(INDXS+2,INDXH)
21446 IF(INDXH.GT.0) THEN
21447 P1 = PSOFT1(1,INDXS+3)
21448 P2 = PSOFT1(2,INDXS+3)
21449 P3 = PSOFT1(3,INDXS+3)
21450 P4 = PSOFT1(4,INDXS+3)
21451 IJSI1(INDXS+3) = IFL2
21453 P1 = PSOFT2(1,INDXS+3)
21454 P2 = PSOFT2(2,INDXS+3)
21455 P3 = PSOFT2(3,INDXS+3)
21456 P4 = PSOFT2(4,INDXS+3)
21457 IJSI2(INDXS+3) = IFL2
21460 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21461 & IHP,IGEN,ICB1,0,IPOS,1)
21462 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21463 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21464 & IFL2,IPOS,SIGN(INDXS+3,INDXH)
21470 C gluon from independent sea quarks
21471 ELSE IF(IVAL.EQ.-1) THEN
21472 IF(IPAMDL(18).EQ.0) THEN
21473 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21474 CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
21475 IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21476 & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21481 IF(DT_RNDM(P1).LT.0.5D0) THEN
21482 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21484 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21486 C remainder of hadron
21487 IF(INDXH.GT.0) THEN
21488 P1 = PSOFT1(1,INDXS)
21489 P2 = PSOFT1(2,INDXS)
21490 P3 = PSOFT1(3,INDXS)
21491 P4 = PSOFT1(4,INDXS)
21492 IJSI1(INDXS) = IFL1
21494 P1 = PSOFT2(1,INDXS)
21495 P2 = PSOFT2(2,INDXS)
21496 P3 = PSOFT2(3,INDXS)
21497 P4 = PSOFT2(4,INDXS)
21498 IJSI2(INDXS) = IFL1
21501 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21502 & IHP,IGEN,ICA1,ICA2,IPOS,1)
21503 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21504 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21505 & IFL1,IPOS,SIGN(INDXS,INDXH)
21507 IF(INDXH.GT.0) THEN
21508 P1 = PSOFT1(1,INDXS-1)
21509 P2 = PSOFT1(2,INDXS-1)
21510 P3 = PSOFT1(3,INDXS-1)
21511 P4 = PSOFT1(4,INDXS-1)
21512 IJSI1(INDXS-1) = IFL2
21514 P1 = PSOFT2(1,INDXS-1)
21515 P2 = PSOFT2(2,INDXS-1)
21516 P3 = PSOFT2(3,INDXS-1)
21517 P4 = PSOFT2(4,INDXS-1)
21518 IJSI2(INDXS-1) = IFL2
21521 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21522 & IHP,IGEN,ICB1,ICB2,IPOS,1)
21523 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21524 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21525 & IFL2,IPOS,SIGN(INDXS-1,INDXH)
21528 CALL PHO_SELCOL(0,0,ICC1,ICA2,ICC2,ICB2,1)
21529 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,I5)')
21530 & 'PHO_HARREM: no spectator added:(INDXS)',
21531 & SIGN(INDXS,INDXH)
21536 WRITE(LO,'(1X,A,2I5)')
21537 & 'PHO_HARREM:ERROR: unsupported combination of IVAL,IJH',
21546 *$ CREATE PHO_HARDIR.FOR
21548 CDECK ID>, PHO_HARDIR
21549 SUBROUTINE PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,
21551 C**********************************************************************
21553 C parton orientated formulation of direct scattering processes
21557 C output: II particle combination (1..4)
21558 C IVAL1,2 0 no valence quarks engaged
21559 C 1 valence quarks engaged
21560 C MSPAR1,2 number of realized soft partons
21561 C MHPAR1,2 number of realized hard partons
21565 C**********************************************************************
21566 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21569 C input/output channels
21571 COMMON /POINOU/ LI,LO
21572 C event debugging information
21574 PARAMETER (NMAXD=100)
21575 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
21576 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21577 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
21578 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21579 C model switches and parameters
21581 INTEGER ISWMDL,IPAMDL
21582 DOUBLE PRECISION PARMDL
21583 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21584 C hard scattering parameters used for most recent hard interaction
21586 DOUBLE PRECISION ALQCD2,BQCD
21587 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
21588 C data of c.m. system of Pomeron / Reggeon exchange
21589 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
21590 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
21591 & SIDP,CODP,SIFP,COFP
21592 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
21593 & SIDP,CODP,SIFP,COFP,NPOSP(2),
21594 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
21595 C obsolete cut-off information
21596 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
21597 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
21598 C hard cross sections and MC selection weights
21600 PARAMETER ( Max_pro_2 = 16 )
21601 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
21602 & MH_acc_1,MH_acc_2
21603 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
21604 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
21605 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
21606 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
21607 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
21608 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
21609 C data on most recent hard scattering
21610 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
21611 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
21612 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
21613 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
21614 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
21615 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
21616 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
21617 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
21618 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
21619 C light-cone x fractions and c.m. momenta of soft cut string ends
21621 PARAMETER ( MAXSOF = 50 )
21622 INTEGER IJSI2,IJSI1
21623 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
21624 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
21625 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
21626 & IJSI1(MAXSOF),IJSI2(MAXSOF)
21627 C hard scattering data
21629 PARAMETER ( MSCAHD = 50 )
21630 INTEGER LSCAHD,LSC1HD,LSIDX,
21631 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
21632 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
21633 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
21634 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
21635 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
21636 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
21637 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
21638 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
21639 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
21640 C internal rejection counters
21642 PARAMETER (NMXJ=60)
21643 CHARACTER*10 REJTIT
21645 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
21647 DIMENSION P1(4),P2(4),PD1(-6:6)
21649 PARAMETER ( TINY = 1.D-10 )
21656 C check phase space
21657 IF(ECMP.LT.(2.D0*PTWANT+0.1D0)) THEN
21658 IFAIL(18) = IFAIL(18)+1
21663 AS = (PARMDL(160+II)/ECMP)**2
21664 AH = (2.D0*PTWANT/ECMP)**2
21669 XMAX = MAX(TINY,1.D0-AS)
21673 C main loop to select hard and soft parton kinematics
21674 C -----------------------------------------------------
21680 IFAIL(17) = IFAIL(17)+1
21681 IF(ITRY.GE.NTRY) THEN
21694 CALL PHO_HARSCA(1,II)
21698 IF(IDEB(25).GE.20) THEN
21699 WRITE(LO,'(1X,A,2E12.4,2I5)')
21700 & 'PHO_HARDIR: AS,XMAX,process ID,ITRY',
21701 & AS,XMAX,MSPR,ITRY
21702 WRITE(LO,'(1X,A,4E12.4)') 'HARD X1,2 SUM X1,2',
21706 IF(MSPR.LE.11) THEN
21707 IF((XSS2.GT.XMAX).OR.((1.D0-XSS2).LT.AS)) GOTO 120
21708 ELSE IF(MSPR.LE.13) THEN
21709 IF((XSS1.GT.XMAX).OR.((1.D0-XSS1).LT.AS)) GOTO 120
21726 NBRAHD(1,1)= IDPDG1
21727 NBRAHD(1,2)= IDPDG2
21731 PPH(4+I,1) = PHO1(I)
21732 PPH(4+I,2) = PHO2(I)
21740 IF(MSPR.LE.11) THEN
21741 NINHD(1,1) = IDPDG1
21743 PDFVA(1,2) = PDF2(IB)
21745 ELSE IF(MSPR.LE.13) THEN
21747 PDFVA(1,1) = PDF1(IA)
21748 NINHD(1,2) = IDPDG2
21751 NINHD(1,1) = IDPDG1
21752 NINHD(1,2) = IDPDG2
21755 N0INHD(1,1) = NINHD(1,1)
21756 N0INHD(1,2) = NINHD(1,2)
21757 N0IVAL(1,1) = IVAL1
21758 N0IVAL(1,2) = IVAL2
21762 C reweight according to photon virtuality
21763 IF(MSPR.NE.14) THEN
21764 IF(IPAMDL(115).GE.1) THEN
21766 IF(((MSPR.EQ.10).OR.(MSPR.EQ.11)).AND.(IDPDG2.EQ.22)) THEN
21768 IF(IPAMDL(115).EQ.1) THEN
21769 IF(QQPD.LT.(PVIRTP(2)+PARMDL(144))) THEN
21772 WGX = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
21773 & /LOG(QQPD/PARMDL(144))
21775 IF(NINHD(1,2).EQ.0) WGX = WGX*WGX
21776 ELSE IF(IPAMDL(115).EQ.2) THEN
21777 CALL PHO_PDF(2,X2,QQPD,PVIRTP(2),PD1)
21778 WGX = PD1(IB)/PDFVA(1,2)
21780 ELSE IF(((MSPR.EQ.12).OR.(MSPR.EQ.13))
21781 & .AND.(IDPDG1.EQ.22)) THEN
21783 IF(IPAMDL(115).EQ.1) THEN
21784 IF(QQPD.LT.(PVIRTP(1)+PARMDL(144))) THEN
21787 WGX = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
21788 & /LOG(QQPD/PARMDL(144))
21790 IF(NINHD(1,1).EQ.0) WGX = WGX*WGX
21791 ELSE IF(IPAMDL(115).EQ.2) THEN
21792 CALL PHO_PDF(1,X1,QQPD,PVIRTP(1),PD1)
21793 WGX = PD1(IA)/PDFVA(1,1)
21798 & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
21799 & 're-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
21800 & KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX
21802 IF(WGX.LT.DT_RNDM(WGX)) THEN
21808 & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
21809 & 're-weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
21810 & KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX
21816 IF((MSPR.NE.14).AND.(ISWMDL(8).GE.2)) THEN
21817 IF(IPAMDL(109).EQ.1) THEN
21818 Q2H = PARMDL(93)*PT**2
21820 Q2H = -PARMDL(93)*VHD(1)*XHD(1,1)*XHD(1,2)*ECMP*ECMP
21822 XHMAX1 = 1.D0 - XSS1 - AS + XHD(1,1)
21823 XHMAX2 = 1.D0 - XSS2 - AS + XHD(1,2)
21828 CALL PHO_HARISR(-1,P1,P2,NOUTHD(1,1),NOUTHD(1,2),N0INHD(1,1),
21829 & N0INHD(1,2),N0IVAL(1,1),N0IVAL(1,2),Q2H,X0HD(1,1),X0HD(1,2),
21830 & XHMAX1,XHMAX2,IFL1,IFL2,IVAL1,IVAL2,XISR1,XISR2,IREJ)
21831 XSS1 = XSS1+XISR1-XHD(1,1)
21832 XSS2 = XSS2+XISR2-XHD(1,2)
21844 C add photon/hadron remnant
21848 XMAXX = 1.D0 - XSS2 - AS
21849 XMAXH = MIN(XMAXX,PARMDL(44))
21850 CALL PHO_HADSP2(IDBAM2,XSS2,XMAXH,XS2,IREJ)
21856 ELSE IF(IFL1.EQ.0) THEN
21857 XMAXX = 1.D0 - XSS1 - AS
21858 XMAXH = MIN(XMAXX,PARMDL(44))
21859 CALL PHO_HADSP2(IDBAM1,XSS1,XMAXH,XS1,IREJ)
21867 ELSE IF(ABS(IFL2).LE.12) THEN
21868 IF(IVAL2.EQ.1) THEN
21869 XS2(1) = 1.D0 - XSS2
21875 XMAXX = 1.D0 - XSS2 - AS
21876 XMAXH = MIN(XMAXX,PARMDL(44))
21877 CALL PHO_HADSP3(IDBAM2,XSS2,XMAXH,XS2,IREJ)
21883 ELSE IF(ABS(IFL1).LE.12) THEN
21884 IF(IVAL1.EQ.1) THEN
21885 XS1(1) = 1.D0 - XSS1
21891 XMAXX = 1.D0 - XSS1 - AS
21892 XMAXH = MIN(XMAXX,PARMDL(44))
21893 CALL PHO_HADSP3(IDBAM1,XSS1,XMAXH,XS1,IREJ)
21900 C double direct process
21901 ELSE IF(MSPR.EQ.14) THEN
21909 WRITE(LO,'(/1X,A,I3/)')
21910 & 'PHO_HARDIR:ERROR: unsupported hard process (MSPR)',MSPR
21915 IF(IDEB(25).GE.3) WRITE(LO,'(1X,A,3I5)')
21916 & 'PHO_HARDIR: int. rejection (MSPR,ITRY,NTRY)',MSPR,ITRY,NTRY
21920 C soft particle momenta
21921 IF(MSPAR1.GT.0) THEN
21925 PSOFT1(3,I) = XS1(I)*ECMP/2.D0
21926 PSOFT1(4,I) = XS1(I)*ECMP/2.D0
21929 IF(MSPAR2.GT.0) THEN
21933 PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
21934 PSOFT2(4,I) = XS2(I)*ECMP/2.D0
21938 MH_acc_1(MSPR,II) = MH_acc_1(MSPR,II)+1
21939 KSOFT = MAX(MSPAR1,MSPAR2)
21940 KHARD = MAX(MHPAR1,MHPAR2)
21942 IF(IDEB(25).GE.10) THEN
21943 WRITE(LO,'(/1X,A,2I3,3I5)')
21944 & 'PHO_HARDIR: accepted IVAL1,IVAL2,MSPR,ITRY,NTRY',
21945 & IVAL1,IVAL2,MSPR,ITRY,NTRY
21946 IF(MSPAR1.GT.0) THEN
21947 WRITE(LO,'(5X,A,I4)') 'soft x particle 1:',MSPAR1
21949 WRITE(LO,'(10X,I3,E12.3)') I,XS1(I)
21952 IF(MSPAR2.GT.0) THEN
21953 WRITE(LO,'(5X,A,I4)') 'soft x particle 2:',MSPAR2
21955 WRITE(LO,'(10X,I3,E12.3)') I,XS2(I)
21958 WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavor particle 1:',MHPAR1
21959 WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,1),NINHD(1,1)
21960 WRITE(LO,'(5X,A,I4)') 'fin.hard momenta particle 1:',MHPAR1
21961 WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,1),K=5,8),NOUTHD(1,1)
21962 WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavour particle 2:',MHPAR2
21963 WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,2),NINHD(1,2)
21964 WRITE(LO,'(5X,A,I4)') 'fin.hard momenta particle 2:',MHPAR2
21965 WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,2),K=5,8),NOUTHD(1,2)
21970 IFAIL(16) = IFAIL(16)+1
21971 IF(IDEB(25).GE.2) THEN
21972 WRITE(LO,'(1X,A,3I5)')
21973 & 'PHO_HARDIR: rejection (ITRY,NTRY,IREJ)',ITRY,NTRY,IREJ
21974 WRITE(LO,'(5X,A,E12.4)') 'available energy:',ECMP
21975 IF(IDEB(25).GE.5) THEN
21978 CALL PHO_PREVNT(-1)
21984 *$ CREATE PHO_POMSCA.FOR
21986 CDECK ID>, PHO_POMSCA
21987 SUBROUTINE PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,
21988 & MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
21989 C**********************************************************************
21991 C parton orientated formulation of soft and hard inelastic events
21994 C input: II particle combiantion (1..4)
21995 C MSPOM number of soft pomerons
21996 C MHPOM number of semihard pomerons
21997 C MSREG number of soft reggeons
21999 C output: IVAL1,2 0 no valence quark engaged
22000 C otherwise: position of valence quark engaged
22001 C neg.number: gluon connected to valence quark
22003 C MSPAR1,2 number of realized soft partons
22004 C MHPAR1,2 number of realized hard partons
22008 C**********************************************************************
22009 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22012 PARAMETER (TINY = 1.D-30 )
22014 C input/output channels
22016 COMMON /POINOU/ LI,LO
22017 C event debugging information
22019 PARAMETER (NMAXD=100)
22020 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
22021 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22022 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
22023 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22024 C model switches and parameters
22026 INTEGER ISWMDL,IPAMDL
22027 DOUBLE PRECISION PARMDL
22028 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
22029 C general process information
22030 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
22031 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
22032 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
22033 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
22034 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
22035 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
22036 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
22037 C event weights and generated cross section
22038 INTEGER IPOWGC,ISWCUT,IVWGHT
22039 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
22040 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
22041 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
22042 C hard cross sections and MC selection weights
22044 PARAMETER ( Max_pro_2 = 16 )
22045 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
22046 & MH_acc_1,MH_acc_2
22047 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
22048 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
22049 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
22050 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
22051 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
22052 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
22053 C hard scattering parameters used for most recent hard interaction
22055 DOUBLE PRECISION ALQCD2,BQCD
22056 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
22057 C data of c.m. system of Pomeron / Reggeon exchange
22058 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
22059 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
22060 & SIDP,CODP,SIFP,COFP
22061 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
22062 & SIDP,CODP,SIFP,COFP,NPOSP(2),
22063 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
22064 C obsolete cut-off information
22065 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
22066 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
22067 C some hadron information, will be deleted in future versions
22069 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
22070 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
22071 C data on most recent hard scattering
22072 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22073 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22074 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22075 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22076 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22077 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22078 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22079 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22080 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22081 C light-cone x fractions and c.m. momenta of soft cut string ends
22083 PARAMETER ( MAXSOF = 50 )
22084 INTEGER IJSI2,IJSI1
22085 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
22086 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
22087 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
22088 & IJSI1(MAXSOF),IJSI2(MAXSOF)
22089 C hard scattering data
22091 PARAMETER ( MSCAHD = 50 )
22092 INTEGER LSCAHD,LSC1HD,LSIDX,
22093 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
22094 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
22095 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
22096 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
22097 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
22098 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
22099 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
22100 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
22101 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
22102 C table of particle indices for recursive PHOJET calls
22104 PARAMETER ( MAXIPX = 100 )
22105 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
22106 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
22107 & IPOIX1,IPOIX2,IPOIX3
22108 C internal rejection counters
22110 PARAMETER (NMXJ=60)
22111 CHARACTER*10 REJTIT
22113 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
22115 DIMENSION P1(4),P2(4),PD1(-6:6)
22117 IF(IDEB(24).GT.20) WRITE(LO,'(1X,A,3I5)')
22118 & 'PHO_POMSCA: MSPOM,MHPOM,MSREG',MSPOM,MHPOM,MSREG
22126 C phase space limitation (single hard valence-valence quark scattering)
22127 IF(MHPOM.GT.0) THEN
22128 Emin = 2.D0*PTWANT + 0.2D0
22129 IF(ECMP.LT.Emin) THEN
22130 IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P,3E10.3)') 'PHO_POMSCA: ',
22131 & 'kin. rejection (1) (Ecm,Ptcut,Emin)',ECMP,PTWANT,Emin
22133 IFAIL(6) = IFAIL(6) + 1
22138 SAS = PARMDL(160+II)/ECMP
22139 SAH = 2.D0*PTWANT/ECMP
22143 C save energy for leading particle effect
22145 if(IHFLS(1).ne.0) XMAXP1 = 1.D0-PARMDL(165)*XPSUB
22147 if(IHFLS(2).ne.0) XMAXP2 = 1.D0-PARMDL(165)*XTSUB
22150 C main loop to select hard and soft parton kinematics
22151 C -----------------------------------------------------
22152 IFAIL(31) = IFAIL(31)+MHARD
22158 IF(ITRY.GT.1) IFAIL(5) = IFAIL(5)+1
22159 IF(ITRY.GE.NTRY) THEN
22165 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
22166 XSS1 = MAX(0.D0,1.D0-XPSUB)
22167 XSS2 = MAX(0.D0,1.D0-XTSUB)
22174 C partons needed to construct soft/hard interactions
22175 MSPAR1 = 2*MSPOM+MSREG+MHPOM
22180 C number of strings
22181 MSCHA = 2*MSPOM+MSREG
22187 C check actual phase space limit
22188 XX = SAS*DBLE(MSCHA)+SAH*DBLE(MHCHA)/2.D0
22189 IF(XX.GE.1.D0) THEN
22190 IF(IDEB(24).GE.3) WRITE(LO,'(1X,2A,/1X,4I3,1P4E12.4)')
22191 & 'PHO_POMSCA: internal kin. rejection ',
22192 & '(MSpom,MHpom,MSchain,MHchain,Ecm,AS,AH,XX):',
22193 & MSPOM,MHPOM,MSCHA,MHCHA,ECMP,AS,AH,XX
22194 if(MSPOM+MSREG+MHPOM.gt.1) then
22195 if(MSREG.gt.0) then
22197 else if(MSPOM.gt.0) THEN
22199 else if(MHPOM.gt.1) then
22204 IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P2E10.3)')
22205 & 'PHO_POMSCA: kin. rejection (2) (Ecm,Ptcut)',ECMP,PTWANT
22207 IFAIL(6) = IFAIL(6) + 1
22211 XMAXX1 = MAX(TINY,1.D0-MIN(MSPAR1,1)*AS-MIN(MHPAR1,1)*AH)
22212 XMAXX2 = MAX(TINY,1.D0-MIN(MSPAR2,1)*AS-MIN(MHPAR2,1)*AH)
22214 C very low energy phase space restriction
22215 if(MHARD.gt.0) then
22216 if((XMAXX1*XMAXX2.le.AH)) then
22217 IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P2E10.3)')
22218 & 'PHO_POMSCA: kin. rejection (3) (Ecm,Ptcut)',ECMP,PTWANT
22220 IFAIL(6) = IFAIL(6) + 1
22225 AS = MAX(AS,PSOMIN/PCMP)
22228 Z1MAX = LOG(XMAXX1)
22229 Z2MAX = LOG(XMAXX2)
22230 Z1DIF = Z1MAX+Z2MAX-ALNH
22234 C select hard parton momenta
22235 C ------------------- begin of inner loop -------------------
22236 IF(IPOIX3.EQ.0) IPOWGC(4+II) = 0
22237 IF(MHARD.GT.MSCAHD) THEN
22238 WRITE(LO,'(1X,2A,2I3)') 'PHO_POMSCA: ',
22239 & 'no space left in /POHSLT/ (MHARD,MSCAHD):',MHARD,MSCAHD
22245 C generate one resolved hard scattering
22248 IF((NN.EQ.1).AND.(II.EQ.1).AND.(HSWCUT(4+II).GT.PTWANT)) THEN
22249 CALL PHO_HARINT(-1,ECMP,PVIRTP(1),PVIRTP(2),
22250 & -1,Max_pro_2,1,4,MSPOM+MHPOM)
22256 AH = (2.D0*PTWANT/ECMP)**2
22258 Z1DIF = Z1MAX+Z2MAX-ALNH
22260 IF((Z1DIF.LE.0.01D0).OR.(Z2DIF.LE.0.01D0)) THEN
22261 IF(IDEB(24).GE.1) WRITE(LO,'(1X,2A,/1X,1P4E12.3)')
22262 & 'PHO_POMSCA: kin.rejection, high-pt option ',
22263 & '(Z1/2max,ALNH,Z1dif):',Z1MAX,Z2MAX,ALNH,Z1DIF
22267 CALL PHO_HARSCA(2,II)
22268 CALL PHO_HARINT(1,ECMP,PVIRTP(1),PVIRTP(2),
22269 & -1,Max_pro_2,1,4,MSPOM+MHPOM)
22274 IPOWGC(4+II) = IPOWGC(4+II)+1
22275 HSWGHT(4+II) = XSCUT/HSig(9)*DBLE(MHARD)
22276 C minimum bias option
22278 CALL PHO_HARSCA(2,II)
22295 PDFVA(NN,1) = PDF1(IA)
22296 PDFVA(NN,2) = PDF2(IB)
22307 NBRAHD(NN,1) = IDPDG1
22308 NBRAHD(NN,2) = IDPDG2
22312 PPH(I3+I,1) = PHI1(I)
22313 PPH(I3+I,2) = PHI2(I)
22314 PPH(I4+I,1) = PHO1(I)
22315 PPH(I4+I,2) = PHO2(I)
22320 C sort according to pt-hat
22322 PTMX = PTHD(LSIDX(NN))
22325 IF(PTHD(LSIDX(I)).GT.PTMX) THEN
22327 PTMX = PTHD(LSIDX(I))
22330 IF(IPTM.NE.NN) CALL PHO_SWAPI(LSIDX(NN),LSIDX(IPTM))
22334 C copy partons, generate ISR
22337 XSSS1 = XSS1+XHD(NN,1)
22338 XSSS2 = XSS2+XHD(NN,2)
22340 IF(IDEB(24).GE.10) WRITE(LO,'(1X,A,3I4,1P,3E11.3)')
22341 & 'PHO_POMSCA: NR,LSIDX,MSPR,X1,X2,PT',
22342 & L,NN,NPROHD(NN),XHD(NN,1),XHD(NN,2),PTHD(NN)
22343 C check phase space
22344 IF( (XSSS1.GT.XMAXX1)
22345 & .OR.(XSSS2.GT.XMAXX2)
22346 & .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
22347 IF(IHARD.EQ.0) THEN
22348 IF(ISWMDL(2).NE.1) GOTO 20
22356 C reweight according to photon virtuality
22357 IF(IPAMDL(115).GE.1) THEN
22360 IF(IDPDG1.EQ.22) THEN
22361 IF(IPAMDL(115).EQ.1) THEN
22362 IF(QQPD.LT.PVIRTP(1)+PARMDL(144)) THEN
22365 WG1 = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
22366 & /LOG(QQPD/PARMDL(144))
22368 IF(NINHD(NN,1).EQ.0) WG1 = WG1*WG1
22369 ELSE IF(IPAMDL(115).EQ.2) THEN
22370 CALL PHO_PDF(1,X0HD(NN,1),QQPD,PVIRTP(1),PD1)
22371 WG1 = PD1(NINHD(NN,1))/PDFVA(NN,1)
22376 IF(IDPDG2.EQ.22) THEN
22377 IF(IPAMDL(115).EQ.1) THEN
22378 IF(QQPD.LT.PVIRTP(2)+PARMDL(144)) THEN
22381 WG1 = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
22382 & /LOG(QQPD/PARMDL(144))
22384 IF(NINHD(NN,2).EQ.0) WG1 = WG1*WG1
22385 ELSE IF(IPAMDL(115).EQ.2) THEN
22386 CALL PHO_PDF(2,X0HD(NN,2),QQPD,PVIRTP(2),PD1)
22387 WG1 = PD1(NINHD(NN,2))/PDFVA(NN,2)
22393 & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_POMSCA: ',
22394 & ' re-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
22395 & KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX
22397 IF(WGX.LT.DT_RNDM(WGX)) THEN
22406 IF(WGX.GT.1.D0) WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)')
22408 & 'weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
22409 & KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX
22414 IF((ISWMDL(8).GE.2)
22415 & .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
22416 IF(IPAMDL(109).EQ.1) THEN
22417 Q2H = PARMDL(93)*PTHD(NN)**2
22419 Q2H = -PARMDL(93)*VHD(NN)
22420 & *XHD(NN,1)*XHD(NN,2)*ECMP*ECMP
22422 XHMAX1 = 1.D0 - XSSS1 - MSCHA*AS + XHD(NN,1)
22423 XHMAX2 = 1.D0 - XSSS2 - MSCHA*AS + XHD(NN,2)
22426 P1(J) = PPH(I3+J,1)
22427 P2(J) = PPH(I3+J,2)
22430 & WRITE(LO,'(1X,A,/5X,2I3,1P,3E12.4)')
22431 & 'PHO_POMSCA: generate ISR for (L,NN,X1,X2,Q2H)',
22432 & L,NN,XHD(NN,1),XHD(NN,2),Q2H
22435 CALL PHO_HARISR(J,P1,P2,NOUTHD(NN,1),NOUTHD(NN,2),
22436 & N0INHD(NN,1),N0INHD(NN,2),N0IVAL(NN,1),N0IVAL(NN,2),Q2H,
22437 & X0HD(NN,1),X0HD(NN,2),XHMAX1,XHMAX2,IFL1,IFL2,
22438 & NIVAL(NN,1),NIVAL(NN,2),XISR1,XISR2,IREJ)
22439 XSSS1 = XSSS1+XISR1-XHD(NN,1)
22440 XSSS2 = XSSS2+XISR2-XHD(NN,2)
22447 C check phase space
22448 IF( (XSSS1.GT.XMAXX1)
22449 & .OR.(XSSS2.GT.XMAXX2)
22450 & .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
22451 IF(IHARD.EQ.0) THEN
22452 IF(ISWMDL(2).NE.1) GOTO 20
22460 C leave energy for leading particle effect
22461 IF((IHARD.GT.0).AND.
22462 & ((XSSS1.GT.XMAXP1).OR.(XSSS2.GT.XMAXP2))) then
22466 C hard scattering accepted
22470 IFAIL(31) = IFAIL(31)-1
22474 C ------------------- end of inner (hard) loop -------------------
22481 C count valences involved in hard scattering
22486 IF((NIVAL(NN,1).NE.0).AND.(IVAL1.EQ.0)) IVAL1 = NN
22487 IF((NIVAL(NN,2).NE.0).AND.(IVAL2.EQ.0)) IVAL2 = NN
22497 C photon, pomeron valences
22498 IF((IVAL1.EQ.0).AND.(NINHD(NN,1).NE.0)) THEN
22499 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
22504 IF((IVAL2.EQ.0).AND.(NINHD(NN,2).NE.0)) THEN
22505 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
22511 C total number of quarks
22512 IF(NINHD(NN,1).NE.0) THEN
22514 ELSE IF(IVGLU1.EQ.0) THEN
22517 IF(NINHD(NN,2).NE.0) THEN
22519 ELSE IF(IVGLU2.EQ.0) THEN
22524 C gluons emitted by valence quarks
22526 IF(II.EQ.1) VALPRO = VALPRG(1)
22529 IVAL1 = MAX(IVAL1,0)
22530 IF(IVAL1.EQ.0) THEN
22532 IF((IVGLU1.NE.0).AND.(DT_RNDM(XSS1).LT.VALPRO)) THEN
22538 IF(II.EQ.1) VALPRO = VALPRG(2)
22541 IVAL2 = MAX(IVAL2,0)
22542 IF(IVAL2.EQ.0) THEN
22544 IF((IVGLU2.NE.0).AND.(DT_RNDM(XSS2).LT.VALPRO)) THEN
22549 MSPOM = MAX(0,MSPOM-IQUA1-IQUA2)
22551 IF(IDEB(24).GE.5) WRITE(LO,'(1X,A,6I4)')
22552 & 'PHO_POMSCA: IVAL1/2,IQUA1/2,IVGLU1/2',
22553 & IVAL1,IVAL2,IQUA1,IQUA2,IVGLU1,IVGLU2
22555 C select soft X values
22557 C number of soft/remnant quarks
22558 IF(MSPOM.EQ.0) THEN
22559 IF(IPAMDL(18).EQ.0) THEN
22560 MSPAR1 = 2+2*MHPOM+MSREG-IQUA1-2*IVQ1-2*IVG1
22561 MSPAR2 = 2+2*MHPOM+MSREG-IQUA2-2*IVQ2-2*IVG2
22563 MSPAR1 = 2+MSREG+IQUA1-2*IVQ1
22564 MSPAR2 = 2+MSREG+IQUA2-2*IVQ2
22567 IF(IPAMDL(18).EQ.0) THEN
22568 MSPAR1 = 2*MSPOM+MSREG+2*MHPOM-IQUA1
22569 MSPAR2 = 2*MSPOM+MSREG+2*MHPOM-IQUA2
22571 MSPAR1 = 2*MSPOM+MSREG+IQUA1+2*IVG1
22572 MSPAR2 = 2*MSPOM+MSREG+IQUA2+2*IVG2
22576 IF(IDEB(24).GE.15) WRITE(LO,'(1X,A,9I3)')
22577 & 'PHO_POMSCA: MSP,MSR,MHP,IVQ1/2,IVG1/2,MSPAR1/2',
22578 & MSPOM,MSREG,MHPOM,IVQ1,IVQ2,IVG1,IVG2,MSPAR1,MSPAR2
22580 XMAX1 = 1.D0 - MAX(MSPAR1-1,0)*AS - XSS1
22581 XMAX2 = 1.D0 - MAX(MSPAR2-1,0)*AS - XSS2
22584 IF(IVAL1.LE.0) I1 = 0
22585 IF(IVAL2.LE.0) I2 = 0
22586 IF((IVQ1+IVG1)*(IVQ2+IVG2).NE.0) THEN
22589 MSDIFF = 2*MAX(0,MSPOM-1)
22593 MSM1 = MSPAR1-MSDIFF
22594 MSM2 = MSPAR2-MSDIFF
22595 XMAXH1 = MIN(XMAX1,PARMDL(44))
22596 XMAXH2 = MIN(XMAX2,PARMDL(44))
22597 CALL PHO_SOFTXX(NPOSP(1),NPOSP(2),MSG1,MSG2,I1,I2,MSM1,MSM2,
22598 & XSS1,XSS2,XMAXH1,XMAXH2,XS1,XS2,IREJ)
22600 C correct for proper simulation of high pt tail
22602 IF(IDEB(48).GE.2) WRITE(LO,'(1X,A,4I4)')
22603 & 'PHO_STDPAR: rejection (PHO_SOFTXX): MSPOM,MHPOM,I1,I2',
22604 & MSPOM,MHPOM,I1,I2
22605 IF(MSPOM*MHPOM.GT.0) THEN
22608 ELSE IF(MSPOM.GT.1) THEN
22611 ELSE IF(MHPOM.GT.1) THEN
22613 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0)
22614 & .AND.(IPROCE.EQ.1)) THEN
22615 XSS1 = MAX(0.D0,1.D0-XPSUB)
22616 XSS2 = MAX(0.D0,1.D0-XTSUB)
22623 XSS1 = XSS1+ XHD(I,1)
22624 XSS2 = XSS2+ XHD(I,2)
22632 MSPOM = MSPOM-(MSPAR1-MSG1)/2
22635 C ------------ kinematics sampled ---------------
22637 IF(IDEB(24).GE.10) THEN
22638 WRITE(LO,'(1X,A,I3)')
22639 & 'PHO_POMSCA: soft x values, ITRY',ITRY
22640 DO 104 I=2,MAX(MSPAR1,MSPAR2)
22641 WRITE(LO,'(10X,I3,2E12.3)') I,XS1(I),XS2(I)
22644 IF((1.D0-XSS1)*(1.D0-XSS2).LT.AS) GOTO 20
22647 XS1(1) = 1.D0 - XSS1
22648 XS2(1) = 1.D0 - XSS2
22652 MH_acc_1(NPROHD(N),II) = MH_acc_1(NPROHD(N),II)+1
22655 C soft particle momenta
22656 IF(MAX(MSPAR1,MSPAR2).GT.MAXSOF) THEN
22657 WRITE(LO,'(1X,2A,3I4)') 'PHO_POMSCA: no space left in ',
22658 & '/POSOFT/ (MSPAR1/2,MAXSOF):',MSPAR1,MSPAR2,MAXSOF
22665 PSOFT1(3,I) = XS1(I)*ECMP/2.D0
22666 PSOFT1(4,I) = XS1(I)*ECMP/2.D0
22671 PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
22672 PSOFT2(4,I) = XS2(I)*ECMP/2.D0
22675 KSOFT = MAX(MSPAR1,MSPAR2)
22676 KHARD = MAX(MHPAR1,MHPAR2)
22682 IF(IDEB(24).GE.10) THEN
22683 WRITE(LO,'(/1X,A,2I3,2I5)')
22684 & 'PHO_POMSCA: accepted IVAL1,IVAL2,ITRY,NTRY',
22685 & IVAL1,IVAL2,ITRY,NTRY
22686 IF(MSPAR1+MSPAR2.GT.0) THEN
22687 WRITE(LO,'(5X,A)') 'soft x particle1 particle2:'
22690 DO 105 I=1,MAX(MSPAR1,MSPAR2)
22691 IF(I.LE.MIN(MSPAR1,MSPAR2)) THEN
22692 WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),XS2(I)
22693 XTMP1 = XTMP1+XS1(I)
22694 XTMP2 = XTMP2+XS2(I)
22695 ELSE IF(I.LE.MSPAR1) THEN
22696 WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),0.D0
22697 XTMP1 = XTMP1+XS1(I)
22698 ELSE IF(I.LE.MSPAR2) THEN
22699 WRITE(LO,'(10X,I3,2E13.4)') I,0.D0,XS2(I)
22700 XTMP2 = XTMP2+XS2(I)
22703 WRITE(LO,'(5X,A,2E13.4)') 'sum X1/2 (soft):',XTMP1,XTMP2
22705 IF(MHPAR1.GT.0) THEN
22707 & 'NR IDX MSPR hard X / hard X ISR / flavor particle 1,2:'
22710 WRITE(LO,'(5X,3I3,4E12.3,2I3)')
22711 & K,I,NPROHD(I),X0HD(I,1),X0HD(I,2),XHD(I,1),XHD(I,2),
22712 & NINHD(I,1),NINHD(I,2)
22713 XTMP1 = XTMP1+XHD(I,1)
22714 XTMP2 = XTMP2+XHD(I,2)
22716 WRITE(LO,'(1X,A,2E13.4)') 'sum X1/2 (soft+hard):',XTMP1,XTMP2
22717 WRITE(LO,'(5X,A)') 'hard momenta particle1:'
22721 WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,1),L=1,4),
22724 WRITE(LO,'(5X,A)') 'hard momenta particle2:'
22728 WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,2),L=1,4),
22735 C event rejected, print debug information
22737 IFAIL(4) = IFAIL(4)+1
22738 IF(IDEB(24).GE.2) THEN
22739 WRITE(LO,'(1X,2A,/,10X,7I5)') 'PHO_POMSCA: ',
22740 & 'rejection (MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ)',
22741 & MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ
22742 WRITE(LO,'(5X,A,I4,1P,2E12.4)') 'IP,Ecm,PTcut:',II,ECMP,PTWANT
22743 IF(IDEB(24).GE.5) THEN
22746 CALL PHO_PREVNT(-1)
22752 *$ CREATE PHO_HARX12.FOR
22754 CDECK ID>, PHO_HARX12
22755 SUBROUTINE PHO_HARX12
22756 C**********************************************************************
22758 C selection of x1 and x2 according to 1/x1*1/x2
22760 C**********************************************************************
22761 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22764 PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
22766 C input/output channels
22768 COMMON /POINOU/ LI,LO
22769 C data on most recent hard scattering
22770 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22771 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22772 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22773 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22774 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22775 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22776 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22777 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22778 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22781 Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
22782 Z2 = Z2MAX-DT_RNDM(X2)*Z2DIF
22783 IF ( (Z1+Z2).LT.ALNH ) GOTO 10
22787 W = SQRT(MAX(TINY,1.D0-AXX))
22792 *$ CREATE PHO_HARDX1.FOR
22794 CDECK ID>, PHO_HARDX1
22795 SUBROUTINE PHO_HARDX1
22796 C**********************************************************************
22798 C selection of x1 according to 1/x1
22801 C**********************************************************************
22802 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22805 PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
22807 C input/output channels
22809 COMMON /POINOU/ LI,LO
22810 C data on most recent hard scattering
22811 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22812 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22813 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22814 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22815 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22816 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22817 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22818 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22819 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22821 Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
22825 W = SQRT(MAX(TINY,1.D0-AXX))
22830 *$ CREATE PHO_HARKIN.FOR
22832 CDECK ID>, PHO_HARKIN
22833 SUBROUTINE PHO_HARKIN(IREJ)
22834 C***********************************************************************
22836 C selection of kinematic variables
22837 C (resolved and direct processes)
22839 C***********************************************************************
22840 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22843 PARAMETER ( TINY= 1.D-30, TINYP=1.D-14 )
22845 C input/output channels
22847 COMMON /POINOU/ LI,LO
22848 C event debugging information
22850 PARAMETER (NMAXD=100)
22851 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
22852 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22853 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
22854 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22855 C data of c.m. system of Pomeron / Reggeon exchange
22856 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
22857 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
22858 & SIDP,CODP,SIFP,COFP
22859 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
22860 & SIDP,CODP,SIFP,COFP,NPOSP(2),
22861 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
22862 C data on most recent hard scattering
22863 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22864 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22865 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22866 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22867 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22868 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22869 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22870 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22871 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22872 C internal cross check information on hard scattering limits
22873 DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
22874 COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)
22876 PARAMETER ( Max_pro_2 = 16 )
22877 DIMENSION RM(-1:Max_pro_2)
22878 DATA RM / 3.31D0, 0.0D0,
22879 & 7.60D0, 0.65D0, 4.00D0, 0.65D0, 0.89D0,
22880 & 0.45D0, 0.89D0, 0.89D0, 0.0D0, 4.776D0,
22881 & 0.615D0,4.776D0,0.615D0,1.0D0, 0.0D0,
22887 C------------- resolved processes -----------
22890 V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
22892 R = (1.D0+W)*2.25D0*(V*V*(3.D0-U*V-V/(U*U))-U)
22893 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22894 & 'PHO_HARKIN:weight error',M
22895 IF ( R*W.LT.RM(1)*DT_RNDM(X2) ) GOTO 10
22896 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22897 ELSEIF ( M.EQ.2 .OR. M.EQ.4 ) THEN
22900 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
22902 R = (U*U+V*V)*((16.D0/27.D0)/U-(4.D0/3.D0)*V)*(WL/W)*AXX
22903 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22904 & 'PHO_HARKIN:weight error',M
22905 IF ( R*W.LT.RM(M)*DT_RNDM(X2) ) GOTO 20
22906 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22907 ELSEIF ( M.EQ.3 ) THEN
22909 V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
22911 R = (1.D0+W)*(1.D0+U*U)*(1.D0-(4.D0/9.D0)*V*V/U)
22912 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22913 & 'PHO_HARKIN:weight error',M
22914 IF ( R*W.LT.RM(3)*DT_RNDM(X2) ) GOTO 30
22915 ELSEIF ( M.EQ.5 ) THEN
22917 V =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
22919 R = (4.D0/9.D0)*(1.D0+U*U+V*V*(U*U+V*V))-(8.D0/27.D0)*U*U*V
22920 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22921 & 'PHO_HARKIN:weight error',M
22922 IF ( R*W.LT.RM(5)*DT_RNDM(X2) ) GOTO 50
22923 ELSEIF ( M.EQ.6 ) THEN
22925 V =-0.5D0*(1.D0+W)+DT_RNDM(X1)*W
22927 R = (4.D0/9.D0)*(U*U+V*V)*AXX
22928 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22929 & 'PHO_HARKIN:weight error',M
22930 IF ( R*W.LT.RM(6)*DT_RNDM(V) ) GOTO 60
22931 ELSEIF ( M.EQ.7 ) THEN
22933 V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
22935 R = (1.D0+W)*((2.D0/9.D0)*(1.D0+U*U+(1.D0+V*V)*V*V/(U*U))
22936 & -(4.D0/27.D0)*V/U)
22937 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22938 & 'PHO_HARKIN:weight error',M
22939 IF ( R*W.LT.RM(7)*DT_RNDM(X2) ) GOTO 70
22940 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22941 ELSEIF ( M.EQ.8 ) THEN
22943 V =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
22945 R = (4.D0/9.D0)*(1.D0+U*U)
22946 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22947 & 'PHO_HARKIN:weight error',M
22948 IF ( R*W.LT.RM(8)*DT_RNDM(X2) ) GOTO 80
22949 ELSEIF ( M.EQ.-1 ) THEN
22952 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
22954 R = (1.D0+V*V)*(V/(U*U)-(4.D0/9.D0))*(WL/W)*AXX
22955 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22956 & 'PHO_HARKIN:weight error',M
22957 IF ( R*W.LT.RM(-1)*DT_RNDM(X2) ) GOTO 90
22958 C------------- direct / single-resolved processes -----------
22959 ELSEIF ( M.EQ.10 ) THEN
22960 100 CALL PHO_HARDX1
22961 WL = LOG(AXX/(1.D0+W)**2)
22962 U =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
22963 R = -(8.D0/3.D0)*(U*U+1.D0)*WL*AXX
22964 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22965 & 'PHO_HARKIN:weight error',M
22966 IF ( R.LT.RM(10)*DT_RNDM(U) ) GOTO 100
22970 ELSEIF ( M.EQ.11) THEN
22971 110 CALL PHO_HARDX1
22973 U =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
22975 R = (U*U+V*V)/V*WL*AXX
22976 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22977 & 'PHO_HARKIN:weight error',M
22978 IF ( R.LT.RM(11)*DT_RNDM(X2) ) GOTO 110
22979 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22982 ELSEIF ( M.EQ.12 ) THEN
22983 120 CALL PHO_HARDX1
22984 WL = LOG(AXX/(1.D0+W)**2)
22985 V =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
22986 R = -(8.D0/3.D0)*(V*V+1.D0)*WL*AXX
22987 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22988 & 'PHO_HARKIN:weight error',M
22989 IF ( R.LT.RM(12)*DT_RNDM(V) ) GOTO 120
22990 ELSEIF ( M.EQ.13) THEN
22991 130 CALL PHO_HARDX1
22993 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
22995 R = (U*U+V*V)/U*WL*AXX
22996 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22997 & 'PHO_HARKIN:weight error',M
22998 IF ( R.LT.RM(13)*DT_RNDM(X2) ) GOTO 130
22999 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23000 C------------- (double) direct process -----------
23001 ELSEIF ((M.EQ.14).OR.(M.EQ.16)) THEN
23005 W = SQRT(MAX(TINY,1.D0-AXX))
23008 140 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
23011 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
23012 & 'PHO_HARKIN:weight error',M
23013 IF ( R.LT.RM(14)*DT_RNDM(X2) ) GOTO 140
23014 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
23015 C---------------------------------------------
23017 WRITE(LO,'(/1X,A,I3)')
23018 & 'PHO_HARKIN:ERROR:unsupported process (MSPR)',MSPR
23022 V = MAX(MIN(V,-TINYP ),-1.D0+TINYP)
23024 U = MAX(MIN(U,-TINYP ),-1.D0+TINYP)
23025 PT = SQRT(U*V*X1*X2)*ECMP
23026 ETAC = 0.5D0*LOG((U*X1)/(V*X2))
23027 ETAD = 0.5D0*LOG((V*X1)/(U*X2))
23029 ***************************************************************
23032 ETAMI(1,MM) = MIN(ETAMI(1,MM),ETAC)
23033 ETAMA(1,MM) = MAX(ETAMA(1,MM),ETAC)
23034 ETAMI(2,MM) = MIN(ETAMI(2,MM),ETAD)
23035 ETAMA(2,MM) = MAX(ETAMA(2,MM),ETAD)
23036 XXMI(1,MM) = MIN(XXMI(1,MM),X1)
23037 XXMA(1,MM) = MAX(XXMA(1,MM),X1)
23038 XXMI(2,MM) = MIN(XXMI(2,MM),X2)
23039 XXMA(2,MM) = MAX(XXMA(2,MM),X2)
23040 ***************************************************************
23042 IF(IDEB(81).GE.25) WRITE(LO,'(1X,A,/5X,6E12.3)')
23043 & 'PHO_HARKIN: V,PT,ETAC,ETAD,X1,X2',V,PT,ETAC,ETAD,X1,X2
23047 *$ CREATE PHO_HARWGH.FOR
23049 CDECK ID>, PHO_HARWGH
23050 SUBROUTINE PHO_HARWGH(PDS,PDA,PDB,FDISTR)
23051 C***********************************************************************
23053 C calculate product of PDFs and coupling constants
23054 C according to selected MSPR (process type)
23058 C output: PDS resulting from PDFs alone
23059 C FDISTR complete weight function
23060 C PDA,PDB fields containing the PDFs
23062 C***********************************************************************
23063 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23066 PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
23068 C input/output channels
23070 COMMON /POINOU/ LI,LO
23071 C event debugging information
23073 PARAMETER (NMAXD=100)
23074 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
23075 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23076 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
23077 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23078 C model switches and parameters
23080 INTEGER ISWMDL,IPAMDL
23081 DOUBLE PRECISION PARMDL
23082 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
23083 C data of c.m. system of Pomeron / Reggeon exchange
23084 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23085 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23086 & SIDP,CODP,SIFP,COFP
23087 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23088 & SIDP,CODP,SIFP,COFP,NPOSP(2),
23089 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
23090 C currently activated parton density parametrizations
23092 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
23093 DOUBLE PRECISION PDFLAM,PDFQ2M
23094 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
23095 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
23096 C hard scattering parameters used for most recent hard interaction
23098 DOUBLE PRECISION ALQCD2,BQCD
23099 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
23100 C some hadron information, will be deleted in future versions
23102 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
23103 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
23104 C scale parameters for parton model calculations
23105 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
23106 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
23107 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
23108 & NQQAL,NQQALI,NQQALF,NQQPD
23109 C data on most recent hard scattering
23110 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23111 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23112 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23113 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23114 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23115 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23116 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23117 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23118 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23119 C hard cross sections and MC selection weights
23121 PARAMETER ( Max_pro_2 = 16 )
23122 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
23123 & MH_acc_1,MH_acc_2
23124 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
23125 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
23126 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
23127 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
23128 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
23129 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
23131 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
23132 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
23133 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
23135 DOUBLE PRECISION PHO_ALPHAS,pho_alphae
23136 DIMENSION PDA(-6:6),PDB(-6:6)
23139 C set hard scale QQ for alpha and partondistr.
23140 IF ( NQQAL.EQ.1 ) THEN
23142 ELSEIF ( NQQAL.EQ.2 ) THEN
23143 QQAL = AQQAL*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
23144 ELSEIF ( NQQAL.EQ.3 ) THEN
23145 QQAL = AQQAL*X1*X2*ECMP*ECMP
23146 ELSEIF ( NQQAL.EQ.4 ) THEN
23147 QQAL = AQQAL*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
23149 IF ( NQQPD.EQ.1 ) THEN
23151 ELSEIF ( NQQPD.EQ.2 ) THEN
23152 QQPD = AQQPD*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
23153 ELSEIF ( NQQPD.EQ.3 ) THEN
23154 QQPD = AQQPD*X1*X2*ECMP*ECMP
23155 ELSEIF ( NQQPD.EQ.4 ) THEN
23156 QQPD = AQQPD*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
23158 C coupling constants, PDFs
23160 ALPHA1 = PHO_ALPHAS(QQAL,3)
23162 CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
23163 CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
23164 IF ( MSPR.EQ.1 .OR. MSPR.EQ.4 ) THEN
23165 PDS = PDA(0)*PDB(0)
23172 S2 = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
23173 S3 = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
23174 S4 = S4+PDA(I)+PDA(-I)
23175 S5 = S5+PDB(I)+PDB(-I)
23177 IF ((MSPR.EQ.2).OR.(MSPR.EQ.5).OR.(MSPR.EQ.6)) THEN
23179 ELSE IF((MSPR.EQ.3).OR.(MSPR.EQ.-1)) THEN
23180 PDS = PDA(0)*S5+PDB(0)*S4
23181 ELSE IF(MSPR.EQ.7) THEN
23183 ELSE IF(MSPR.EQ.8) THEN
23184 PDS = S4*S5-(S2+S3)
23187 ELSE IF(MSPR.LT.12) THEN
23188 ALPHA2 = PHO_ALPHAS(QQAL,2)
23189 IF(IDPDG1.EQ.22) THEN
23190 ALPHA1 = pho_alphae(QQAL)
23191 ELSE IF(IDPDG1.EQ.990) THEN
23192 ALPHA1 = PARMDL(74)
23194 CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
23198 S4 = S4+PDB(I)+PDB(-I)
23200 * IF(MOD(I,2).EQ.0) THEN
23201 * S6 = S6+(PDB(I)+PDB(-I))*4.D0/9.D0
23203 * S6 = S6+(PDB(I)+PDB(-I))*1.D0/9.D0
23205 S6 = S6+(PDB(I)+PDB(-I))*Q_ch2(I)
23207 IF(MSPR.EQ.10) THEN
23208 IF(IDPDG1.EQ.990) THEN
23216 ELSE IF(MSPR.LT.14) THEN
23217 ALPHA1 = PHO_ALPHAS(QQAL,1)
23218 IF(IDPDG2.EQ.22) THEN
23219 ALPHA2 = pho_alphae(QQAL)
23220 ELSE IF(IDPDG2.EQ.990) THEN
23221 ALPHA2 = PARMDL(74)
23223 CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
23227 S4 = S4+PDA(I)+PDA(-I)
23229 * IF(MOD(I,2).EQ.0) THEN
23230 * S6 = S6+(PDA(I)+PDA(-I))*4.D0/9.D0
23232 * S6 = S6+(PDA(I)+PDA(-I))*1.D0/9.D0
23234 S6 = S6+(PDA(I)+PDA(-I))*Q_ch2(I)
23236 IF(MSPR.EQ.12) THEN
23237 IF(IDPDG2.EQ.990) THEN
23245 ELSE IF(MSPR.EQ.14) THEN
23246 SSR = X1*X2*ECMP*ECMP
23247 IF(IDPDG1.EQ.22) THEN
23248 ALPHA1 = pho_alphae(SSR)
23249 ELSE IF(IDPDG1.EQ.990) THEN
23250 ALPHA1 = PARMDL(74)
23252 IF(IDPDG2.EQ.22) THEN
23253 ALPHA2 = pho_alphae(SSR)
23254 ELSE IF(IDPDG2.EQ.990) THEN
23255 ALPHA2 = PARMDL(74)
23259 WRITE(LO,'(/1X,A,I4)')
23260 & 'PHO_HARWGH:ERROR: invalid hard process number (MSPR)',MSPR
23265 FDISTR = HFac(MSPR)*ALPHA1*ALPHA2*PDS
23268 IF(IDEB(15).GE.20) WRITE(LO,'(1X,A,/5X,I3,2I6,4E10.3)')
23269 & 'PHO_HARWGH: MSPR,ID1,ID2,AL1,AL2,PDS,FDIS',
23270 & MSPR,IDPDG1,IDPDG2,ALPHA1,ALPHA2,PDS,FDISTR
23274 *$ CREATE PHO_HARSCA.FOR
23276 CDECK ID>, PHO_HARSCA
23277 SUBROUTINE PHO_HARSCA(IMODE,IP)
23278 C***********************************************************************
23280 C PHO_HARSCA determines the type of hard subprocess, the partons
23281 C taking part in this subprocess and the kinematic variables
23283 C input: IMODE 1 direct processes
23284 C 2 resolved processes
23285 C -1 initialization
23286 C -2 output of statistics
23287 C IP 1-4 particle combination (hadron/photon)
23289 C***********************************************************************
23290 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23293 PARAMETER( EPS = 1.D-10,
23296 C input/output channels
23298 COMMON /POINOU/ LI,LO
23299 C event debugging information
23301 PARAMETER (NMAXD=100)
23302 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
23303 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23304 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
23305 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23306 C model switches and parameters
23308 INTEGER ISWMDL,IPAMDL
23309 DOUBLE PRECISION PARMDL
23310 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
23311 C internal rejection counters
23313 PARAMETER (NMXJ=60)
23314 CHARACTER*10 REJTIT
23316 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
23317 C hard scattering parameters used for most recent hard interaction
23319 DOUBLE PRECISION ALQCD2,BQCD
23320 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
23321 C data of c.m. system of Pomeron / Reggeon exchange
23322 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23323 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23324 & SIDP,CODP,SIFP,COFP
23325 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23326 & SIDP,CODP,SIFP,COFP,NPOSP(2),
23327 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
23328 C names of hard scattering processes
23330 PARAMETER ( Max_pro_1 = 16 )
23332 COMMON /POHPRO/ PROC(0:Max_pro_1)
23333 C data on most recent hard scattering
23334 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23335 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23336 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23337 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23338 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23339 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23340 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23341 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23342 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23343 C hard scattering data
23345 PARAMETER ( MSCAHD = 50 )
23346 INTEGER LSCAHD,LSC1HD,LSIDX,
23347 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
23348 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
23349 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
23350 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
23351 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
23352 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
23353 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
23354 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
23355 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
23356 C hard cross sections and MC selection weights
23358 PARAMETER ( Max_pro_2 = 16 )
23359 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
23360 & MH_acc_1,MH_acc_2
23361 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
23362 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
23363 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
23364 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
23365 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
23366 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
23368 INTEGER IPFIL,IFAFIL,IFBFIL
23369 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
23370 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
23371 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
23372 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
23373 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
23374 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
23375 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
23376 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
23377 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
23378 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
23379 & IPFIL,IFAFIL,IFBFIL
23381 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
23382 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
23383 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
23387 C resolved processes
23388 IF(IMODE.EQ.2) THEN
23390 MH_pro_on(0,IP) = 0
23393 IF(MH_pro_on(M,IP).EQ.1) HWgx(9) = HWgx(9)+HWgx(M)
23395 IF(HWgx(9).LT.DEPS) THEN
23396 WRITE(LO,'(/1X,2A,I4,1P,E12.4)') 'PHO_HARSCA:ERROR: ',
23397 & 'no resolved process possible for IP',IP,HWgx(9)
23401 C ----------------------------------------------I
23402 C begin of iteration loop (resolved processes) I
23407 IF(IREJSC.GT.1000) THEN
23408 WRITE(LO,'(/1X,A,I10)')
23409 & 'PHO_HARSCA:ERROR: too many rejections (resolved)',IREJSC
23414 B = DT_RNDM(X1)*HWgx(9)
23418 IF ( MH_pro_on(MSPR,IP).EQ.1 ) SUM = SUM+HWgx(MSPR)
23419 IF ( SUM.LT.B .AND. MSPR.LT.8 ) GOTO 20
23421 IF(IDEB(78).GE.20) WRITE(LO,'(1x,a,i3,i6)')
23422 & 'PHO_HARSCA: resolved process (MSPR,IREJSC)',MSPR,IREJSC
23424 C find kin. variables X1,X2 and V
23425 CALL PHO_HARKIN(IREJ)
23427 IFAIL(29) = IFAIL(29)+1
23430 C calculate remaining distribution
23431 CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
23432 C actualize counter for cross-section calculation
23433 if(F.LE.1.D-15) then
23437 * XSECT(5,MSPR) = XSECT(5,MSPR)+F
23438 * XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
23439 MH_tried(MSPR,IP) = MH_tried(MSPR,IP)+1
23440 C check F against FMAX
23441 WEIGHT = F/(HWgx(MSPR)+DEPS)
23442 IF ( WEIGHT.LT.DT_RNDM(X2) ) GOTO 10
23443 C-------------------------------------------------------------------
23444 IF(WEIGHT.GT.1.D0) THEN
23445 WRITE(LO,1234) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR),WEIGHT
23446 1234 FORMAT(/,' PHO_HARSCA: (resolved) W>1 (MSPR,IP,ID1,2)',
23447 & 2I3,2I7,/' F,HWgx(MSPR),W',3E12.4)
23448 WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
23449 & ECMP,PTWANT,AS,AH,PT
23450 WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
23451 & ETAC,ETAD,X1,X2,V
23452 CALL PHO_PREVNT(-1)
23454 C-------------------------------------------------------------------
23456 C end of iteration loop (resolved processes) I
23457 C --------------------------------------------I
23459 C*********************************************************************
23463 ELSE IF(IMODE.EQ.1) THEN
23465 C single-resolved processes kinematically forbidden
23466 if(Z1DIF.lt.0.D0) then
23474 if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
23476 IF(MH_pro_on(M,IP).EQ.1) then
23477 if((M.eq.10).or.(M.eq.11)) then
23478 fac = FSUH(1)*FSUP(2)
23479 else if((M.eq.12).or.(M.eq.13)) then
23480 fac = FSUP(1)*FSUH(2)
23482 fac = FSUH(1)*FSUH(2)
23484 HWgx(15) = HWgx(15)+HWgx(M)*fac
23489 IF(MH_pro_on(M,IP).EQ.1) HWgx(15)=HWgx(15)+HWgx(M)
23492 IF(HWgx(15).LT.DEPS) THEN
23493 WRITE(LO,'(/1X,2A,I4)') 'PHO_HARSCA:ERROR: ',
23494 & 'no direct/single-resolved process possible (IP)',IP
23498 C ----------------------------------------------I
23499 C begin of iteration loop (direct processes) I
23504 IF(IREJSC.GT.1000) THEN
23505 WRITE(LO,'(/1X,A,I10)')
23506 & 'PHO_HARSCA:ERROR: too many rejections (direct)',IREJSC
23511 B = DT_RNDM(X1)*HWgx(15)
23514 if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
23517 IF(MH_pro_on(MSPR,IP).EQ.1) then
23518 if((MSPR.eq.10).or.(MSPR.eq.11)) then
23519 fac = FSUH(1)*FSUP(2)
23520 else if((MSPR.eq.12).or.(MSPR.eq.13)) then
23521 fac = FSUP(1)*FSUH(2)
23523 fac = FSUH(1)*FSUH(2)
23525 SUM = SUM+HWgx(MSPR)*fac
23527 IF ( SUM.LT.B .AND. MSPR.LT.14 ) GOTO 150
23531 IF(MH_pro_on(MSPR,IP).EQ.1) SUM = SUM+HWgx(MSPR)
23532 IF ( SUM.LT.B .AND. MSPR.LT.14 ) GOTO 200
23535 IF(IDEB(78).GE.20) WRITE(LO,'(1x,a,i3,i6)')
23536 & 'PHO_HARSCA: direct process (MSPR,IREJSC)',MSPR,IREJSC
23538 C find kin. variables X1,X2 and V
23539 CALL PHO_HARKIN(IREJ)
23541 IFAIL(28) = IFAIL(28)+1
23545 C calculate remaining distribution
23546 CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
23548 C counter for cross-section calculation
23549 if(F.LE.1.D-15) then
23553 * XSECT(5,MSPR) = XSECT(5,MSPR)+F
23554 * XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
23555 MH_tried(MSPR,IP) = MH_tried(MSPR,IP)+1
23556 C check F against FMAX
23557 WEIGHT = F/(HWgx(MSPR)+DEPS)
23558 IF(WEIGHT.LT.DT_RNDM(X2)) GOTO 100
23559 C-------------------------------------------------------------------
23560 IF(WEIGHT.GT.1.D0) THEN
23561 WRITE(LO,1235) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR),WEIGHT
23562 1235 FORMAT(/,' PHO_HARSCA: (direct) W>1 (MSPR,IP,ID1,2)',
23563 & 2I3,2I7,/,' F,HWgx(MSPR),W',3E12.4)
23564 WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
23565 & ECMP,PTWANT,AS,AH,PT
23566 WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
23567 & ETAC,ETAD,X1,X2,V
23568 CALL PHO_PREVNT(-1)
23570 C-------------------------------------------------------------------
23572 C end of iteration loop (direct processes) I
23573 C --------------------------------------------I
23575 ELSE IF(IMODE.EQ.-1) THEN
23577 C initialize cross section calculations
23579 DO 40 M=-1,Max_pro_2
23581 * XSECT(I,M) = 0.D0
23590 IF(IDEB(78).GE.0) THEN
23591 WRITE(LO,'(/1X,A,/1X,A)')
23592 & 'PHO_HARSCA: activated hard processes',
23593 & '------------------------------------'
23594 WRITE(LO,'(5X,A)') 'PROCESS, IP= 1 ... 4 (on/off)'
23595 DO 42 M=1,Max_pro_2
23596 WRITE(LO,'(1X,I3,5X,A,4I3)') M,PROC(M),
23597 & (MH_pro_on(M,J),J=1,4)
23602 ELSE IF(IMODE.EQ.-2) THEN
23604 C calculation of process statistics
23618 MH_tried(3,K) = MH_tried(3,K)+MH_tried(-1,K)
23619 MH_acc_1(3,K) = MH_acc_1(3,K)+MH_acc_1(-1,K)
23620 MH_acc_2(3,K) = MH_acc_2(3,K)+MH_acc_2(-1,K)
23623 MH_tried(9,K) = MH_tried(9,K)+MH_tried(M,K)
23624 MH_acc_1(9,K) = MH_acc_1(9,K)+MH_acc_1(M,K)
23625 MH_acc_2(9,K) = MH_acc_2(9,K)+MH_acc_2(M,K)
23628 MH_tried(15,K) = MH_tried(15,K)+MH_tried(M,K)
23629 MH_acc_1(15,K) = MH_acc_1(15,K)+MH_acc_1(M,K)
23630 MH_acc_2(15,K) = MH_acc_2(15,K)+MH_acc_2(M,K)
23632 MH_tried(0,K) = MH_tried(9,K)+MH_tried(15,K)
23633 MH_acc_1(0,K) = MH_acc_1(9,K)+MH_acc_1(15,K)
23634 MH_acc_2(0,K) = MH_acc_2(9,K)+MH_acc_2(15,K)
23637 IF(IDEB(78).GE.1) THEN
23638 WRITE(LO,'(/1X,A,/1X,A)')
23639 & 'PHO_HARSCA: internal rejection statistics',
23640 & '-----------------------------------------'
23642 IF(MH_tried(0,K).GT.0) THEN
23643 WRITE(LO,'(5X,A,I3)')
23644 & 'process (sampled/accepted) for IP:',K
23646 WRITE(LO,'(1X,I3,1X,A,2X,3I12,F10.4)') M,PROC(M),
23647 & MH_tried(M,K),MH_acc_1(M,K),MH_acc_2(K,K),
23648 & dble(MH_acc_1(M,K))/dble(max(1,MH_tried(M,K)))
23656 WRITE(LO,'(/1X,2A,I10)') 'PHO_HARSCA:ERROR: ',
23657 & 'unsupported mode',IMODE
23661 C the event is accepted now
23662 C actualize counter for accepted events
23663 MH_acc_1(MSPR,IP) = MH_acc_1(MSPR,IP)+1
23664 IF(MSPR.EQ.-1) MSPR = 3
23666 C find flavor of initial partons
23669 SCHECK = DT_RNDM(SUM)*PDS-EPS
23670 IF ( MSPR.EQ.1 .OR. MSPR.EQ.4 ) THEN
23673 ELSEIF ( MSPR.EQ.2 .OR. MSPR.EQ.5 .OR. MSPR.EQ.6 ) THEN
23675 IF ( IA.EQ.0 ) GOTO 610
23676 SUM = SUM+PDF1(IA)*PDF2(-IA)
23677 IF ( SUM.GE.SCHECK ) GOTO 620
23680 ELSEIF ( MSPR.EQ.3 ) THEN
23683 IF ( IA.EQ.0 ) GOTO 630
23684 SUM = SUM+PDF1(0)*PDF2(IA)
23685 IF ( SUM.GE.SCHECK ) GOTO 640
23686 SUM = SUM+PDF1(IA)*PDF2(0)
23687 IF ( SUM.GE.SCHECK ) GOTO 650
23692 ELSEIF ( MSPR.EQ.7 ) THEN
23694 IF ( IA.EQ.0 ) GOTO 660
23695 SUM = SUM+PDF1(IA)*PDF2(IA)
23696 IF ( SUM.GE.SCHECK ) GOTO 670
23699 ELSEIF ( MSPR.EQ.8 ) THEN
23701 IF ( IA.EQ.0 ) GOTO 690
23703 IF ( ABS(IB).EQ.ABS(IA) .OR. IB.EQ.0 ) GOTO 680
23704 SUM = SUM+PDF1(IA)*PDF2(IB)
23705 IF ( SUM.GE.SCHECK ) GOTO 700
23709 ELSEIF ( MSPR.EQ.10 ) THEN
23712 IF ( IB.NE.0 ) THEN
23713 IF(IDPDG1.EQ.22) THEN
23714 * IF(MOD(ABS(IB),2).EQ.0) THEN
23715 * SUM = SUM+PDF2(IB)*4.D0/9.D0
23717 * SUM = SUM+PDF2(IB)*1.D0/9.D0
23719 SUM = SUM+PDF2(IB)*Q_ch2(IB)
23723 IF ( SUM.GE.SCHECK ) GOTO 720
23727 ELSEIF ( MSPR.EQ.12 ) THEN
23730 IF ( IA.NE.0 ) THEN
23731 IF(IDPDG2.EQ.22) THEN
23732 * IF(MOD(ABS(IA),2).EQ.0) THEN
23733 * SUM = SUM+PDF1(IA)*4.D0/9.D0
23735 * SUM = SUM+PDF1(IA)*1.D0/9.D0
23737 SUM = SUM+PDF1(IA)*Q_ch2(IA)
23741 IF ( SUM.GE.SCHECK ) GOTO 820
23745 ELSEIF ((MSPR.EQ.11).OR.(MSPR.EQ.13).OR.(MSPR.EQ.14)) THEN
23750 IF((ABS(IA).GT.NF).OR.(ABS(IB).GT.NF)) THEN
23751 WRITE(LO,*) 'PHO_HARSCA: rejection, final check IA,IB',IA,IB
23752 WRITE(LO,*) 'EVENT,MSPR,IA,IB,NF: ',KEVENT,MSPR,IA,IB,NF
23756 C find flavour of final partons
23760 IF ( MSPR.EQ.2 ) THEN
23763 ELSEIF ( MSPR.EQ.4 ) THEN
23764 IC = INT(FLOAT(NF+NF)*DT_RNDM(SUM))+1
23765 IF ( IC.GT.NF ) IC = NF-IC
23767 ELSEIF ( MSPR.EQ.6 ) THEN
23768 IC = INT(FLOAT(NF+NF-2)*DT_RNDM(SUM))+1
23769 IF ( IC.GT.NF-1 ) IC = NF-1-IC
23770 IF ( ABS(IC).EQ.ABS(IA) ) IC = SIGN(NF,IC)
23772 ELSEIF ( MSPR.EQ.11) THEN
23775 IF ( IC.NE.0 ) THEN
23776 IF(IDPDG1.EQ.22) THEN
23777 * IF(MOD(ABS(IC),2).EQ.0) THEN
23782 SUM = SUM + Q_ch2(IC)
23788 SCHECK = DT_RNDM(SUM)*SUM-EPS
23791 IF ( IC.NE.0 ) THEN
23792 IF(IDPDG1.EQ.22) THEN
23793 * IF(MOD(ABS(IC),2).EQ.0) THEN
23798 SUM = SUM + Q_ch2(IC)
23802 IF ( SUM.GE.SCHECK ) GOTO 750
23807 ELSEIF ( MSPR.EQ.12) THEN
23810 ELSEIF ( MSPR.EQ.13) THEN
23813 IF ( IC.NE.0 ) THEN
23814 IF(IDPDG2.EQ.22) THEN
23815 * IF(MOD(ABS(IC),2).EQ.0) THEN
23820 SUM = SUM + Q_ch2(IC)
23826 SCHECK = DT_RNDM(SUM)*SUM-EPS
23829 IF ( IC.NE.0 ) THEN
23830 IF(IDPDG2.EQ.22) THEN
23831 * IF(MOD(ABS(IC),2).EQ.0) THEN
23836 SUM = SUM + Q_ch2(IC)
23840 IF ( SUM.GE.SCHECK ) GOTO 850
23845 ELSEIF ( MSPR.EQ.14) THEN
23850 IF(MOD(ABS(IC),2).EQ.0) THEN
23851 IF(IDPDG1.EQ.22) FAC1 = 4.D0
23852 IF(IDPDG2.EQ.22) FAC2 = 4.D0
23854 SUM = SUM + FAC1*FAC2
23856 IF(IPAMDL(64).NE.0) THEN
23857 IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) SUM = SUM + 81.D0
23859 SCHECK = DT_RNDM(SUM)*SUM-EPS
23864 IF(MOD(ABS(IC),2).EQ.0) THEN
23865 IF(IDPDG1.EQ.22) FAC1 = 4.D0
23866 IF(IDPDG2.EQ.22) FAC2 = 4.D0
23868 SUM = SUM + FAC1*FAC2
23869 IF ( SUM.GE.SCHECK ) GOTO 950
23874 IF(DT_RNDM(FAC1).GT.0.5D0) CALL PHO_SWAPI(IC,ID)
23879 XM3 = PHO_PMASS(IC,3)
23884 XM4 = PHO_PMASS(ID,3)
23886 IF(ABS(IC).EQ.15) GOTO 955
23888 C valence quarks involved?
23891 IF(IDPDG1.EQ.22) THEN
23892 CALL PHO_QPMPDF(IA,X1,QQPD,0.D0,PVIRTP(1),FXP)
23893 IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(IA)-FXP) IV1 = 1
23895 IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(-IA)) IV1 = 1
23900 IF(IDPDG2.EQ.22) THEN
23901 CALL PHO_QPMPDF(IB,X2,QQPD,0.D0,PVIRTP(2),FXP)
23902 IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(IB)-FXP) IV2 = 1
23904 IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(-IB)) IV2 = 1
23908 C fill event record
23911 CALL PHO_SFECFE(SINPHI,COSPHI)
23925 PHO1(1) = PT*COSPHI
23926 PHO1(2) = PT*SINPHI
23927 PHO1(3) = -ECM2*(U*X1-V*X2)
23928 PHO1(4) = -ECM2*(U*X1+V*X2)
23932 PHO2(3) = -ECM2*(V*X1-U*X2)
23933 PHO2(4) = -ECM2*(V*X1+U*X2)
23936 C convert to mass shell
23937 CALL PHO_MSHELL(PHO1,PHO2,XM3,XM4,PHO1,PHO2,IREJ)
23939 IF(IDEB(78).GE.5) WRITE(LO,'(1X,A,1P,3E11.3)')
23940 & 'PHO_HARSCA: rejection by PHO_MSHELL (PT,M1,M2)',
23944 PTfin = SQRT(PHO1(1)**2+PHO1(2)**2)
23947 IF(IDEB(78).GE.20) THEN
23948 SHAT = X1*X2*ECMP*ECMP
23949 WRITE(LO,'(1X,A,5I4)') 'PHO_HARSCA: MSPR,IA,IB,IC,ID',
23951 WRITE(LO,'(5X,A,1P,4E11.3)') 'X1/2,MU2,Q2 ',X1,X2,QQPD,QQAL
23952 WRITE(LO,'(5X,A,1P,4E11.3)') 'U,V,PT,SHAT ',U,V,PT,SHAT
23953 WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI1 ',PHI1
23954 WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI2 ',PHI2
23955 WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO1 ',PHO1
23956 WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO2 ',PHO2
23961 *$ CREATE PHO_HARFAC.FOR
23963 CDECK ID>, PHO_HARFAC
23964 SUBROUTINE PHO_HARFAC(PTCUT,ECMI)
23965 C*********************************************************************
23967 C initialization: find scaling factors and maxima of remaining
23970 C input: PTCUT transverse momentum cutoff
23973 C output: Hfac(-1:Max_pro_2) field for sampling hard processes
23975 C*********************************************************************
23976 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23979 PARAMETER ( MXABWT = 96 )
23981 C input/output channels
23983 COMMON /POINOU/ LI,LO
23984 C data of c.m. system of Pomeron / Reggeon exchange
23985 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23986 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23987 & SIDP,CODP,SIFP,COFP
23988 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23989 & SIDP,CODP,SIFP,COFP,NPOSP(2),
23990 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
23992 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
23993 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
23994 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
23995 C hard scattering parameters used for most recent hard interaction
23997 DOUBLE PRECISION ALQCD2,BQCD
23998 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
23999 C integration precision for hard cross sections (obsolete)
24000 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
24001 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
24002 C data on most recent hard scattering
24003 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24004 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24005 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24006 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24007 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24008 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24009 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24010 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24011 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24012 C hard cross sections and MC selection weights
24014 PARAMETER ( Max_pro_2 = 16 )
24015 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
24016 & MH_acc_1,MH_acc_2
24017 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
24018 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
24019 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
24020 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
24021 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24022 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24024 DIMENSION ABSZ(MXABWT),WEIG(MXABWT)
24025 DIMENSION S(-1:Max_pro_2),S1(-1:Max_pro_2),S2(-1:Max_pro_2),
24026 & F124(-1:Max_pro_2)
24027 DATA F124 / 1.D0,0.D0,
24028 & 4.D0,2.D0,2.D0,2.D0,4.D0,1.D0,4.D0,4.D0,0.D0,1.D0,
24029 & 2.D0,1.D0,2.D0,1.D0,0.D0,1.D0 /
24032 AH = (2.D0*PTCUT/ECMI)**2
24036 CALL PHO_GAUSET(0.D0,1.D0,NPOINT,ABSZ,WEIG)
24037 DO 10 M=-1,Max_pro_2
24041 C resolved processes
24050 Z2 = (1.D0-Z1)*ABSZ(I2)
24053 W = SQRT(1.D0-FAXX)
24063 VA =-0.5D0*W1/(W1+Z*W)
24065 VB =-0.5D0*FAXX/(W1+2.D0*W*Z)
24067 VC =-EXP(HLN+Z*WLOG)
24069 VE =-0.5D0*(1.D0+W)+Z*W
24071 S(1) = S(1)+(1.+W)*2.25*(VA*VA*(3.-UA*VA-VA/(UA*UA))-UA)*
24073 S(2) = S(2)+(VC*VC+UC*UC)*((16./27.)/UC-(4./3.)*VC)*FWW*
24075 S(3) = S(3)+(1.+W)*(1.+UA*UA)*(1.-(4./9.)*VA*VA/UA)*WEIG(I)
24076 S(5) = S(5)+((4./9.)*(1.+UB*UB+(UB*UB+VB*VB)*VB*VB)-
24077 & (8./27.)*UA*UA*VA)*WEIG(I)
24078 S(6) = S(6)+(4./9.)*(UE*UE+VE*VE)*FAXX*WEIG(I)
24079 S(7) = S(7)+(1.+W)*((2./9.)*(1.+UA*UA+(1.+VA*VA)*VA*VA/
24080 & (UA*UA))-(4./27.)*VA/UA)*WEIG(I)
24081 S(8) = S(8)+(4./9.)*(1.+UB*UB)*WEIG(I)
24082 S(-1) = S(-1)+(1.+VC*VC)*(VC/(UC*UC)-(4./9.))*FWW*WEIG(I)
24084 S(4) = S(2)*(9./32.)
24086 S2(M) = S2(M)+S(M)*WEIG(I2)*W
24090 S1(M) = S1(M)+S2(M)*(1.D0-Z1)*WEIG(I1)
24094 S1(6) = S1(6)*MAX(0,NF-1)
24097 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
24098 & .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24103 W = SQRT(1.D0-FAXX)
24106 WL = LOG(FAXX/(1.D0+W)**2)
24108 FWW2 = FAXX*WLOG/ALN
24115 UA =-(1.D0+W)/2.D0*EXP(Z*WL)
24117 VB =-EXP(HLN+Z*WLOG)
24119 S(10) = S(10)+(8.D0/3.D0)*(1.D0+UA*UA)*WEIG(I)*FWW1
24120 S(11) = S(11)-(VB*VB+UB*UB)/UB*WEIG(I)*FWW2
24123 S1(M) = S1(M)+S(M)*WEIG(I1)
24128 C quark charges fractions
24129 IF(IDPDG1.EQ.22) THEN
24132 CHRNF = CHRNF + Q_ch2(I)
24134 S1(11) = S1(11)*CHRNF
24135 ELSE IF(IDPDG1.EQ.990) THEN
24140 IF(IDPDG2.EQ.22) THEN
24143 CHRNF = CHRNF + Q_ch2(I)
24145 S1(13) = S1(13)*CHRNF
24146 ELSE IF(IDPDG2.EQ.990) THEN
24154 FFF = PI*GEV2MB*ALN*ALN/(AH*SS)
24155 DO 90 M=-1,Max_pro_2
24156 Hfac(M) = MAX(FFF*F124(M)*S1(M),0.D0)
24159 C double direct process
24160 IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
24161 & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
24164 IF(IDPDG1.EQ.22) THEN
24169 IF(IDPDG2.EQ.22) THEN
24174 FAC = FAC+F1*F2*3.D0
24176 ZZ = SQRT(1.D0-4.D0*PTCUT*PTCUT/SS)
24177 Hfac(14) = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)
24182 *$ CREATE PHO_HARWGX.FOR
24184 CDECK ID>, PHO_HARWGX
24185 SUBROUTINE PHO_HARWGX(PTCUT,ECM)
24186 C**********************************************************************
24188 C find maximum of remaining weight for MC sampling
24190 C input: PTCUT transverse momentum cutoff
24193 C output: HWgx(-1:Max_pro_2) field for sampling hard processes
24195 C**********************************************************************
24196 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24199 PARAMETER ( NKM = 10 )
24200 PARAMETER ( TINY = 1.D-20 )
24202 C input/output channels
24204 COMMON /POINOU/ LI,LO
24205 C event debugging information
24207 PARAMETER (NMAXD=100)
24208 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24209 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24210 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24211 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24212 C data on most recent hard scattering
24213 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24214 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24215 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24216 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24217 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24218 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24219 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24220 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24221 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24222 C hard cross sections and MC selection weights
24224 PARAMETER ( Max_pro_2 = 16 )
24225 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
24226 & MH_acc_1,MH_acc_2
24227 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
24228 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
24229 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
24230 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
24231 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24232 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24234 DIMENSION Z(3),D(3),FF(0:NKM),PDA(-6:6),PDB(-6:6),XM1(NKM),
24235 & XM2(NKM),PTM(NKM),ZMX(3,NKM),DMX(3,NKM),IMX(NKM),IPO(NKM)
24236 DIMENSION IFTAB(-1:Max_pro_2)
24237 DATA IFTAB / 4,0,1,2,4,1,2,2,3,5,0,6,7,8,9,10,0,10 /
24240 AH = (2.D0*PTCUT/ECM)**2
24262 C start configuration
24264 Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24270 ELSE IF(IST.EQ.2) THEN
24277 ELSE IF(IST.EQ.3) THEN
24278 Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24284 ELSE IF(IST.EQ.4) THEN
24285 Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24293 CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F2)
24294 C process possible?
24295 IF(F2.LE.0.D0) GOTO 35
24303 CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
24304 IF ( F2.GT.F3 ) Z(I) = Z(I)-D(I)
24305 IF ( F2.GT.F3 ) D(I) =-D(I)
24310 CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
24311 IF ( F3.GT.F2 ) GOTO 20
24313 Z(I) = ZZ+0.5*D(I)*(F3-F1)/MAX(TINY,F2+F2-F1-F3)
24314 IF ( ABS(ZZ-Z(I)).GT.D(I)*0.1D0 )
24315 & CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F1)
24316 IF ( F1.LE.F2 ) Z(I) = ZZ
24319 IF((ABS(FOLD-F2)/MAX(TINY,F2).GT.0.002D0).OR.(IT.LT.3)) GOTO 10
24321 IF(F2.GT.FF(NKON)) THEN
24322 FF(NKON) = MAX(F2,0.D0)
24341 IF(IDEB(38).GE.5) THEN
24342 WRITE(LO,'(/1X,A)')
24343 & 'PHO_HARWGX: maximum of weight (I,IT,IS,FF,Z(1-3),D(1-3))'
24345 IF(IMX(I).NE.0) WRITE(LO,'(1X,I2,I3,I2,7E10.3)') I,IMX(I),
24346 & IPO(I),FF(I),ZMX(1,I),ZMX(2,I),ZMX(3,I),DMX(1,I),
24347 & DMX(2,I),DMX(3,I)
24351 DO 70 I=-1,Max_pro_2
24352 HWgx(I) = MAX(FF(IFTAB(I))*Hfac(I),0.D0)
24356 IF(IDEB(38).GE.5) THEN
24357 WRITE(LO,'(/1X,A)') 'PHO_HARWGX: total weights'
24358 WRITE(LO,'(5X,A)') 'I X1 X2 PT HWgx(I) FDIS'
24359 DO 80 I=-1,Max_pro_2
24360 IF((IFTAB(I).NE.0).AND.(HWgx(I).GT.0.D0)) THEN
24362 X1 = MIN(XM1(IFTAB(I)),0.9999999999D0)
24363 X2 = MIN(XM2(IFTAB(I)),0.9999999999D0)
24365 CALL PHO_HARWGH(PDS,PDA,PDB,FDIS)
24366 WRITE(LO,'(1X,I3,5E12.3)') I,X1,X2,PT,HWgx(I),FDIS
24373 *$ CREATE PHO_HARWGI.FOR
24375 CDECK ID>, PHO_HARWGI
24376 SUBROUTINE PHO_HARWGI(ECMX,PTCUT,NKON,Z,FDIS)
24377 C**********************************************************************
24379 C auxiliary subroutine to find maximum of remaining weight
24381 C input: ECMX current CMS energy
24382 C PTCUT current pt cutoff
24383 C NKON process label 1..5 resolved
24384 C 6..7 direct particle 1
24385 C 8..9 direct particle 2
24387 C Z(3) transformed variable
24389 C output: remaining weight
24391 C**********************************************************************
24392 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24397 PARAMETER ( NKM = 10 )
24398 PARAMETER ( TINY = 1.D-30,
24401 C input/output channels
24403 COMMON /POINOU/ LI,LO
24404 C event debugging information
24406 PARAMETER (NMAXD=100)
24407 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24408 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24409 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24410 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24411 C model switches and parameters
24413 INTEGER ISWMDL,IPAMDL
24414 DOUBLE PRECISION PARMDL
24415 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24416 C data of c.m. system of Pomeron / Reggeon exchange
24417 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
24418 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
24419 & SIDP,CODP,SIFP,COFP
24420 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
24421 & SIDP,CODP,SIFP,COFP,NPOSP(2),
24422 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
24423 C currently activated parton density parametrizations
24425 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
24426 DOUBLE PRECISION PDFLAM,PDFQ2M
24427 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
24428 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
24429 C hard scattering parameters used for most recent hard interaction
24431 DOUBLE PRECISION ALQCD2,BQCD
24432 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
24433 C some hadron information, will be deleted in future versions
24435 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
24436 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
24437 C scale parameters for parton model calculations
24438 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24439 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24440 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24441 & NQQAL,NQQALI,NQQALF,NQQPD
24442 C data on most recent hard scattering
24443 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24444 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24445 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24446 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24447 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24448 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24449 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24450 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24451 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24453 DOUBLE PRECISION PHO_ALPHAS,pho_alphae
24454 DIMENSION F(NKM),PDA(-6:6),PDB(-6:6)
24458 IF(IDEB(64).GE.25) WRITE(LO,'(1X,A,/5X,5E12.3,I5)')
24459 & 'PHO_HARWGI: ECM,PT,Z,NK',ECMX,PTCUT,Z,NKON
24460 C check input values
24461 IF ( Z(1).LT.0.D0 .OR. Z(1).GT.1.D0 ) RETURN
24462 IF ( Z(2).LT.0.D0 .OR. Z(2).GT.1.D0 ) RETURN
24463 IF ( Z(3).LT.0.D0 .OR. Z(3).GT.1.D0 ) RETURN
24465 Y1 = EXP(ALNH*Z(1))
24467 C resolved kinematic
24468 Y2 =-(1.D0-Y1)+2.D0*(1.D0-Y1)*Z(2)
24469 X1 = 0.5D0*(Y2+SQRT(Y2*Y2+4.D0*Y1))
24471 X1 = MIN(X1,0.999999999999D0)
24472 X2 = MIN(X2,0.999999999999D0)
24473 ELSE IF(NKON.LE.7) THEN
24474 C direct kinematic 1
24476 X2 = MIN(Y1,0.999999999999D0)
24477 ELSE IF(NKON.LE.9) THEN
24478 C direct kinematic 2
24479 X1 = MIN(Y1,0.999999999999D0)
24482 C double direct kinematic
24486 W = SQRT(MAX(TINY,1.D0-AH/Y1))
24487 V =-0.5D0+W*(Z(3)-0.5D0)
24489 PT = MAX(SQRT(U*V*Y1*ECMX*ECMX),PTCUT)
24491 C set hard scale QQ for alpha and partondistr.
24492 IF ( NQQAL.EQ.1 ) THEN
24494 ELSEIF ( NQQAL.EQ.2 ) THEN
24495 QQAL = AQQAL*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
24496 ELSEIF ( NQQAL.EQ.3 ) THEN
24497 QQAL = AQQAL*Y1*ECMX*ECMX
24498 ELSEIF ( NQQAL.EQ.4 ) THEN
24499 QQAL = AQQAL*Y1*ECMX*ECMX*(U*V)**(1./3.)
24501 IF ( NQQPD.EQ.1 ) THEN
24503 ELSEIF ( NQQPD.EQ.2 ) THEN
24504 QQPD = AQQPD*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
24505 ELSEIF ( NQQPD.EQ.3 ) THEN
24506 QQPD = AQQPD*Y1*ECMX*ECMX
24507 ELSEIF ( NQQPD.EQ.4 ) THEN
24508 QQPD = AQQPD*Y1*ECMX*ECMX*(U*V)**(1./3.)
24515 C resolved processes
24516 ALPHA1 = PHO_ALPHAS(QQAL,3)
24518 CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
24519 CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
24520 C calculate full distribution FDIS
24522 F(2) = F(2)+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
24523 F(3) = F(3)+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
24524 F(4) = F(4)+PDA(I)+PDA(-I)
24525 F(5) = F(5)+PDB(I)+PDB(-I)
24527 F(1) = PDA(0)*PDB(0)
24528 T = PDA(0)*F(5)+PDB(0)*F(4)
24529 F(5) = F(4)*F(5)-(F(2)+F(3))
24531 ELSE IF(NKON.LE.7) THEN
24532 C direct processes particle 1
24533 IF(IDPDG1.EQ.22) THEN
24534 ALPHA1 = pho_alphae(QQAL)
24537 ELSE IF(IDPDG1.EQ.990) THEN
24538 ALPHA1 = PARMDL(74)
24545 ALPHA2 = PHO_ALPHAS(QQAL,2)
24546 CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
24549 F(6) = F(6)+(PDB(I)+PDB(-I))*(CH1-CH2*MOD(I,2))
24552 ELSE IF(NKON.LE.9) THEN
24553 C direct processes particle 2
24554 ALPHA1 = PHO_ALPHAS(QQAL,1)
24555 IF(IDPDG2.EQ.22) THEN
24556 ALPHA2 = pho_alphae(QQAL)
24559 ELSE IF(IDPDG2.EQ.990) THEN
24560 ALPHA2 = PARMDL(74)
24567 CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
24570 F(8) = F(8)+(PDA(I)+PDA(-I))*(CH1-CH2*MOD(I,2))
24574 C double direct process
24576 IF(IDPDG1.EQ.22) THEN
24577 ALPHA1 = pho_alphae(SSR)
24578 ELSE IF(IDPDG1.EQ.990) THEN
24579 ALPHA1 = PARMDL(74)
24584 IF(IDPDG2.EQ.22) THEN
24585 ALPHA2 = pho_alphae(SSR)
24586 ELSE IF(IDPDG2.EQ.990) THEN
24587 ALPHA2 = PARMDL(74)
24595 FDIS = MAX(0.D0,F(NKON)*ALPHA1*ALPHA2)
24598 IF(IDEB(64).GE.20) WRITE(LO,'(1X,A,/2X,I3,2I6,7E11.3)')
24599 & 'PHO_HARWGI: NKON,ID1,ID2,AL1,AL2,X1,X2,PT,F(NKON),FDIS',
24600 & NKON,IDPDG1,IDPDG2,ALPHA1,ALPHA2,X1,X2,PT,F(NKON),FDIS
24604 *$ CREATE PHO_HARINI.FOR
24606 CDECK ID>, PHO_HARINI
24607 SUBROUTINE PHO_HARINI(IP,IDP1,IDP2,PV1,PV2,NOUT,MODE)
24608 C**********************************************************************
24610 C initialize calculation of hard cross section
24612 C must not be called during MC generation
24614 C***********************************************************************
24615 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24618 PARAMETER ( DEPS = 1.D-10 )
24620 C input/output channels
24622 COMMON /POINOU/ LI,LO
24623 C event debugging information
24625 PARAMETER (NMAXD=100)
24626 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24627 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24628 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24629 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24630 C model switches and parameters
24632 INTEGER ISWMDL,IPAMDL
24633 DOUBLE PRECISION PARMDL
24634 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24635 C currently activated parton density parametrizations
24637 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
24638 DOUBLE PRECISION PDFLAM,PDFQ2M
24639 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
24640 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
24642 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
24643 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
24644 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
24645 C scale parameters for parton model calculations
24646 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24647 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24648 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24649 & NQQAL,NQQALI,NQQALF,NQQPD
24650 C data of c.m. system of Pomeron / Reggeon exchange
24651 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
24652 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
24653 & SIDP,CODP,SIFP,COFP
24654 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
24655 & SIDP,CODP,SIFP,COFP,NPOSP(2),
24656 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
24657 C obsolete cut-off information
24658 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
24659 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
24660 C hard scattering parameters used for most recent hard interaction
24662 DOUBLE PRECISION ALQCD2,BQCD
24663 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
24665 double precision pho_alphas
24669 C set local Pomeron c.m. system data
24675 CALL PHO_ACTPDF(IDPDG1,1)
24676 CALL PHO_ACTPDF(IDPDG2,2)
24677 C initialize alpha_s calculation
24678 DUMMY = PHO_ALPHAS(0.D0,-4)
24679 C initialize scales with defaults
24680 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
24681 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24683 AQQALI = PARMDL(86)
24684 AQQALF = PARMDL(89)
24687 NQQALI = IPAMDL(86)
24688 NQQALF = IPAMDL(89)
24692 AQQALI = PARMDL(85)
24693 AQQALF = PARMDL(88)
24696 NQQALI = IPAMDL(85)
24697 NQQALF = IPAMDL(88)
24700 ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24702 AQQALI = PARMDL(85)
24703 AQQALF = PARMDL(88)
24706 NQQALI = IPAMDL(85)
24707 NQQALF = IPAMDL(88)
24711 AQQALI = PARMDL(84)
24712 AQQALF = PARMDL(87)
24715 NQQALI = IPAMDL(84)
24716 NQQALF = IPAMDL(87)
24719 IF(PARMDL(109+IP).LT.DEPS) PARMDL(109+IP) = AQQAL
24720 IF(PARMDL(113+IP).LT.DEPS) PARMDL(113+IP) = AQQALI
24721 IF(PARMDL(117+IP).LT.DEPS) PARMDL(117+IP) = AQQALF
24722 IF(PARMDL(121+IP).LT.DEPS) PARMDL(121+IP) = AQQPD
24723 IF(IPAMDL(64+IP).LT.0) IPAMDL(64+IP) = NQQAL
24724 IF(IPAMDL(68+IP).LT.0) IPAMDL(68+IP) = NQQALI
24725 IF(IPAMDL(72+IP).LT.0) IPAMDL(72+IP) = NQQALF
24726 IF(IPAMDL(76+IP).LT.0) IPAMDL(76+IP) = NQQPD
24727 AQQAL = PARMDL(109+IP)
24728 AQQALI = PARMDL(113+IP)
24729 AQQALF = PARMDL(117+IP)
24730 AQQPD = PARMDL(121+IP)
24731 NQQAL = IPAMDL(64+IP)
24732 NQQALI = IPAMDL(68+IP)
24733 NQQALF = IPAMDL(72+IP)
24734 NQQPD = IPAMDL(76+IP)
24735 PTCUT(1) = PARMDL(36)
24736 PTCUT(2) = PARMDL(37)
24737 PTCUT(3) = PARMDL(38)
24738 PTCUT(4) = PARMDL(39)
24739 PTANO(1) = PARMDL(130)
24740 PTANO(2) = PARMDL(131)
24741 PTANO(3) = PARMDL(132)
24742 PTANO(4) = PARMDL(133)
24743 RFLAG = '(energy-independent)'
24744 IF(IPAMDL(7).GT.0) RFLAG = '(energy-dependent)'
24746 C write out all settings
24747 IF((IDEB(66).GE.15).OR.(MODE.GT.0)) THEN
24748 WRITE(NOUT,1050) IP,IDPDG1,IDPDG2,PTCUT(IP),RFLAG,
24749 & PDFNAM(1),IGRP(1),ISET(1),IEXT(1),
24750 & PDFNAM(2),IGRP(2),ISET(2),IEXT(2),
24751 & PDFLAM,NF,NQQAL,AQQAL,NQQPD,AQQPD
24753 & ' PHO_HARINI: hard scattering parameters for IP:',I3/,
24754 & 5X,'particle 1 / particle 2:',2I8,/,
24755 & 5X,'min. PT :',F7.1,2X,A,/,
24756 & 5X,'PDF side 1:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
24757 & 5X,'PDF side 2:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
24758 & 5X,'LAMBDA1,2 (4 active flavours):',2F8.3,/,
24759 & 5X,'max. number of active flavours NF :',I3,/,
24760 & 5X,'NQQAL/AQQAL/NQQPD/AQQPD:',I5,F8.3,I5,F8.3)
24765 *$ CREATE PHO_HARINT.FOR
24767 CDECK ID>, PHO_HARINT
24768 SUBROUTINE PHO_HARINT(IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM)
24769 C**********************************************************************
24771 C interpolate cross sections and weights for hard scattering
24773 C input: IPP particle combination (neg. for add. user cuts)
24774 C ECM CMS energy (GeV)
24775 C P2V1/2 particle virtualities (pos., GeV**2)
24776 C I1 first subprocess to calculate
24777 C I2 last subprocess to calculate
24778 C <-1 only scales and cutoffs calculated
24779 C K1 first variable to calculate
24780 C K2 last variable to calculate
24781 C MSPOM cross sections to use for pt distribution
24785 C for K1 < 3 the soft pt distribution is also calculated
24787 C output: interpolated values in HWgx, HSig, Hdpt
24789 C***********************************************************************
24790 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24793 PARAMETER ( DEPS = 1.D-15,
24796 C input/output channels
24798 COMMON /POINOU/ LI,LO
24799 C event debugging information
24801 PARAMETER (NMAXD=100)
24802 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24803 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24804 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24805 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24806 C model switches and parameters
24808 INTEGER ISWMDL,IPAMDL
24809 DOUBLE PRECISION PARMDL
24810 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24811 C Reggeon phenomenology parameters
24812 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
24813 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
24814 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
24815 & ALREG,ALREGP,GR(2),B0REG(2),
24816 & GPPP,GPPR,B0PPP,B0PPR,
24817 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
24818 C parameters of 2x2 channel model
24819 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
24820 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
24821 C data needed for soft-pt calculation
24822 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
24823 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
24824 C scale parameters for parton model calculations
24825 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24826 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24827 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24828 & NQQAL,NQQALI,NQQALF,NQQPD
24829 C obsolete cut-off information
24830 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
24831 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
24832 C event weights and generated cross section
24833 INTEGER IPOWGC,ISWCUT,IVWGHT
24834 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
24835 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
24836 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
24837 C parameters for DGLAP backward evolution in ISR
24839 DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
24840 COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
24841 C hard cross sections and MC selection weights
24843 PARAMETER ( Max_pro_2 = 16 )
24844 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
24845 & MH_acc_1,MH_acc_2
24846 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
24847 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
24848 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
24849 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
24850 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24851 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24852 C interpolation tables for hard cross section and MC selection weights
24853 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
24854 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
24855 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
24856 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
24857 & HQ2a_tab,HQ2b_tab,HEcm_tab
24859 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24860 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24861 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24862 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24863 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
24864 & HEcm_tab(1:Max_tab_E,0:4),
24865 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
24866 C data on most recent hard scattering
24867 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24868 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24869 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24870 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24871 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24872 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24873 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24874 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24875 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24876 C energy-interpolation table
24878 PARAMETER ( IEETA2 = 20 )
24880 DOUBLE PRECISION SIGTAB,SIGECM
24881 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
24883 DOUBLE PRECISION XP,PTS
24884 DIMENSION XP(2),PTS(0:2,2)
24889 IF(IDEB(58).GE.25) WRITE(LO,'(1X,2A,/,5X,I2,3E12.3,5I4)')
24890 & 'PHO_HARINT: called with ',
24891 & 'IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM',
24892 & IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM
24896 C default minimum bias cutoff
24897 PTCUT(IP) = pho_ptcut(ECM,IP)
24899 C user defined additional cutoff
24900 PTCUT(IP) = HSWCUT(4+IP)
24905 Q2CUT = MIN(PTWANT**2,PARMDL(125+IP))
24906 Q2MISR(1) = MAX(P2V1,Q2CUT)
24907 Q2MISR(2) = MAX(P2V2,Q2CUT)
24908 C cutoff for direct photon contribution to photon PDF
24909 PTANO(IP) = MIN(PTCUT(IP),PARMDL(129+IP))
24911 C scales for hard scattering
24912 AQQAL = PARMDL(109+IP)
24913 AQQALI = PARMDL(113+IP)
24914 AQQALF = PARMDL(117+IP)
24915 AQQPD = PARMDL(121+IP)
24916 NQQAL = IPAMDL(64+IP)
24917 NQQALI = IPAMDL(68+IP)
24918 NQQALF = IPAMDL(72+IP)
24919 NQQPD = IPAMDL(76+IP)
24920 IF(IDEB(58).GE.15) WRITE(LO,'(1X,A,4I3,4E10.3)')
24921 & 'PHO_HARINT: scales:',
24922 & NQQAL,NQQALI,NQQALF,NQQPD,AQQAL,AQQALI,AQQALF,AQQPD
24924 IF(I2.LT.-1) RETURN
24927 IF(IPP.LT.0) IL = 0
24929 C double-log interpolation
24930 IF(ECM.LT.2.1D0*PTCUT(IP)) THEN
24941 IF((ECM.GT.HEcm_tab(I,IL)).AND.(I.LT.IH_Ecm_up(IL))) GOTO 310
24945 fac = LOG(ECM/HEcm_tab(I-1,IL))
24946 & /LOG(HEcm_tab(I,IL)/HEcm_tab(I-1,IL))
24948 C factor due to phase space integration
24949 XX = LOG(Hfac_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
24950 & *LOG((Hfac_tab(M,I,Ia,Ib,IL)+DEPS)
24951 & /(Hfac_tab(M,I-1,Ia,Ib,IL)+DEPS))
24953 IF(XX.LT.DEPS2) XX = 0.D0
24956 XX = LOG(HWgx_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
24957 & *LOG((HWgx_tab(M,I,Ia,Ib,IL)+DEPS)
24958 & /(HWgx_tab(M,I-1,Ia,Ib,IL)+DEPS))
24960 IF(XX.LT.DEPS2) XX = 0.D0
24962 C hard cross section
24963 XX = LOG(HSig_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
24964 & *LOG((HSig_tab(M,I,Ia,Ib,IL)+DEPS)
24965 & /(HSig_tab(M,I-1,Ia,Ib,IL)+DEPS))
24967 IF(XX.LT.DEPS2) XX = 0.D0
24969 C differential hard cross section
24970 XX = LOG(Hdpt_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
24971 & *LOG((Hdpt_tab(M,I,Ia,Ib,IL)+DEPS)
24972 & /(Hdpt_tab(M,I-1,Ia,Ib,IL)+DEPS))
24974 IF(XX.LT.DEPS2) XX = 0.D0
24979 IF((K1.LT.3).AND.(K2.GE.3)) THEN
24981 IF((I1.GT.9).OR.(I2.LT.9)) THEN
24982 WRITE(LO,'(1X,2A,2I4)') 'PHO_HARINT: ',
24983 & 'hard cross section not calculated ',I1,I2
24987 C load soft cross sections from interpolation table
24988 IF(ECM.LE.SIGECM(IP,1)) THEN
24991 ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
24993 IF(ECM.LE.SIGECM(IP,I)) GOTO 205
24999 WRITE(LO,'(/1X,A,I3,1P,2E11.3)')
25000 & 'PHO_HARINT: energy too high (IP,Ecm,Emax)',
25001 & IP,ECM,SIGECM(IP,ISIMAX)
25002 CALL PHO_PREVNT(-1)
25007 IF(L1.NE.L2) FAC2=LOG(ECM/SIGECM(IP,L1))
25008 & /LOG(SIGECM(IP,L2)/SIGECM(IP,L1))
25010 SIGS = FAC2*(SIGTAB(IP,56,L2)+SIGTAB(IP,57,L2))+
25011 & FAC1*(SIGTAB(IP,56,L1)+SIGTAB(IP,57,L1))
25015 CALL PHO_SOFTPT(-1,PTWANT,PTWANT,XP,IV,PTS)
25021 IF(IDEB(58).GE.15) THEN
25022 WRITE(LO,'(1X,A,I10,3I2,2E10.3)')
25023 & 'PHO_HARINT: weights EV,IP,K1/2,ECM,PTC',
25024 & KEVENT,IP,K1,K2,ECM,PTCUT(IP)
25026 WRITE(LO,'(5X,2I3,1p,4E12.3)')
25027 & M,MH_pro_on(M,IP),Hfac(M),HWgx(M),HSig(M),Hdpt(M)
25033 *$ CREATE PHO_PTCUT.FOR
25035 DOUBLE PRECISION FUNCTION PHO_PTCUT(ECM,IP)
25036 C***********************************************************************
25038 C calculate energy-dependent transverse momentum cutoff
25040 C***********************************************************************
25044 double precision ECM
25047 C input/output channels
25049 COMMON /POINOU/ LI,LO
25050 C event debugging information
25052 PARAMETER (NMAXD=100)
25053 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
25054 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25055 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
25056 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25057 C model switches and parameters
25059 INTEGER ISWMDL,IPAMDL
25060 DOUBLE PRECISION PARMDL
25061 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25063 pho_ptcut = PARMDL(35+IP)
25065 IF(IPAMDL(7).EQ.1) THEN
25066 C Bopp et al. type (DPMJET)
25067 pho_ptcut = PARMDL(35+IP)
25068 & + max(0.D0,0.12D0*(LOG10(ECM/50.D0))**3)
25069 ELSE IF(IPAMDL(7).EQ.2) THEN
25070 C Gribov-Levin-Ryskin type
25071 pho_ptcut = PARMDL(35+IP)
25072 & + 0.065D0*exp(0.9D0*sqrt(2.D0*log(Ecm)))
25077 *$ CREATE PHO_HARMCI.FOR
25079 CDECK ID>, PHO_HARMCI
25080 SUBROUTINE PHO_HARMCI(IP,EMAXF)
25081 C**********************************************************************
25083 C initialize MC sampling and calculate hard cross section
25085 C input: IP particle combination (neg. number for user cut)
25086 C EMAXF maximum CMS energy for
25087 C interpolation table in reference to PTCUT(1..4)
25089 C***********************************************************************
25090 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25093 PARAMETER (DEPS = 1.D-10,
25096 C input/output channels
25098 COMMON /POINOU/ LI,LO
25099 C event debugging information
25101 PARAMETER (NMAXD=100)
25102 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
25103 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25104 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
25105 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25107 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25108 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25109 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25110 C global event kinematics and particle IDs
25111 INTEGER IFPAP,IFPAB
25112 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
25113 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
25114 C data of c.m. system of Pomeron / Reggeon exchange
25115 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25116 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25117 & SIDP,CODP,SIFP,COFP
25118 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25119 & SIDP,CODP,SIFP,COFP,NPOSP(2),
25120 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
25121 C model switches and parameters
25123 INTEGER ISWMDL,IPAMDL
25124 DOUBLE PRECISION PARMDL
25125 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25126 C obsolete cut-off information
25127 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
25128 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
25129 C scale parameters for parton model calculations
25130 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25131 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25132 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25133 & NQQAL,NQQALI,NQQALF,NQQPD
25134 C names of hard scattering processes
25136 PARAMETER ( Max_pro_1 = 16 )
25138 COMMON /POHPRO/ PROC(0:Max_pro_1)
25139 C hard cross sections and MC selection weights
25141 PARAMETER ( Max_pro_2 = 16 )
25142 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
25143 & MH_acc_1,MH_acc_2
25144 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
25145 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
25146 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
25147 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
25148 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
25149 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
25150 C interpolation tables for hard cross section and MC selection weights
25151 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
25152 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
25153 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
25154 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
25155 & HQ2a_tab,HQ2b_tab,HEcm_tab
25157 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25158 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25159 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25160 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25161 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
25162 & HEcm_tab(1:Max_tab_E,0:4),
25163 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
25164 C event weights and generated cross section
25165 INTEGER IPOWGC,ISWCUT,IVWGHT
25166 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
25167 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
25168 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
25171 DIMENSION DSIG(0:Max_pro_2),DSPT(0:Max_pro_2)
25173 C initialization for all pt cutoffs
25180 PTC = pho_ptcut(parmdl(19),I)
25183 C skip unassigned PTCUT
25184 IF(PTC.LT.0.5D0) GOTO 1000
25192 Hfac_tab(M,Ie,Ia,Ib,I) = 0.D0
25193 HWgx_tab(M,Ie,Ia,Ib,I) = 0.D0
25194 HSig_tab(M,Ie,Ia,Ib,I) = 0.D0
25195 Hdpt_tab(M,Ie,Ia,Ib,I) = 0.D0
25201 ELLOW = LOG(2.05*PTC)
25202 DELTA = (LOG(EMAXF)-ELLOW)/DBLE(IH_Ecm_up(I)-1)
25204 IF(DELTA.LE.0.D0) GOTO 1000
25206 C switch between external particles and Pomeron
25212 ELSE IF(I.EQ.3) THEN
25217 ELSE IF(I.EQ.2) THEN
25229 C initialize PT scales
25230 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
25231 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25232 FPS(I) = PARMDL(105)
25233 FPH(I) = PARMDL(106)
25235 FPS(I) = PARMDL(103)
25236 FPH(I) = PARMDL(104)
25238 ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25239 FPS(I) = PARMDL(103)
25240 FPH(I) = PARMDL(104)
25242 FPS(I) = PARMDL(101)
25243 FPH(I) = PARMDL(102)
25246 C initialize hard scattering
25248 CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8)+1)
25250 CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8))
25253 C energy/virtuality grid
25254 do Ie=1,IH_Ecm_up(IL)
25255 HEcm_tab(Ie,IL) = EXP(ELLOW+DELTA*(IE-1))
25257 do Ia=1,IH_Q2a_up(IL)
25258 HQ2a_tab(Ia,IL) = 0.D0
25260 do Ib=1,IH_Q2b_up(IL)
25261 HQ2b_tab(Ib,IL) = 0.D0
25264 C initialization for several energies and particle virtualities
25265 do Ie=1,IH_Ecm_up(IL)
25266 do Ia=1,IH_Q2a_up(IL)
25267 do Ib=1,IH_Q2b_up(IL)
25269 EE = HEcm_tab(IE,IL)
25270 Q2a = HQ2a_tab(Ia,IL)
25271 Q2b = HQ2b_tab(Ib,IL)
25272 CALL PHO_HARINT(IP,EE,0.D0,0.D0,0,-2,0,0,1)
25273 IF(IDEB(8).GE.5) WRITE(LO,'(1X,A,2E10.3,2I7)')
25274 & 'PHO_HARMCI: initialization PT,ECM,ID1,ID2:',
25275 & PTCUT(I),EE,IDPDG1,IDPDG2
25276 Hfac_tab(0,Ie,Ia,Ib,IL) = PTCUT(I)
25277 CALL PHO_HARFAC(PTCUT(I),EE)
25278 CALL PHO_HARWGX(PTCUT(I),EE)
25279 CALL PHO_HARXTO(EE,PTCUT(I),PTCUT(I),DSIG,DSPT)
25280 IF(IDEB(8).GE.10) THEN
25281 WRITE(LO,'(1X,A,/,1X,A)')
25282 & 'hard cross sections SIGH(mb),DSIG/DPT(mb/GeV**2)',
25283 & '------------------------------------------------'
25285 WRITE(LO,'(10X,A,1P2E14.4)')
25286 & PROC(M),DREAL(DSIG(M)),DSPT(M)
25290 C store in interpolation tables
25291 Hfac_tab(-1,IE,Ia,Ib,IL) = Hfac(-1)
25292 HWgx_tab(-1,IE,Ia,Ib,IL) = HWgx(-1)
25294 Hfac_tab(M,IE,Ia,Ib,IL) = Hfac(M)
25295 HWgx_tab(M,IE,Ia,Ib,IL) = HWgx(M)
25296 HSig_tab(M,IE,Ia,Ib,IL) = DREAL(DSIG(M))*MH_pro_on(M,I)
25297 Hdpt_tab(M,IE,Ia,Ib,IL) = DSPT(M)*MH_pro_on(M,I)
25300 C summed quantities
25301 HSig_tab(9,IE,Ia,Ib,IL) = 0.D0
25302 Hdpt_tab(9,IE,Ia,Ib,IL) = 0.D0
25304 IF(MH_pro_on(M,I).GT.0) THEN
25305 HSig_tab(9,IE,Ia,Ib,IL) =
25306 & HSig_tab(9,IE,Ia,Ib,IL) + HSig_tab(M,IE,Ia,Ib,IL)
25307 Hdpt_tab(9,IE,Ia,Ib,IL) =
25308 & Hdpt_tab(9,IE,Ia,Ib,IL) + Hdpt_tab(M,IE,Ia,Ib,IL)
25311 HSig_tab(15,IE,Ia,Ib,IL) = 0.D0
25312 Hdpt_tab(15,IE,Ia,Ib,IL) = 0.D0
25314 IF(MH_pro_on(M,I).GT.0) THEN
25315 HSig_tab(15,IE,Ia,Ib,IL) =
25316 & HSig_tab(15,IE,Ia,Ib,IL) + HSig_tab(M,IE,Ia,Ib,IL)
25317 Hdpt_tab(15,IE,Ia,Ib,IL) =
25318 & Hdpt_tab(15,IE,Ia,Ib,IL) + Hdpt_tab(M,IE,Ia,Ib,IL)
25321 HSig_tab(0,IE,Ia,Ib,IL) =
25322 & HSig_tab(9,IE,Ia,Ib,IL) + HSig_tab(15,IE,Ia,Ib,IL)
25323 Hdpt_tab(0,IE,Ia,Ib,IL) =
25324 & Hdpt_tab(9,IE,Ia,Ib,IL) + Hdpt_tab(15,IE,Ia,Ib,IL)
25330 C debug output of weights
25332 IF(IDEB(8).GE.5) THEN
25333 WRITE(LO,'(/1X,A,5X,2I7,I3,F7.2,/1X,A)')
25334 & 'PHO_HARMCI: weights, maxima (ID1/2,IP,PTC)',
25335 & IDPDG1,IDPDG2,IP,PTCUT(I),
25336 & '------------------------------------------'
25338 IF((M.EQ.0).OR.(M.EQ.9).OR.(M.EQ.15)) GOTO 512
25339 WRITE(LO,'(2X,A,I3,2I7)')
25340 & 'PHO_HARMCI: ECM Hfac, HWgx, HSig, Hdpt for MSTR,ID1,ID2',
25342 do k=1,IH_Ecm_up(IL)
25343 do ia=1,IH_Q2a_up(IL)
25344 do ib=1,IH_Q2b_up(IL)
25345 WRITE(LO,'(3X,1p,7E10.3)') HEcm_tab(k,IL),
25346 & HQ2a_tab(ia,IL),HQ2b_tab(ib,IL),
25347 & Hfac_tab(M,k,ia,ib,IL),HWgx_tab(M,k,ia,ib,IL),
25348 & HSig_tab(M,k,ia,ib,IL),Hdpt_tab(M,k,ia,ib,IL)
25358 *$ CREATE PHO_HARXR3.FOR
25360 CDECK ID>, PHO_HARXR3
25361 SUBROUTINE PHO_HARXR3(ECMH,PT,ETAC,ETAD,DSIGMC)
25362 C**********************************************************************
25364 C differential cross section DSIG/(DETAC*DETAD*DPT)
25366 C input: ECMH CMS energy
25368 C ETAC pseudorapidity of parton C
25369 C ETAD pseudorapidity of parton D
25371 C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac/detad
25373 C**********************************************************************
25374 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25377 PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-20)
25379 PARAMETER ( Max_pro_2 = 16 )
25381 DIMENSION DSIGMC(0:Max_pro_2)
25382 DIMENSION DSIGM(0:Max_pro_2)
25384 C input/output channels
25386 COMMON /POINOU/ LI,LO
25388 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25389 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25390 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25391 C Reggeon phenomenology parameters
25392 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25393 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25394 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25395 & ALREG,ALREGP,GR(2),B0REG(2),
25396 & GPPP,GPPR,B0PPP,B0PPR,
25397 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25398 C currently activated parton density parametrizations
25400 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
25401 DOUBLE PRECISION PDFLAM,PDFQ2M
25402 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
25403 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
25404 C hard scattering parameters used for most recent hard interaction
25406 DOUBLE PRECISION ALQCD2,BQCD
25407 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25408 C scale parameters for parton model calculations
25409 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25410 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25411 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25412 & NQQAL,NQQALI,NQQALF,NQQPD
25414 DOUBLE PRECISION PHO_ALPHAS
25415 DIMENSION PDA(-6:6),PDB(-6:6)
25418 DSIGMC(I) = CMPLX(0.D0,0.D0)
25424 C kinematic conversions
25425 XA = PT*(EC+ED)/ECMH
25427 IF((XA.GE.1.D0).OR.(XB.GE.1.D0)) THEN
25428 WRITE(LO,'(/1X,A,2E12.4)') 'PHO_HARXR3:ERROR:X1 OR X2 > 1',XA,XB
25431 SP = XA*XB*ECMH*ECMH
25437 C set hard scale QQ for alpha and partondistr.
25438 IF ( NQQAL.EQ.1 ) THEN
25440 ELSEIF ( NQQAL.EQ.2 ) THEN
25441 QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25442 ELSEIF ( NQQAL.EQ.3 ) THEN
25444 ELSEIF ( NQQAL.EQ.4 ) THEN
25445 QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25447 IF ( NQQPD.EQ.1 ) THEN
25449 ELSEIF ( NQQPD.EQ.2 ) THEN
25450 QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25451 ELSEIF ( NQQPD.EQ.3 ) THEN
25453 ELSEIF ( NQQPD.EQ.4 ) THEN
25454 QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25457 ALPHA = PHO_ALPHAS(QQAL,3)
25458 FACTOR = PI2*GEV2MB*PT*(ALPHA/SP)**2*AKFAC
25459 C parton distributions (times x)
25460 CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
25461 CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
25468 S2 = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
25469 S3 = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
25470 S4 = S4+PDA(I)+PDA(-I)
25471 S5 = S5+PDB(I)+PDB(-I)
25473 C partial cross sections (including color and symmetry factors)
25474 C resolved photon matrix elements (light quarks)
25475 DSIGM(1) = 2.25D0*(3.-((UP*TP)+UP/TT+TP/UU))
25476 DSIGM(6) = (4.D0/9.D0)*(UU+TT)
25477 DSIGM(8) = (4.D0/9.D0)*(1.D0+UU)/TT
25478 DSIGM(2) = (16.D0/27.D0)*(UU+TT)/(UP*TP)-3.D0*DSIGM(6)
25479 DSIGM(3) = ((1.D0+UU)/TT)-(4.D0/9.D0)*(1.D0+UU)/UP
25480 DSIGM(4) = (9.D0/32.D0)*DSIGM(2)
25481 DSIGM(5) = DSIGM(6)+DSIGM(8)-(8.D0/27.D0)*UU/TP
25482 DSIGM(7) = 0.5D0*(DSIGM(8)+(4.D0/9.D0)*(1.D0+TT)/UU-
25483 & (8.D0/27.D0)/(UP*TP))
25485 DSIGM(1) = FACTOR*DSIGM(1)*S1
25486 DSIGM(2) = FACTOR*DSIGM(2)*S2
25487 DSIGM(3) = FACTOR*DSIGM(3)*(PDA(0)*S5+PDB(0)*S4)
25488 DSIGM(4) = FACTOR*DSIGM(4)*S1*NF
25489 DSIGM(5) = FACTOR*DSIGM(5)*S2
25490 DSIGM(6) = FACTOR*DSIGM(6)*S2*MAX(0,(NF-1))
25491 DSIGM(7) = FACTOR*DSIGM(7)*S3
25492 DSIGM(8) = FACTOR*DSIGM(8)*(S4*S5-(S2+S3))
25495 FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25498 IF(DSIGM(I).LT.EPS) DSIGM(I) = 0.D0
25499 DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25500 DSIGMC(9) = DSIGMC(9)+DSIGMC(I)
25504 *$ CREATE PHO_HARXR2.FOR
25506 CDECK ID>, PHO_HARXR2
25507 SUBROUTINE PHO_HARXR2(ECMH,PT,ETAC,DSIGMC)
25508 C**********************************************************************
25510 C differential cross section DSIG/(DETAC*DPT)
25512 C input: ECMH CMS energy
25514 C ETAC pseudorapidity of parton C
25516 C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
25518 C**********************************************************************
25519 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25522 PARAMETER ( TINY= 1.D-20 )
25524 PARAMETER ( Max_pro_2 = 16 )
25526 DIMENSION DSIGMC(0:Max_pro_2)
25528 C input/output channels
25530 COMMON /POINOU/ LI,LO
25531 C integration precision for hard cross sections (obsolete)
25532 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25533 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25536 DIMENSION DSIG1(0:Max_pro_2)
25537 DIMENSION ABSZ(32),WEIG(32)
25540 DSIGMC(M) = CMPLX(0.D0,0.D0)
25546 IF ( ARG.LE.EC .OR. ARG.LE.1.D0/EC ) RETURN
25548 EDL =-LOG(ARG-1.D0/EC)
25550 CALL PHO_GAUSET(EDL,EDU,NPOINT,ABSZ,WEIG)
25552 CALL PHO_HARXR3(ECMH,PT,ETAC,ABSZ(I),DSIG1)
25554 PCTRL= DREAL(DSIG1(M))/TINY
25555 IF( PCTRL.GE.1.D0 ) THEN
25556 DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
25562 *$ CREATE PHO_HARXD2.FOR
25564 CDECK ID>, PHO_HARXD2
25565 SUBROUTINE PHO_HARXD2(ECMH,PT,ETAC,DSIGMC)
25566 C**********************************************************************
25568 C differential cross section DSIG/(DETAC*DPT) for direct processes
25570 C input: ECMH CMS energy of scattering system
25572 C ETAC pseudorapidity of parton C
25574 C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
25576 C**********************************************************************
25577 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25580 PARAMETER ( Max_pro_2 = 16 )
25582 DIMENSION DSIGMC(0:Max_pro_2)
25583 PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-25)
25585 C input/output channels
25587 COMMON /POINOU/ LI,LO
25588 C model switches and parameters
25590 INTEGER ISWMDL,IPAMDL
25591 DOUBLE PRECISION PARMDL
25592 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25593 C data of c.m. system of Pomeron / Reggeon exchange
25594 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25595 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25596 & SIDP,CODP,SIFP,COFP
25597 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25598 & SIDP,CODP,SIFP,COFP,NPOSP(2),
25599 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
25600 C Reggeon phenomenology parameters
25601 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25602 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25603 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25604 & ALREG,ALREGP,GR(2),B0REG(2),
25605 & GPPP,GPPR,B0PPP,B0PPR,
25606 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25607 C currently activated parton density parametrizations
25609 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
25610 DOUBLE PRECISION PDFLAM,PDFQ2M
25611 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
25612 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
25613 C hard scattering parameters used for most recent hard interaction
25615 DOUBLE PRECISION ALQCD2,BQCD
25616 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25617 C some hadron information, will be deleted in future versions
25619 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
25620 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
25621 C scale parameters for parton model calculations
25622 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25623 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25624 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25625 & NQQAL,NQQALI,NQQALF,NQQPD
25627 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25628 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25629 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25631 DOUBLE PRECISION PHO_ALPHAS,pho_alphae
25632 DIMENSION PDA(-6:6),PDB(-6:6),DSIGM(0:Max_pro_2)
25637 DSIGMC(I) = CMPLX(0.D0,0.D0)
25640 DSIGMC(15) = CMPLX(0.D0,0.D0)
25643 C direct particle 1
25644 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
25647 C kinematic conversions
25650 IF ( XB.GE.1.D0 ) THEN
25651 WRITE(LO,'(/1X,A,2E12.4)')
25652 & 'PHO_HARXD2:ERROR: XB>1 (XA,XB)',XA,XB
25655 SP = XA*XB*ECMH*ECMH
25661 C set hard scale QQ for alpha and partondistr.
25662 IF ( NQQAL.EQ.1 ) THEN
25664 ELSEIF ( NQQAL.EQ.2 ) THEN
25665 QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25666 ELSEIF ( NQQAL.EQ.3 ) THEN
25668 ELSEIF ( NQQAL.EQ.4 ) THEN
25669 QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25671 IF ( NQQPD.EQ.1 ) THEN
25673 ELSEIF ( NQQPD.EQ.2 ) THEN
25674 QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25675 ELSEIF ( NQQPD.EQ.3 ) THEN
25677 ELSEIF ( NQQPD.EQ.4 ) THEN
25678 QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25681 ALPHA2 = PHO_ALPHAS(QQAL,2)
25682 IF(IDPDG1.EQ.22) THEN
25683 ALPHA1 = pho_alphae(QQAL)
25684 ELSE IF(IDPDG1.EQ.990) THEN
25685 ALPHA1 = PARMDL(74)
25687 FACTOR = -PI2*GEV2MB*UP/PT*ALPHA1*ALPHA2/SP*AKFAC
25688 C parton distribution (times x)
25689 CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
25694 IF(IDPDG1.EQ.22) THEN
25696 * IF(MOD(I,2).EQ.0) THEN
25697 * S2 = S2 + (PDB(I)+PDB(-I))*TWO32
25700 * S2 = S2 + (PDB(I)+PDB(-I))*ONE32
25703 S2 = S2 + (PDB(I)+PDB(-I))*Q_ch2(I)
25706 ELSE IF(IDPDG1.EQ.990) THEN
25708 S2 = S2 + PDB(I)+PDB(-I)
25712 C partial cross sections (including color and symmetry factors)
25713 C direct photon matrix elements
25714 DSIGM(10) = -8.D0/3.D0*(UU+1.D0)/UP
25715 DSIGM(11) = (UU+TT)/(UP*TP)
25717 DSIGM(10) = FACTOR*DSIGM(10)*S2
25718 DSIGM(11) = FACTOR*DSIGM(11)*S1*S3
25721 FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25724 IF(DSIGM(I).LT.0.D0) THEN
25725 WRITE(LO,'(1X,A,I3,1P,2E12.4)')
25726 & 'PHO_HARXD2: neg. cross section',I,DSIGM(I),ECMH
25729 DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25730 DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
25734 C direct particle 2
25735 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25737 ED = 1.D0/(ECMH/PT-1.D0/EC)
25738 C kinematic conversions
25739 XA = PT*(EC+ED)/ECMH
25741 IF ( XA.GE.1.D0 ) THEN
25742 WRITE(LO,'(/1X,A,2E12.4)')
25743 & 'PHO_HARXD2:ERROR:XA>1 (XA,XB)',XA,XB
25746 SP = XA*XB*ECMH*ECMH
25752 C set hard scale QQ for alpha and partondistr.
25753 IF ( NQQAL.EQ.1 ) THEN
25755 ELSEIF ( NQQAL.EQ.2 ) THEN
25756 QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25757 ELSEIF ( NQQAL.EQ.3 ) THEN
25759 ELSEIF ( NQQAL.EQ.4 ) THEN
25760 QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25762 IF ( NQQPD.EQ.1 ) THEN
25764 ELSEIF ( NQQPD.EQ.2 ) THEN
25765 QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25766 ELSEIF ( NQQPD.EQ.3 ) THEN
25768 ELSEIF ( NQQPD.EQ.4 ) THEN
25769 QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25772 ALPHA1 = PHO_ALPHAS(QQAL,1)
25773 IF(IDPDG2.EQ.22) THEN
25774 ALPHA2 = pho_alphae(QQAL)
25775 ELSE IF(IDPDG2.EQ.990) THEN
25776 ALPHA2 = PARMDL(74)
25778 FACTOR = -PI2*GEV2MB*TP/PT*ALPHA1*ALPHA2/SP*AKFAC
25779 C parton distribution (times x)
25780 CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
25785 IF(IDPDG2.EQ.22) THEN
25787 * IF(MOD(I,2).EQ.0) THEN
25788 * S2 = S2 + (PDA(I)+PDA(-I))*TWO32
25791 * S2 = S2 + (PDA(I)+PDA(-I))*ONE32
25794 S2 = S2 + (PDA(I)+PDA(-I))*Q_ch2(I)
25797 ELSE IF(IDPDG2.EQ.990) THEN
25799 S2 = S2 + PDA(I)+PDA(-I)
25803 C partial cross sections (including color and symmetry factors)
25804 C direct photon matrix elements
25805 DSIGM(12) = -8.D0/3.D0*(TT+1.D0)/TP
25806 DSIGM(13) = (UU+TT)/(UP*TP)
25808 DSIGM(12) = FACTOR*DSIGM(12)*S2
25809 DSIGM(13) = FACTOR*DSIGM(13)*S3*S1
25812 FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25815 IF(DSIGM(I).LT.0.D0) THEN
25816 WRITE(LO,'(1X,A,I3,1P,2E12.4)')
25817 & 'PHO_HARXD2: neg. cross section:',I,DSIGM(I),ECMH
25820 DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25821 DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
25826 *$ CREATE PHO_HARXPT.FOR
25828 CDECK ID>, PHO_HARXPT
25829 SUBROUTINE PHO_HARXPT(ECMH,PT,IPRO,DSIGMC)
25830 C**********************************************************************
25832 C differential cross section DSIG/DPT
25834 C input: ECMH CMS energy of scattering system
25836 C IPRO 1 resolved processes
25837 C 2 direct processes
25838 C 3 resolved and direct processes
25840 C output: DSIGMC(0:12) QCD-PM cross sections dsigma/dpt
25842 C**********************************************************************
25843 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25846 PARAMETER ( Max_pro_2 = 16 )
25848 DIMENSION DSIGMC(0:Max_pro_2)
25849 PARAMETER ( TINY= 1.D-10, ONEP1=1.1, EPS=1.D-25)
25851 C input/output channels
25853 COMMON /POINOU/ LI,LO
25855 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25856 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25857 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25858 C model switches and parameters
25860 INTEGER ISWMDL,IPAMDL
25861 DOUBLE PRECISION PARMDL
25862 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25863 C data of c.m. system of Pomeron / Reggeon exchange
25864 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25865 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25866 & SIDP,CODP,SIFP,COFP
25867 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25868 & SIDP,CODP,SIFP,COFP,NPOSP(2),
25869 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
25870 C Reggeon phenomenology parameters
25871 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25872 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25873 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25874 & ALREG,ALREGP,GR(2),B0REG(2),
25875 & GPPP,GPPR,B0PPP,B0PPR,
25876 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25877 C integration precision for hard cross sections (obsolete)
25878 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25879 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25880 C hard scattering parameters used for most recent hard interaction
25882 DOUBLE PRECISION ALQCD2,BQCD
25883 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25884 C some hadron information, will be deleted in future versions
25886 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
25887 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
25889 double precision pho_alphae
25892 DIMENSION DSIG1(0:Max_pro_2)
25893 DIMENSION ABSZ(32),WEIG(32)
25895 DO 10 M=0,Max_pro_2
25896 DSIGMC(M) = CMPLX(0.D0,0.D0)
25897 DSIG1(M) = CMPLX(0.D0,0.D0)
25900 C resolved and direct processes
25902 IF ( AMT.GE.1.D0 ) RETURN
25903 ECU = LOG((SQRT(1.D0-AMT*AMT)+1.D0)/AMT)
25906 CALL PHO_GAUSET(ECL,ECU,NPOINT,ABSZ,WEIG)
25908 DSIG1(9) = CMPLX(0.D0,0.D0)
25909 DSIG1(15) = CMPLX(0.D0,0.D0)
25911 CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
25912 ELSE IF(IPRO.EQ.2) THEN
25913 CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
25915 CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
25916 CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
25918 DO 20 M=1,Max_pro_2
25919 DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
25924 IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
25925 & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
25928 ALPHAE = pho_alphae(SS)
25930 IF(IDPDG1.EQ.22) THEN
25931 * F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
25932 F1 = Q_ch2(I)*ALPHAE
25936 IF(IDPDG2.EQ.22) THEN
25937 * F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
25938 F2 = Q_ch2(I)*ALPHAE
25942 FAC = FAC+F1*F2*3.D0
25944 C direct cross sections
25945 ZZ = SQRT(1.D0-4.D0*PT*PT/SS+TINY)
25946 T1 = -SS/2.D0*(1.D0+ZZ)
25947 T2 = -SS/2.D0*(1.D0-ZZ)
25948 XM = -2.D0*PT/ZZ*((SS+T1)/T1+T1/(SS+T1)+(SS+T2)/T2+T2/(SS+T2))
25950 DSIGMC(14) = GEV2MB*2.D0*PI*FAC/(SS*SS)*XM*AKFAC
25952 C leptonic part (e, mu, tau)
25954 IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
25955 DSIGMC(16) = DSIGMC(14)/FAC*3.D0*ALPHAE**2
25956 C simulation of tau together with quarks
25957 IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
25961 DSIGMC(15) = DSIGMC(15)+DSIGMC(14)
25962 DSIGMC(0) = DSIGMC(9)+DSIGMC(15)
25966 *$ CREATE PHO_HARXTO.FOR
25968 CDECK ID>, PHO_HARXTO
25969 SUBROUTINE PHO_HARXTO(ECMH,PTCUTR,PTCUTD,DSIGMC,DSDPTC)
25970 C**********************************************************************
25972 C total hard cross section (perturbative QCD, Parton Model)
25974 C input: ECMH CMS energy of scattering system
25975 C PTCUTR PT cutoff for resolved processes
25976 C PTCUTD PT cutoff for direct processes (photon, Pomeron)
25978 C output: DSIGMC(0:MARPR2) cross sections for given cutoff
25979 C DSDPTC(0:MARPR2) differential cross sections at cutoff
25981 C note: COMPLEX*16 DSIGMC
25982 C DOUBLE PRECISION DSDPTC
25984 C**********************************************************************
25985 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25988 PARAMETER ( Max_pro_2 = 16 )
25990 DIMENSION DSIGMC(0:Max_pro_2),DSDPTC(0:Max_pro_2)
25992 C input/output channels
25994 COMMON /POINOU/ LI,LO
25995 C model switches and parameters
25997 INTEGER ISWMDL,IPAMDL
25998 DOUBLE PRECISION PARMDL
25999 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
26000 C data of c.m. system of Pomeron / Reggeon exchange
26001 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
26002 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
26003 & SIDP,CODP,SIFP,COFP
26004 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
26005 & SIDP,CODP,SIFP,COFP,NPOSP(2),
26006 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
26007 C Reggeon phenomenology parameters
26008 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
26009 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
26010 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
26011 & ALREG,ALREGP,GR(2),B0REG(2),
26012 & GPPP,GPPR,B0PPP,B0PPR,
26013 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
26015 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
26016 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
26017 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
26018 C integration precision for hard cross sections (obsolete)
26019 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
26020 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
26021 C some hadron information, will be deleted in future versions
26023 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
26024 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
26025 C hard scattering parameters used for most recent hard interaction
26027 DOUBLE PRECISION ALQCD2,BQCD
26028 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
26030 double precision pho_alphae
26033 DIMENSION DSIG1(0:Max_pro_2)
26034 DIMENSION ABSZ(32),WEIG(32)
26038 DO 10 M=0,Max_pro_2
26039 DSIGMC(M)= CMPLX(0.D0,0.D0)
26043 IF ( PTCUTR.GE.EEC ) GOTO 100
26045 C integration for resolved processes
26047 PTMAX = MIN(FAC*PTMIN,EEC)
26049 CALL PHO_HARXPT(ECMH,PTMIN,1,DSIG1)
26051 DSDPTC(M) = DREAL(DSIG1(M))
26053 DSIGH = DREAL(DSIG1(9))
26054 PTMXX = 0.95D0*PTMAX
26055 CALL PHO_HARXPT(ECMH,PTMXX,1,DSIG1)
26056 DSIGL = DREAL(DSIG1(9))
26057 EX = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
26060 IF ( PTMIN.GE.PTMAX ) GOTO 40
26063 CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
26066 PT = R**(1.0D0/EX1)
26067 CALL PHO_HARXPT(ECMH,PT,1,DSIG1)
26068 F = WEIG(I)*PT/(R*EX1)
26070 DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
26078 DSIGMC(0) = DSIGMC(9)
26079 DSDPTC(0) = DSDPTC(9)
26081 C integration for direct processes
26082 IF((PTCUTD.GE.EEC).OR.(PTCUTD.LT.0.5D0)) RETURN
26084 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
26085 & .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
26087 PTMAX = MIN(FAC*PTMIN,EEC)
26089 CALL PHO_HARXPT(ECMH,PTMIN,2,DSIG1)
26090 IF(DREAL(DSIG1(15)).LT.1.D-15) GOTO 170
26092 DSDPTC(M) = DREAL(DSIG1(M))
26094 DSIGH = DREAL(DSIG1(15)-DSIG1(14))
26095 PTMXX = 0.95D0*PTMAX
26096 CALL PHO_HARXPT(ECMH,PTMXX,2,DSIG1)
26097 DSIGL = DREAL(DSIG1(15)-DSIG1(14))
26098 EX = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
26101 IF ( PTMIN.GE.PTMAX ) GOTO 140
26104 CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
26107 PT = R**(1.0D0/EX1)
26108 CALL PHO_HARXPT(ECMH,PT,2,DSIG1)
26109 F = WEIG(I)*PT/(R*EX1)
26111 DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
26122 C double direct process
26123 IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
26124 & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
26127 ALPHAE = pho_alphae(SS)
26129 IF(IDPDG1.EQ.22) THEN
26130 * F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
26131 F1 = Q_ch2(I)*ALPHAE
26135 IF(IDPDG2.EQ.22) THEN
26136 * F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
26137 F2 = Q_ch2(I)*ALPHAE
26141 FACC = FACC + F1*F2*3.D0
26144 ZZ = SQRT(1.D0-4.D0*PTCUTD*PTCUTD/SS)
26145 R = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)*GEV2MB
26146 C hadronic cross section
26147 DSIGMC(14) = R*FACC*AKFAC
26148 C leptonic cross section
26149 IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
26150 DSIGMC(16) = R*3.D0*ALPHAE**2*AKFAC
26151 C simulation of tau together with quarks
26152 IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
26153 DSIGMC(16) = DSIGMC(16)*2.D0/3.D0
26155 DSIGMC(16) = CMPLX(0.D0,0.D0)
26157 C sum of direct part
26158 DSIGMC(15) = CMPLX(0.D0,0.D0)
26160 DSIGMC(15) = DSIGMC(15) + DSIGMC(I)
26163 C total sum (hadronic)
26164 DSIGMC(0) = DSIGMC(9) + DSIGMC(15)
26165 DSDPTC(0) = DSDPTC(9) + DSDPTC(15)
26169 *$ CREATE PHO_HARISR.FOR
26171 CDECK ID>, PHO_HARISR
26172 SUBROUTINE PHO_HARISR(IHPOM,P1,P2,IPF1,IPF2,IPA1,IPA2,IV1,IV2,Q2H,
26173 & XH1,XH2,XHMAX1,XHMAX2,IPB1,IPB2,IVO1,IVO2,XISR1,XISR2,IREJ)
26174 C********************************************************************
26176 C initial state radiation according to DGLAP evolution equations
26177 C (backward evolution, no spin effects)
26179 C input: IHPOM index of hard Pomeron
26180 C negative: delete all previous entries
26181 C P1,P2 4 momenta of hard scattered final partons
26182 C (in CMS of hard scattering)
26183 C IPF1,2 flavours of final partons
26184 C IPA1,2 flavours of initial partons
26185 C IV1,2 valence quark labels (0/1)
26186 C Q2H momentum transfer (squared, positive)
26187 C XH1,XH2 x values of initial partons
26188 C XHMAX1,2 max. x values allowed
26190 C output: all emitted partons in /POPISR/, final state
26191 C partons are the first two entries
26192 C shower evolution traced in /PODGL1/
26193 C IPB1,2 flavours of new initial partons
26194 C XISR1,2 x values of new initial partons
26195 C IVO1,2 valence quark labels (0/1)
26197 C attention: quark numbering according to PDG convention,
26200 C********************************************************************
26201 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26204 PARAMETER (RHOMAS = 0.766D0,
26208 DIMENSION P1(4),P2(4)
26210 C input/output channels
26212 COMMON /POINOU/ LI,LO
26213 C event debugging information
26215 PARAMETER (NMAXD=100)
26216 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
26217 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26218 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
26219 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26220 C internal rejection counters
26222 PARAMETER (NMXJ=60)
26223 CHARACTER*10 REJTIT
26225 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
26226 C model switches and parameters
26228 INTEGER ISWMDL,IPAMDL
26229 DOUBLE PRECISION PARMDL
26230 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
26231 C data of c.m. system of Pomeron / Reggeon exchange
26232 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
26233 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
26234 & SIDP,CODP,SIFP,COFP
26235 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
26236 & SIDP,CODP,SIFP,COFP,NPOSP(2),
26237 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
26238 C some hadron information, will be deleted in future versions
26240 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
26241 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
26242 C currently activated parton density parametrizations
26244 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
26245 DOUBLE PRECISION PDFLAM,PDFQ2M
26246 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
26247 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
26248 C scale parameters for parton model calculations
26249 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
26250 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
26251 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
26252 & NQQAL,NQQALI,NQQALF,NQQPD
26253 C parameters for DGLAP backward evolution in ISR
26255 DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
26256 COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
26257 C initial state parton radiation (internal part)
26258 INTEGER MXISR3,MXISR4
26259 PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
26260 INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
26261 DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
26262 COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
26263 & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
26264 & IFL1(2,MXISR3),IFL2(2,MXISR3),
26265 & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
26267 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
26268 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
26269 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
26270 C particles created by initial state evolution
26271 INTEGER MXISR1,MXISR2
26272 PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
26273 INTEGER IFLISR,IPOISR,IMXISR
26274 DOUBLE PRECISION PHISR
26275 COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
26276 & IPOISR(2,2,MXISR2),IMXISR(2)
26278 DOUBLE PRECISION PYP,EER,THER,QMAXR
26281 DIMENSION XHMA(2),NEXT(2),PD1(-6:6),PD2(-6:6),WGGAP(-6:6),
26282 & WGPDF(-6:6),XHMI(2),GB(4),PM(4),PN(4),PC(2,4),Q2(2),
26283 & IVAL(2),IPAL(2),IL(2),IFSUM(2),IDMO(2)
26289 IF(IDEB(79).GE.10) THEN
26290 WRITE(LO,'(1X,A,/1X,I10,3I3,5E11.3,2(/5X,4E12.3))')
26291 & 'PHO_HARISR: KEV,IHPOM,IP1,IP2,Q2H,XH1,XH2,XHM1,XHM2:',
26292 & KEVENT,IHPOM,IPA1,IPA2,Q2H,XH1,XH2,XHMAX1,XHMAX2,P1,P2
26294 IF(IHPOM.EQ.0) RETURN
26301 C copy final state partons to local fields
26303 IF(IHIDX.GT.MXISR2) THEN
26304 WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26305 & '/POPISR/ for hard scattering labels (IHIDX,MXISR2):',
26310 IF(IHPOM.LT.0) IMXISR(K) = 0
26311 IPOISR(K,1,IHIDX) = IMXISR(K)+1
26312 IPAL(K) = IPOISR(K,1,IHIDX)
26315 PHISR(1,I,IPAL(1)) = P1(I)
26316 PHISR(2,I,IPAL(2)) = P2(I)
26318 IFLISR(1,IPAL(1)) = IPF1
26319 IFLISR(2,IPAL(2)) = IPF2
26321 C check limitations, initialize /PODGL1/
26322 IF((Q2H.GT.Q2MISR(1)).AND.(XH1.LT.XHMAX1)) THEN
26329 IF((Q2H.GT.Q2MISR(2)).AND.(XH2.LT.XHMAX2)) THEN
26344 IF((IPA1.EQ.22).OR.(IPA1.EQ.990)) NEXT(1) = 0
26347 IF((IPA2.EQ.22).OR.(IPA2.EQ.990)) NEXT(2) = 0
26349 IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,/5X,2I2,3E12.3)')
26350 & 'PHO_HARISR:INITIAL TESTS (NEXT1,2 Q2H Q21,2)',NEXT,Q2H,Q2MISR
26351 IF(NEXT(1)+NEXT(2).EQ.0) GOTO 800
26353 C initialize parton shower loop
26354 B0QCD = (33.D0-2.D0*NFSISR)/6.D0
26355 AL2ISR(1) = PDFLAM(1)
26356 AL2ISR(2) = PDFLAM(2)
26359 XHMI(1) = PMISR(1)/PCMP
26360 XHMI(2) = PMISR(2)/PCMP
26363 SHAT1 = XH1*XH2*ECMP**2
26364 IF(IPAMDL(109).EQ.1) THEN
26367 PT2SH(1,1) = Q2H*(1.D0-Q2H/SHAT1)
26369 PT2SH(2,1) = PT2SH(1,1)
26370 IF(PT2SH(1,1).LT.Q2MISR(1)) NEXT(1) = 0
26371 IF(PT2SH(2,1).LT.Q2MISR(2)) NEXT(2) = 0
26372 THSH(1,1) = 2.D0*SQRT(Q2H/SHAT1)
26373 THSH(2,1) = THSH(1,1)
26377 IF(IREJ.NE.0) GOTO 800
26379 C main generation loop
26380 C -------------------------------------------------
26382 C choose parton side to become solved
26383 IF((NEXT(1)+NEXT(2)).EQ.2) THEN
26384 IF(Q2SH(1,ISH(1)).GT.Q2SH(2,ISH(2))) THEN
26386 ELSE IF(Q2SH(2,ISH(2)).GT.Q2SH(1,ISH(1))) THEN
26389 IP = MAX(INT(DT_RNDM(SHAT1)*2.D0+0.999999D0),1)
26391 ELSE IF(NEXT(1).EQ.1) THEN
26393 ELSE IF(NEXT(2).EQ.1) THEN
26399 C INDX now parton position of parton to become solved
26400 C IP now side to be treated
26402 Q2P = Q2SH(IP,INDX)
26403 PT2 = PT2SH(IP,INDX)
26404 IFLB = IFL1(IP,INDX)
26405 C check available x
26407 C cutoff by x limitation: no further development
26408 IF((XHMA(IP)-XP).LT.XMIP*2.D0) THEN
26410 Q2SH(IP,INDX) = 0.D0
26411 IF(IDEB(79).GE.17) THEN
26412 WRITE(LO,'(1X,A,/5X,3E12.4,2I3)')
26413 & 'PHO_HARISR: evolution x-stop (XP,XMIP,XHMA,IP,INDX)',
26414 & XP,XMIP,XHMA(IP),IP,INDX
26418 C initial value of evolution variable t
26419 TT = LOG(AQQALI*Q2P/AL2ISR(IP))
26420 DO 110 I=-NFSISR,NFSISR
26426 ZMAX = XP/(XP+XMIP)
26428 C q --> q g, g --> g g
26430 WGGAP(0) = CF*((ZMAX**2-ZMIN**2)/2.D0-2.D0*(ZMAX-ZMIN)
26431 & +2.D0*LOG(ZMAX/ZMIN))
26433 WGGAP(I) = WGGAP(0)
26434 WGGAP(-I) = WGGAP(0)
26436 WGGAP(0) = 6.D0*((ZMIN**3-ZMAX**3)/3.D0+(ZMAX**2-ZMIN**2)/2.D0
26437 & -2.D0*(ZMAX-ZMIN)+LOG(ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)))
26438 C q --> g q, g --> q qb
26439 ELSE IF(ABS(IFLB).LE.6) THEN
26440 WGGAP(IFLB) = CF*((ZMIN**2-ZMAX**2)/2.D0-ZMAX+ZMIN
26441 & -2.D0*LOG((1.D0-ZMAX)/(1.D0-ZMIN)))
26442 IF(IVAL(IP).EQ.0) WGGAP(0) = 0.5D0*(2./3.*(ZMAX**3-ZMIN**3)
26443 & -ZMAX**2+ZMIN**2+ZMAX-ZMIN)
26445 WRITE(LO,'(/1X,A,I7)')
26446 & 'PHO_HARISR:ERROR: unsupported particle ID',IFLB
26449 C anomalous/resolved evolution
26451 IF(IPAMDL(110).GE.1) THEN
26452 IF((IDMO(IP).EQ.22).AND.(IFLB.NE.0)
26453 & .AND.(IFLB.NE.21)) THEN
26455 IF(NQQALI.EQ.1) THEN
26460 CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26462 CALL PHO_QPMPDF(IFLB,XP,SCALE2,PTA1,PVIRTP(IP),WGDIR)
26463 XI = DT_RNDM(XP)*PD1(IFLB)
26464 IF(WGDIR.GT.XI) THEN
26466 IF(IDEB(79).GE.17) WRITE(LO,'(1X,2A,/5X,4E12.5,I2,I3)')
26468 & 'direct splitting (WGDIR,WGPDF,X,SCALE2,IP,IFLB)',
26469 & WGDIR,PD1(IFLB),XP,SCALE2,IP,IFLB
26470 Q2SH(IP,INDX) = 0.D0
26478 C rejection loop for z,t sampling
26479 C ------------------------------------
26482 IF(NITER.GE.NTRY) THEN
26483 WRITE(LO,'(1X,A,2I6)')
26484 & 'PHO_HARISR: too many rejections',NITER,NTRY
26485 CALL PHO_PREVNT(-1)
26491 IF(IPDFC.EQ.0) THEN
26492 IF(NQQALI.EQ.1) THEN
26497 CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26502 DO 210 I=-NFSISR,NFSISR
26503 WGPDF(I) = PD1(I)/(PD1(IFLB)+1.D-12)*5.D0
26504 WGTOT = WGTOT+WGPDF(I)*WGGAP(I)
26508 C sample new t value
26509 TT = TT*EXP(MAX(-10.D0,LOG(DT_RNDM(SHAT1))*B0QCD/WGTOT))
26510 Q2NEW = AL2ISR(IP)*EXP(TT)/AQQALI
26512 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.5)')
26513 & 'PHO_HARISR: pre-selected Q2:',Q2NEW
26514 C compare to limits
26515 IF(Q2NEW.LT.Q2MISR(IP)) THEN
26516 Q2SH(IP,INDX) = 0.D0
26518 IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,2E10.3,2I3)')
26519 & 'PHO_HARISR: evolution Q2-stop (Q2,Q2MIN,IP,INDX):',
26520 & Q2NEW,Q2MISR(IP),IP,INDX
26523 Q2SH(IP,INDX) = Q2NEW
26524 TT = LOG(AQQALI*Q2NEW/AL2ISR(IP))
26525 C selection of flavours
26526 XI = WGTOT*DT_RNDM(TT)
26530 XI = XI-WGPDF(IFLA)*WGGAP(IFLA)
26531 IF((XI.GT.0.D0).AND.(IFLA.LT.NFSISR)) GOTO 220
26533 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,2I3)')
26534 & 'PHO_HARISR: pre-selected IFLA (IFLA,IFLB):',IFLA,IFLB
26536 CALL PHO_HARZSP(IFLA,IFLB,NFSISR,ZMIN,ZMAX,ZZ)
26538 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.3)')
26539 & 'PHO_HARISR: pre-selected ZZ',ZZ
26541 THETA = 4.D0*ZZ**2*Q2NEW/((ECMP*XP)**2*(1.D0-ZZ))
26542 IF(THETA.GT.THSH(IP,INDX)) THEN
26543 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,2E12.3)')
26544 & 'PHO_HARISR: reject by angle (NEW/OLD)',
26545 & THETA,THSH(IP,INDX)
26548 C rejection weight given by new PDFs
26550 PT2NEW = Q2NEW*(1.D0-ZZ)
26551 IF(NQQALI.EQ.1) THEN
26552 SCALE2 = PT2NEW*AQQPD
26554 SCALE2 = Q2NEW*AQQPD
26556 IF(SCALE2.LT.Q2MISR(IP)) THEN
26557 Q2SH(IP,INDX) = 0.D0
26559 IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,2E10.3,2I3)')
26560 & 'PHO_HARISR: evol.Q2-stop (SCALE2,Q2MIN,IP,INDX):',
26561 & Q2NEW,Q2MISR(IP),IP,INDX
26564 CALL PHO_PDF(IP,XNEW,SCALE2,0.D0,PD2)
26565 IF(PD2(IFLA).LT.1.D-10) GOTO 200
26566 CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26567 PD1(IFLB) = MAX(PD1(IFLB),1.D-10)
26568 WGF = PD2(IFLA)/PD1(IFLB)/(WGPDF(IFLA)+1.D-12)
26569 IF(NQQALI.EQ.1) WGF = WGF*LOG(Q2NEW*AQQALI/AL2ISR(IP))
26570 & /LOG(PT2NEW*AQQALI/AL2ISR(IP))
26571 IF((WGF.GT.1.D0).AND.(IDEB(79).GE.2)) THEN
26572 WRITE(LO,'(1X,A,E12.3)')
26573 & 'PHO_HARISR: final weight:',WGF
26574 WRITE(LO,'(6X,A,I7,2I3,3E11.3)')
26575 & 'EV,IFLA,IFLB,Q2,PT2,Z:',KEVENT,IFLA,IFLB,Q2NEW,PT2NEW,ZZ
26577 IF(WGF.LT.DT_RNDM(XNEW)) GOTO 200
26579 IF(IDEB(79).GE.15) THEN
26580 WRITE(LO,'(1X,A,/3X,3I3,3E11.3)')
26581 & 'PHO_HARISR: accepted IP,IFLA,IFLB,PT2,Q2,Z:',
26582 & IP,IFLA,IFLB,PT2NEW,Q2NEW,ZZ
26585 IF(INDX.GE.MXISR3) THEN
26586 WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26587 & '/POINT6/ for parton radiation (INDX,MXISR3):',INDX,MXISR3
26591 C branching accepted, registration
26592 Q2SH(IP,INDX) = Q2NEW
26593 PT2SH(IP,INDX) = PT2NEW
26595 IFL2(IP,INDX) = IFLA-IFLB
26596 Q2SH(IP,INDX+1) = Q2NEW
26597 PT2SH(IP,INDX+1) = PT2SH(IP,INDX)
26598 XPSH(IP,INDX+1) = XNEW
26599 THSH(IP,INDX+1) = THETA
26600 IFL1(IP,INDX+1) = IFLA
26601 ISH(IP) = ISH(IP)+1
26604 IF(NACC.GT.MXISR4) THEN
26605 WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26606 & '/POINT6/ for parton radiation (NACC,MXISR4):',NACC,MXISR4
26612 IBRA(2,NACC) = INDX
26615 C generation of next branching
26616 IF(NEXT(1)+NEXT(2).NE.0) GOTO 100
26620 C new initial flavours, x values
26621 IPB1 = IFL1(1,ISH(1))
26622 IPB2 = IFL1(2,ISH(2))
26623 XISR1 = XPSH(1,ISH(1))
26624 XISR2 = XPSH(2,ISH(2))
26629 IF(ISH(1).GT.1) THEN
26630 CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
26631 IF(IDPDG1.EQ.22) THEN
26632 CALL PHO_QPMPDF(IPB1,XISR1,Q2MISR(1),0.D0,PVIRTP(1),FXP)
26633 IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(IPB1)-FXP) IVAL(1) = 1
26635 CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
26636 IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(-IPB1)) IVAL(1) = 1
26641 IF(ISH(2).GT.1) THEN
26642 CALL PHO_PDF(2,XISR2,Q2MISR(2),0.D0,PD1)
26643 IF(IDPDG2.EQ.22) THEN
26644 CALL PHO_QPMPDF(IPB2,XISR2,Q2MISR(2),0.D0,PVIRTP(2),FXP)
26645 IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(IPB2)-FXP) IVAL(2) = 1
26647 IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(-IPB2)) IVAL(2) = 1
26652 C parton kinematics
26654 C final partons in CMS
26655 PM(3) = (XH1-XH2)*ECMP/2.D0
26656 PM(4) = (XH1+XH2)*ECMP/2.D0
26657 SH = XH1*XH2*ECMP**2
26661 CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P1(1),P1(2),P1(3),
26662 & P1(4),PTOT1,PHISR(1,1,IPAL(1)),PHISR(1,2,IPAL(1)),
26663 & PHISR(1,3,IPAL(1)),PHISR(1,4,IPAL(1)))
26664 CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P2(1),P2(2),P2(3),
26665 & P2(4),PTOT1,PHISR(2,1,IPAL(2)),PHISR(2,2,IPAL(2)),
26666 & PHISR(2,3,IPAL(2)),PHISR(2,4,IPAL(2)))
26672 IL(IPA) = IBRA(2,I)
26673 C new initial partons in CMS
26676 SHZ = SH/ZPSH(IPA,IL(IPA))
26678 Q2(1) = Q2SH(1,IL(1))
26679 Q2(2) = Q2SH(2,IL(2))
26682 PC(1,3) = SQRT((SH+Q2(1)+Q2(2))**2-4.D0*Q2(1)*Q2(2))
26684 PC(1,4) = (SH-Q2(1)+Q2(2))/(2.D0*SSH)
26688 PC(2,4) = SSH-PC(1,4)
26689 XMS4 = PHO_PMASS(IFL2(IPA,IL(IPA)),1)**2
26690 EE3 = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
26691 S1 = SH+Q2(IPA)+Q2(IPB)
26692 S3 = SHZ+Q2(IPB)+Q2SH(IPA,IL(IPA)+1)
26693 R1 = SQRT(S1**2-4.D0*Q2(IPA)*Q2(IPB))
26694 R3 = SQRT(S3**2-4.D0*Q2(IPB)*Q2SH(IPA,IL(IPA)+1))
26695 IF(Q2(IPB).LT.0.1D0) THEN
26696 XMS4M = (Q2(IPA)/ZPSH(IPA,IL(IPA))-Q2SH(IPA,IL(IPA)+1))
26697 & *(SH/(SH+Q2(IPA))-SH/(SHZ+Q2SH(IPA,IL(IPA)+1)))
26699 XMS4M = (S1*S3-R1*R3)/(2.D0*Q2(IPB))
26700 & -Q2(IPA)-Q2SH(IPA,IL(IPA)+1)
26703 C max. virtuality for time-like showers
26704 QMAX = MIN(XMS4M,PARMDL(95)*Q2(IPA))
26705 IF((IPAMDL(111).GE.1).AND.(QMAX.GT.PARMDL(94))) THEN
26706 C generate time-like parton shower
26707 KF = IFL2(IPA,IL(IPA))
26708 IF(KF.EQ.0) KF = 21
26709 EER = MIN(EE3-PC(IPA,4),ECMP)
26711 CALL PY1ENT(1,KF,EER,THER,THER)
26713 CALL PYSHOW(1,0,QMAXR)
26715 IF(IDEB(79).GE.25) THEN
26716 WRITE(LO,'(1X,2A,/,5X,1P,4E12.4)') 'PHO_HARISR: ',
26717 & 'PYSHOW called for EE,QMAX,XMS4M,Q2(IPA)',
26718 & EER,QMAX,XMS4M,Q2(IPA)
26729 IF(PYK(K,1).LE.4) THEN
26731 IF(KK.GT.MXISR1) THEN
26732 WRITE(LO,'(1X,2A,2I5)') 'PHO_HARISR: no space ',
26733 & 'left in /POPISR/ (KK,MXISR1):',KK,MXISR1
26737 PHISR(IPA,1,KK) = PYP(K,1)
26738 PJX = PJX+PHISR(IPA,1,KK)
26739 PHISR(IPA,2,KK) = PYP(K,2)
26740 PJY = PJY+PHISR(IPA,2,KK)
26741 PHISR(IPA,3,KK) = PYP(K,3)
26742 PJZ = PJZ+PHISR(IPA,3,KK)
26743 PHISR(IPA,4,KK) = PYP(K,4)
26744 PJE = PJE+PHISR(IPA,4,KK)
26745 IFLISR(IPA,KK) = PYK(K,2)
26746 IF(IFLISR(IPA,KK).EQ.21) IFLISR(IPA,KK) = 0
26747 IF(IFLISR(IPA,KK).EQ.5) IFLISR(IPA,KK) = 3
26748 IF(IFLISR(IPA,KK).EQ.-5) IFLISR(IPA,KK) = -3
26751 NGEN = KK-IPAL(IPA)
26752 XMS4 = (PJE+PJZ)*(PJE-PJZ)-PJX**2-PJY**2
26753 PP4 = SQRT(PJE**2-XMS4)
26754 EE3 = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
26756 IF(IDEB(79).GE.20) WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)')
26758 & 'time-like shower: PJE,PJX,PJY,PJZ,PP4,XMS4',
26759 & PJE,PJX,PJY,PJZ,PP4,XMS4
26762 PZ3 = (2.D0*PC(IPA,4)*EE3+Q2(IPA)+Q2SH(IPA,IL(IPA)+1)+XMS4)
26763 & /(2.D0*PC(IPA,3))
26764 PT3 = (EE3+PZ3)*(EE3-PZ3)+Q2SH(IPA,IL(IPA)+1)
26765 IF(PT3.LT.0.D0) THEN
26766 IF(IDEB(79).GE.5) WRITE(LO,'(1X,A,E12.3)')
26767 & 'PHO_HARISR: rejection due to PT3',PT3
26771 CALL PHO_SFECFE(SFE,CFE)
26776 C time-like shower generated
26777 EE4 = EE3-PC(IPA,4)
26778 PZ4 = PZ3-PC(IPA,3)
26779 PP4 = SQRT(PT3**2+PZ4**2)
26781 GAM = (EE4*PJE-PP4*PJZ)/XMS4
26782 BEG = (PJE*PP4-EE4*PJZ)/XMS4
26785 SIDD = SQRT(PX3**2+PY3**2)/PP4
26788 IF(PP4*SIDD.GT.1.D-5) THEN
26789 COFD = PX3/(SIDD*PP4)
26790 SIFD = PY3/(SIDD*PP4)
26791 ANORF = SQRT(COFD*COFD+SIFD*SIFD)
26795 C copy partons back
26799 PX = PHISR(IPA,1,KK)
26800 PY = PHISR(IPA,2,KK)
26801 PZ = PHISR(IPA,3,KK)
26802 COH= PHISR(IPA,4,KK)
26803 EE = GAM*COH+BEG*PZ
26804 PZ = GAM*PZ +BEG*COH
26805 PHISR(IPA,4,KK) = EE
26806 CALL PHO_TRANS(PX,PY,PZ,CODD,SIDD,COFD,SIFD,
26807 & PHISR(IPA,1,KK),PHISR(IPA,2,KK),PHISR(IPA,3,KK))
26811 C no time-like shower generated
26812 IPAL(IPA) = IPAL(IPA)+1
26813 PHISR(IPA,1,IPAL(IPA)) = PX3
26814 PHISR(IPA,2,IPAL(IPA)) = PY3
26815 PHISR(IPA,3,IPAL(IPA)) = PZ3-PC(IPA,3)
26816 PHISR(IPA,4,IPAL(IPA)) = EE3-PC(IPA,4)
26817 IFLISR(IPA,IPAL(IPA)) = IFL2(IPA,IL(IPA))
26823 C boost / rotate into new CMS
26825 GB(K) = (PC(1,K)+PC(2,K))/SSHZ
26827 CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),PC(1,1),PC(1,2),
26828 & PC(1,3),PC(1,4),PTOT1,PM(1),PM(2),PM(3),PM(4))
26830 SIG= SQRT(PM(1)**2+PM(2)**2)/PTOT1
26833 IF(PTOT1*SIG.GT.1.D-5) THEN
26834 COH=PM(1)/(SIG*PTOT1)
26835 SIH=PM(2)/(SIG*PTOT1)
26836 ANORF=SQRT(COH*COH+SIH*SIH)
26841 DO 844 L=IPOISR(K,1,IHIDX),IPAL(K)
26842 CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),
26843 & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),
26844 & PTOT1,PM(1),PM(2),PM(3),PM(4))
26845 CALL PHO_TRANI(PM(1),PM(2),PM(3),COG,SIG,COH,SIH,PN(1),
26847 CALL PHO_TRANS(PN(1),PN(2),PN(3),1.D0,0.D0,COH,SIH,
26848 & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L))
26849 PHISR(K,4,L) = PM(4)
26853 C boost back to global CMS
26854 PM(3) = (XISR1-XISR2)/2.D0
26855 PM(4) = (XISR1+XISR2)/2.D0
26856 SSH = SQRT(XISR1*XISR2)
26860 DO 944 L=IPOISR(K,1,IHIDX),IPAL(K)
26861 CALL PHO_ALTRA(GB(4),0.D0,0.D0,GB(3),PHISR(K,1,L),
26862 & PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),PTOT1,PM(1),
26863 & PM(2),PM(3),PM(4))
26864 PHISR(K,1,L) = PM(1)
26865 PHISR(K,2,L) = PM(2)
26866 PHISR(K,3,L) = PM(3)
26867 PHISR(K,4,L) = PM(4)
26871 IPOISR(1,2,IHIDX) = IPAL(1)
26872 IPOISR(2,2,IHIDX) = IPAL(2)
26873 IMXISR(1) = IPAL(1)
26874 IMXISR(2) = IPAL(2)
26877 IF(IDEB(79).GE.10) THEN
26878 WRITE(LO,'(1X,A,2I10/,6X,A,2E12.3,2I5)') 'NUMBER OF EMISSIONS',
26879 & ISH(1)-1,ISH(2)-1,'NEW X1,X2,IFL1,ILF2',XISR1,XISR2,IPB1,IPB2
26881 WRITE(LO,'(1X,A,2I5,/6X,A)')
26882 & 'PHO_HARISR: ISR configuration (NITER,NACC)',NITER,NACC,
26883 & ' SIDE NO. IFLB IFLC Q2SH PT2SH XH ZZ'
26887 WRITE(LO,'(5X,4I5,4E11.3)')
26888 & K,I,IFL1(K,I),IFL2(K,I),Q2SH(K,I),PT2SH(K,I),XPSH(K,I),
26892 C check of final configuration
26899 WRITE(LO,'(1X,A)') 'PHO_HARISR: outgoing partons'
26901 DO 744 L=IPOISR(K,1,IHIDX),IPOISR(K,2,IHIDX)
26902 WRITE(LO,'(6X,2I4,I6,4E11.3)') K,L,IFLISR(K,L),
26903 & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L)
26904 IFSUM(K) = IFSUM(K)+ IFLISR(K,L)
26905 PX3 = PX3 + PHISR(K,1,L)
26906 PY3 = PY3 + PHISR(K,2,L)
26907 PZ3 = PZ3 + PHISR(K,3,L)
26908 EE3 = EE3 + PHISR(K,4,L)
26911 IFSUM(1) = IFSUM(1)-IPB1
26912 IFSUM(2) = IFSUM(2)-IPB2
26913 PZ3 = PZ3 -(XISR1-XISR2)*ECMP/2.D0
26914 EE3 = EE3 -(XISR1+XISR2)*ECMP/2.D0
26915 WRITE(LO,'(1X,A,2I4,4E11.3)') 'CHECK:IFL1,2 PCM(1-4)',
26916 & IFSUM,PX3,PY3,PZ3,EE3
26920 *$ CREATE PHO_HARZSP.FOR
26922 CDECK ID>, PHO_HARZSP
26923 SUBROUTINE PHO_HARZSP(IFLA,IFLB,NFSH,ZMIN,ZMAX,ZZ)
26924 C*********************************************************************
26926 C sampling of z values from DGLAP kernels
26928 C input: IFLA,IFLB parton flavours
26929 C NFSH flavours involved in hard processes
26930 C ZMIN minimal ZZ allowed
26931 C ZMAX maximal ZZ allowed
26933 C output: ZZ z value
26935 C*********************************************************************
26936 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26939 PARAMETER ( DEPS = 1.D-10 )
26941 C input/output channels
26943 COMMON /POINOU/ LI,LO
26944 C event debugging information
26946 PARAMETER (NMAXD=100)
26947 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
26948 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26949 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
26950 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26951 C internal rejection counters
26953 PARAMETER (NMXJ=60)
26954 CHARACTER*10 REJTIT
26956 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
26958 IF(ZMAX.LE.ZMIN) THEN
26959 WRITE(LO,'(1X,A,2E12.3)')
26960 & 'PHO_HARZSP: ZMAX<ZMIN (ZMAX,ZMIN)',ZMAX,ZMIN
26961 CALL PHO_PREVNT(-1)
26969 C1 = ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)
26970 C2 = (1.D0-ZMIN)/ZMIN
26972 ZZ = 1.D0/(1.D0+C2/C1**DT_RNDM(ZMIN))
26973 IF(((1.D0-ZZ*(1.D0-ZZ))**2).LT.DT_RNDM(ZMAX)) GOTO 100
26974 ELSE IF(ABS(IFLA).LE.NFSH) THEN
26978 ZZ = ZMIN*C1**DT_RNDM(ZMIN)
26979 IF((0.5D0*(1.D0+(1.D0-ZZ)**2)).LT.DT_RNDM(ZMAX)) GOTO 200
26983 ELSE IF(ABS(IFLB).LE.NFSH) THEN
26988 ZZ = ZMIN+C1*DT_RNDM(ZMIN)
26989 IF((2.D0*ZZ*(ZZ-1.D0)+1.D0).LT.DT_RNDM(ZMAX)) GOTO 300
26990 ELSE IF(ABS(IFLA).LE.NFSH) THEN
26992 C1 = (1.D0-ZMAX)/(1.D0-ZMIN)
26995 ZZ = 1.D0-C2*C1**DT_RNDM(ZMIN)
26996 IF(0.5D0*(1.D0+ZZ**2).LT.DT_RNDM(ZMAX)) GOTO 400
27004 IF(IDEB(80).GE.20) WRITE(LO,'(1X,A,2I3,3E11.3)')
27005 & 'PHO_HARZSP: IFLA,IFLB,ZZ,ZMIN,ZMAX',
27006 & IFLA,IFLB,ZZ,ZMIN,ZMAX
27010 WRITE(LO,'(/1X,A,2I7)') 'PHO_HARZSP:ERROR: invalid flavours A,B',
27016 *$ CREATE PHO_ALPHAE.FOR
27018 CDECK ID>, PHO_ALPHAE
27019 DOUBLE PRECISION FUNCTION PHO_ALPHAE(Q2)
27020 C**********************************************************************
27022 C calculation of ALPHA_em
27024 C input: Q2 scale in GeV**2
27026 C**********************************************************************
27030 DOUBLE PRECISION Q2
27032 C input/output channels
27034 COMMON /POINOU/ LI,LO
27035 C model switches and parameters
27037 INTEGER ISWMDL,IPAMDL
27038 DOUBLE PRECISION PARMDL
27039 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27041 DOUBLE PRECISION PYALEM
27043 pho_alphae = 1.D0/137.D0
27045 if(ipamdl(120).eq.1) then
27046 pho_alphae = PYALEM(Q2)
27051 *$ CREATE PHO_ALPHAS.FOR
27053 CDECK ID>, PHO_ALPHAS
27054 DOUBLE PRECISION FUNCTION PHO_ALPHAS(Q2,IMODE)
27055 C**********************************************************************
27057 C calculation of ALPHA_S
27059 C input: IMODE = 1 lambda_QCD**2 for PDF 1 evolution
27060 C 2 lambda_QCD**2 for PDF 2 evolution
27061 C 3 lambda_QCD**2 for hard scattering
27062 C Q2 scale in GeV**2
27064 C initialization needed:
27065 C IMODE = 0 lambda values taken from PDF table
27066 C -1 given Q2 is 4-flavour lambda 1
27067 C -2 given Q2 is 4-flavour lambda 2
27068 C -3 given Q2 is 4-flavour lambda 3
27071 C**********************************************************************
27075 DOUBLE PRECISION Q2
27078 C input/output channels
27080 COMMON /POINOU/ LI,LO
27081 C model switches and parameters
27083 INTEGER ISWMDL,IPAMDL
27084 DOUBLE PRECISION PARMDL
27085 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27086 C hard scattering parameters used for most recent hard interaction
27088 DOUBLE PRECISION ALQCD2,BQCD
27089 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
27090 C currently activated parton density parametrizations
27092 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
27093 DOUBLE PRECISION PDFLAM,PDFQ2M
27094 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
27095 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
27101 IF(IMODE.GT.0) THEN
27103 IF(Q2.LT.PARMDL(148)) THEN
27105 ELSE IF(Q2.LT.PARMDL(149)) THEN
27107 ELSE IF(Q2.LT.PARMDL(150)) THEN
27113 PHO_ALPHAS = BQCD(NFbeta)/LOG(Q2/ALQCD2(IMODE,NFbeta))
27116 ELSE IF(IMODE.EQ.0) THEN
27120 ALQCD2(I,2) = PDFLAM(1)*PDFLAM(2)
27122 ALQCD2(I,2) = PDFLAM(I)*PDFLAM(I)
27124 ALQCD2(I,1) = PARMDL(148)
27125 & *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
27126 ALQCD2(I,3) = PARMDL(149)
27127 & *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
27128 ALQCD2(I,4) = PARMDL(150)
27129 & *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))
27133 ELSE IF(IMODE.LT.0) THEN
27135 if(IMODE.eq.-4) then
27137 ALQCD2(I,2) = SQRT(ALQCD2(1,2)*ALQCD2(2,2))
27142 ALQCD2(I,1) = PARMDL(148)
27143 & *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
27144 ALQCD2(I,3) = PARMDL(149)
27145 & *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
27146 ALQCD2(I,4) = PARMDL(150)
27147 & *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))
27153 *$ CREATE PHO_DFWRAP.FOR
27155 CDECK ID>, PHO_DFWRAP
27156 SUBROUTINE PHO_DFWRAP(MODE,JM1,JM2)
27157 C**********************************************************************
27159 C wrapper for diffraction dissociation in hadron-nucleus and
27160 C nucleus-nucleus collisions with DPMJET
27162 C input: MODE 1: transformation into CMS
27163 C 2: transformation into Lab
27164 C JM1/2 indices of old mother particles
27165 C JM1/2N indices of new mother particles
27167 C**********************************************************************
27171 INTEGER MODE,JM1,JM2
27173 C input/output channels
27175 COMMON /POINOU/ LI,LO
27176 C event debugging information
27178 PARAMETER (NMAXD=100)
27179 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27180 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27181 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27182 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27183 C standard particle data interface
27185 PARAMETER (NMXHEP=4000)
27186 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
27187 DOUBLE PRECISION PHEP,VHEP
27188 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27189 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
27191 C extension to standard particle data interface (PHOJET specific)
27192 INTEGER IMPART,IPHIST,ICOLOR
27193 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
27194 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
27195 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
27196 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
27197 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
27198 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
27200 DOUBLE PRECISION GAMBED(4),P1(4),P2(4),P3(4),P4(4),XM1,XM2
27201 DOUBLE PRECISION SS,ECMD,PTOT1,CODD,SIDD,COFD,SIFD,ANORF
27203 INTEGER I,NHEPS,JM1S,JM2S,JM1N,JM2N,IREJ
27205 C transformation into CMS
27217 P1(1) = PHEP(1,JM1)+PHEP(1,JM2)
27218 P1(2) = PHEP(2,JM1)+PHEP(2,JM2)
27219 P1(3) = PHEP(3,JM1)+PHEP(3,JM2)
27220 P1(4) = PHEP(4,JM1)+PHEP(4,JM2)
27221 SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
27224 GAMBED(I) = P1(I)/ECMD
27226 CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
27227 & PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
27228 & PHEP(4,JM1),PTOT1,P1(1),P1(2),P1(3),P1(4))
27231 SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
27234 IF(PTOT1*SIDD.GT.1.D-5) THEN
27235 COFD = P1(1)/(SIDD*PTOT1)
27236 SIFD = P1(2)/(SIDD*PTOT1)
27237 ANORF= SQRT(COFD*COFD+SIFD*SIFD)
27242 C initial particles in CMS
27246 P1(3) = ECMD/2.D0*XPSUB
27251 P2(3) = -ECMD/2.D0*XTSUB
27254 CALL PHO_MSHELL(P1,P2,XM1,XM2,P3,P4,IREJ)
27256 CALL PHO_REGPAR(1,IDHEP(JM1),IMPART(JM1),JM1,JM2,
27257 & P3(1),P3(2),P3(3),P3(4),IPHIST(1,JM1),IPHIST(2,JM1),
27258 & ICOLOR(1,JM1),ICOLOR(2,JM1),JM1N,1)
27260 CALL PHO_REGPAR(1,IDHEP(JM2),IMPART(JM2),JM2,JM1,
27261 & P4(1),P4(2),P4(3),P4(4),IPHIST(1,JM2),IPHIST(2,JM2),
27262 & ICOLOR(1,JM2),ICOLOR(2,JM2),JM2N,1)
27267 C transformation into lab.
27269 ELSE IF(MODE.EQ.2) THEN
27271 CALL PHO_LTRHEP(JM1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
27272 & GAMBED(1),GAMBED(2),GAMBED(3))
27277 C clean up after rejection
27279 ELSE IF(MODE.EQ.-2) THEN
27288 WRITE(LO,'(1X,A,I6)') 'PHO_DFWRAP: invalid MODE parameter:',MODE
27294 *$ CREATE PHO_DIFDIS.FOR
27296 CDECK ID>, PHO_DIFDIS
27297 SUBROUTINE PHO_DIFDIS(IDIF1,IDIF2,IMOTH1,IMOTH2,SPROB,IMODE,
27298 & MSOFT,MHARD,IREJ)
27299 C***********************************************************************
27301 C sampling of diffractive events of different kinds,
27302 C (produced particles stored in /POEVT1/)
27304 C input: IDIF1/2 diffractive process particle 1/2
27305 C 0 elastic/quasi-elastic scattering
27306 C 1 diffraction dissociation
27307 C IMOTH1/2 index of mother particles in /POEVT1/
27308 C SPROB suppression factor (survival probability) for
27309 C resolved diffraction dissociation
27310 C IMODE mode of operation
27311 C 0 sampling of diffractive cut
27312 C 1 sampling of enhanced cut
27313 C 2 sampling of diffractive cut without
27314 C scattering (needed for double-pomeron)
27315 C -1 initialization
27316 C -2 output of statistics
27318 C output: MSOFT number of generated soft strings
27319 C MHARD number of generated hard strings
27320 C IDIF1/2 diffraction label for particle 1/2 in /PROCES/
27321 C 0 quasi elastic scattering
27322 C 1 low-mass diffractive dissociation
27323 C 2 soft high-mass diffractive dissociation
27324 C 3 hard resolved diffractive dissociation
27325 C 4 hard direct diffractive dissociation
27326 C IREJ rejection label
27327 C 0 successful generation of partons
27330 C***********************************************************************
27331 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27334 PARAMETER ( EPS = 1.D-7,
27337 C input/output channels
27339 COMMON /POINOU/ LI,LO
27340 C event debugging information
27342 PARAMETER (NMAXD=100)
27343 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27344 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27345 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27346 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27347 C general process information
27348 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
27349 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
27350 C internal rejection counters
27352 PARAMETER (NMXJ=60)
27353 CHARACTER*10 REJTIT
27355 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
27356 C global event kinematics and particle IDs
27357 INTEGER IFPAP,IFPAB
27358 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
27359 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
27360 C c.m. kinematics of diffraction
27362 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
27363 & SIDD,CODD,SIFD,COFD,PDCMS
27364 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
27365 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
27366 C obsolete cut-off information
27367 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
27368 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
27370 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
27371 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
27372 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
27373 C model switches and parameters
27375 INTEGER ISWMDL,IPAMDL
27376 DOUBLE PRECISION PARMDL
27377 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27378 C Reggeon phenomenology parameters
27379 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
27380 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
27381 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
27382 & ALREG,ALREGP,GR(2),B0REG(2),
27383 & GPPP,GPPR,B0PPP,B0PPR,
27384 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
27385 C parameters of 2x2 channel model
27386 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
27387 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
27388 C table of particle indices for recursive PHOJET calls
27390 PARAMETER ( MAXIPX = 100 )
27391 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
27392 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
27393 & IPOIX1,IPOIX2,IPOIX3
27394 C standard particle data interface
27396 PARAMETER (NMXHEP=4000)
27397 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
27398 DOUBLE PRECISION PHEP,VHEP
27399 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27400 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
27402 C extension to standard particle data interface (PHOJET specific)
27403 INTEGER IMPART,IPHIST,ICOLOR
27404 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
27405 C event weights and generated cross section
27406 INTEGER IPOWGC,ISWCUT,IVWGHT
27407 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
27408 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
27409 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
27411 DOUBLE PRECISION P1,P2,XMASS,AMP,PP,PD1,PD2
27412 DIMENSION P1(5),P2(5),XMASS(2),AMP(2),PP(7,2),PD1(7),PD2(7)
27413 DIMENSION IDPDG(2),IDBAM(2),IPAR(2),IPOSP(2,2),IRPDG(2),IVEC(2),
27414 & IRBAM(2),IFL1P(2),IFL2P(2),ISAM(2),JSAM(2),KSAM(2),
27417 IF(IMODE.EQ.-1) THEN
27420 ELSE IF(IMODE.EQ.-2) THEN
27421 C output of statistics
27429 IF(IDEB(45).GE.10) THEN
27430 WRITE(LO,'(1X,2A,/16X,7I6)') 'PHO_DIFDIS: (1) ',
27431 & 'IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
27432 & IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE
27436 C save current status
27446 JDA11 = JDAHEP(1,IMOTH1)
27447 JDA21 = JDAHEP(2,IMOTH1)
27448 JDA12 = JDAHEP(1,IMOTH2)
27449 JDA22 = JDAHEP(2,IMOTH2)
27450 ISTH1 = ISTHEP(IMOTH1)
27451 ISTH2 = ISTHEP(IMOTH2)
27457 IDPDG(I) = IDHEP(NPOSD(I))
27458 IDBAM(I) = IMPART(NPOSD(I))
27459 AMP(I) = PHO_PMASS(IDBAM(I),0)
27460 IF(IDPDG(I).EQ.22) THEN
27461 PMASSD(I) = 0.765D0
27462 PVIRTD(I) = PHEP(5,NPOSD(I))**2
27464 PMASSD(I) = PHO_PMASS(IDBAM(I),0)
27469 P1(1) = PHEP(1,IMOTH1)+PHEP(1,IMOTH2)
27470 P1(2) = PHEP(2,IMOTH1)+PHEP(2,IMOTH2)
27471 P1(3) = PHEP(3,IMOTH1)+PHEP(3,IMOTH2)
27472 P1(4) = PHEP(4,IMOTH1)+PHEP(4,IMOTH2)
27473 SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
27475 IF(IDEB(45).GE.15) WRITE(LO,'(1X,A,E12.4)')
27476 & 'PHO_DIFDIS: availabe energy',ECMD
27477 C check total available energy
27478 IF((AMP(1)+AMP(2)+0.1D0).GE.ECMD) THEN
27479 IF(IDEB(45).GE.2) WRITE(LO,'(1X,2A,/5X,A,1P,3E11.3)')
27481 & 'not enough energy for inelastic diffraction',
27482 & 'ECM, particle masses:',ECMD,AMP
27483 IFAIL(7) = IFAIL(7)+1
27489 GAMBED(I) = P1(I)/ECMD
27491 CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
27492 & PHEP(1,IMOTH1),PHEP(2,IMOTH1),PHEP(3,IMOTH1),
27493 & PHEP(4,IMOTH1),PTOT1,P1(1),P1(2),P1(3),P1(4))
27496 SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
27499 IF(PTOT1*SIDD.GT.1.D-5) THEN
27500 COFD = P1(1)/(SIDD*PTOT1)
27501 SIFD = P1(2)/(SIDD*PTOT1)
27502 ANORF= SQRT(COFD*COFD+SIFD*SIFD)
27506 C initial particles in CMS
27513 PDCMS(3,2) = -PTOT1
27514 PDCMS(4,2) = ECMD-P1(4)
27515 C get new CM momentum
27516 AM12 = PMASSD(1)**2
27517 AM22 = PMASSD(2)**2
27518 PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)
27520 C coherence constraint (min/max diffractive mass allowed)
27521 IF(IMODE.EQ.2) THEN
27522 THRM1 = PARMDL(71)/SQRT(1-PARMDL(72))
27523 THRM1 = MAX(THRM1,PARMDL(70)*PARMDL(71))
27524 THRM2 = SQRT(1-PARMDL(72))*ECMD
27525 THRM2 = MIN(THRM2,ECMD/PARMDL(70))
27528 THRM2 = PARMDL(45)*ECMD
27529 C check kinematic limits
27530 IF(THRM2.LE.(4.D0*PARMDL(162))) IPAR(1) = MIN(IPAR(1),1)
27531 IF(THRM2.LE.(4.D0*PARMDL(163))) IPAR(2) = MIN(IPAR(2),1)
27534 C check energy vs. coherence constraints
27535 IF(MAX(PARMDL(162),PMASSD(1)+THRM1).GE.THRM2) IPAR(1) = 0
27536 IF(MAX(PARMDL(163),PMASSD(2)+THRM1).GE.THRM2) IPAR(2) = 0
27538 C no phase space available
27539 IF(IPAR(1)+IPAR(2).EQ.0) THEN
27540 IF(IDEB(45).GE.2) WRITE(LO,'(1X,2A,1P,E11.3,2(/5X,A,2E11.3))')
27542 & 'not enough phase space for ine. diffraction (Ecm)',ECMD,
27543 & 'side 1: min. mass, upper mass limit:',
27544 & MAX(PARMDL(162),PMASSD(1)+THRM1),THRM2,
27545 & 'side 2: min. mass, upper mass limit:',
27546 & MAX(PARMDL(163),PMASSD(2)+THRM1),THRM2
27547 IFAIL(7) = IFAIL(7)+1
27557 C main rejection loop
27558 C -------------------------------
27562 IFAIL(13) = IFAIL(13)+1
27563 IF(ITRY.GE.ITRYM) THEN
27564 IF(IDEB(45).GE.2) WRITE(LO,'(1X,A,I10,2I3)')
27565 & 'PHO_DIFDIS: rejection (KEVE,IPAR1/2) ',KEVENT,IPAR
27566 IFAIL(7) = IFAIL(7)+1
27577 C reset mother-daugther relations
27579 JDAHEP(1,IMOTH1) = JDA11
27580 JDAHEP(2,IMOTH1) = JDA21
27581 JDAHEP(1,IMOTH2) = JDA12
27582 JDAHEP(2,IMOTH2) = JDA22
27583 ISTHEP(IMOTH1) = ISTH1
27584 ISTHEP(IMOTH2) = ISTH2
27593 C calculation of kinematics
27595 C sampling of masses
27598 IFL1P(I) = IDPDG(I)
27599 IFL2P(I) = IDBAM(I)
27605 IF(IPAR(I).EQ.0) THEN
27606 C vector meson dominance assumed
27608 CALL PHO_VECRES(IVEC(I),XMASS(I),IFL1P(I),IFL2P(I))
27609 C diffraction dissociation
27610 ELSE IF(IPAR(I).EQ.1) THEN
27611 XMMIN = MAX(PARMDL(161+I),PMASSD(I)+THRM1)
27612 PREF2 = PMASSD(I)**2
27613 XMASS(I) = PHO_DFMASS(XMMIN,THRM2,PREF2,PVIRTD(I),ISWMDL(22))
27615 WRITE(LO,'(/1X,A,2I3)')
27616 & 'PHO_DIFDIS:ERROR:invalid IPAR1,IPAR2',IPAR(1),IPAR(2)
27621 C sampling of momentum transfer
27622 CALL PHO_DIFSLP(IPAR(1),IPAR(2),IVEC(1),IVEC(2),XMASS(1),XMASS(2),
27623 & THRM2,TT,SLWGHT,IREJ)
27626 IF(NSLP.LT.100) GOTO 55
27627 WRITE(LO,'(1X,2A,/10X,2I3,2E12.3)') 'PHO_DIFDIS: ',
27628 & 'too many slope rejections:IPAR1,IPAR2,M1,M2',IPAR,XMASS
27633 C correct for t-M^2 correlation in diffraction
27634 IF(DT_RNDM(TT).GT.SLWGHT) THEN
27636 IF(NCOR.LT.100) GOTO 55
27637 WRITE(LO,'(1X,2A,I10)') 'PHO_DIFDIS: ',
27638 & 'too many rejections due to t-M**2 correlation (EVE)',KEVENT
27644 IF(IDEB(45).GE.5) THEN
27645 WRITE(LO,'(1X,A,/5X,2I3,3E12.3)')
27646 & 'PHO_DIFDIS: IPAR1,IPAR2,XMASS1,XMASS2,TT',IPAR,XMASS,TT
27648 C not double pomeron scattering
27649 IF(IMODE.NE.2) THEN
27650 C sample diffractive interaction processes
27652 IF(IPAR(I).NE.0) THEN
27653 C find particle combination
27654 IF(IDPDG(I).EQ.IFPAP(1)) THEN
27656 ELSE IF(IDPDG(I).EQ.IFPAP(2)) THEN
27658 ELSE IF(IDPDG(I).EQ.990) THEN
27663 C sample dissociation process
27664 CALL PHO_DIFPRO(IP,ISWMDL(16),IDPDG(I),990,XMASS(I),
27665 & PVIRTD(I),0.D0,SPROB,IPROC(I),ISAM(I),JSAM(I),
27667 IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
27668 C store process label
27669 IF(IDIR(I).GT.0) THEN
27671 ELSE IF(KSAM(I).GT.0) THEN
27673 ELSE IF(ISAM(I).GT.0) THEN
27677 C mass fine correction
27678 CALL PHO_MASSAD(IDPDG(I),IFL1P(I),IFL2P(I),PMASSD(I),
27679 & XMASS(I),XMNEW,IRPDG(I),IRBAM(I))
27683 C diffractive pomeron-hadron interaction
27684 IPAR(I) = 10+IPROC(I)
27687 IF(IDEB(45).GE.15) WRITE(LO,'(1X,A,/10X,I3,E12.4,5I3)')
27688 & 'PHO_DIFDIS: IP,XMASS,IPROC,ISAM,JSAM,KSAM,IDIR',
27689 & IP,XMASS(I),IPROC(I),ISAM(I),JSAM(I),KSAM(I),IDIR(I)
27693 C actualize debug information
27694 IF(IMODE.EQ.1) THEN
27698 C calculate new momenta in CMS
27699 CALL PHO_DIFKIN(XMASS(1),XMASS(2),TT,P1,P2,IREJ)
27700 IF(IREJ.NE.0) GOTO 50
27706 C comment line for diffraction
27707 CALL PHO_REGPAR(30,IPROCE,IMODE,NPOSD(1),NPOSD(2),XMASS(1),
27708 & XMASS(2),TT,ECMD,IPAR(1),IPAR(2),IDPDG(1),IDPDG(2),ICPOS,1)
27709 C write diffractive strings/particles
27717 PP(6,I1) = SIGN(PHEP(5,NPOSD(I1))**2,PHEP(5,NPOSD(I1)))
27719 IGEN = IPHIST(2,NPOSD(I1))
27720 if(IGEN.eq.0) IGEN = -I1*10
27721 CALL PHO_DIFPAR(NPOSD(I1),NPOSD(I2),IGEN,IFL1P(I1),IFL2P(I1),
27722 & IPAR(I1),PD1,PD2,IPOSP(1,I1),IPOSP(2,I1),IMODE,IREJ)
27724 IFAIL(7+I) = IFAIL(7+I)+1
27725 IF(IDEB(45).GE.3) WRITE(LO,'(1X,A,2I3,E11.3)')
27726 & 'PHO_DIFDIS: rejection by PHO_DIFPAR (I,IPAR,XM)',
27727 & I,IPAR(I),XMASS(I)
27730 ICOLOR(I1,ICPOS) = IPOSP(1,I1)
27732 C double-pomeron scattering?
27733 IF(IMODE.EQ.2) GOTO 150
27735 C diffractive final states
27738 IF(IPAR(I).EQ.0) THEN
27739 C vector meson production
27740 IF(IDPDG(I).EQ.22) THEN
27741 IF(ISWMDL(21).GE.0) THEN
27743 IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
27744 CALL PHO_SDECAY(IPOSP(1,I),ISP,2)
27746 C hadronic state of multi-pomeron coupling
27747 ELSE IF(IDPDG(I).EQ.990) THEN
27748 CALL PHO_SDECAY(IPOSP(1,I),0,2)
27751 IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
27752 IF(ISAM(I)+JSAM(I)+KSAM(I).EQ.0) JSAM(I) = 1
27753 IF(IDIR(I).GT.0) THEN
27755 ELSE IF(KSAM(I).GT.0) THEN
27757 ELSE IF(ISAM(I).GT.0) THEN
27763 IPAR(I) = 10+IPROC(I)
27765 IPHIST(I,ICPOS) = IPAR(I)
27766 C update debug informantion
27773 IF((IRPDG(I).NE.0).AND.(ISWMDL(23).GT.0)) THEN
27775 C resonance decay, pi+pi- background
27776 P1(1) = PHEP(1,IPOSP(1,I))+PHEP(1,IPOSP(2,I))
27777 P1(2) = PHEP(2,IPOSP(1,I))+PHEP(2,IPOSP(2,I))
27778 P1(3) = PHEP(3,IPOSP(1,I))+PHEP(3,IPOSP(2,I))
27779 P1(4) = PHEP(4,IPOSP(1,I))+PHEP(4,IPOSP(2,I))
27780 CALL PHO_REGPAR(1,IRPDG(I),IRBAM(I),IPOSP(1,I),IPOSP(2,I),
27781 & P1(1),P1(2),P1(3),P1(4),0,2,0,0,IPOS,1)
27783 IF(IDPDG(I).EQ.22) THEN
27785 IF(ISWMDL(21).GE.0) THEN
27787 IF(ISWMDL(21).GE.2) ISP = IPAMDL(4)
27788 CALL PHO_SDECAY(IPOS,ISP,2)
27791 CALL PHO_SDECAY(IPOS,IPAMDL(3),2)
27796 C particle-pomeron scattering
27797 IF(IPAR(I).LE.4) THEN
27798 C non-diffractive particle-pomeron scattering
27799 IGEN = IPHIST(2,NPOSD(I))
27807 CALL PHO_STDPAR(IPOSP(1,I),IPOSP(2,I),IGEN,
27808 & ISAM(I),JSAM(I),KSAM(I),IDIR(I),IREJ)
27810 C diffractive particle-pomeron scattering
27812 IPORES(IPOIX2) = IPROC(I)
27813 IPOPOS(1,IPOIX2) = IPOSP(1,I)
27814 IPOPOS(2,IPOIX2) = IPOSP(2,I)
27821 IFAIL(20+I) = IFAIL(20+I)+1
27822 IF(IPAR(I).GT.1) THEN
27823 IF(IPAR(I).EQ.3) IFAIL(7+2*I) = IFAIL(7+2*I)+1
27824 IF(IPAR(I).EQ.4) IFAIL(8+2*I) = IFAIL(8+2*I)+1
27825 IF(IDIR(I).GT.0) THEN
27827 ELSE IF(KSAM(I).GT.0) THEN
27828 KSAM(I) = KSAM(I)-1
27829 ELSE IF(ISAM(I).GT.0) THEN
27830 ISAM(I) = ISAM(I)-1
27834 IF(IDEB(45).GE.2) WRITE(LO,'(1X,A,2I3,E11.3)')
27835 & 'PHO_DIFDIS: rejection PHO_STDPAR (I,IPAR,XM)',
27836 & I,IPAR(I),XMASS(I)
27844 C update debug information
27845 KSPOM = KSPOMS+ISAM(1)+ISAM(2)
27846 KSREG = KSREGS+JSAM(1)+JSAM(2)
27847 KHPOM = KHPOMS+KSAM(1)+KSAM(2)
27848 KHDIR = KHDIRS+IDIR(1)+IDIR(2)
27853 IF(IDEB(45).GE.10) THEN
27854 WRITE(LO,'(1X,2A,/18X,7I6)') 'PHO_DIFDIS: (2) ',
27855 & 'IPAR1,IPAR2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
27856 & IPAR,NPOSD,MSOFT,MHARD,IMODE
27858 IF(IDEB(45).GE.15) THEN
27859 WRITE(LO,'(2(/1X,A))') 'PHO_DIFDIS: output of /POEVT1/',
27860 & '------------------------------'
27866 *$ CREATE PHO_DIFPRO.FOR
27868 CDECK ID>, PHO_DIFPRO
27869 SUBROUTINE PHO_DIFPRO(IP,ICUT,ID1,ID2,XMASS,P2V1,P2V2,SPROB,
27870 & IPROC,ISAM,JSAM,KSAM,IDIR)
27871 C*********************************************************************
27873 C sampling of diffraction dissociation process
27875 C input: IP particle combination
27876 C ICUT user imposed limitations
27877 C ID1/2 PDG particle code of scattering particles
27878 C XMASS diffractively produced mass (GeV)
27879 C P2V1/2 virtuality of scattering particles (Gev**2)
27880 C SPROB suppression factor for resolved single and
27881 C double diffraction dissociation
27883 C output: IRPOC process ID
27884 C ISAM number of cut pomerons (soft)
27885 C JSAM number of cut reggeons
27886 C KSAM number of cut pomerons (hard)
27887 C IDIR direct hard interaction
27889 C*********************************************************************
27890 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27893 C input/output channels
27895 COMMON /POINOU/ LI,LO
27896 C event debugging information
27898 PARAMETER (NMAXD=100)
27899 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27900 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27901 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27902 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27903 C general process information
27904 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
27905 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
27906 C model switches and parameters
27908 INTEGER ISWMDL,IPAMDL
27909 DOUBLE PRECISION PARMDL
27910 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27911 C energy-interpolation table
27913 PARAMETER ( IEETA2 = 20 )
27915 DOUBLE PRECISION SIGTAB,SIGECM
27916 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
27923 IF(XMASS.GT.3.D0) THEN
27924 C rapidity gap survival probability
27926 IF(ISWMDL(28).GE.1) SPRO = SPROB
27927 C sample interaction
27929 CALL PHO_SAMPRO(IP,ID1,ID2,XMASS,P2V1,P2V2,SPRO,IPROC)
27933 IF(IPROC.EQ.1) CALL PHO_SAMPRB(XMASS,IP,ISAM,JSAM,KSAM)
27934 C non-diffractive hadron-pomeron interaction
27935 IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
27936 C option for suppression of multiple interaction
27939 IF(ISAM+KSAM+IDIR.GT.0) THEN
27947 ELSE IF(ICUT.EQ.1) THEN
27949 ELSE IF(KSAM.GT.0) THEN
27953 ELSE IF(ISAM.GT.0) THEN
27959 ELSE IF(ICUT.EQ.2) THEN
27961 ELSE IF(ICUT.EQ.3) THEN
27967 *$ CREATE PHO_DIFPAR.FOR
27969 CDECK ID>, PHO_DIFPAR
27970 SUBROUTINE PHO_DIFPAR(IMOTH1,IMOTH2,IGENM,IFL1,IFL2,IPAR,P1,P2,
27971 & IPOSH1,IPOSH2,IMODE,IREJ)
27972 C***********************************************************************
27974 C perform string construction for diffraction dissociation
27976 C input: IMOTH1,2 index of mother particles in POEVT1
27977 C IGENM production process of mother particles
27978 C IFL1,IFL2 particle numbers
27979 C (IDPDG,IDBAM for quasi-elas. hadron)
27980 C IPAR 0 quasi-elasic scattering
27981 C 1 single string configuration
27982 C 2 two string configuration
27983 C P1 massive 4 momentum of first
27984 C P1(6) virtuality/squ.mass of particle (GeV**2)
27985 C P1(7) virtuality of Pomeron (neg, GeV**2)
27986 C P2 massive 4 momentum of second particle
27987 C IMODE 1 diffraction dissociation
27988 C 2 double-pomeron scattering
27990 C output: IPOSH1,2 index of the particles in /POEVT1/
27991 C IREJ 0 successful string construction
27992 C 1 no string construction possible
27994 C***********************************************************************
27995 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27998 DIMENSION P1(7),P2(7)
28000 PARAMETER ( EPS = 1.D-7,
28003 C input/output channels
28005 COMMON /POINOU/ LI,LO
28006 C event debugging information
28008 PARAMETER (NMAXD=100)
28009 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28010 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28011 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28012 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28013 C internal rejection counters
28015 PARAMETER (NMXJ=60)
28016 CHARACTER*10 REJTIT
28018 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
28019 C c.m. kinematics of diffraction
28021 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
28022 & SIDD,CODD,SIFD,COFD,PDCMS
28023 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
28024 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
28025 C model switches and parameters
28027 INTEGER ISWMDL,IPAMDL
28028 DOUBLE PRECISION PARMDL
28029 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28031 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28032 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28033 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28034 C standard particle data interface
28036 PARAMETER (NMXHEP=4000)
28037 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28038 DOUBLE PRECISION PHEP,VHEP
28039 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28040 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28042 C extension to standard particle data interface (PHOJET specific)
28043 INTEGER IMPART,IPHIST,ICOLOR
28044 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28046 DIMENSION PCH1(2,4)
28053 if(IGENM.le.-10) IGEN = 0
28057 IF((IFL1.EQ.92).OR.(IFL1.EQ.91)) THEN
28058 if(IGEN.eq.0) IGEN = 3
28059 C pi+/pi- isotropic background
28060 CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,
28061 & P1(1),P1(2),P1(3),P1(4),0,IGEN,0,0,IPOSH1,1)
28062 CALL PHO_SDECAY(IPOSH1,0,-2)
28066 if(IFL1.ne.IDHEP(IMOTH1)) IGEN = 3
28068 C registration of particle or resonance
28069 CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,P1(1),P1(2),P1(3),
28070 & P1(4),0,IGEN,0,0,IPOSH1,1)
28073 C diffraction dissociation
28074 ELSE IF((IPAR.GE.1).AND.(IPAR.LE.18)) THEN
28075 C calculation of resulting particle momenta
28076 IF(IMOTH1.EQ.NPOSD(1)) THEN
28082 PCH1(2,I) = PDCMS(I,K)-P2(I)
28083 PCH1(1,I) = P1(I)-PCH1(2,I)
28087 if(IMODE.LT.2) then
28088 if(IGEN.eq.0) IGEN = -IGENM/10+4
28089 CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,PCH1(1,1),
28090 & PCH1(1,2),PCH1(1,3),PCH1(1,4),-1,IGEN,IC1,IC2,IPOSH1,1)
28092 if(IGEN.eq.0) IGEN = 4
28094 CALL PHO_REGPAR(1,990,0,IMOTH2,IMOTH1,PCH1(2,1),PCH1(2,2),
28095 & PCH1(2,3),PCH1(2,4),-1,IGEN,IC1,IC2,IPOSH2,1)
28099 WRITE(LO,'(/1X,A,I6)') 'PHO_DIFPAR:ERROR: invalid IPAR:',IPAR
28103 C back transformation
28104 CALL PHO_LTRHEP(ILTR1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
28105 & GAMBED(1),GAMBED(2),GAMBED(3))
28109 *$ CREATE PHO_QELAST.FOR
28111 CDECK ID>, PHO_QELAST
28112 SUBROUTINE PHO_QELAST(IPROC,JM1,JM2,IREJ)
28113 C**********************************************************************
28115 C sampling of quasi elastic processes
28117 C input: IPROC 2 purely elastic scattering
28118 C IPROC 3 q-ela. omega/omega/phi/pi+pi- production
28119 C IPROC 4 double pomeron scattering
28120 C IPROC -1 initialization
28121 C IPROC -2 output of statistics
28122 C JM1/2 index of initial particle 1/2
28124 C output: initial and final particles in /POEVT1/ involving
28125 C polarized resonances in /POEVT1/ and decay
28128 C IREJ 0 successful
28130 C 50 user rejection
28132 C**********************************************************************
28133 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28136 PARAMETER ( NTAB = 20,
28141 C input/output channels
28143 COMMON /POINOU/ LI,LO
28144 C event debugging information
28146 PARAMETER (NMAXD=100)
28147 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28148 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28149 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28150 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28151 C global event kinematics and particle IDs
28152 INTEGER IFPAP,IFPAB
28153 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28154 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28155 C c.m. kinematics of diffraction
28157 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
28158 & SIDD,CODD,SIFD,COFD,PDCMS
28159 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
28160 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
28161 C model switches and parameters
28163 INTEGER ISWMDL,IPAMDL
28164 DOUBLE PRECISION PARMDL
28165 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28167 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28168 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28169 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28171 INTEGER IPFIL,IFAFIL,IFBFIL
28172 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
28173 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
28174 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
28175 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
28176 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
28177 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
28178 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
28179 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
28180 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
28181 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
28182 & IPFIL,IFAFIL,IFBFIL
28183 C standard particle data interface
28185 PARAMETER (NMXHEP=4000)
28186 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28187 DOUBLE PRECISION PHEP,VHEP
28188 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28189 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28191 C extension to standard particle data interface (PHOJET specific)
28192 INTEGER IMPART,IPHIST,ICOLOR
28193 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28195 DOUBLE PRECISION P,PK1,PK2,PMI,RMASS
28196 DIMENSION P(4,2),PK1(5),PK2(5),PMI(2),RMASS(2)
28197 DIMENSION IFL(2),IDPRO(4)
28198 character*15 pho_pname
28199 CHARACTER*8 VMESA(0:4),VMESB(0:4)
28200 DIMENSION ISAMVM(4,4)
28201 DATA IDPRO / 113,223,333,92 /
28202 DATA VMESA / 'vmeson ','rho ','omega ','phi ',
28204 DATA VMESB / 'vmeson ','rho ','omega ','phi ',
28207 C sampling of elastic/quasi-elastic processes
28208 IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
28213 PMI(I) = PHEP(5,NPOSD(I))
28214 IF(PMI(I).LT.0.1D0) PMI(I) = 0.765D0
28217 PK1(1) = PHEP(1,JM1)+PHEP(1,JM2)
28218 PK1(2) = PHEP(2,JM1)+PHEP(2,JM2)
28219 PK1(3) = PHEP(3,JM1)+PHEP(3,JM2)
28220 PK1(4) = PHEP(4,JM1)+PHEP(4,JM2)
28221 SS = (PK1(4)+PK1(3))*(PK1(4)-PK1(3))-PK1(1)**2-PK1(2)**2
28224 IF(ECMD.LE.PMI(1)+PMI(2)) THEN
28225 IF(IDEB(34).GE.3) WRITE(LO,'(1X,A,I12,3E12.4)')
28226 & 'PHO_QELAST: too small mass (EV,ECM,M1,M2)',KEVENT,
28233 GAMBED(I) = PK1(I)/ECMD
28235 CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
28236 & PHEP(1,NPOSD(1)),PHEP(2,NPOSD(1)),PHEP(3,NPOSD(1)),
28237 & PHEP(4,NPOSD(1)),PTOT1,PK1(1),PK1(2),PK1(3),PK1(4))
28239 CODD = PK1(3)/PTOT1
28240 SIDD = SQRT(PK1(1)**2+PK1(2)**2)/PTOT1
28243 IF(PTOT1*SIDD.GT.1.D-5) THEN
28244 COFD = PK1(1)/(SIDD*PTOT1)
28245 SIFD = PK1(2)/(SIDD*PTOT1)
28246 ANORF = SQRT(COFD*COFD+SIFD*SIFD)
28253 PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)
28255 C production process of mother particles
28256 IGEN = IPHIST(2,NPOSD(1))
28257 if(IGEN.eq.0) IGEN = IPROC
28260 C main rejection label
28262 C determine process and final particles
28263 IFL(1) = IDHEP(NPOSD(1))
28264 IFL(2) = IDHEP(NPOSD(2))
28265 IF(IPROC.EQ.3) THEN
28269 IF(ITRY.GT.50) THEN
28270 IF(IDEB(34).GE.3) WRITE(LO,'(1X,A,I12,I5,E12.4)')
28271 & 'PHO_QELAST: mass rejection (EV,ITRY,ECM)',KEVENT,
28276 XI = DT_RNDM(PCMD)*SIGVM(0,0)-DEPS
28280 IF(XI.LE.0.D0) GOTO 130
28284 IF(IFL(1).EQ.22) IFL(1) = IDPRO(I)
28285 IF(IFL(2).EQ.22) IFL(2) = IDPRO(J)
28286 ISAMVM(I,J) = ISAMVM(I,J)+1
28288 C sample new masses
28289 CALL PHO_SAMASS(IFL(1),RMASS(1))
28290 CALL PHO_SAMASS(IFL(2),RMASS(2))
28291 IF(RMASS(1)+RMASS(2).GE.ECMD) GOTO 100
28292 ELSE IF(IPROC.EQ.2) THEN
28296 RMASS(1) = PHO_PMASS(NPOSD(1),2)
28297 RMASS(2) = PHO_PMASS(NPOSD(2),2)
28299 WRITE(LO,'(/1X,A,I6)') 'PHO_QELAST:ERROR: invalid IPROC',IPROC
28302 C sample momentum transfer
28303 CALL PHO_DIFSLP(0,0,I,J,RMASS(1),RMASS(2),RMASS(1),TT,
28305 IF(IDEB(34).GE.5) WRITE(LO,'(1X,A,2I6,I3,3E11.3)')
28306 & 'PHO_QELAST: IF1,2,T,RM1,RM2',IFL,IPROC,TT,RMASS
28307 C calculate new momenta
28308 CALL PHO_DIFKIN(RMASS(1),RMASS(2),TT,PK1,PK2,IREJ)
28309 IF(IREJ.NE.0) GOTO 50
28314 C comment line for elastic/quasi-elastic scattering
28315 CALL PHO_REGPAR(35,IPROC,0,NPOSD(1),NPOSD(2),RMASS(1),RMASS(2),
28316 & TT,ECMD,IFL(1),IFL(2),IDHEP(NPOSD(1)),IDHEP(NPOSD(2)),ICPOS,1)
28322 IF((IFL(I).EQ.92).OR.(IFL(I).EQ.91)) THEN
28323 C pi+/pi- isotropic background
28325 CALL PHO_REGPAR(1,113,0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
28326 & P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
28327 ICOLOR(I,ICPOS) = IPOS
28328 CALL PHO_SDECAY(IPOS,0,-2)
28332 if(IFL(I).ne.IDHEP(NPOSD(I))) IGEN = 3
28333 CALL PHO_REGPAR(1,IFL(I),0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
28334 & P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
28335 ICOLOR(I,ICPOS) = IPOS
28339 C search for vector mesons
28341 C decay according to polarization
28342 IF((IDHEP(JMOHEP(1,I)).EQ.22).AND.(ISWMDL(21).GE.0)) THEN
28344 IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
28345 CALL PHO_SDECAY(I,ISP,2)
28349 C back transformation
28350 CALL PHO_LTRHEP(I1,I2,CODD,SIDD,COFD,SIFD,GAMBED(4),GAMBED(1),
28351 & GAMBED(2),GAMBED(3))
28353 C initialization of tables
28354 ELSE IF(IPROC.EQ.-1) THEN
28362 IF(IFPAP(1).NE.22) VMESA(1) = PHO_PNAME(IFPAP(1),1)
28363 IF(IFPAP(2).NE.22) VMESB(1) = PHO_PNAME(IFPAP(2),1)
28364 CALL PHO_SAMASS(-1,RMASS(1))
28367 C output of statistics
28368 ELSE IF(IPROC.EQ.-2) THEN
28369 IF(ICALL.LT.10) RETURN
28370 WRITE(LO,'(/,1X,A,I10/,1X,A)')
28371 & 'PHO_QELAST: statistics of (quasi-)elastic processes',ICALL,
28372 & '---------------------------------------------------'
28373 WRITE(LO,'(1X,A,I10)')
28374 & 'sampled elastic processes:',ISAMEL
28375 WRITE(LO,'(1X,A,I10)')
28376 & 'sampled quasi-elastic vectormeson production:',ISAMQE
28377 WRITE(LO,'(15X,4(4X,A))') (VMESB(I),I=1,4)
28379 WRITE(LO,'(5X,A,4I12)') VMESA(I),(ISAMVM(I,K),K=1,4)
28381 CALL PHO_SAMASS(-2,RMASS(1))
28383 WRITE(LO,'(/1X,2A,I3)') 'PHO_QELAST:ERROR: ',
28384 & 'unknown process ID',IPROC
28390 *$ CREATE PHO_CDIFF.FOR
28392 CDECK ID>, PHO_CDIFF
28393 SUBROUTINE PHO_CDIFF(IMOTH1,IMOTH2,MSOFT,MHARD,IMODE,IREJ)
28394 C**********************************************************************
28396 C preparation of /POEVT1/ for double-pomeron scattering
28398 C input: IMOTH1/2 index of mother particles in /POEVT1/
28400 C IMODE 1 sampling of pomeron-pomeron scattering
28401 C -1 initialization
28402 C -2 output of statistics
28404 C output: MSOFT number of generated soft strings
28405 C MHARD number of generated hard strings
28408 C 50 user rejection
28410 C**********************************************************************
28411 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28414 PARAMETER ( EPS = 1.D-10,
28417 C input/output channels
28419 COMMON /POINOU/ LI,LO
28420 C event debugging information
28422 PARAMETER (NMAXD=100)
28423 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28424 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28425 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28426 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28427 C internal rejection counters
28429 PARAMETER (NMXJ=60)
28430 CHARACTER*10 REJTIT
28432 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
28433 C model switches and parameters
28435 INTEGER ISWMDL,IPAMDL
28436 DOUBLE PRECISION PARMDL
28437 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28438 C general process information
28439 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
28440 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
28441 C Reggeon phenomenology parameters
28442 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
28443 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
28444 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
28445 & ALREG,ALREGP,GR(2),B0REG(2),
28446 & GPPP,GPPR,B0PPP,B0PPR,
28447 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
28448 C parameters of 2x2 channel model
28449 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
28450 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
28452 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28453 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28454 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28455 C energy-interpolation table
28457 PARAMETER ( IEETA2 = 20 )
28459 DOUBLE PRECISION SIGTAB,SIGECM
28460 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
28461 C table of particle indices for recursive PHOJET calls
28463 PARAMETER ( MAXIPX = 100 )
28464 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
28465 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
28466 & IPOIX1,IPOIX2,IPOIX3
28467 C standard particle data interface
28469 PARAMETER (NMXHEP=4000)
28470 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28471 DOUBLE PRECISION PHEP,VHEP
28472 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28473 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28475 C extension to standard particle data interface (PHOJET specific)
28476 INTEGER IMPART,IPHIST,ICOLOR
28477 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28481 if(IMODE.ne.1) return
28485 C select first diffraction
28486 IF(DT_RNDM(DUM).GT.0.5D0) THEN
28496 C save current status
28506 JDA11 = JDAHEP(1,IMOTH1)
28507 JDA21 = JDAHEP(2,IMOTH1)
28508 JDA12 = JDAHEP(1,IMOTH2)
28509 JDA22 = JDAHEP(2,IMOTH2)
28510 ISTH1 = ISTHEP(IMOTH1)
28511 ISTH2 = ISTHEP(IMOTH2)
28514 C find mother particle production process
28515 IGEN = IPHIST(2,IMOTH1)
28516 if(IGEN.eq.0) IGEN = 4
28518 C main generation loop
28527 C reset mother-daugther relations
28529 JDAHEP(1,IMOTH1) = JDA11
28530 JDAHEP(2,IMOTH1) = JDA21
28531 JDAHEP(1,IMOTH2) = JDA12
28532 JDAHEP(2,IMOTH2) = JDA22
28533 ISTHEP(IMOTH1) = ISTH1
28534 ISTHEP(IMOTH2) = ISTH2
28538 C rejection counter
28540 IF(ITRY2.GT.1) THEN
28541 IFAIL(39) = IFAIL(39)+1
28542 IF(ITRY2.GE.ITRYM) GOTO 50
28544 C generate two diffractive events
28545 CALL PHO_DIFDIS(I1,I2,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
28546 IF(IREJ.NE.0) GOTO 50
28547 CALL PHO_DIFDIS(I2,I1,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
28548 IF(IREJ.NE.0) GOTO 50
28549 C mass of pomeron-pomeron system
28550 DO 100 I2 = NHEP,1,-1
28551 IF(IDHEP(I2).EQ.990) GOTO 110
28554 DO 120 I1 = I2-1,1,-1
28555 IF(IDHEP(I1).EQ.990) GOTO 130
28559 PD(I) = PHEP(I,I1)+PHEP(I,I2)
28561 XMASS = (PD(4)-PD(3))*(PD(4)+PD(3))-PD(1)**2-PD(2)**2
28562 IF(IDEB(59).GE.20) WRITE(LO,'(1X,A,2I3,E12.4)')
28563 & 'PHO_CDIFF: IPOM1,IPOM2,MASS**2',I1,I2,XMASS
28564 IF(XMASS.LT.0.1D0) GOTO 60
28565 XMASS = SQRT(XMASS)
28566 IF(XMASS.LT.PARMDL(71)) GOTO 60
28568 C sample pomeron-pomeron interaction process
28569 CALL PHO_DIFPRO(4,ISWMDL(17),990,990,XMASS,0.D0,0.D0,1.D0,
28570 & IPROC,ISAM,JSAM,KSAM,IDIR)
28572 C non-diffractive pomeron-pomeron interactions
28573 IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
28575 IF(ISAM+JSAM+KSAM+IDIR.EQ.0) JSAM = 1
28577 IF(IDEB(59).GE.15) WRITE(LO,'(1X,A,/5X,I3,E12.4,4I5)')
28578 & 'PHO_CDIFF: IP,XMASS,ISAM,JSAM,KSAM,IDIR,',
28579 & IP,XMASS,ISAM,JSAM,KSAM,IDIR
28580 C store debug information
28583 ELSE IF(KSAM.GT.0) THEN
28585 ELSE IF(ISAM.GT.0) THEN
28591 IF(ISAM+JSAM.GT.0) KSDPO = 1
28592 IF(KSAM+IDIR.GT.0) KHDPO = 1
28599 C generate pomeron-pomeron interaction
28600 CALL PHO_STDPAR(I1,I2,IGEN,ISAM,JSAM,KSAM,IDIR,IREJ)
28602 IFAIL(3) = IFAIL(3)+1
28604 IF(IPAR.EQ.3) IFAIL(9) = IFAIL(9)+1
28606 IFAIL(10) = IFAIL(10)+1
28608 ELSE IF(KSAM.GT.0) THEN
28610 ELSE IF(ISAM.GT.0) THEN
28615 IF(IDEB(59).GE.2) WRITE(LO,'(1X,A,2I3,E11.3)')
28616 & 'PHO_CDIFF: rejection by PHO_STDPAR (I,IPAR,XM)',
28622 C diffractive pomeron-pomeron interactions
28625 IPORES(IPOIX2) = IPROC
28626 IPOPOS(1,IPOIX2) = I1
28627 IPOPOS(2,IPOIX2) = I2
28632 C update debug information
28633 KSPOM = KSPOMS+ISAM
28634 KSREG = KSREGS+JSAM
28635 KHPOM = KHPOMS+KSAM
28636 KHDIR = KHDIRS+IDIR
28637 C comment line for central diffraction
28638 CALL PHO_REGPAR(40,4,IPAR,IMOTH1,IMOTH2,PD(1),PD(2),PD(3),PD(4),
28639 & I1,I2,IDHEP(IMOTH1),IDHEP(IMOTH2),IPOS,1)
28640 PHEP(5,IPOS) = XMASS
28642 IF(IDEB(59).GE.15) THEN
28643 WRITE(LO,'(2(/1X,A))') 'PHO_CDIFF: output of /POEVT1/',
28644 & '-----------------------------'
28649 C treatment of rejection
28652 IFAIL(40) = IFAIL(40)+1
28653 IF(IDEB(59).GE.3) THEN
28655 & 'PHO_CDIFF: rejection (ITRY,ITRYM)',ITRY2,ITRYM
28656 IF(IDEB(59).GE.10) THEN
28659 CALL PHO_PREVNT(-1)
28665 *$ CREATE PHO_SAMASS.FOR
28667 CDECK ID>, PHO_SAMASS
28668 SUBROUTINE PHO_SAMASS(IFLA,RMASS)
28669 C**********************************************************************
28671 C resonance mass sampling of quasi elastic processes
28673 C input: IFLA PDG number of particle
28674 C IFLA -1 initialization
28675 C IFLA -2 output of statistics
28677 C output: RMASS particle mass (in GeV)
28679 C**********************************************************************
28680 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28683 PARAMETER(EPS = 1.D-10 )
28685 C input/output channels
28687 COMMON /POINOU/ LI,LO
28688 C event debugging information
28690 PARAMETER (NMAXD=100)
28691 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28692 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28693 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28694 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28695 C model switches and parameters
28697 INTEGER ISWMDL,IPAMDL
28698 DOUBLE PRECISION PARMDL
28699 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28700 C parameters of the "simple" Vector Dominance Model
28701 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
28702 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
28704 PARAMETER(NTABM=50)
28705 DIMENSION XMA(4,NTABM),XMC(4,NTABM),RMA(4,NTABM)
28706 DIMENSION SUM(4),ICALL(4)
28708 C*****************************************************************
28709 C initialization of tables
28710 IF(IFLA.EQ.-1) THEN
28715 DELTAM=(RMAX(I)-RMIN(I))/DBLE(NSTEP-1)
28717 RMA(I,K)=RMIN(I)+DELTAM*DBLE(K-1)
28720 C calculate table of dsig/dm
28721 CALL PHO_DSIGDM(RMA,XMA,NSTEP)
28723 IF(IDEB(35).GE.1) THEN
28724 WRITE(LO,'(/5X,A)') 'table: mass (GeV) DSIG/DM (mub/GeV)'
28725 WRITE(LO,'(1X,A,/1X,A)')
28726 & ' (m, rho, m, omega, m, phi, m, pi+pi-)',
28727 & ' -------------------------------------------------------'
28729 WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMA(1,K),
28730 & RMA(2,K),XMA(2,K),RMA(3,K),XMA(3,K),RMA(4,K),XMA(4,K)
28733 C make second table for sampling
28737 SUM(I) = SUM(I) + (XMA(I,K-1)+XMA(I,K))/2.D0
28744 XMC(I,K) = XMC(I,K)/XMC(I,NSTEP)
28747 IF(IDEB(35).GE.10) THEN
28748 WRITE(LO,'(/5X,A)') 'PHO_DSIGDM: normalized summed table:'
28749 WRITE(LO,'(1X,A,/1X,A)')
28750 & ' (m, rho, m, omega, m, phi, m, pi+pi-)',
28751 & ' -------------------------------------------------------'
28753 WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMC(1,K),
28754 & RMA(2,K),XMC(2,K),RMA(3,K),XMC(3,K),RMA(4,K),XMC(4,K)
28758 C**************************************************
28759 C output of statistics
28760 ELSE IF(IFLA.EQ.-2) THEN
28761 WRITE(LO,'(2(/1X,A))') 'PHO_SAMASS: statistics',
28762 & '----------------------'
28763 WRITE(LO,'(4(/8X,A,I10))') 'rho: ',ICALL(1),
28764 & 'omega: ',ICALL(2),'phi: ',ICALL(3),'pi+pi-:',ICALL(4)
28766 C********************************************************
28767 C sampling of RMASS
28769 C quasi-elastic vector meson production
28770 IF(IFLA.EQ.113) THEN
28772 ELSE IF(IFLA.EQ.223) THEN
28774 ELSE IF(IFLA.EQ.333) THEN
28776 ELSE IF(IFLA.EQ.92) THEN
28778 C quasi-elastic production of h*
28779 ELSE IF(IFLA.EQ.91) THEN
28782 C elastic hadron scattering
28784 RMASS = PHO_PMASS(IFLA,1)
28785 IF(IDEB(35).GE.20) WRITE(LO,'(1X,A,I7,E12.3)')
28786 & 'PHO_SAMASS: IFLA,MASS',IFLA,RMASS
28790 C sample mass of vector mesonsn / two-pi background
28791 XI = DT_RNDM(RMASS) + EPS
28793 IF((XMC(KP,1).LE.XI).AND.(XMC(KP,NSTEP).GE.XI)) THEN
28797 IF((KMAX-KMIN).EQ.1) GOTO 400
28799 IF(XI.LE.XMC(KP,KK)) THEN
28807 WRITE(LO,'(1X,A)') 'PHO_SAMASS:ERROR:XI out of range'
28808 WRITE(LO,'(5X,A,I7,I6,3E12.4)') 'EVENT,IFLA,XI,XImin,XImax',
28809 & KEVENT,IFLA,XI,XMC(KP,1),XMC(KP,NSTEP)
28812 C fine interpolation
28813 RMASS = RMA(KP,KMIN)+
28814 & (RMA(KP,KMAX)-RMA(KP,KMIN))/
28815 & (XMC(KP,KMAX)-XMC(KP,KMIN))
28816 & *(XI-XMC(KP,KMIN))
28817 IF(IDEB(35).GE.20) THEN
28818 IF(IDEB(35).GE.25) WRITE(LO,'(1X,A,3E15.3)')
28819 & 'PHO_SAMASS: MLEFT,MRIGHT,RMASS',
28820 & RMA(KP,KMIN),RMA(KP,KMAX),RMASS
28821 WRITE(LO,'(1X,A,I7,E12.3)') 'PHO_SAMASS: IFLA,MASS',
28824 ICALL(KP) = ICALL(KP)+1
28828 *$ CREATE PHO_DSIGDM.FOR
28830 CDECK ID>, PHO_DSIGDM
28831 SUBROUTINE PHO_DSIGDM(RMA,XMA,NSTEP)
28832 C**********************************************************************
28834 C differential cross section DSIG/DM of low mass enhancement
28836 C input: RMA(4,NTABM) mass values
28837 C output: XMA(4,NTABM) DSIG/DM of resonances
28839 C 2 omega production
28841 C 4 pi-pi continuum
28843 C**********************************************************************
28844 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28847 PARAMETER ( EPS = 1.D-10 )
28849 PARAMETER(NTABM=50)
28850 DIMENSION XMA(4,NTABM),RMA(4,NTABM)
28852 C input/output channels
28854 COMMON /POINOU/ LI,LO
28855 C event debugging information
28857 PARAMETER (NMAXD=100)
28858 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28859 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28860 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28861 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28862 C model switches and parameters
28864 INTEGER ISWMDL,IPAMDL
28865 DOUBLE PRECISION PARMDL
28866 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28867 C parameters of the "simple" Vector Dominance Model
28868 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
28869 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
28872 C rho meson shape (mass dependent width)
28873 QRES = SQRT(VMAS(1)**2 - 4.D0*PIMASS**2)
28876 QQ = SQRT(XMASS**2 - 4.D0*PIMASS**2)
28877 GAMMA = GAMM(1)*(QQ/QRES)**3
28878 XMA(1,I) = XMASS*GAMMA*(VMAS(1)/XMASS)**PARMDL(170)
28879 & /((VMAS(1)**2-XMASS**2)**2+VMAS(1)**2*GAMMA**2)
28881 C omega/phi meson (constant width)
28885 XMA(K,I) = XMASS*GAMM(K)
28886 & /((VMAS(K)**2-XMASS**2)**2+VMAS(K)**2*GAMM(K)**2)
28892 XMA(4,I) = (XMASS-0.29D0)**2/XMASS
28897 *$ CREATE PHO_SDECAY.FOR
28899 CDECK ID>, PHO_SDECAY
28900 SUBROUTINE PHO_SDECAY(NPOS,ISP,ILEV)
28901 C**********************************************************************
28903 C decay of single resonance of /POEVT1/:
28904 C decay in helicity frame according to polarization, isotropic
28905 C decay and decay with limited transverse phase space possible
28908 C reference to particle number of CPC has to exist
28910 C input: NPOS position in /POEVT1/
28911 C ISP 0 decay according to phase space
28912 C 1 decay according to transversal polarization
28913 C 2 decay according to longitudinal polarization
28914 C 3 decay with limited phase space
28915 C ILEV decay mode to use
28917 C 2 strong and ew of tau, charm, and bottom
28918 C 3 strong and electro-weak decays
28919 C negative: remove mother resonance after decay
28921 C output: /POEVT1/,/POEVT2/ final particles according to decay mode
28923 C**********************************************************************
28924 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28927 PARAMETER ( EPS = 1.D-15,
28930 C input/output channels
28932 COMMON /POINOU/ LI,LO
28933 C event debugging information
28935 PARAMETER (NMAXD=100)
28936 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28937 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28938 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28939 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28940 C model switches and parameters
28942 INTEGER ISWMDL,IPAMDL
28943 DOUBLE PRECISION PARMDL
28944 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28946 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28947 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28948 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28949 C standard particle data interface
28951 PARAMETER (NMXHEP=4000)
28952 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28953 DOUBLE PRECISION PHEP,VHEP
28954 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28955 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28957 C extension to standard particle data interface (PHOJET specific)
28958 INTEGER IMPART,IPHIST,ICOLOR
28959 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28960 C general particle data
28961 double precision xm_list,tau_list,gam_list,
28962 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
28963 & xm_bb82_list,xm_bb102_list
28964 integer ich3_list,iba3_list,iq_list,
28965 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
28966 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
28967 & xm_psm2_list(6,6),xm_vem2_list(6,6),
28968 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
28969 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
28970 & ich3_list(300),iba3_list(300),iq_list(3,300),
28971 & id_psm_list(6,6),id_vem_list(6,6),
28972 & id_b8_list(6,6,6),id_b10_list(6,6,6)
28973 C particle decay data
28974 double precision wg_sec_list
28975 integer idec_list,isec_list
28976 COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
28978 C auxiliary data for three particle decay
28979 DOUBLE PRECISION ECM,PCM,COD,COF,SIF
28980 COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
28982 DIMENSION WGHD(20),KCH(20),ID(3)
28985 IF(IDEB(36).GE.15) WRITE(LO,'(1X,A,3I5)')
28986 & 'PHO_SDECAY: NPOS,ISP,ILEV',NPOS,ISP,ILEV
28989 IF(ISTHEP(NPOS).GT.11) RETURN
28992 IDcpc = IMPART(NPOS)
28993 IF(IDcpc.EQ.0) return
28994 IDabs = iabs(IDcpc)
28995 if(idec_list(1,IDabs).eq.0) return
28997 C different decay modi (times)
28998 IF(IMODE.EQ.1) THEN
28999 if(idec_list(1,IDabs).ne.1) return
29000 ELSE IF(IMODE.EQ.2) THEN
29001 if(idec_list(1,IDabs).gt.2) return
29002 ELSE IF(IMODE.EQ.3) THEN
29003 if(idec_list(1,IDabs).gt.3) return
29005 WRITE(LO,'(/1X,A,I5)') 'PHO_SDECAY: invalid mode (ILEV)',ILEV
29009 C decay products, check for mass limitations
29012 AMIST = PHEP(5,NPOS)
29013 DO 100 I=idec_list(2,IDabs),idec_list(3,IDabs)
29016 ID(L) = isec_list(L,I)
29017 IF(ID(L).NE.0) AMSUM = AMSUM+pho_pmass(ID(L),0)
29019 IF(AMSUM.LT.AMIST) THEN
29021 WGHD(K) = wg_sec_list(I)
29026 WRITE(LO,'(/1X,A,I6,3E12.4)')
29027 & 'PHO_SDECAY: particle mass too small (NPOS,MA,DCYM)',
29033 C sample new decay channel
29034 XI = (DT_RNDM(AMSUM)-EPS)*WGSUM
29039 WGSUM = WGSUM+WGHD(K)
29040 IF(XI.GT.WGSUM) GOTO 500
29042 ID(1) = isec_list(1,IK)
29043 ID(2) = isec_list(2,IK)
29044 ID(3) = isec_list(3,IK)
29045 if(IDcpc.lt.0) then
29046 ID(1) = ipho_anti(ID(1))
29047 ID(2) = ipho_anti(ID(2))
29048 if(ID(3).ne.0) ID(3) = ipho_anti(ID(3))
29052 PTOT = SQRT(PHEP(1,NPOS)**2+PHEP(2,NPOS)**2+PHEP(3,NPOS)**2)
29053 CXS = PHEP(1,NPOS)/PTOT
29054 CYS = PHEP(2,NPOS)/PTOT
29055 CZS = PHEP(3,NPOS)/PTOT
29058 GAM = PHEP(4,NPOS)/AMIST
29060 IF(ID(3).EQ.0) THEN
29061 C two particle decay
29062 CALL PHO_SDECY2(AMIST,pho_pmass(ID(1),0),pho_pmass(ID(2),0),ISP)
29064 C three particle decay
29065 CALL PHO_SDECY3(AMIST,pho_pmass(ID(1),0),pho_pmass(ID(2),0),
29066 & pho_pmass(ID(3),0),ISP)
29070 IF(NHEP.NE.NPOS) THEN
29071 WRITE(LO,'(/1X,2A,2I5)') 'PHO_SDECAY:ERROR: ',
29072 & 'cannot remove resonance (NPOS,NHEP)',NPOS,NHEP
29075 IMO1 = JMOHEP(1,NPOS)
29076 IMO2 = JMOHEP(2,NPOS)
29082 IPH1 = IPHIST(1,NPOS)
29083 IPH2 = IPHIST(2,NPOS)
29085 C back transformation and registration
29087 IF(ID(I).NE.0) THEN
29088 CALL PHO_LTRANS(GAM,GBET,CXS,CYS,CZS,COD(I),COF(I),SIF(I),
29089 & PCM(I),ECM(I),PTOT,CX,CY,CZ,EE)
29093 CALL PHO_REGPAR(1,0,ID(I),IMO1,IMO2,XX,YY,ZZ,EE,
29094 & IPH1,IPH2,0,0,IPOS,1)
29100 IF(IDEB(36).GE.20) THEN
29101 WRITE(LO,'(2(/1X,A))') 'PHO_SDECAY: /POEVT1/',
29102 & '--------------------'
29108 *$ CREATE PHO_SDECY2.FOR
29110 CDECK ID>, PHO_SDECY2
29111 SUBROUTINE PHO_SDECY2(UMO,AM1,AM2,ISP)
29112 C**********************************************************************
29114 C isotropic/anisotropic two particle decay in CM system,
29115 C (transversely/longitudinally polarized boson into two
29116 C pseudo-scalar mesons)
29118 C**********************************************************************
29119 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29122 C input/output channels
29124 COMMON /POINOU/ LI,LO
29125 C auxiliary data for three particle decay
29126 DOUBLE PRECISION ECM,PCM,COD,COF,SIF
29127 COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
29132 ECM(1)=(UMO2+AM11-AM22)/(2.D0*UMO)
29134 WAU=ECM(1)*ECM(1)-AM11
29135 IF(WAU.LT.0.D0) THEN
29136 WRITE(LO,'(/1X,A,E12.4)') 'PHO_SDECY2:ERROR:too small mass',WAU
29142 CALL PHO_SFECFE(SIF(1),COF(1))
29145 COD(1) = 2.D0*DT_RNDM(UMO)-1.D0
29146 ELSE IF(ISP.EQ.1) THEN
29147 C transverse polarization
29149 COD(1) = 2.D0*DT_RNDM(AM22)-1.D0
29150 SID12 = 1.D0-COD(1)*COD(1)
29151 IF(SID12.LT.DT_RNDM(AM1)) GOTO 400
29152 ELSE IF(ISP.EQ.2) THEN
29153 C longitudinal polarization
29155 COD(1) = 2.D0*DT_RNDM(AM2)-1.D0
29156 COD12 = COD(1)*COD(1)
29157 IF(COD12.LT.DT_RNDM(AM11)) GOTO 500
29159 WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY2:ERROR: ',
29160 & 'invalid polarization',ISP
29170 *$ CREATE PHO_SDECY3.FOR
29172 CDECK ID>, PHO_SDECY3
29173 SUBROUTINE PHO_SDECY3(UMO,AM1,AM2,AM3,ISP)
29174 C**********************************************************************
29176 C isotropic/anisotropic three particle decay in CM system,
29177 C (transversely/longitudinally polarized boson into three
29178 C pseudo-scalar mesons)
29180 C**********************************************************************
29181 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29184 PARAMETER ( DEPS = 1.D-30,
29187 C input/output channels
29189 COMMON /POINOU/ LI,LO
29190 C auxiliary data for three particle decay
29191 DOUBLE PRECISION ECM,PCM,COD,COF,SIF
29192 COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
29194 DIMENSION F(5),XX(5)
29196 C calculation of maximum of S2 phase space weight
29200 UFAK=1.0000000000001D0
29201 IF (GU.GT.GO) UFAK=0.99999999999999D0
29214 S22=GU+(I-1.D0)*DS2
29216 RHO2=PHO_XLAM(S22,UMO2,AM11)*PHO_XLAM(S22,AM22,AM33)/(S22+EPS)
29217 IF(RHO2.LT.RHO1) GOTO 125
29221 S2SUP=(S22-S21)/2.D0+S21
29222 SUPRHO=PHO_XLAM(S2SUP,UMO2,AM11)*PHO_XLAM(S2SUP,AM22,AM33)
29224 SUPRHO=SUPRHO*1.05D0
29226 IF(GU.LT.GO.AND.XO.LT.GU) XO=GU
29227 IF(GU.GT.GO.AND.XO.GT.GU) XO=GU
29233 F(1)=PHO_XLAM(XO,UMO2,AM11)*PHO_XLAM(XO,AM22,AM33)/(XO+EPS)
29234 F(2)=PHO_XLAM(X1,UMO2,AM11)*PHO_XLAM(X1,AM22,AM33)/(X1+EPS)
29236 X4=(XX(1)+XX(2))*0.5D0
29237 X5=(XX(2)+XX(3))*0.5D0
29238 F(4)=PHO_XLAM(X4,UMO2,AM11)*PHO_XLAM(X4,AM22,AM33)/(X4+EPS)
29239 F(5)=PHO_XLAM(X5,UMO2,AM11)*PHO_XLAM(X5,AM22,AM33)/(X5+EPS)
29245 IF(F(II).LT.F(III)) THEN
29260 IF (XX(II).LT.XX(III)) THEN
29278 IF(ITH.GT.200) THEN
29279 WRITE(LO,'(/1X,A,I10)')
29280 & 'PHO_SDECY3:ERROR: too many iterations',ITH
29283 S2=AM23+DT_RNDM(AM2)*((UMO-AM1)**2-AM23)
29284 Y=DT_RNDM(AM23)*SUPRHO
29285 RHO=PHO_XLAM(S2,UMO2,AM11)*PHO_XLAM(S2,AM22,AM33)/S2
29286 IF(Y.GT.RHO) GOTO 200
29289 S1=DT_RNDM(AM2)*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)
29290 & /(2.D0*S2)-RHO/2.D0
29291 S3=UMO2+AM11+AM22+AM33-S1-S2
29292 ECM(1)=(UMO2+AM11-S2)/UMOO
29293 ECM(2)=(UMO2+AM22-S3)/UMOO
29294 ECM(3)=(UMO2+AM33-S1)/UMOO
29295 PCM(1)=SQRT((ECM(1)+AM1)*(ECM(1)-AM1))
29296 PCM(2)=SQRT((ECM(2)+AM2)*(ECM(2)-AM2))
29297 PCM(3)=SQRT((ECM(3)+AM3)*(ECM(3)-AM3))
29299 C calculation of angles: TH between p1,p2; TH1 p3,p1; TH2 p3,p2
29300 IF((PCM(1).LE.EPS).OR.(PCM(2).LE.EPS)) THEN
29301 COSTH=(DT_RNDM(S1)-0.5D0)*2.D0
29303 COSTH=(ECM(1)*ECM(2)+0.5D0*(AM11+AM22-S1))/(PCM(1)*PCM(2))
29305 COSTH2=(PCM(3)*PCM(3)+PCM(2)*PCM(2)-PCM(1)*PCM(1))
29306 & /(2.D0*PCM(2)*PCM(3))
29307 SINTH2=SQRT(1.D0-COSTH2*COSTH2)
29308 SINTH1=COSTH2*SQRT(1.D0-COSTH*COSTH)-COSTH*SINTH2
29309 COSTH1=COSTH*COSTH2+SINTH2*SQRT(1.D0-COSTH*COSTH)
29311 C selection of the sperical coordinates of particle 3
29312 CALL PHO_SFECFE(SIF(3),COF(3))
29315 COD(3) = 2.D0*DT_RNDM(S2)-1.D0
29316 ELSE IF(ISP.EQ.1) THEN
29317 C transverse polarization
29319 COD(3) = 2.D0*DT_RNDM(S1)-1.D0
29320 SID32 = 1.D0-COD(3)*COD(3)
29321 IF(SID32.LT.DT_RNDM(COSTH)) GOTO 400
29322 ELSE IF(ISP.EQ.2) THEN
29323 C longitudinal polarization
29325 COD(3) = 2.D0*DT_RNDM(COSTH2)-1.D0
29326 COD32 = COD(3)*COD(3)
29327 IF(COD32.LT.DT_RNDM(SINTH1)) GOTO 500
29329 WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY3:ERROR: ',
29330 & 'invalid polarization',ISP
29334 C selection of the rotation angle of p1-p2 plane along p3
29336 CALL PHO_SFECFE(SFE,CFE)
29348 SID3 = SQRT((1.D0+COD(3))*(1.D0-COD(3)))
29349 COD(1)=CX11*COD(3)+CZ11*SID3
29350 IF((1.D0-COD(1)*COD(1)).LT.DEPS) THEN
29351 WRITE(LO,'(1X,A,5E12.4)') 'PHO_SDECY3: COS(TH1) > 1',
29352 & COD(1),COF(3),SID3,CX11,CZ11
29353 CALL PHO_PREVNT(-1)
29356 SID1=SQRT((1.D0+COD(1))*(1.D0-COD(1)))
29357 COF(1)=(CX11*SID3*COF(3)-CY11*SIF(3)-CZ11*COD(3)*COF(3))/SID1
29358 SIF(1)=(CX11*SID3*SIF(3)+CY11*COF(3)-CZ11*COD(3)*SIF(3))/SID1
29359 COD(2)=CX22*COD(3)+CZ22*SID3
29360 SID2=SQRT((1.D0+COD(2))*(1.D0-COD(2)))
29361 COF(2)=(CX22*SID3*COF(3)-CY22*SIF(3)-CZ22*COD(3)*COF(3))/SID2
29362 SIF(2)=(CX22*SID3*SIF(3)+CY22*COF(3)-CZ22*COD(3)*SIF(3))/SID2
29366 *$ CREATE PHO_DFMASS.FOR
29368 CDECK ID>, PHO_DFMASS
29369 DOUBLE PRECISION FUNCTION PHO_DFMASS(XMIN,XMAX,PREF2,PVIRT2,IMODE)
29370 C**********************************************************************
29372 C sampling of Mx diffractive mass distribution within
29373 C limits XMIN, XMAX
29375 C input: XMIN,XMAX mass limitations (GeV)
29376 C PREF2 original particle mass/ reference mass
29377 C (squared, GeV**2)
29378 C PVIRT2 particle virtuality
29379 C IMODE M**2 mass distribution
29381 C 2 1/(M**2+Q**2)**alpha
29382 C -1 1/(M**2-Mref**2+Q**2)
29383 C -2 1/(M**2-Mref**2+Q**2)**alpha
29385 C output: diffractive mass (GeV)
29387 C**********************************************************************
29388 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29391 PARAMETER(EPS = 1.D-10)
29393 C input/output channels
29395 COMMON /POINOU/ LI,LO
29396 C event debugging information
29398 PARAMETER (NMAXD=100)
29399 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29400 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29401 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29402 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29403 C model switches and parameters
29405 INTEGER ISWMDL,IPAMDL
29406 DOUBLE PRECISION PARMDL
29407 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29409 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29410 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29411 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29413 IF((XMIN.GE.XMAX).OR.(XMIN.LE.0.3D0)) THEN
29414 WRITE(LO,'(/1X,2A,3E12.4)') 'PHO_DFMASS:ERROR: ',
29415 & 'invalid mass limits',XMIN,XMAX,PREF2
29416 CALL PHO_PREVNT(-1)
29417 PHO_DFMASS = 0.135D0
29421 IF(IMODE.GT.0) THEN
29424 PM2 = PREF2 - PVIRT2
29428 IF(ABS(IMODE).EQ.1) THEN
29429 XMIN2 = LOG(XMIN**2-PM2)
29430 XMAX2 = LOG(XMAX**2-PM2)
29431 XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
29434 C supercritical pomeron
29435 ELSE IF(ABS(IMODE).EQ.2) THEN
29436 DDELTA = 1.D0-PARMDL(48)
29437 XMIN2 = (XMIN**2-PM2)**DDELTA
29438 XMAX2 = (XMAX**2-PM2)**DDELTA
29439 XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
29440 XMA2 = XI**(1.D0/DDELTA)+PM2
29442 WRITE(LO,'(/,1X,A,I3)')
29443 & 'PHO_DFMASS:ERROR: unsupported mode',IMODE
29447 PHO_DFMASS = SQRT(XMA2)
29449 IF(IDEB(43).GE.15) THEN
29450 WRITE(LO,'(1X,A,4E12.3)') 'PHO_DFMASS:Mmin,Mmax,Mref,Mass',
29451 & XMIN,XMAX,PREF2,SQRT(XMA2)
29456 *$ CREATE PHO_DIFSLP.FOR
29458 CDECK ID>, PHO_DIFSLP
29459 SUBROUTINE PHO_DIFSLP(IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,XMX,
29461 C**********************************************************************
29463 C sampling of T (Mandelstam variable) distribution within
29464 C certain limits TMIN, TMAX
29466 C input: IDF1,2 type of diffractive vertex
29467 C 0 elastic/quasi-elastic scattering
29468 C 1 diffraction dissociation
29469 C IVEC1,2 vector meson IDs in case of quasi-elastic
29470 C scattering, otherwise 0
29471 C XM1 mass of diffractive system 1 (GeV)
29472 C XM2 mass of diffractive system 2 (GeV)
29473 C XMX max. mass of diffractive system (GeV)
29475 C output: TT squared momentum transfer ( < 0, GeV**2)
29476 C SLWGHT weight to allow for mass-dependent slope
29477 C IREJ 0 successful sampling
29478 C 1 masses too big for given T range
29480 C**********************************************************************
29481 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29484 PARAMETER(EPS = 1.D-10)
29486 C input/output channels
29488 COMMON /POINOU/ LI,LO
29489 C event debugging information
29491 PARAMETER (NMAXD=100)
29492 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29493 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29494 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29495 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29496 C model switches and parameters
29498 INTEGER ISWMDL,IPAMDL
29499 DOUBLE PRECISION PARMDL
29500 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29501 C internal rejection counters
29503 PARAMETER (NMXJ=60)
29504 CHARACTER*10 REJTIT
29506 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
29507 C c.m. kinematics of diffraction
29509 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
29510 & SIDD,CODD,SIFD,COFD,PDCMS
29511 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
29512 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
29514 INTEGER IPFIL,IFAFIL,IFBFIL
29515 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
29516 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
29517 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
29518 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
29519 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
29520 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
29521 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
29522 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
29523 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
29524 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
29525 & IPFIL,IFAFIL,IFBFIL
29526 C Reggeon phenomenology parameters
29527 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
29528 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
29529 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
29530 & ALREG,ALREGP,GR(2),B0REG(2),
29531 & GPPP,GPPR,B0PPP,B0PPR,
29532 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
29533 C parameters of 2x2 channel model
29534 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
29535 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
29536 C parameters of the "simple" Vector Dominance Model
29537 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
29538 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
29540 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29541 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29542 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29549 C range of momentum transfer t
29552 C determine min. abs(t) necessary to produce masses
29554 PCMP2 = PHO_XLAM(SS,XM12,XM22)**2/(4.D0*SS)
29555 IF(PCMP2.LE.0.D0) THEN
29560 TMINP = PMASSD(1)**2+XM12+2.D0*PCMD*SQRT(PCMP2)
29561 & -2.D0*SQRT((PMASSD(1)**2+PCM2)*(XM12+PCMP2))
29563 IF(TMINP.LT.TMAX) THEN
29564 IF(IDEB(44).GE.3) THEN
29565 WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
29566 & 'too large Tmin (XM1/2,TMIN,TMAX,TMINP)',
29567 & XM1,XM2,TMIN,TMAX,TMINP
29569 IFAIL(32) = IFAIL(32)+1
29574 TMINA = MIN(TMIN,TMINP)
29576 C calculation of slope (mass-dependent parametrization)
29577 IF(IDF1+IDF2.GT.0) THEN
29578 C diffraction dissociation
29579 XMP12 = XM1**2+PVIRTD(1)
29580 XMP22 = XM2**2+PVIRTD(2)
29583 CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
29584 FAC = 4.D0*(PMASSD(1)*PMASSD(2))**2
29585 SLOPE = DBLE(IDF1+IDF2)*B0PPP
29586 & +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
29587 & /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
29588 SLOPE = MAX(SLOPE,1.D0)
29594 ELSE IF(IDF1.EQ.0) THEN
29597 XMP12 = XMA1**2+PVIRTD(1)
29598 XMP22 = XMA2**2+PVIRTD(2)
29601 CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
29602 SLMIN = DBLE(IDF1+IDF2)*B0PPP
29603 & +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
29604 & /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
29605 SLMIN = MAX(SLMIN,1.D0)
29607 C elastic/quasi-elastic scattering
29608 IF(ISWMDL(13).EQ.0) THEN
29609 C external slope values
29610 WRITE(LO,*) 'PHO_DIFSLP:ERROR: this option is not installed !'
29612 ELSE IF(ISWMDL(13).EQ.1) THEN
29614 IF(IVEC1*IVEC2.EQ.0) THEN
29617 SLOPE = SLOVM(IVEC1,IVEC2)
29621 WRITE(LO,'(/1X,A,I5)') 'SASDSDT:ERROR: invalid ISWMDL(13)',
29627 C determine max. abs(t) to avoid underflows
29628 TMAXP = -25.D0/SLOPE
29629 TMAXA = MAX(TMAX,TMAXP)
29631 IF(TMINA.LT.TMAXA) THEN
29632 IF(IDEB(44).GE.3) THEN
29633 WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
29634 & 'too small Tmax (XM1/2,TMINA,TMAXA,SLOPE)',
29635 & XM1,XM2,TMINA,TMAXA,SLOPE
29637 IFAIL(32) = IFAIL(32)+1
29643 C sampling from corrected range of T
29644 TMINE = EXP(SLMIN*TMINA)
29645 TMAXE = EXP(SLMIN*TMAXA)
29646 XI = (TMINE-TMAXE)*DT_RNDM(SLMIN)+TMAXE
29648 SLWGHT = EXP((SLOPE-SLMIN)*TT)
29651 IF(IDEB(44).GE.15) THEN
29652 WRITE(LO,'(1X,A,1P,E12.3/5X,A,2I2,2X,2I2,2E10.2,/5X,A,5E10.2)')
29653 & 'PHO_DIFSLP: sampled momentum transfer:',TT,
29654 & 'IDF1/2,IVEC1/2,XM1/2:',IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,
29655 & 'Tmi,Tmx,SLMIN,SLOPE,WGHT:',TMINP,TMAXP,SLMIN,SLOPE,SLWGHT
29659 *$ CREATE PHO_DIFKIN.FOR
29661 CDECK ID>, PHO_DIFKIN
29662 SUBROUTINE PHO_DIFKIN(XMP1,XMP2,TT,PMOM1,PMOM2,IREJ)
29663 C**********************************************************************
29665 C calculation of diffractive kinematics
29667 C input: XMP1 mass of outgoing particle system 1 (GeV)
29668 C XMP2 mass of outgoing particle system 2 (GeV)
29669 C TT momentum transfer (GeV**2, negative)
29671 C output: PMOM1(5) four momentum of outgoing system 1
29672 C PMOM2(5) four momentum of outgoing system 2
29673 C IREJ 0 kinematics consistent
29674 C 1 kinematics inconsistent
29676 C**********************************************************************
29677 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29680 PARAMETER(EPS = 1.D-10,
29683 C input/output channels
29685 COMMON /POINOU/ LI,LO
29686 C event debugging information
29688 PARAMETER (NMAXD=100)
29689 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29690 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29691 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29692 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29693 C c.m. kinematics of diffraction
29695 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
29696 & SIDD,CODD,SIFD,COFD,PDCMS
29697 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
29698 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
29700 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29701 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29702 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29704 DOUBLE PRECISION PMOM1,PMOM2
29705 DIMENSION PMOM1(5),PMOM2(5)
29708 IF(IDEB(49).GT.10) WRITE(LO,'(1X,A,/5X,5E12.4)')
29709 & 'PHO_DIFKIN: Ecmd,Pcmd,Mini-1,Mini-2,TT:',
29710 & ECMD,PCMD,XMP1,XMP2,TT
29712 C general kinematic constraints
29714 IF(ECMD.LE.1.1D0*(XMP1+XMP2)) RETURN
29716 C new squared cms momentum
29721 PCMP2 = PHO_XLAM(SS,XMP12,XMP22)**2/(4.D0*SS)
29723 C new longitudinal/transverse momentum
29724 E1I = SQRT(PCM2+PMASSD(1)**2)
29725 E1F = SQRT(PCMP2+XMP12)
29726 E2F = SQRT(PCMP2+XMP22)
29727 PLONG = (TT+PCM2+PCMP2-(E1I-E1F)**2)/(2.D0*PCMD)
29728 PTRAN = PCMP2-PLONG**2
29730 C check consistency of kinematics
29731 IF(PTRAN.LT.0.D0) THEN
29732 IF(IDEB(49).GE.1) THEN
29733 WRITE(LO,'(1X,2A,I10)') 'PHO_DIFKIN: ',
29734 & 'inconsistent kinematics in event call: ',KEVENT
29735 WRITE(LO,'(1X,A,/5X,1p,6E11.3)')
29736 & 'PHO_DIFKIN: XMP1,XMP2,TT,PCMP,PLONG,PTRANS',
29737 & XMP1,XMP2,TT,SQRT(PCMP2),PLONG,SIGN(SQRT(ABS(PTRAN)),PTRAN)
29742 PTRAN = SQRT(PTRAN)
29744 XI = PI2*DT_RNDM(PTRAN)
29746 C outgoing momenta in cm. system
29748 PMOM1(1) = PTRAN*COS(XI)
29749 PMOM1(2) = PTRAN*SIN(XI)
29754 PMOM2(1) = -PMOM1(1)
29755 PMOM2(2) = -PMOM1(2)
29760 C debug output / precision check
29761 IF(IDEB(49).GE.0) THEN
29763 XM1 = (PMOM1(4)-PMOM1(3))*(PMOM1(4)+PMOM1(3))
29764 & -PMOM1(1)**2-PMOM1(2)**2
29765 XM1 = SIGN(SQRT(ABS(XM1)),XM1)
29766 XM2 = (PMOM2(4)-PMOM2(3))*(PMOM2(4)+PMOM2(3))
29767 & -PMOM2(1)**2-PMOM2(2)**2
29768 XM2 = SIGN(SQRT(ABS(XM2)),XM2)
29769 IF((ABS(XM1-XMP1).GT.DEPS).OR.(ABS(XM1-XMP1).GT.DEPS)) THEN
29770 WRITE(LO,'(1X,2A,/5X,4E11.4)') 'PHO_DIFKIN: ',
29771 & 'inconsistent masses: MINI-1,MOUT-1,MINI-2,MOUT-2',
29772 & XMP1,XM1,XMP2,XM2
29773 CALL PHO_PREVNT(-1)
29776 IF(IDEB(49).GT.10) THEN
29777 WRITE(LO,'(1X,A,5E11.3,/1X,A,5E11.3)')
29778 & 'PHO_DIFKIN: P1',PMOM1,' P2',PMOM2
29784 *$ CREATE PHO_VECRES.FOR
29786 CDECK ID>, PHO_VECRES
29787 SUBROUTINE PHO_VECRES(IVEC,RMASS,IDPDG,IDBAM)
29788 C**********************************************************************
29790 C sampling of vector meson resonance in diffractive processes
29791 C (nothing done for hadrons)
29793 C input: /POSVDM/ VDMFAC factors
29795 C output: IVEC 0 incoming hadron
29799 C 4 pi+/pi- background
29800 C RMASS mass of vector meson (GeV)
29801 C IDPDG particle ID according to PDG
29802 C IDBAM particle ID according to CPC
29804 C**********************************************************************
29805 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29808 PARAMETER(EPS = 1.D-10)
29810 C input/output channels
29812 COMMON /POINOU/ LI,LO
29813 C event debugging information
29815 PARAMETER (NMAXD=100)
29816 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29817 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29818 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29819 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29820 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
29821 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
29822 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
29823 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
29824 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
29825 C parameters of the "simple" Vector Dominance Model
29826 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
29827 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
29829 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29830 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29831 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29833 C particle code translation
29834 DIMENSION ITRANS(4)
29835 C rho0,omega,phi,pi+/pi-
29836 DATA ITRANS /113, 223, 333, 92 /
29840 C vector meson production
29841 IF(IDPDG.EQ.22) THEN
29842 XI = DT_RNDM(RMASS)*(VMFA(1)+VMFA(2)+VMFA(3)+VMFA(4))
29845 SUM = SUM + VMFA(K)
29846 IF(XI.LE.SUM) GOTO 65
29851 IDBAM = ipho_pdg2id(IDPDG)
29853 C sample mass of vector meson
29854 CALL PHO_SAMASS(IDPDG,RMASS)
29856 C hadronic resonance of multi-pomeron coupling
29857 ELSE IF(IDPDG.EQ.990) THEN
29860 IDBAM = ipho_pdg2id(IDPDG)
29862 C sample mass of two-pion system
29863 CALL PHO_SAMASS(IDPDG,RMASS)
29865 C hadron remnants in inucleus interactions
29866 ELSE IF(IDPDG.EQ.81) THEN
29867 IF(IHFLD(1,1).EQ.0) THEN
29868 CALL PHO_SEAFLA(1,IFL1,IFL2,RMASS)
29869 CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
29871 CALL PHO_HACODE(IHFLD(1,1),IHFLD(1,2),IDBA1,IDBA2)
29873 RMAS1 = PHO_PMASS(IDBA1,0)
29874 RMAS2 = PHO_PMASS(IDBA2,0)
29875 IF((IDBA2.NE.0).AND.
29876 & (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
29883 IDPDG = IPHO_ID2PDG(IDBAM)
29885 ELSE IF(IDPDG.EQ.82) THEN
29886 IF(IHFLD(2,1).EQ.0) THEN
29887 CALL PHO_SEAFLA(2,IFL1,IFL2,RMASS)
29888 CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
29890 CALL PHO_HACODE(IHFLD(2,1),IHFLD(2,2),IDBA1,IDBA2)
29892 RMAS1 = PHO_PMASS(IDBA1,0)
29893 RMAS2 = PHO_PMASS(IDBA2,0)
29894 IF((IDBA2.NE.0).AND.
29895 & (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
29902 IDPDG = IPHO_ID2PDG(IDBAM)
29906 IF(IDEB(47).GE.5) THEN
29907 WRITE(LO,'(1X,A,/10X,3I7,E12.4)')
29908 & 'PHO_VECRES: IDPDG-OLD,IDPDG,IDBAM,MASS',
29909 & IDPDO,IDPDG,IDBAM,RMASS
29914 *$ CREATE PHO_DIFRES.FOR
29916 CDECK ID>, PHO_DIFRES
29917 SUBROUTINE PHO_DIFRES(IDMOTH,IVAL1,IVAL2,
29918 & IDPDG,IDBAM,RMASS,RGAM,RWG,LISTL)
29919 C**********************************************************************
29921 C list of resonance states for low mass resonances
29923 C input: IDMOTH PDG ID of mother particle
29924 C IVAL1,2 quarks (photon only)
29926 C output: IDPDG list of PDG IDs for possible resonances
29927 C IDBAM list of corresponding CPC IDs
29929 C RGAMS decay width
29930 C RMASS additional weight factor
29931 C LISTL entries in current list
29933 C**********************************************************************
29934 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29937 DIMENSION IDPDG(10),IDBAM(10),RMASS(10),RGAM(10),RWG(10)
29939 PARAMETER (EPS = 1.D-10,
29942 C input/output channels
29944 COMMON /POINOU/ LI,LO
29945 C event debugging information
29947 PARAMETER (NMAXD=100)
29948 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29949 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29950 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29951 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29952 C particle ID translation table
29953 integer ID_pdg_list,ID_list,ID_pdg_max
29954 character*12 name_list
29955 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
29957 C general particle data
29958 double precision xm_list,tau_list,gam_list,
29959 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
29960 & xm_bb82_list,xm_bb102_list
29961 integer ich3_list,iba3_list,iq_list,
29962 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
29963 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
29964 & xm_psm2_list(6,6),xm_vem2_list(6,6),
29965 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
29966 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
29967 & ich3_list(300),iba3_list(300),iq_list(3,300),
29968 & id_psm_list(6,6),id_vem_list(6,6),
29969 & id_b8_list(6,6,6),id_b10_list(6,6,6)
29971 DIMENSION RWGHT(20),IRPDG(20),IRBAM(20)
29972 DATA IRPDG /113, 223, 333, 50223, 40113, 60223, 10333, 30113,
29973 & 12212, 42212, -12212, -42212,
29975 DATA RWGHT /1.D0, 0.11D0, 0.1D0, 0.11D0, 1.D0, 0.11D0, 0.1D0,
29976 & 1.D0, 1.D0, 1.D0, 1.D0, 1.D0,
29984 if(IRPDG(i).ne.0) then
29985 IRBAM(i) = ipho_pdg2id(IRPDG(i))
29991 C copy table with particles and isospin weights
29993 IF(IDMOTH.EQ.22) THEN
29996 ELSE IF(IDMOTH.EQ.2212) THEN
29999 ELSE IF(IDMOTH.EQ.-2212) THEN
30008 IDBAM(LISTL) = IRBAM(I)
30009 IDPDG(LISTL) = IRPDG(I)
30010 RMASS(LISTL) = xm_list(iabs(IDBAM(LISTL)))
30011 RGAM(LISTL) = gam_list(iabs(IDBAM(LISTL)))
30012 RWG(LISTL) = RWGHT(I)
30016 IF(IDEB(85).GE.20) THEN
30017 WRITE(LO,'(1X,A,3I7)') 'PHO_DIFRES: mother,quarks',IDMOTH,
30020 WRITE(LO,'(1X,I3,2I7,E12.4)') I,IDBAM(I),IDPDG(I),RMASS(I)
30026 *$ CREATE PHO_MASSAD.FOR
30028 CDECK ID>, PHO_MASSAD
30029 SUBROUTINE PHO_MASSAD(IFLMO,IFL1,IFL2,
30030 & PMASS,XMCON,XMOUT,IDPDG,IDcpc)
30031 C***********************************************************************
30033 C fine-correction of low mass strings to mass of corresponding
30034 C resonance or two particle threshold
30036 C input: IFLMO PDG ID of mother particle
30037 C IFL1,2 requested parton flavours
30038 C (not used at the moment)
30039 C PMASS reference mass (mass of mother particle)
30040 C XMCON conjecture of mass
30042 C output: XMOUT output mass (adjusted input mass)
30043 C moved ot nearest mass possible
30044 C IDPDG PDG resonance ID
30045 C IDcpc CPC resonance ID
30047 C**********************************************************************
30048 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30051 PARAMETER ( DEPS = 1.D-8 )
30053 C input/output channels
30055 COMMON /POINOU/ LI,LO
30056 C event debugging information
30058 PARAMETER (NMAXD=100)
30059 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30060 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30061 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30062 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30063 C model switches and parameters
30065 INTEGER ISWMDL,IPAMDL
30066 DOUBLE PRECISION PARMDL
30067 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
30068 C general particle data
30069 double precision xm_list,tau_list,gam_list,
30070 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
30071 & xm_bb82_list,xm_bb102_list
30072 integer ich3_list,iba3_list,iq_list,
30073 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
30074 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
30075 & xm_psm2_list(6,6),xm_vem2_list(6,6),
30076 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
30077 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
30078 & ich3_list(300),iba3_list(300),iq_list(3,300),
30079 & id_psm_list(6,6),id_vem_list(6,6),
30080 & id_b8_list(6,6,6),id_b10_list(6,6,6)
30081 C particle decay data
30082 double precision wg_sec_list
30083 integer idec_list,isec_list
30084 COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
30087 DIMENSION XWG(10),RMA(10),RGA(10),RWG(10),IRPDG(10),IRBAM(10)
30094 C resonance treatment activated?
30095 IF(ISWMDL(23).EQ.0) RETURN
30097 CALL PHO_DIFRES(IFLMO,IFL1,IFL2,IRPDG,IRBAM,RMA,RGA,RWG,LISTL)
30098 IF(LISTL.LT.1) THEN
30099 IF(IDEB(7).GE.2) WRITE(LO,'(1X,A,3I7)')
30100 & 'PHO_MASSAD: no resonances for (IFMO,IF1,IF2)',
30105 PMASSL = (PMASS+0.15D0)**2
30107 C determine resonance probability
30109 RPROB = (PMASSL+DM2)*(XMINP2-PMASSL)/(DM2*XMINP2)
30110 IF(RPROB.LT.DT_RNDM(PMASSL)) THEN
30111 C sample new resonance
30114 XWG(I) = RWG(I)/RMA(I)**2
30115 XWGSUM = XWGSUM+XWG(I)
30129 XI = XWGSUM*DT_RNDM(XMOUT)
30132 XWGSUM = XWGSUM-XWG(I)
30133 IF((XI.LT.XWGSUM).AND.(I.LT.LISTL)) GOTO 200
30139 C sample new mass (from Breit-Wigner cross section)
30140 ALO = ATAN((PMASSL-XMRES2)/(XMRES*GARES))
30141 AHI = ATAN((5.D0-XMRES2)/(XMRES*GARES))
30142 XI = (AHI-ALO)*DT_RNDM(XMRES)+ALO
30143 XMOUT = XMRES*GARES*TAN(XI)+XMRES2
30144 XMOUT = SQRT(XMOUT)
30146 C check mass for decay
30149 DO 250 IK=idec_list(2,ID),idec_list(3,ID)
30152 IF(isec_list(I,IK).NE.0)
30153 & AMSUM = AMSUM + xm_list(iabs(isec_list(I,IK)))
30155 AMDCY = MIN(AMDCY,AMSUM)
30157 IF(AMDCY.GE.XMOUT) GOTO 150
30161 & WRITE(LO,'(1X,2A,/1X,3I6,2E10.3,2I7,2E10.3)')
30163 & 'IFMO,IF1,IF2,XMCON,XMOUT,IDPDG,IDcpc,RMA,RGA',
30164 & IFLMO,IFL1,IFL2,XMCON,XMOUT,IDPDG,IDcpc,RMA(I),RGA(I)
30171 & WRITE(LO,'(1X,A,/1X,3I6,2E10.3)')
30172 & 'PHO_MASSAD: string sampled: IFMO,IF1,IF2,XMCON,XMOUT',
30173 & IFLMO,IFL1,IFL2,XMCON,XMOUT
30177 *$ CREATE PHO_PDF.FOR
30180 SUBROUTINE PHO_PDF(NPAR,X,SCALE2,P2VIR,PD)
30181 C***************************************************************
30183 C call different PDF sets for different particle types
30185 C input: NPAR 1 IGRP(1),ISET(1)
30186 C 2 IGRP(2),ISET(2)
30187 C X momentum fraction
30188 C SCALE2 squared scale (GeV**2)
30189 C P2VIR particle virtuality (positive, GeV**2)
30191 C output PD(-6:6) field containing the x*PDF fractions
30193 C***************************************************************
30194 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30199 C input/output channels
30201 COMMON /POINOU/ LI,LO
30202 C currently activated parton density parametrizations
30204 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
30205 DOUBLE PRECISION PDFLAM,PDFQ2M
30206 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
30207 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
30208 C event debugging information
30210 PARAMETER (NMAXD=100)
30211 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30212 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30213 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30214 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30215 C model switches and parameters
30217 INTEGER ISWMDL,IPAMDL
30218 DOUBLE PRECISION PARMDL
30219 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
30221 DIMENSION PARAM(20),VALUE(20)
30224 REAL XR,P2R,Q2R,F2GM,XPDFGM
30225 DIMENSION XPDFGM(-6:6)
30227 C check of kinematic boundaries
30230 IF(IDEB(37).GE.0) THEN
30231 WRITE(LO,'(/,1X,A,E15.8/)')
30232 & 'PHO_PDF: x>1 (corrected to x=1)',X
30233 CALL PHO_PREVNT(-1)
30235 XI = 0.99999999999D0
30236 ELSE IF(X.LE.0.D0) THEN
30237 IF(IDEB(37).GE.0) THEN
30238 WRITE(LO,'(/,1X,A,E15.8/)') 'PHO_PDF: X <= 0 ',X
30239 CALL PHO_PREVNT(-1)
30249 IF((NPAR.EQ.1).OR.(NPAR.EQ.2)) THEN
30253 IF(IEXT(NPAR).EQ.0) THEN
30254 IF(ITYPE(NPAR).EQ.1) THEN
30256 IF(IGRP(NPAR).EQ.5) THEN
30257 IF(ISET(NPAR).EQ.3) THEN
30258 CALL PHO_DOR92HO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
30263 ELSE IF(ISET(NPAR).EQ.4) THEN
30264 CALL PHO_DOR92LO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
30269 ELSE IF(ISET(NPAR).EQ.5) THEN
30270 CALL PHO_DOR94HO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
30271 C heavy quarks from GRV92-HO
30273 ALAM2 = 0.248 * 0.248
30274 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30278 AKC = -0.625 - 0.523 * S
30280 BC = 1.896 + 1.616 * S
30281 DC = 4.12 + 0.683 * S
30282 EC = 4.36 + 1.328 * S
30283 ESC = 0.677 + 0.679 * S
30284 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30288 AKB = 0.0 - 0.193 * S
30291 DB = 3.447 + 0.927 * S
30292 EB = 4.68 + 1.259 * S
30293 ESB = 1.892 + 2.199 * S
30294 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30296 ELSE IF(ISET(NPAR).EQ.6) THEN
30297 CALL PHO_DOR94LO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
30298 C heavy quarks from GRV92-LO
30301 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30307 BC = 4.24 - 0.804 * S
30308 DC = 3.46 + 1.076 * S
30309 EC = 4.61 + 1.490 * S
30310 ESC = 2.555 + 1.961 * S
30311 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30318 DB = 2.929 + 1.396 * S
30319 EB = 4.71 + 1.514 * S
30320 ESB = 4.02 + 1.239 * S
30321 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30323 ELSE IF(ISET(NPAR).EQ.7) THEN
30324 CALL PHO_DOR94DI(XI,SCALE2, UV, DV, DEL, UDB, SB, GL)
30325 C heavy quarks from GRV92-HO
30327 ALAM2 = 0.248 * 0.248
30328 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30332 AKC = -0.625 - 0.523 * S
30334 BC = 1.896 + 1.616 * S
30335 DC = 4.12 + 0.683 * S
30336 EC = 4.36 + 1.328 * S
30337 ESC = 0.677 + 0.679 * S
30338 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30342 AKB = 0.0 - 0.193 * S
30345 DB = 3.447 + 0.927 * S
30346 EB = 4.68 + 1.259 * S
30347 ESB = 1.892 + 2.199 * S
30348 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30350 ELSE IF(ISET(NPAR).EQ.8) THEN
30351 CALL PHO_DOR98LO(XI,SCALE2,UV,DV,US,DS,SB,GL)
30354 C heavy quarks from GRV92-LO
30357 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30363 BC = 4.24 - 0.804 * S
30364 DC = 3.46 + 1.076 * S
30365 EC = 4.61 + 1.490 * S
30366 ESC = 2.555 + 1.961 * S
30367 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30374 DB = 2.929 + 1.396 * S
30375 EB = 4.71 + 1.514 * S
30376 ESB = 4.02 + 1.239 * S
30377 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30379 ELSE IF(ISET(NPAR).EQ.9) THEN
30380 * CALL PHO_DOR98SC(XI,SCALE2,UV,DV,US,DS,SB,GL)
30383 C heavy quarks from GRV92-LO
30386 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30392 BC = 4.24 - 0.804 * S
30393 DC = 3.46 + 1.076 * S
30394 EC = 4.61 + 1.490 * S
30395 ESC = 2.555 + 1.961 * S
30396 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30403 DB = 2.929 + 1.396 * S
30404 EB = 4.71 + 1.514 * S
30405 ESB = 4.02 + 1.239 * S
30406 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30412 PD(-2) = 0.5D0*(UDB-DEL)
30413 PD(-1) = 0.5D0*(UDB+DEL)
30421 ELSE IF(ITYPE(NPAR).EQ.2) THEN
30422 C pion PDFs (default for pi+)
30423 IF(IGRP(NPAR).EQ.5) THEN
30424 IF(ISET(NPAR).EQ.1) THEN
30425 CALL PHO_DORPHO (XI,SCALE2,VA,GL,QB,CB,BB)
30427 ELSE IF(ISET(NPAR).EQ.2) THEN
30428 CALL PHO_DORPLO (XI,SCALE2,VA,GL,QB,CB,BB)
30443 ELSE IF(ITYPE(NPAR).EQ.3) THEN
30445 IF(IGRP(NPAR).EQ.5) THEN
30446 IF(ISET(NPAR).EQ.1) THEN
30447 CALL PHO_DORGH0 (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30449 ELSE IF(ISET(NPAR).EQ.2) THEN
30450 CALL PHO_DORGHO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30452 ELSE IF(ISET(NPAR).EQ.3) THEN
30453 CALL PHO_DORGLO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30456 C reweight with Drees-Godbole factor
30458 IF(P2VIR.GT.0.001D0) THEN
30459 WGX = LOG(SCALE2/(P2VIR+PARMDL(144)))
30460 & /LOG(SCALE2/PARMDL(144))
30461 WGX = MAX(WGX,0.D0)
30463 PD(-5) = BB*WGX/137.D0
30464 PD(-4) = CB*WGX/137.D0
30465 PD(-3) = SB*WGX/137.D0
30466 PD(-2) = UB*WGX/137.D0
30467 PD(-1) = DB*WGX/137.D0
30468 PD(0) = GL*WGX*WGX/137.D0
30474 ELSE IF(IGRP(NPAR).EQ.8) THEN
30475 IF(ISET(NPAR).EQ.1) THEN
30476 CALL PHO_PHGAL (XI,SCALE2,PD)
30480 ELSE IF(ITYPE(NPAR).EQ.20) THEN
30484 PD(0) = 6.D0*(1.D0-XI)**5*PARMDL(26)*PARMDL(78)
30486 ELSE IF(MODE.EQ.2) THEN
30487 PD(0) = 6.D0*XI*(1.D0-XI)*PARMDL(26)*PARMDL(78)
30489 ELSE IF(MODE.EQ.3) THEN
30490 PD(0) = (0.18D0/XI+5.46D0)*(1.D0-XI)*PARMDL(26)*PARMDL(78)
30492 ELSE IF(MODE.EQ.4) THEN
30493 CALL PHO_CKMTPD(990,XI,SCALE2,PD)
30495 PD(I) = PD(I)*PARMDL(78)
30503 ELSE IF(IEXT(NPAR).EQ.2) THEN
30504 C PDFLIB call: new PDF numbering
30505 IF(NPAR.NE.NPAOLD) THEN
30506 PARAM(1) = 'NPTYPE'
30507 PARAM(2) = 'NGROUP'
30510 VALUE(1) = ITYPE(NPAR)
30511 VALUE(2) = ABS(IGRP(NPAR))
30512 VALUE(3) = ISET(NPAR)
30513 CALL PDFSET(PARAM,VALUE)
30515 IF(ITYPE(NPAR).EQ.3) THEN
30517 CALL STRUCTP(XI,SCALE2,P2VIR,IP2,PD(2),PD(1),PD(-2),PD(-1),
30518 & PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
30520 SCALE = SQRT(SCALE2)
30521 CALL STRUCTM(XI,SCALE,PD(2),PD(1),PD(-2),PD(-1),
30522 & PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
30527 IF(ITYPE(NPAR).EQ.1) THEN
30528 C proton valence quarks
30529 PD(1) = PD(1)+PD(-1)
30530 PD(2) = PD(2)+PD(-2)
30531 ELSE IF(ITYPE(NPAR).EQ.2) THEN
30535 PD(-1) = DVAL+PD(1)
30536 PD(2) = PD(2)+PD(-2)
30537 ELSE IF(ITYPE(NPAR).EQ.3) THEN
30538 C photon conventions
30544 ELSE IF(IEXT(NPAR).EQ.3) THEN
30545 C PHOLIB call: version 2.0
30546 CALL PHVAL(IGRP(NPAR),ISET(NPAR),XI,SCALE2,PD,IRET)
30548 WRITE(LO,'(/1X,A,I2)')
30549 & 'PHO_PDF:ERROR: non-vanishing PHVAL return code',IRET
30554 C photon PDFs depending on photon virtuality
30556 ELSE IF(IEXT(NPAR).EQ.4) THEN
30557 IF(IGRP(NPAR).EQ.1) THEN
30558 C Schuler/Sjostrand PDF (interface to single precision)
30563 CALL PHO_SASGAM(ISET(NPAR),XR,Q2R,P2R,IP2,F2GM,XPDFGM)
30565 PD(I) = DBLE(XPDFGM(I))
30568 ELSE IF(IGRP(NPAR).EQ.5) THEN
30569 C Gluck/Reya/Stratmann
30570 IF(ISET(NPAR).EQ.4) THEN
30571 CALL PHO_DORGLV (XI,SCALE2,P2VIR, UB, DB, SB, GL)
30572 CALL PHO_QPMPDF(4,XI,SCALE2,0.D0,P2VIR,CB)
30593 WRITE(LO,'(/1X,A,/10X,5I6)')
30594 & 'PHO_PDF:ERROR:unsupported PDF(NPAR,IEXT,ITYPE,IGRP,ISET)',
30595 & NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
30600 WRITE(LO,'(/1X,A,I5)') 'PHO_PDF:ERROR:invalid NPAR(1,2) ',NPAR
30605 C valence quark treatment
30607 IF(ITYPE(NPAR).EQ.2) THEN
30608 C meson conventions
30609 IF(IPARID(NPAR).EQ.111) THEN
30610 C pi0 valence quarks
30611 PD(-1) = (PD(1)+PD(-1))/2.D0
30613 PD(-2) = (PD(2)+PD(-2))/2.D0
30615 ELSE IF(ABS(IPARID(NPAR)).EQ.321) THEN
30617 VALS = PD(-1)-PD(1)
30619 PD(-3) = PD(-3)+VALS
30620 ELSE IF( (IPARID(NPAR).EQ.311)
30621 & .OR.(IPARID(NPAR).EQ.310)
30622 & .OR.(IPARID(NPAR).EQ.130)) THEN
30624 VALS = PD(-1)-PD(1)
30625 VALU = PD(2)-PD(-2)
30628 PD(2) = PD(2)+VALU/2.D0
30629 PD(-2) = PD(-2)+VALU/2.D0
30630 PD(3) = PD(3)+VALS/2.D0
30631 PD(-3) = PD(-3)+VALS/2.D0
30633 ELSE IF(ITYPE(NPAR).EQ.1) THEN
30634 C nucleon conventions
30635 IF(ABS(IPARID(NPAR)).EQ.2112) THEN
30636 C neutron valence quarks
30640 ELSE IF(ABS(IPARID(NPAR)).EQ.3222) THEN
30642 VALS = PD(1)-PD(-1)
30645 ELSE IF(ABS(IPARID(NPAR)).EQ.3112) THEN
30647 VALS = PD(1)-PD(-1)
30648 VALD = PD(2)-PD(-2)
30653 ELSE IF( (ABS(IPARID(NPAR)).EQ.3122)
30654 & .OR.(ABS(IPARID(NPAR)).EQ.3212)) THEN
30655 C (anti-)sigma0 and (anti-)lambda
30656 VALS = PD(1)-PD(-1)
30657 VALD = (PD(2)-PD(-2))/2.D0
30667 IF(IPARID(NPAR).LT.0) THEN
30675 C optionally remove valence quarks
30676 IF(IPAVA(NPAR).EQ.0) THEN
30678 PD(I) = MIN(PD(-I),PD(I))
30683 C debug information
30684 IF(IDEB(37).GE.30) WRITE(LO,
30685 & '(1X,A,I4,1P,3E12.4/,2X,A,6E10.3,/2X,A,E10.3,/2X,A,6E10.3)')
30686 & 'PHO_PDF: NPAR,X,SCALE**2,P2VIR',
30687 & NPAR,X,SCALE2,P2VIR,'PD(-6..-1)',(PD(I),I=-6,-1),
30688 & 'PD(0) ',PD(0),'PD(1..6) ',(PD(I),I=1,6)
30692 *$ CREATE PHO_QPMPDF.FOR
30694 CDECK ID>, PHO_QPMPDF
30695 SUBROUTINE PHO_QPMPDF(IQ,X,SCALE2,PTREF,PVIRT,FXP)
30696 C***************************************************************
30698 C contribution to photon PDF from box graph
30699 C (Bethe-Heitler process)
30701 C input: IQ quark flavour
30702 C SCALE2 scale (GeV**2, positive)
30703 C PTREF reference scale (GeV, positive)
30704 C X parton momentum fraction
30705 C PVIRT photon virtuality (GeV**2, positive)
30706 C FXP x*f(x,Q**2), x times parton density
30708 C***************************************************************
30709 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30712 C input/output channels
30714 COMMON /POINOU/ LI,LO
30715 C event debugging information
30717 PARAMETER (NMAXD=100)
30718 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30719 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30720 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30721 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30722 C internal rejection counters
30724 PARAMETER (NMXJ=60)
30725 CHARACTER*10 REJTIT
30727 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
30729 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
30730 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
30731 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
30734 DATA QM / 0.2D0,0.25D0,0.5D0,1.5D0,4.5D0,174.D0 /
30739 * QM2 = MAX(QM(I),PTREF)**2
30740 * QM2 = MAX(QM2,PVIRT)
30741 * BBE = (1.D0-X)*SCALE2
30742 * IF(BBE.LE.0.D0) THEN
30743 * IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
30744 * & 'PHO_QPMPDF: over mass limit (X,Q2,P2,QM)',X,SCALE2,
30747 * FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(2.D0*137.D0*PI)
30748 * & *((X**2+(1.D0-X)**2)*LOG(BBE/(QM2*X))+8.D0*X*(1.D0-X)-1.D0)
30749 C Bethe-Heitler process approximation for 2*x*p2/q2 << 1
30750 QM2 = MAX(QM(I),PTREF)**2
30751 W2 = SCALE2/X*(1.D0-X-X*PVIRT/SCALE2)
30752 IF(W2.GT.4.D0*QM2) THEN
30753 BE = SQRT(1.D0-4.D0*QM2/W2)
30754 BP = SQRT(1.D0+BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
30755 BM = SQRT(1.D0-BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
30756 * FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(137.D0*PI)*(BE*(-1.D0
30757 FXP = X*Q_ch2(I)*3.D0/(137.D0*PI)*(BE*(-1.D0
30758 & +6.D0*X-6.D0*X*X)+2.D0*X*X*((2.D0*QM2-PVIRT)/SCALE2
30759 & -4.D0*QM2*QM2/SCALE2**2)*(1.D0/BM-1.D0/BP)
30760 & +(X*X+(1.D0-X)**2+X*(1-3.D0*X)*4.D0*QM2/SCALE2
30761 & -X*X*8.D0*QM2*QM2/SCALE2**2)*LOG(BP/BM))
30763 IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
30764 & 'PHO_QPMPDF: under mass limit (X,Q2,P2,QM)',X,SCALE2,
30768 IF(IDEB(27).GE.20) WRITE(LO,'(1X,A,I3,1P,5E10.3)')
30769 & 'PHO_QPMPDF: X,Q2,P2,QM',I,X,SCALE2,PVIRT,QM(I),FXP
30772 *$ CREATE PHO_SETPDF.FOR
30774 CDECK ID>, PHO_SETPDF
30775 SUBROUTINE PHO_SETPDF(IDPDG,ITYP,IPAR,ISET,IEXT,IPAVAL,MODE)
30776 C***************************************************************
30778 C assigns PDF numbers to particles
30780 C input: IDPDG PDG number of particle
30781 C ITYP particle type
30782 C IPAR PDF paramertization
30783 C ISET number of set
30784 C IEXT library number for PDF calculation
30785 C IPAVAL (only output)
30786 C 1 PDF with valence quarks
30787 C 0 PDF without valence quarks
30788 C MODE -1 add entry to table
30789 C 1 read from table
30790 C 2 output of table
30792 C***************************************************************
30793 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30796 C input/output channels
30798 COMMON /POINOU/ LI,LO
30799 C event debugging information
30801 PARAMETER (NMAXD=100)
30802 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30803 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30804 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30805 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30806 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
30807 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
30808 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
30809 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
30810 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
30812 DIMENSION IPDFS(5,50)
30817 IF(IDPDG.EQ.81) THEN
30820 ELSE IF(IDPDG.EQ.82) THEN
30828 IF(IDCMP.EQ.IPDFS(1,I)) THEN
30833 IF(IDEB(80).GE.15) WRITE(LO,'(1X,A,I7,5X,3I4)')
30834 & 'PHO_SETPDF: ID,IPAR,ISET,IEXT',IDCMP,IPAR,ISET,IEXT
30838 IF(I.GT.IENTRY) THEN
30839 WRITE(LO,'(/1X,A,I7)')
30840 & 'PHO_SETPDF: no PDF assigned to ',IDCMP
30844 ELSE IF(MODE.EQ.-1) THEN
30846 IF(IDPDG.EQ.IPDFS(1,I)) THEN
30847 WRITE(LO,'(/1X,A,5I6)')
30848 & 'PHO_SETPDF: overwrite old particle PDF',
30849 & IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
30855 WRITE(LO,'(/1X,A,/1x,6I6)')
30856 & 'PHO_SETPDF:ERROR: no space left in IPDFS:',
30857 & I,IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
30863 IF(IDPDG.EQ.990) THEN
30865 ELSE IF(IDPDG.EQ.22) THEN
30867 ELSE IF(ABS(IDPDG).LT.1000) THEN
30876 ELSE IF(MODE.EQ.-2) THEN
30877 WRITE(LO,'(/1X,A)') 'PHO_SETPDF: PDFs assigned by user:'
30879 WRITE(LO,'(5X,I4,A,I7,A,4I5)') I,' particle:',IPDFS(1,I),
30880 & ' PDF-set ',IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
30883 WRITE(LO,'(/1X,A,I5)') 'PHO_SETPDF:ERROR: invalid mode ',MODE
30887 *$ CREATE PHO_GETPDF.FOR
30889 CDECK ID>, PHO_GETPDF
30890 SUBROUTINE PHO_GETPDF(NPAR,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
30891 C***************************************************************
30893 C get PDF information
30895 C input: NPAR 1 first PDF in /POPPDF/
30896 C 2 second PDF in /POPPDF/
30898 C output: PDFNA name of PDf parametrization
30899 C ALA QCD LAMBDA (4 flavours, in GeV)
30905 C***************************************************************
30906 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30911 C input/output channels
30913 COMMON /POINOU/ LI,LO
30915 C PHOLIB 4.15 common
30916 COMMON /W50512/ QCDL4,QCDL5
30917 COMMON /W50513/ XMIN,XMAX,Q2MIN,Q2MAX
30919 C PHOPDF version 2.0 common
30920 PARAMETER (MAXS=6,MAXP=10)
30922 COMMON/PHCOM1/ XLIM(MAXP,0:MAXS,2), Q2LIM(MAXP,0:MAXS,2),
30923 & NSET(MAXP,2),NFL(MAXP)
30924 COMMON/PHCOM2/ ALM(MAXP,0:MAXS),CHPAR(MAXP),IORD(MAXP,-MAXS:MAXS)
30926 C currently activated parton density parametrizations
30928 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
30929 DOUBLE PRECISION PDFLAM,PDFQ2M
30930 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
30931 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
30933 DIMENSION PARAM(20),VALUE(20)
30936 IF((NPAR.NE.1).AND.(NPAR.NE.2)) THEN
30937 WRITE(LO,'(/1X,A,I6)')
30938 & 'PHO_GETPDF:ERROR: invalid PDF number (1,2)',NPAR
30943 IF(IEXT(NPAR).EQ.0) THEN
30945 C internal parametrizations
30947 IF(ITYPE(NPAR).EQ.1) THEN
30949 IF(IGRP(NPAR).EQ.5) THEN
30950 IF(ISET(NPAR).EQ.3) THEN
30954 ELSE IF(ISET(NPAR).EQ.4) THEN
30958 ELSE IF(ISET(NPAR).EQ.5) THEN
30962 ELSE IF(ISET(NPAR).EQ.6) THEN
30966 ELSE IF(ISET(NPAR).EQ.7) THEN
30970 ELSE IF(ISET(NPAR).EQ.8) THEN
30974 ELSE IF(ISET(NPAR).EQ.9) THEN
30980 ELSE IF(ITYPE(NPAR).EQ.2) THEN
30982 IF(IGRP(NPAR).EQ.5) THEN
30983 IF(ISET(NPAR).EQ.1) THEN
30987 ELSE IF(ISET(NPAR).EQ.2) THEN
30993 ELSE IF(ITYPE(NPAR).EQ.3) THEN
30995 IF(IGRP(NPAR).EQ.5) THEN
30996 IF(ISET(NPAR).EQ.1) THEN
31000 ELSE IF(ISET(NPAR).EQ.2) THEN
31004 ELSE IF(ISET(NPAR).EQ.3) THEN
31009 ELSE IF(IGRP(NPAR).EQ.8) THEN
31010 IF(ISET(NPAR).EQ.1) THEN
31016 ELSE IF(ITYPE(NPAR).EQ.20) THEN
31018 IF(IGRP(NPAR).EQ.4) THEN
31019 CALL PHO_CKMTPA(990,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
31027 C external parametrizations
31029 ELSE IF(IEXT(NPAR).EQ.1) THEN
31030 C PDFLIB call: old numbering
31033 VALUE(1) = IGRP(NPAR)
31034 CALL PDFSET(PARAM,VALUE)
31041 ELSE IF(IEXT(NPAR).EQ.2) THEN
31042 C PDFLIB call: new numbering
31043 PARAM(1) = 'NPTYPE'
31044 PARAM(2) = 'NGROUP'
31047 VALUE(1) = ITYPE(NPAR)
31048 VALUE(2) = IGRP(NPAR)
31049 VALUE(3) = ISET(NPAR)
31050 CALL PDFSET(PARAM,VALUE)
31057 ELSE IF(IEXT(NPAR).EQ.3) THEN
31059 ALA = ALM(IGRP(NPAR),ISET(NPAR))
31061 PDFNA = CHPAR(IGRP(NPAR))
31063 C some special internal parametrizations
31065 ELSE IF(IEXT(NPAR).EQ.4) THEN
31066 C photon PDFs depending on virtualities
31067 IF(IGRP(NPAR).EQ.1) THEN
31068 C Schuler/Sjostrand parametrization
31070 IF(ISET(NPAR).EQ.1) THEN
31073 ELSE IF(ISET(NPAR).EQ.2) THEN
31076 ELSE IF(ISET(NPAR).EQ.3) THEN
31079 ELSE IF(ISET(NPAR).EQ.4) THEN
31083 ELSE IF(IGRP(NPAR).EQ.5) THEN
31084 C Gluck/Reya/Stratmann parametrization
31085 IF(ISET(NPAR).EQ.4) THEN
31091 ELSE IF(IEXT(NPAR).EQ.5) THEN
31092 C Schuler/Sjostrand anomalous only
31097 IF(ALA.LT.0.01D0) THEN
31098 WRITE(LO,'(/1X,2A,/10X,5I6)')
31099 & 'PHO_GETPDF:ERROR: ',
31100 & 'unsupported PDF (NPAR,IEXT,ITYPE,IGRP,ISET)',
31101 & NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
31107 *$ CREATE PHO_ACTPDF.FOR
31109 CDECK ID>, PHO_ACTPDF
31110 SUBROUTINE PHO_ACTPDF(IDPDG,K)
31111 C***************************************************************
31113 C activate PDF for QCD calculations
31115 C input: IDPDG PDG particle number
31116 C K 1 first PDF in /POPPDF/
31117 C 2 second PDF in /POPPDF/
31118 C -2 write current settings
31122 C***************************************************************
31123 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31126 C input/output channels
31128 COMMON /POINOU/ LI,LO
31129 C event debugging information
31131 PARAMETER (NMAXD=100)
31132 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31133 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31134 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31135 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31136 C currently activated parton density parametrizations
31138 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
31139 DOUBLE PRECISION PDFLAM,PDFQ2M
31140 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
31141 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
31145 C read PDF from table
31146 CALL PHO_SETPDF(IDPDG,ITYPE(K),IGRP(K),ISET(K),IEXT(K),
31149 C get PDF parameters
31150 CALL PHO_GETPDF(K,PDFNAM(K),PDFLAM(K),PDFQ2M(K),Q2MA,XMI,XMA)
31151 C initialize alpha_s calculation
31152 alam2 = PDFLAM(K)*PDFLAM(K)
31153 DUMMY = PHO_ALPHAS(alam2,-K)
31155 IF(IDEB(2).GE.20) THEN
31157 & 'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
31158 WRITE(LO,'(1X,A,I2,2E12.3,2X,A8,4I4,I7)') 'SIDE',K,
31159 & PDFLAM(K),PDFQ2M(K),PDFNAM(K),ITYPE(K),IGRP(K),ISET(K),
31160 & IEXT(K),IPARID(K)
31164 ELSE IF(K.EQ.-2) THEN
31166 C write table of current PDFs
31168 & 'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
31169 WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 1:',PDFLAM(1),
31170 & PDFQ2M(1),PDFNAM(1),ITYPE(1),IGRP(1),ISET(1),IEXT(1),
31172 WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 2:',PDFLAM(2),
31173 & PDFQ2M(2),PDFNAM(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),
31178 WRITE(LO,'(/1X,A,2I4)')
31179 & 'PHO_ACTPDF:ERROR: invalid arguments',IDPDG,K
31186 *$ CREATE PHO_PDFTST.FOR
31188 CDECK ID>, PHO_PDFTST
31189 SUBROUTINE PHO_PDFTST(IDPDG,SCALE2,P2MASS)
31190 C*********************************************************************
31192 C structure function test utility
31194 C input: IDPDG PDG ID of particle
31195 C SCALE2 squared scale (GeV**2)
31196 C P2MASS particle virtuality (pos, GeV**2)
31198 C output: tables of PDF, sum rule checking, table of F2
31200 C*********************************************************************
31201 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31204 C input/output channels
31206 COMMON /POINOU/ LI,LO
31207 C currently activated parton density parametrizations
31209 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
31210 DOUBLE PRECISION PDFLAM,PDFQ2M
31211 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
31212 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
31214 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
31215 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
31216 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
31218 DIMENSION PD(-6:6),PDSUM(-6:6),PDAVE(-6:6),FXP(4)
31221 CALL PHO_ACTPDF(IDPDG,1)
31222 CALL PHO_GETPDF(1,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
31224 WRITE(LO,'(/,A)') ' *** Structure Function Test Utility ***'
31225 WRITE(LO,'(A)') ' ======================================='
31227 WRITE(LO,'(/,A,3I10)')
31228 & ' used structure function:',ITYPE(1),IGRP(1),ISET(1)
31229 WRITE(LO,'(A,A)') ' corresponds to ',PDFNA
31230 WRITE(LO,'(A,E12.3)') ' used squared scale (GeV**2):',SCALE2
31231 WRITE(LO,'(A,E12.3)') ' particle virtuality (GeV**2):',P2MASS
31232 WRITE(LO,'(/1X,A)') 'x times parton densities'
31233 WRITE(LO,'(1X,A)') ' X PD(-4 - 4)'
31235 & ' ============================================================'
31237 C logarithmic loop over x values
31246 XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
31250 CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
31251 IF(X.NE.XCONTR) THEN
31252 WRITE(LO,*) ' x changed! old: ',XCONTR,' new: ',X
31254 WRITE(LO,'(1X,1P,10E11.4)') XCONTR,(PD(K),K=-4,4)
31255 XFIRST=XFIRST+XDELTA
31258 IF(IDPDG.EQ.22) THEN
31259 WRITE(LO,'(/1X,A)')
31260 & 'comparison PDF to contribution due to box diagram'
31261 WRITE(LO,'(1X,A)') ' X PD(1),PB(1), .... ,PD(4),PB(4)'
31263 & ' ============================================================'
31265 XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
31268 CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
31270 CALL PHO_QPMPDF(K,X,SCALE2,0.D0,P2MASS,FXP(K))
31272 WRITE(LO,'(1X,1P,9E11.4)') X,(PD(K),FXP(K),K=1,4)
31273 XFIRST=XFIRST+XDELTA
31277 C check momentum sum rule
31279 WRITE(LO,'(/1X,A)') 'PHO_PDFTST: estimate of quark sum rules'
31286 XX=DBLE(I)/DBLE(ITER)
31287 IF(XX.EQ.1.D0) XX = 0.999999D0
31288 CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
31290 PDSUM(K) = PDSUM(K)+PD(K)/XX
31291 PDAVE(K) = PDAVE(K)+PD(K)
31295 & 'Table: parton-ID, dx-integral over Q(X,Q**2), X*Q(X,Q**2)'
31298 PDSUM(I) = PDSUM(I)/DBLE(ITER)
31299 PDAVE(I) = PDAVE(I)/DBLE(ITER)
31300 XSUM = XSUM+PDAVE(I)
31301 WRITE(LO,'(9X,I3,3X,2E15.4)') I,PDSUM(I),PDAVE(I)
31303 WRITE(LO,'(1X,A)') 'PHO_PDFTST: valence flavours'
31305 WRITE(LO,'(9X,I3,E12.4)') I,PDSUM(I)-PDSUM(-I)
31307 WRITE(LO,'(1X,A,E12.4)') 'momentum sum rule',XSUM
31308 WRITE(LO,'(A/)') ' ============================================='
31312 WRITE(LO,'(/1X,A,E12.4,/1X,A)')
31313 & 'PHO_PDFTST: TABLE OF X, F2(X,Q**2) FOR Q**2',SCALE2,
31314 & '-----------------------------------------------------'
31317 XX=DBLE(I)/DBLE(ITER)
31318 IF(XX.EQ.1.D0) XX = 0.9999D0
31319 CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
31322 IF(K.NE.0) F2 = F2 + Q_ch2(K)*PD(K)
31324 WRITE(LO,'(5X,1P,2E14.5)') XX,F2
31326 WRITE(LO,'(A/)') ' ============================================='
31329 *$ CREATE PHO_REGPAR.FOR
31331 CDECK ID>, PHO_REGPAR
31332 SUBROUTINE PHO_REGPAR(ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4,
31333 & IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE)
31334 C**********************************************************************
31336 C registration of particle in /POEVT1/ and /POEVT2/
31338 C input: ISTH status code of particle
31339 C -2 initial parton hard scattering
31342 C 1 visible particle (no color)
31343 C 2 decayed particle
31344 C IDPDG PDG particle ID code
31345 C IDBAM CPC particle ID code
31346 C JM1,JM2 first and second mother index
31347 C P1..P4 four momentum
31348 C IPHIS1 extended history information
31349 C IPHIS1<100: JM1 from particle 1
31350 C IPHIS1>100: JM1 from particle 2
31352 C 2 valence diquark
31355 C (neg. for antipartons)
31356 C IPHIS2 extended history information
31357 C positive: JM2 from particle 1
31358 C negative: JM2 from particle 2
31360 C IC1,IC2 color labels for partons
31361 C IMODE 1 register given parton
31362 C 0 reset /POEVT1/ and /POEVT2/
31363 C 2 return data of entry IPOS
31365 C IPOS position of particle in /POEVT1/
31367 C**********************************************************************
31368 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31371 PARAMETER (DEPS = 1.D-20)
31373 C input/output channels
31375 COMMON /POINOU/ LI,LO
31376 C event debugging information
31378 PARAMETER (NMAXD=100)
31379 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31380 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31381 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31382 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31383 C standard particle data interface
31385 PARAMETER (NMXHEP=4000)
31386 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
31387 DOUBLE PRECISION PHEP,VHEP
31388 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
31389 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
31391 C extension to standard particle data interface (PHOJET specific)
31392 INTEGER IMPART,IPHIST,ICOLOR
31393 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
31395 IF(IMODE.EQ.1) THEN
31396 IF(IDEB(76).GE.26) THEN
31397 WRITE(LO,'(1X,A,/2X,I3,I6,3I4,4E10.3)')
31398 & 'PHO_REGPAR: ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4',
31399 & ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4
31400 WRITE(LO,'(1X,A,/2X,6I6)')
31401 & 'PHO_REGPAR: IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE',
31402 & IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE
31404 IF(NHEP.EQ.NMXHEP) THEN
31405 WRITE(LO,'(/1X,2A,2I6/)') 'PHO_REGPAR: ',
31406 & 'no space left in /POEVT1/ (NHEP,NMXHEP):',NHEP,NMXHEP
31412 IF(ABS(ISTH).LE.2) THEN
31413 IF((IDBAM.NE.0).AND.(IDPDG.EQ.0)) THEN
31414 IDPDGI = ipho_id2pdg(IDBAM)
31415 ELSE IF((IDBAM.EQ.0).AND.(IDPDG.NE.0)) THEN
31416 IDBAMI = ipho_pdg2id(IDPDG)
31420 ISTHEP(NHEP) = ISTH
31421 IDHEP(NHEP) = IDPDGI
31422 JMOHEP(1,NHEP) = JM1
31423 JMOHEP(2,NHEP) = JM2
31424 C update of mother-daugther relations
31425 IF(ABS(ISTH).LE.1) THEN
31427 IF(JDAHEP(1,JM1).EQ.0) THEN
31428 JDAHEP(1,JM1) = NHEP
31431 JDAHEP(2,JM1) = NHEP
31433 IF((JM2.NE.JM1).AND.(JM2.GT.0)) THEN
31434 IF(JDAHEP(1,JM2).EQ.0) THEN
31435 JDAHEP(1,JM2) = NHEP
31438 JDAHEP(2,JM2) = NHEP
31439 ELSE IF(JM2.LT.0) THEN
31440 DO 100 II=JM1+1,-JM2
31441 IF(JDAHEP(1,II).EQ.0) THEN
31442 JDAHEP(1,II) = NHEP
31445 JDAHEP(2,II) = NHEP
31453 IF((ABS(ISTH).LE.3).OR.(ISTH.EQ.20).OR.(ISTH.EQ.21)) THEN
31454 TMP=(P4-P3)*(P4+P3)-P1**2-P2**2
31455 PHEP(5,NHEP) = SIGN(SQRT(ABS(TMP)),TMP)
31457 PHEP(5,NHEP) = 0.D0
31461 C extended information
31462 IMPART(NHEP) = IDBAMI
31463 C extended history information
31464 IPHIST(1,NHEP) = IPHIS1
31465 IPHIST(2,NHEP) = IPHIS2
31466 C charge/baryon number or color labels
31468 ICOLOR(1,NHEP) = IPHO_CHR3(NHEP,2)
31469 ICOLOR(2,NHEP) = IPHO_BAR3(NHEP,2)
31471 ICOLOR(1,NHEP) = IC1
31472 ICOLOR(2,NHEP) = IC2
31476 IF(IDEB(76).GE.26) THEN
31477 WRITE(LO,'(1X,A,2I4,2X,2I4,E12.3,I5)')
31478 & 'PHO_REGPAR: IPHIST1/2,IC1/2,MASS,IPOS',IPHIST(1,NHEP),
31479 & IPHIST(2,NHEP),ICOLOR(1,NHEP),ICOLOR(2,NHEP),
31480 & PHEP(5,NHEP),IPOS
31483 ELSE IF(IMODE.EQ.0) THEN
31485 ELSE IF(IMODE.EQ.2) THEN
31486 IF((IPOS.LT.1).OR.(IPOS.GT.NHEP)) THEN
31487 WRITE(LO,'(1X,2A,2I8)') 'PHO_REGPAR: ',
31488 & 'index out of bounds (NHEP,IPOS)',NHEP,IPOS
31491 ISTH = ISTHEP(IPOS)
31492 IDPDG = IDHEP(IPOS)
31493 IDBAM = IMPART(IPOS)
31494 JM1 = JMOHEP(1,IPOS)
31495 JM2 = JMOHEP(2,IPOS)
31500 IPHIS1= IPHIST(1,IPOS)
31501 IPHIS2= IPHIST(2,IPOS)
31502 IC1 = ICOLOR(1,IPOS)
31503 IC2 = ICOLOR(2,IPOS)
31505 WRITE(LO,'(1X,A,I8)') 'PHO_REGPAR: invalid mode',IMODE
31509 *$ CREATE IPHO_CNV1.FOR
31511 CDECK ID>, IPHO_CNV1
31512 INTEGER FUNCTION IPHO_CNV1(IPART)
31513 C*********************************************************************
31515 C conversion of quark numbering scheme to PARTICLE DATA GROUP
31518 C input: old internal particle code of hard scattering
31524 C valence quarks changed to standard numbering
31526 C output: standard particle codes
31528 C*********************************************************************
31529 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31533 C change gluon number
31536 C change valence quark
31537 ELSE IF((II.GT.6).AND.(II.LT.13)) THEN
31538 IPHO_CNV1 = SIGN(II-6,IPART)
31544 *$ CREATE PHO_HACODE.FOR
31546 CDECK ID>, PHO_HACODE
31547 SUBROUTINE PHO_HACODE(ID1,ID2,IDcpc1,IDcpc2)
31548 C*********************************************************************
31550 C determination of hadron index from quarks
31552 C input: ID1,ID2 parton code according to PDG conventions
31554 C output: IDcpc1,2 CPC particle codes
31556 C*********************************************************************
31560 integer ID1,ID2,IDcpc1,IDcpc2
31562 C input/output channels
31564 COMMON /POINOU/ LI,LO
31565 C event debugging information
31567 PARAMETER (NMAXD=100)
31568 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31569 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31570 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31571 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31572 C general particle data
31573 double precision xm_list,tau_list,gam_list,
31574 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
31575 & xm_bb82_list,xm_bb102_list
31576 integer ich3_list,iba3_list,iq_list,
31577 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
31578 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
31579 & xm_psm2_list(6,6),xm_vem2_list(6,6),
31580 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
31581 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
31582 & ich3_list(300),iba3_list(300),iq_list(3,300),
31583 & id_psm_list(6,6),id_vem_list(6,6),
31584 & id_b8_list(6,6,6),id_b10_list(6,6,6)
31587 integer ii,jj,kk,i1,i2
31592 if(ID1*ID2.lt.0) then
31601 IDcpc1 = ID_psm_list(ii,jj)
31602 IDcpc2 = ID_vem_list(ii,jj)
31610 jj = (i1-ii*1000)/100
31615 kk = (i2-jj*1000)/100
31617 IDcpc1 = sign(ID_b8_list(ii,jj,kk),ID1)
31618 IDcpc2 = sign(ID_b10_list(ii,jj,kk),ID1)
31624 *$ CREATE PHO_ID2STR.FOR
31626 CDECK ID>, PHO_ID2STR
31627 SUBROUTINE PHO_ID2STR(ID1,ID2,NOBAM,IBAM1,IBAM2,IBAM3,IBAM4)
31628 C*********************************************************************
31630 C conversion of quark numbering scheme
31632 C input: standard particle codes:
31636 C output: NOBAM CPC string code
31637 C quark codes (PDG convention):
31643 C NOBAM = -1 invalid flavour combinations
31645 C*********************************************************************
31646 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31649 C input/output channels
31651 COMMON /POINOU/ LI,LO
31656 C quark-antiquark string
31657 IF((IDA1.LE.6).AND.(IDA2.LE.6)) THEN
31658 IF((ID1*ID2).GE.0) GOTO 100
31664 C quark-diquark string
31665 ELSE IF((IDA2.GT.6).AND.(IDA1.LE.6)) THEN
31666 IF((ID1*ID2).LE.0) GOTO 100
31669 IBAM3 = (ID2-IBAM2*1000)/100
31672 C diquark-quark string
31673 ELSE IF((IDA1.GT.6).AND.(IDA2.LE.6)) THEN
31674 IF((ID1*ID2).LE.0) GOTO 100
31676 IBAM2 = (ID1-IBAM1*1000)/100
31680 C gluon-gluon string
31681 ELSE IF((IDA1.EQ.21).AND.(IDA2.EQ.21)) THEN
31687 C diquark-antidiquark string
31688 ELSE IF((IDA1.GT.6).AND.(IDA2.GT.6)) THEN
31689 IF((ID1*ID2).GE.0) GOTO 100
31691 IBAM2 = (ID1-IBAM1*1000)/100
31693 IBAM4 = (ID2-IBAM3*1000)/100
31698 C invalid combination
31700 WRITE(LO,'(//1X,A,2I10)')
31701 & 'PHO_ID2STR: invalid flavors for string (ID1,ID2)',ID1,ID2
31706 *$ CREATE PHO_MKSLTR.FOR
31708 CDECK ID>, PHO_MKSLTR
31709 SUBROUTINE PHO_MKSLTR(P1,P2,GAM,GAMB)
31710 C********************************************************************
31712 C calculate successive Lorentz boots for arbitrary Lorentz trans.
31714 C input: P1 initial 4 vector
31715 C GAM(3),GAMB(3) Lorentz boost parameters
31717 C output: P2 final 4 vector
31719 C********************************************************************
31720 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31723 DIMENSION P1(4),P2(4),GAM(3),GAMB(3)
31727 P2(I)=GAM(I)*P1(I)+GAMB(I)*P2(4)
31728 P2(4)=GAM(I)*P2(4)+GAMB(I)*P1(I)
31732 *$ CREATE PHO_GETLTR.FOR
31734 CDECK ID>, PHO_GETLTR
31735 SUBROUTINE PHO_GETLTR(P1,P2,GAM,GAMB,DELE,IREJ)
31736 C********************************************************************
31738 C calculate Lorentz boots for arbitrary Lorentz transformation
31740 C input: P1 initial 4 vector
31741 C P2 final 4 vector
31743 C output: GAM(3),GAMB(3)
31744 C DELE energy deviation
31748 C********************************************************************
31749 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31752 PARAMETER ( DREL = 0.001D0 )
31754 C input/output channels
31756 COMMON /POINOU/ LI,LO
31758 DIMENSION P1(4),P2(4),GAM(3),GAMB(3),PA(4),PP(4)
31765 PM1 = P1(4)**2-P1(1)**2-P1(2)**2-P1(3)**2
31768 PP(4) = PM1+PP(1)**2+PP(2)**2+PP(3)**2
31769 IF(PP(4).LE.0.D0) RETURN
31770 PP(4) = SQRT(PP(4))
31771 GAMB(I) = (SQRT(PA(4)**2-PA(I)**2+PP(I)**2)*PP(I)
31772 & -PA(4)*PA(I))/(PA(4)**2+PP(I)**2)
31773 GAM(I) = 1.D0/SQRT(1.D0-GAMB(I)**2)
31774 GAMB(I) = GAMB(I)*GAM(I)
31781 C consistency check
31782 * IF(ABS(P2(4)-PP(4))/MAX(P2(4),PP(4)).GT.DREL) THEN
31783 * PM2 = P2(4)**2-P2(1)**2-P2(2)**2-P2(3)**2
31784 * WRITE(LO,'(/1X,A,2E12.5)')
31785 * & 'PHO_GETLTR: INCONSISTENT ENERGIES',P2(4),PP(4)
31786 * WRITE(LO,'(1X,A,2E12.4)') 'INPUT MASSES',PM1,PM2
31787 * WRITE(LO,'(1X,A,4E12.4)') 'INPUT ',P1
31788 * WRITE(LO,'(1X,A,4E12.4)') 'OUTPUT',P2
31789 * WRITE(LO,'(1X,A,4E12.4)') 'INTERN',PP
31793 *$ CREATE PHO_ALTRA.FOR
31795 CDECK ID>, PHO_ALTRA
31796 SUBROUTINE PHO_ALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
31797 C*********************************************************************
31799 C arbitrary Lorentz transformation
31801 C*********************************************************************
31802 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31805 EP=PCX*BGX+PCY*BGY+PCZ*BGZ
31810 P=SQRT(PX*PX+PY*PY+PZ*PZ)
31815 *$ CREATE PHO_LTRANS.FOR
31817 CDECK ID>, PHO_LTRANS
31818 SUBROUTINE PHO_LTRANS(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
31819 & PL,CXL,CYL,CZL,EL)
31820 C**********************************************************************
31822 C Lorentz transformation into lab - system
31824 C**********************************************************************
31825 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31828 PARAMETER ( TINY=1.D-08,TINY2=1.D-30 )
31830 C input/output channels
31832 COMMON /POINOU/ LI,LO
31834 SID=SQRT(1.D0-COD*COD)
31838 PLZ=GAM*PCMZ+BGAM*ECM
31839 PL=SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
31840 EL=GAM*ECM+BGAM*PCMZ
31842 C rotation into the original direction
31844 SIZ=SQRT(MAX((1.D0-COZ)*(1.D0+COZ),0.D0))
31846 * CALL PHO_DTRANS(CX,CY,CZ,COZ,SIZ,COF,SIF,CXL,CYL,CZL)
31857 IF (ABS(CX)-TINY) 1,1,2
31858 1 IF (ABS(CY)-TINY) 3,3,2
31861 * WRITE(LO,*) ' PHO_DTRANS CX CY CZ =',CX,CY,CZ
31865 * WRITE(LO,*) ' PHO_DTRANS CXL=SIZ*COF CYL=SIZ*SIF CZL=COZ'
31866 * WRITE(LO,*) CXL,CYL,CZL
31870 IF(AMAX.GT.TINY2) THEN
31873 A=AMAX*SQRT(1.D0+AR)
31875 * WRITE(LO,*) ' PHO_DTRANS AMAX LE TINY2 '
31881 CXL=-CY*XI/A-CZ*CX*YI/A+CX*ZI
31882 CYL=CX*XI/A-CZ*CY*YI/A+CY*ZI
31887 *$ CREATE PHO_TRANS.FOR
31889 CDECK ID>, PHO_TRANS
31890 SUBROUTINE PHO_TRANS(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
31891 C**********************************************************************
31893 C rotation of coordinate frame (1) de rotation around y axis
31894 C (2) fe rotation around z axis
31895 C (inverse rotation to PHO_TRANI)
31897 C**********************************************************************
31898 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31901 X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
31902 Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
31903 Z=-SDE *XO +CDE *ZO
31907 *$ CREATE PHO_TRANI.FOR
31909 CDECK ID>, PHO_TRANI
31910 SUBROUTINE PHO_TRANI(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
31911 C**********************************************************************
31913 C rotation of coordinate frame (1) -fe rotation around z axis
31914 C (2) -de rotation around y axis
31915 C (inverse rotation to PHO_TRANS)
31917 C**********************************************************************
31918 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31921 X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
31923 Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
31927 *$ CREATE pho_cpcini.FOR
31929 CDECK ID>, pho_cpcini
31930 SUBROUTINE pho_cpcini(Nrows,Number,List)
31931 C***********************************************************************
31933 C initialization of particle hash table
31935 C input: Number vector with Nrows entries according to PDG
31938 C output: List vector with hash table
31940 C (this code is based on the function initpns written by
31941 C Gerry Lynch, LBL, January 1990)
31943 C***********************************************************************
31947 C input/output channels
31949 COMMON /POINOU/ LI,LO
31951 integer Number(*),List(*),Nrows
31953 Integer Nin,Nout,Ip,I
31959 C Loop over all of the elements in the Number vector
31961 Do 500 Ip = 1,Nrows
31964 C Calculate a list number for this particle id number
31965 If(Nin.Gt.99999.or.Nin.Le.0) Then
31967 Else If(Nin.Le.577) Then
31970 Nout = Mod(Nin,577)
31976 C Count the bad entries
31977 WRITE(LO,'(1x,a,i10)')
31978 & 'pho_cpcini: invalid particle ID',Nin
31981 If(List(Nout).eq.0) Then
31984 If(Nin.eq.Number(List(Nout))) Then
31985 WRITE(LO,'(1x,a,i10)')
31986 & 'pho_cpcini: double particle ID',Nin
31989 If(Nout.Gt.577) Nout = Mod(Nout, 577)
31997 *$ CREATE ipho_pdg2id.FOR
31999 CDECK ID>, ipho_pdg2id
32000 INTEGER FUNCTION ipho_pdg2id(IDpdg)
32001 C**********************************************************************
32003 C calculation internal particle code using the particle index i
32004 C according to the PDG proposal.
32006 C input: IDpdg PDG particle number
32007 C output: ipho_pdg2id internal particle code
32008 C (0 for invalid IDpdg)
32010 C the hash algorithm is based on a program by Gerry Lynch
32012 C**********************************************************************
32018 C input/output channels
32020 COMMON /POINOU/ LI,LO
32021 C event debugging information
32023 PARAMETER (NMAXD=100)
32024 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32025 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32026 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32027 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32028 C particle ID translation table
32029 integer ID_pdg_list,ID_list,ID_pdg_max
32030 character*12 name_list
32031 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32038 if((Nin.gt.99999).or.(Nin.eq.0)) then
32039 C invalid particle number
32040 if(ideb(71).gt.5) WRITE(LO,'(1x,A,I10)')
32041 & 'ipho_pdg2id: invalid PDG ID number ',IDpdg
32044 else If(Nin.le.577) then
32048 C use hash algorithm
32049 Nout = mod(Nin,577)
32054 C particle not in table
32055 if(ID_list(Nout).Eq.0) then
32056 if(ideb(71).ge.0) WRITE(LO,'(1x,A,I10)')
32057 & 'ipho_pdg2id: particle not in table ',IDpdg
32062 if(ID_pdg_list(ID_list(Nout)).eq.Nin) then
32063 C particle ID found
32064 ipho_pdg2id = sign(ID_list(Nout),IDpdg)
32067 C increment and try again
32069 If(Nout.gt.577) Nout = Mod(Nout,577)
32075 *$ CREATE IPHO_ID2PDG.FOR
32077 CDECK ID>, IPHO_ID2PDG
32078 INTEGER FUNCTION ipho_id2pdg(IDcpc)
32079 C**********************************************************************
32081 C conversion of internal particle code to PDG standard
32083 C input: IDcpc internal particle number
32084 C output: ipho_id2pdg PDG particle number
32085 C (0 for invalid IDcpc)
32087 C**********************************************************************
32093 C input/output channels
32095 COMMON /POINOU/ LI,LO
32096 C event debugging information
32098 PARAMETER (NMAXD=100)
32099 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32100 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32101 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32102 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32103 C particle ID translation table
32104 integer ID_pdg_list,ID_list,ID_pdg_max
32105 character*12 name_list
32106 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32112 if((IDabs.lt.1).or.(IDabs.gt.ID_pdg_max)) then
32117 ipho_id2pdg = sign(ID_pdg_list(IDabs),IDcpc)
32121 *$ CREATE IPHO_LU2PDG.FOR
32123 CDECK ID>, IPHO_LU2PDG
32124 INTEGER FUNCTION IPHO_LU2PDG(LUKF)
32125 C**********************************************************************
32127 C conversion of JETSET KF code to PDG code
32129 C**********************************************************************
32130 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32132 PARAMETER (NTAB=10)
32133 DIMENSION LU2PD(2,NTAB)
32134 DATA LU2PD / 4232, 4322,
32146 IF(LU2PD(1,I).EQ.LUKF) THEN
32147 IPHO_LU2PDG=LU2PD(2,I)
32155 *$ CREATE IPHO_PDG2LU.FOR
32157 CDECK ID>, IPHO_PDG2LU
32158 INTEGER FUNCTION IPHO_PDG2LU(IPDG)
32159 C**********************************************************************
32161 C conversion of PDG code to JETSET code
32163 C**********************************************************************
32164 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32167 DIMENSION LU2PD(2,NTAB)
32168 DATA LU2PD / 4232, 4322,
32178 IF(LU2PD(2,I).EQ.IPDG) THEN
32179 IPHO_PDG2LU=LU2PD(1,I)
32187 *$ CREATE pho_pname.FOR
32189 CDECK ID>, pho_pname
32190 CHARACTER*15 FUNCTION pho_pname(ID,mode)
32191 C***********************************************************************
32193 C returns particle name for given ID number
32195 C input: ID particle ID number
32196 C mode 0: ID treated as compressed particle code
32197 C 1: ID treated as PDG number
32199 C***********************************************************************
32205 C input/output channels
32207 COMMON /POINOU/ LI,LO
32208 C standard particle data interface
32210 PARAMETER (NMXHEP=4000)
32211 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32212 DOUBLE PRECISION PHEP,VHEP
32213 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32214 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32216 C extension to standard particle data interface (PHOJET specific)
32217 INTEGER IMPART,IPHIST,ICOLOR
32218 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32219 C particle ID translation table
32220 integer ID_pdg_list,ID_list,ID_pdg_max
32221 character*12 name_list
32222 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32224 C general particle data
32225 double precision xm_list,tau_list,gam_list,
32226 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32227 & xm_bb82_list,xm_bb102_list
32228 integer ich3_list,iba3_list,iq_list,
32229 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32230 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32231 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32232 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32233 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32234 & ich3_list(300),iba3_list(300),iq_list(3,300),
32235 & id_psm_list(6,6),id_vem_list(6,6),
32236 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32238 C external functions
32239 integer ipho_id2pdg,ipho_pdg2id
32242 integer IDpdg,i,ii,k,l,ichar,i_anti
32245 pho_pname = '(?????????????)'
32249 IDpdg = ipho_id2pdg(ID)
32250 if(IDpdg.eq.0) return
32251 else if(mode.eq.1) then
32252 i = ipho_pdg2id(ID)
32255 else if(mode.eq.2) then
32256 if(ISTHEP(ID).gt.11) then
32257 if(ISTHEP(ID).eq.20) then
32258 pho_pname = 'hard ini. part.'
32259 else if(ISTHEP(ID).eq.21) then
32260 pho_pname = 'hard fin. part.'
32261 else if(ISTHEP(ID).eq.25) then
32262 pho_pname = 'hard scattering'
32263 else if(ISTHEP(ID).eq.30) then
32264 pho_pname = 'diff. diss. '
32265 else if(ISTHEP(ID).eq.35) then
32266 pho_pname = 'elastic scatt. '
32267 else if(ISTHEP(ID).eq.40) then
32268 pho_pname = 'central scatt. '
32275 WRITE(LO,'(1x,a,2i4)')
32276 & 'pho_pname: invalid arguments (ID,mode): ',ID,mode
32281 if((ii.eq.0).or.(ii.gt.ID_pdg_max)) return
32283 name = name_list(ii)
32284 ichar = ich3_list(ii)*sign(1,i)
32285 if(mod(ichar,3).ne.0) then
32291 C find position of first blank character
32295 if(name(k:k).ne.' ') goto 100
32297 C append anti-particle sign
32301 i_anti = i_anti+iq_list(l,ii)
32303 if(iba3_list(ii).ne.0) then
32306 else if(((i_anti.ne.0).and.(ichar.eq.0))
32307 & .or.(IDpdg.eq.-12)
32308 & .or.(IDpdg.eq.-14)
32309 & .or.(IDpdg.eq.-16)) then
32315 C append charge sign
32316 if(ichar.eq.-2) then
32318 else if(ichar.eq.-1) then
32320 else if(ichar.eq.1) then
32322 else if(ichar.eq.2) then
32330 *$ CREATE ipho_anti.FOR
32332 CDECK ID>, ipho_anti
32333 INTEGER FUNCTION ipho_anti(ID)
32334 C**********************************************************************
32336 C determine antiparticle for given ID
32338 C input: ID gives CPC particle number
32340 C output: ipho_anti antiparticle code
32342 C**********************************************************************
32348 C input/output channels
32350 COMMON /POINOU/ LI,LO
32351 C event debugging information
32353 PARAMETER (NMAXD=100)
32354 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32355 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32356 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32357 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32358 C particle ID translation table
32359 integer ID_pdg_list,ID_list,ID_pdg_max
32360 character*12 name_list
32361 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32363 C general particle data
32364 double precision xm_list,tau_list,gam_list,
32365 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32366 & xm_bb82_list,xm_bb102_list
32367 integer ich3_list,iba3_list,iq_list,
32368 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32369 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32370 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32371 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32372 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32373 & ich3_list(300),iba3_list(300),iq_list(3,300),
32374 & id_psm_list(6,6),id_vem_list(6,6),
32375 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32376 C standard particle data interface
32378 PARAMETER (NMXHEP=4000)
32379 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32380 DOUBLE PRECISION PHEP,VHEP
32381 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32382 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32384 C extension to standard particle data interface (PHOJET specific)
32385 INTEGER IMPART,IPHIST,ICOLOR
32386 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32388 C external functions
32389 integer ipho_id2pdg,ipho_pdg2id
32392 integer IDabs,IDpdg,i_anti,l
32398 if(iba3_list(IDabs).ne.0) return
32400 C charged particles
32401 if(ich3_list(IDabs).ne.0) return
32404 IDpdg = ipho_id2pdg(ID)
32405 if(IDpdg.eq.310) then
32406 ID = ipho_pdg2id(130)
32408 else if(IDpdg.eq.130) then
32409 ID = ipho_pdg2id(310)
32413 C neutral mesons with open strangeness, charm, or beauty
32416 i_anti = i_anti+iq_list(l,IDabs)
32418 if(i_anti.ne.0) return
32422 if((IDpdg.eq.12).or.(IDpdg.eq.14).or.(IDpdg.eq.16)) return
32428 *$ CREATE ipho_chr3.FOR
32430 CDECK ID>, ipho_chr3
32431 INTEGER FUNCTION ipho_chr3(ID,mode)
32432 C**********************************************************************
32434 C output of three times the electric charge
32437 C 0 ID gives CPC particle number
32438 C 1 ID gives PDG particle number
32439 C 2 ID gives position of particle in /POEVT1/
32441 C**********************************************************************
32447 C input/output channels
32449 COMMON /POINOU/ LI,LO
32450 C event debugging information
32452 PARAMETER (NMAXD=100)
32453 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32454 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32455 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32456 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32457 C standard particle data interface
32459 PARAMETER (NMXHEP=4000)
32460 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32461 DOUBLE PRECISION PHEP,VHEP
32462 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32463 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32465 C extension to standard particle data interface (PHOJET specific)
32466 INTEGER IMPART,IPHIST,ICOLOR
32467 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32468 C particle ID translation table
32469 integer ID_pdg_list,ID_list,ID_pdg_max
32470 character*12 name_list
32471 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32473 C general particle data
32474 double precision xm_list,tau_list,gam_list,
32475 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32476 & xm_bb82_list,xm_bb102_list
32477 integer ich3_list,iba3_list,iq_list,
32478 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32479 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32480 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32481 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32482 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32483 & ich3_list(300),iba3_list(300),iq_list(3,300),
32484 & id_psm_list(6,6),id_vem_list(6,6),
32485 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32487 C external functions
32488 integer ipho_pdg2id
32497 else if(mode.eq.1) then
32498 i = ipho_pdg2id(ID)
32501 else if(mode.eq.2) then
32502 if(ISTHEP(ID).gt.11) return
32505 IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32506 ipho_chr3 = ICOLOR(1,ID)
32510 WRITE(LO,'(1x,a,2i4)')
32511 & 'ipho_chr3: invalid mode (ID,mode): ',ID,mode
32515 if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32516 WRITE(LO,'(1x,a,3i8)')
32517 & 'ipho_chr3: invalid arguments (ID,mode,i): ',ID,mode,i
32518 ipho_chr3 = 1.D0/dble(i)
32523 ipho_chr3 = ich3_list(iabs(i))*sign(1,i)
32527 *$ CREATE ipho_bar3.FOR
32529 CDECK ID>, ipho_bar3
32530 INTEGER FUNCTION ipho_bar3(ID,mode)
32531 C**********************************************************************
32533 C output of three times the baryon charge
32536 C 0 ID gives CPC particle number
32537 C 1 ID gives PDG particle number
32538 C 2 ID gives position of particle in /POEVT1/
32540 C**********************************************************************
32546 C input/output channels
32548 COMMON /POINOU/ LI,LO
32549 C event debugging information
32551 PARAMETER (NMAXD=100)
32552 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32553 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32554 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32555 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32556 C standard particle data interface
32558 PARAMETER (NMXHEP=4000)
32559 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32560 DOUBLE PRECISION PHEP,VHEP
32561 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32562 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32564 C extension to standard particle data interface (PHOJET specific)
32565 INTEGER IMPART,IPHIST,ICOLOR
32566 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32567 C particle ID translation table
32568 integer ID_pdg_list,ID_list,ID_pdg_max
32569 character*12 name_list
32570 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32572 C general particle data
32573 double precision xm_list,tau_list,gam_list,
32574 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32575 & xm_bb82_list,xm_bb102_list
32576 integer ich3_list,iba3_list,iq_list,
32577 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32578 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32579 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32580 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32581 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32582 & ich3_list(300),iba3_list(300),iq_list(3,300),
32583 & id_psm_list(6,6),id_vem_list(6,6),
32584 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32586 C external functions
32587 integer ipho_pdg2id
32596 else if(mode.eq.1) then
32597 i = ipho_pdg2id(ID)
32600 else if(mode.eq.2) then
32601 if(ISTHEP(ID).gt.11) return
32604 IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32605 ipho_bar3 = ICOLOR(2,ID)
32609 WRITE(LO,'(1x,a,2i4)')
32610 & 'ipho_bar3: invalid mode (ID,mode): ',ID,mode
32614 if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32615 WRITE(LO,'(1x,a,3i8)')
32616 & 'ipho_bar3: invalid arguments (ID,mode,i): ',ID,mode,i
32617 ipho_bar3 = 1.D0/dble(i)
32621 ipho_bar3 = iba3_list(iabs(i))*sign(1,i)
32625 *$ CREATE pho_pmass.FOR
32627 CDECK ID>, pho_pmass
32628 DOUBLE PRECISION FUNCTION pho_pmass(ID,mode)
32629 C***********************************************************************
32633 C input: mode -1 initialization
32634 C 0 ID gives CPC particle number
32635 C 1 ID gives PDG particle number,
32636 C (for quarks current masses are returned)
32637 C 2 ID gives position of particle in /POEVT1/
32638 C 3 ID gives PDG parton number,
32639 C (for quarks constituent masses are returned)
32641 C output: average particle mass (in GeV)
32643 C***********************************************************************
32647 integer ID,mode,MSTJ24
32649 C input/output channels
32651 COMMON /POINOU/ LI,LO
32652 C event debugging information
32654 PARAMETER (NMAXD=100)
32655 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32656 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32657 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32658 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32659 C model switches and parameters
32661 INTEGER ISWMDL,IPAMDL
32662 DOUBLE PRECISION PARMDL
32663 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
32664 C standard particle data interface
32666 PARAMETER (NMXHEP=4000)
32667 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32668 DOUBLE PRECISION PHEP,VHEP
32669 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32670 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32672 C extension to standard particle data interface (PHOJET specific)
32673 INTEGER IMPART,IPHIST,ICOLOR
32674 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32675 C particle ID translation table
32676 integer ID_pdg_list,ID_list,ID_pdg_max
32677 character*12 name_list
32678 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32680 C general particle data
32681 double precision xm_list,tau_list,gam_list,
32682 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32683 & xm_bb82_list,xm_bb102_list
32684 integer ich3_list,iba3_list,iq_list,
32685 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32686 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32687 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32688 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32689 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32690 & ich3_list(300),iba3_list(300),iq_list(3,300),
32691 & id_psm_list(6,6),id_vem_list(6,6),
32692 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32694 DOUBLE PRECISION PARU,PARJ
32695 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32697 C external functions
32698 integer ipho_pdg2id,ipho_id2pdg
32699 DOUBLE PRECISION PYMASS
32708 else if(mode.eq.1) then
32709 i = ipho_pdg2id(ID)
32711 else if(mode.eq.2) then
32712 if(ISTHEP(ID).gt.11) return
32715 IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32716 pho_pmass = PHEP(5,ID)
32719 else if(mode.eq.3) then
32721 if((i.gt.0).and.(i.le.6)) then
32722 pho_pmass = PARMDL(150+i)
32725 i = ipho_pdg2id(ID)
32728 else if(mode.eq.-1) then
32729 C initialization: take masses for quarks and di-quarks from JETSET
32733 IDpdg = ipho_id2pdg(i)
32734 xm_list(i) = PYMASS(IDpdg)
32739 WRITE(LO,'(1x,a,2i4)')
32740 & 'pho_pmass: invalid arguments (ID,mode): ',ID,mode
32744 if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32745 WRITE(LO,'(1x,a,2i8)')
32746 & 'pho_pmass: invalid arguments (ID,mode): ',ID,mode
32747 pho_pmass = 1.D0/dble(i)
32751 pho_pmass = xm_list(iabs(i))
32755 *$ CREATE PHO_MEMASS.FOR
32757 CDECK ID>, PHO_MEMASS
32758 SUBROUTINE PHO_MEMASS(I,J,AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
32759 C**********************************************************************
32761 C determine meson masses corresponding to the input flavours
32763 C input: I,J,K quark flavours (PDG convention)
32765 C output: AMPS pseudo scalar meson mass
32766 C AMPS2 next possible two particle configuration
32767 C (two pseudo scalar mesons)
32768 C AMVE vector meson mass
32769 C AMVE2 next possible two particle configuration
32770 C (two vector mesons)
32771 C IPS,IVE meson numbers in CPC
32773 C**********************************************************************
32777 integer I,J,IPS,IVE
32778 double precision AMPS,AMPS2,AMVE,AMVE2
32780 C input/output channels
32782 COMMON /POINOU/ LI,LO
32783 C event debugging information
32785 PARAMETER (NMAXD=100)
32786 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32787 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32788 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32789 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32790 C particle ID translation table
32791 integer ID_pdg_list,ID_list,ID_pdg_max
32792 character*12 name_list
32793 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32795 C general particle data
32796 double precision xm_list,tau_list,gam_list,
32797 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32798 & xm_bb82_list,xm_bb102_list
32799 integer ich3_list,iba3_list,iq_list,
32800 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32801 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32802 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32803 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32804 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32805 & ich3_list(300),iba3_list(300),iq_list(3,300),
32806 & id_psm_list(6,6),id_vem_list(6,6),
32807 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32821 IPS = id_psm_list(ii,jj)
32822 IVE = id_vem_list(ii,jj)
32825 AMPS = xm_list(iabs(IPS))
32830 AMVE = xm_list(iabs(IVE))
32835 C next possible two-particle configurations (add phase space)
32836 AMPS2 = xm_psm2_list(ii,jj)*1.5D0
32837 AMVE2 = xm_vem2_list(ii,jj)*1.1D0
32841 *$ CREATE PHO_BAMASS.FOR
32843 CDECK ID>, PHO_BAMASS
32844 SUBROUTINE PHO_BAMASS(I,J,K,AM8,AM82,AM10,AM102,I8,I10)
32845 C**********************************************************************
32847 C determine baryon masses corresponding to the input flavours
32849 C input: I,J,K quark flavours (PDG convention)
32851 C output: AM8 octett baryon mass
32852 C AM82 next possible two particle configuration
32853 C (octett baryon and meson)
32854 C AM10 decuplett baryon mass
32855 C AM102 next possible two particle configuration
32856 C (decuplett baryon and meson,
32857 C baryon built up from first two quarks)
32858 C I8,I10 internal baryon numbers
32860 C**********************************************************************
32864 integer I,J,K,I8,I10
32865 double precision AM8,AM82,AM10,AM102
32867 C input/output channels
32869 COMMON /POINOU/ LI,LO
32870 C event debugging information
32872 PARAMETER (NMAXD=100)
32873 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32874 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32875 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32876 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32877 C particle ID translation table
32878 integer ID_pdg_list,ID_list,ID_pdg_max
32879 character*12 name_list
32880 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32882 C general particle data
32883 double precision xm_list,tau_list,gam_list,
32884 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32885 & xm_bb82_list,xm_bb102_list
32886 integer ich3_list,iba3_list,iq_list,
32887 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32888 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32889 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32890 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32891 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32892 & ich3_list(300),iba3_list(300),iq_list(3,300),
32893 & id_psm_list(6,6),id_vem_list(6,6),
32894 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32899 C find particle ID's
32903 I8 = id_b8_list(ii,jj,kk)
32904 I10 = id_b10_list(ii,jj,kk)
32906 C masses (if combination possible)
32914 AM10 = xm_list(I10)
32920 C next possible two-particle configurations (add phase space)
32921 AM82 = xm_b82_list(ii,jj,kk)*1.5D0
32922 AM102 = xm_b102_list(ii,jj,kk)*1.1D0
32926 *$ CREATE PHO_DQMASS.FOR
32928 CDECK ID>, PHO_DQMASS
32929 SUBROUTINE PHO_DQMASS(I,J,K,L,AM82,AM102)
32930 C**********************************************************************
32932 C determine minimal masses corresponding to the input flavours
32933 C (diquark a-diquark string system)
32935 C input: I,J,K,L quark flavours (PDG convention)
32937 C output: AM82 mass of two octett baryons
32938 C AM102 mass of two decuplett baryons
32940 C**********************************************************************
32945 double precision AM82,AM102
32947 C input/output channels
32949 COMMON /POINOU/ LI,LO
32950 C event debugging information
32952 PARAMETER (NMAXD=100)
32953 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32954 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32955 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32956 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32957 C general particle data
32958 double precision xm_list,tau_list,gam_list,
32959 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32960 & xm_bb82_list,xm_bb102_list
32961 integer ich3_list,iba3_list,iq_list,
32962 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32963 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32964 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32965 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32966 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32967 & ich3_list(300),iba3_list(300),iq_list(3,300),
32968 & id_psm_list(6,6),id_vem_list(6,6),
32969 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32972 integer ii,jj,kk,ll
32979 AM82 = xm_bb82_list(ii,jj,kk,ll)
32980 AM102 = xm_bb102_list(ii,jj,kk,ll)
32984 *$ CREATE PHO_CHECK.FOR
32986 CDECK ID>, PHO_CHECK
32987 SUBROUTINE PHO_CHECK(MD,IDEV)
32988 C**********************************************************************
32990 C check quantum numbers of entries in /POEVT1/ and /POEVT2/
32991 C (energy, momentum, charge, baryon number conservation)
32993 C input: MD -1 check overall momentum conservation
32994 C and perform detailed check only in case of
32996 C 1 test all branchings, mother-daughter
32999 C output: IDEV 0 no deviations
33000 C 1 deviations found
33002 C**********************************************************************
33003 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33006 C input/output channels
33008 COMMON /POINOU/ LI,LO
33009 C event debugging information
33011 PARAMETER (NMAXD=100)
33012 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33013 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33014 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33015 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33016 C model switches and parameters
33018 INTEGER ISWMDL,IPAMDL
33019 DOUBLE PRECISION PARMDL
33020 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33021 C global event kinematics and particle IDs
33022 INTEGER IFPAP,IFPAB
33023 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
33024 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
33025 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
33026 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
33027 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
33028 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
33029 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
33030 C standard particle data interface
33032 PARAMETER (NMXHEP=4000)
33033 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33034 DOUBLE PRECISION PHEP,VHEP
33035 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33036 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33038 C extension to standard particle data interface (PHOJET specific)
33039 INTEGER IMPART,IPHIST,ICOLOR
33040 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33041 C color string configurations including collapsed strings and hadrons
33043 PARAMETER (MSTR=500)
33044 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33045 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33046 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33047 & NNCH(MSTR),IBHAD(MSTR),ISTR
33049 C count number of errors to avoid disk overflow
33053 C conservation check suppressed
33054 IF((IPAMDL(15).EQ.0).OR.(IDEB(20).LE.-10)) RETURN
33056 IF(IPAMDL(13).GT.0) THEN
33058 C DPMJET call with x limitations
33060 ECM1 = SQRT(XPSUB*XTSUB)*ECM
33066 C first two entries are considered as scattering particles
33067 EE1 = PHEP(4,1) + PHEP(4,2)
33068 PX1 = PHEP(1,1) + PHEP(1,2)
33069 PY1 = PHEP(2,1) + PHEP(2,2)
33070 PZ1 = PHEP(3,1) + PHEP(3,2)
33076 IF(MODE.EQ.-1) GOTO 500
33083 C recognize only decayed particles as mothers
33084 IF(ISTHEP(I).EQ.2) THEN
33085 C search for other mother particles
33088 IF(IPAMDL(178).NE.0)
33089 & WRITE(LO,'(1X,2A,I4)') 'PHO_CHECK: ',
33090 & 'entry marked as decayed but no dauther given:',I
33095 C sum over mother particles
33096 ICH1 = IPHO_CHR3(K1,2)
33097 IBA1 = IPHO_BAR3(K1,2)
33104 IF((K1.GT.I).OR.(K2.LT.I)) THEN
33105 WRITE(LO,'(/,1X,2A,3I4)') 'PHO_CHECK: ',
33106 & 'inconsistent mother/daughter relation found',I,K1,K2
33107 CALL PHO_PREVNT(-1)
33110 IF(ABS(ISTHEP(II)).LE.2) THEN
33111 ICH1 = ICH1 + IPHO_CHR3(II,2)
33112 IBA1 = IBA1 + IPHO_BAR3(II,2)
33113 EE1 = EE1 + PHEP(4,II)
33114 PX1 = PX1 + PHEP(1,II)
33115 PY1 = PY1 + PHEP(2,II)
33116 PZ1 = PZ1 + PHEP(3,II)
33119 ELSE IF((K2.GT.0).AND.(K2.NE.K1)) THEN
33120 ICH1 = ICH1 + IPHO_CHR3(K2,2)
33121 IBA1 = IBA1 + IPHO_BAR3(K2,2)
33122 EE1 = EE1 + PHEP(4,K2)
33123 PX1 = PX1 + PHEP(1,K2)
33124 PY1 = PY1 + PHEP(2,K2)
33125 PZ1 = PZ1 + PHEP(3,K2)
33128 C sum over daughter particles
33135 DO 200 II=JDAHEP(1,I),JDAHEP(2,I)
33136 IF(ABS(ISTHEP(II)).LE.2) THEN
33137 ICH2 = ICH2 + IPHO_CHR3(II,2)
33138 IBA2 = IBA2 + IPHO_BAR3(II,2)
33139 EE2 = EE2 + PHEP(4,II)
33140 PX2 = PX2 + PHEP(1,II)
33141 PY2 = PY2 + PHEP(2,II)
33142 PZ2 = PZ2 + PHEP(3,II)
33146 C conservation check
33147 ESC = MAX(MAX(EE1,EE2)*DDREL,DDABS)
33148 IF(ABS(EE1-EE2).GT.ESC) THEN
33149 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E10.3)')
33150 & 'PHO_CHECK: energy conservation violated for',
33151 & 'entry,initial,final:',I,EE1,EE2
33154 ESC = MAX(MAX(ABS(PX1),ABS(PX2))*DDREL,DDABS)
33155 IF(ABS(PX1-PX2).GT.ESC) THEN
33156 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33157 & 'PHO_CHECK: x-momentum conservation violated for',
33158 & 'entry,initial,final:',I,PX1,PX2
33161 ESC = MAX(MAX(ABS(PY1),ABS(PY2))*DDREL,DDABS)
33162 IF(ABS(PY1-PY2).GT.ESC) THEN
33163 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33164 & 'PHO_CHECK: y-momentum conservation violated for',
33165 & 'entry,initial,final:',I,PY1,PY2
33168 ESC = MAX(MAX(ABS(PZ1),ABS(PZ2))*DDREL,DDABS)
33169 IF(ABS(PZ1-PZ2).GT.ESC) THEN
33170 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33171 & 'PHO_CHECK: z-momentum conservation violated for',
33172 & 'entry,initial,final:',I,PZ1,PZ2
33175 IF(ICH1.NE.ICH2) THEN
33176 WRITE(LO,'(1X,A,/,5X,A,I3,2X,2I5)')
33177 & 'PHO_CHECK: charge conservation violated for',
33178 & 'entry,initial,final:',I,ICH1,ICH2
33181 IF(IBA1.NE.IBA2) THEN
33182 WRITE(LO,'(1X,2A,/,5X,A,I3,2X,2I5)') 'PHO_CHECK: ',
33183 & 'baryon charge conservation violated for',
33184 & 'entry,initial,final:',I,IBA1,IBA2
33187 IF(IDEB(20).GE.35) THEN
33189 & '(/,1X,A,A,2(2X,I4,A,I4),2(/,5X,A,4E13.4),/5X,A,4I5)')
33190 & 'PHO_CHECK diagnostics:',
33191 & '(1.mother/l.mother,1.daughter/l.daughter):',
33192 & K1,'/',K2,JDAHEP(1,I),'/',JDAHEP(2,I),
33193 & 'mother momenta ',PX1,PY1,PZ1,EE1,
33194 & 'daughter momenta ',PX2,PY2,PZ2,EE2,
33195 & 'charge,baryon no ',ICH1,ICH2,IBA1,IBA2
33200 IF(I.LE.NHEP) GOTO 100
33206 C write complete event in case of deviations
33207 IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
33211 IF(ISWMDL(6).GE.0) CALL PYLIST(1)
33215 C stop after too many errors
33216 IF(IERR.GT.IPAMDL(179)) THEN
33217 WRITE(LO,'(////1X,2A,I6,////)') 'PHO_CHECK:ERROR:',
33218 & 'too many inconsistencies found, program terminated',IERR
33224 C overall check only (less time consuming)
33236 C recognize only existing particles as possible daughters
33237 IF(ABS(ISTHEP(K)).EQ.1) THEN
33238 ICH2 = ICH2 + IPHO_CHR3(K,2)
33239 IBA2 = IBA2 + IPHO_BAR3(K,2)
33240 EE2 = EE2 + PHEP(4,K)
33241 PX2 = PX2 + PHEP(1,K)
33242 PY2 = PY2 + PHEP(2,K)
33243 PZ2 = PZ2 + PHEP(3,K)
33247 C check energy-momentum conservation
33250 IF(IPAMDL(13).GT.0) THEN
33252 C DPMJET call with x limitations
33253 ECM2 = SQRT((EE2-PZ2)*(EE2+PZ2)-PX2**2-PY2**2)
33254 IF(ABS(ECM1-ECM2).GT.ESC) THEN
33255 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33256 & 'PHO_CHECK: c.m. energy conservation violated',
33257 & 'initial/final energy:',ECM1,ECM2
33264 IF(ABS(EE1-EE2).GT.ESC) THEN
33265 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33266 & 'PHO_CHECK: energy conservation violated',
33267 & 'initial/final energy:',EE1,EE2
33270 IF(ABS(PX1-PX2).GT.ESC) THEN
33271 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33272 & 'PHO_CHECK: x-momentum conservation violated',
33273 & 'initial/final x-momentum:',PX1,PX2
33276 IF(ABS(PY1-PY2).GT.ESC) THEN
33277 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33278 & 'PHO_CHECK: y-momentum conservation violated',
33279 & 'initial/final y-momentum:',PY1,PY2
33282 IF(ABS(PZ1-PZ2).GT.ESC) THEN
33283 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33284 & 'PHO_CHECK: z-momentum conservation violated',
33285 & 'initial/final z-momentum:',PZ1,PZ2
33289 C check of quantum number conservation
33291 ICH1 = IPHO_CHR3(1,2) + IPHO_CHR3(2,2)
33292 IBA1 = IPHO_BAR3(1,2) + IPHO_BAR3(2,2)
33294 IF(ICH1.NE.ICH2) THEN
33295 WRITE(LO,'(1X,A,/,5X,A,2I5)')
33296 & 'PHO_CHECK: charge conservation violated',
33297 & 'initial/final charge sum',ICH1,ICH2
33300 IF(IBA1.NE.IBA2) THEN
33301 WRITE(LO,'(1X,2A,/,5X,A,2I5)') 'PHO_CHECK: ',
33302 & 'baryonic charge conservation violated',
33303 & 'initial/final baryonic charge sum',IBA1,IBA2
33309 C perform detailed checks in case of deviations
33310 IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
33311 IF(IPAMDL(13).GT.0) THEN
33316 WRITE(LO,'(/1X,2A,2E12.4)') 'PHO_CHECK: ',
33317 & 'increasing precision of tests to',DDREL,DDABS
33324 *$ CREATE PHO_ABORT.FOR
33326 CDECK ID>, PHO_ABORT
33327 SUBROUTINE PHO_ABORT
33328 C**********************************************************************
33330 C top MC event generation due to fatal error,
33331 C print all information of event generation and history
33333 C**********************************************************************
33334 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33337 C input/output channels
33339 COMMON /POINOU/ LI,LO
33340 C event debugging information
33342 PARAMETER (NMAXD=100)
33343 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33344 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33345 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33346 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33347 C model switches and parameters
33349 INTEGER ISWMDL,IPAMDL
33350 DOUBLE PRECISION PARMDL
33351 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33352 C standard particle data interface
33354 PARAMETER (NMXHEP=4000)
33355 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33356 DOUBLE PRECISION PHEP,VHEP
33357 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33358 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33360 C extension to standard particle data interface (PHOJET specific)
33361 INTEGER IMPART,IPHIST,ICOLOR
33362 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33363 C color string configurations including collapsed strings and hadrons
33365 PARAMETER (MSTR=500)
33366 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33367 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33368 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33369 & NNCH(MSTR),IBHAD(MSTR),ISTR
33370 C light-cone x fractions and c.m. momenta of soft cut string ends
33372 PARAMETER ( MAXSOF = 50 )
33373 INTEGER IJSI2,IJSI1
33374 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
33375 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
33376 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
33377 & IJSI1(MAXSOF),IJSI2(MAXSOF)
33378 C hard scattering data
33380 PARAMETER ( MSCAHD = 50 )
33381 INTEGER LSCAHD,LSC1HD,LSIDX,
33382 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
33383 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
33384 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
33385 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
33386 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
33387 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
33388 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
33389 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
33390 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
33392 WRITE(LO,'(//,1X,A,/,1X,A)')
33393 & 'PHO_ABORT: program execution stopped',
33394 & '===================================='
33395 WRITE(LO,'(/,1X,A,/,1X,A)') 'listing of available data follows:'
33397 CALL PHO_SETMDL(0,0,-2)
33398 CALL PHO_PREVNT(-1)
33399 CALL PHO_ACTPDF(0,-2)
33400 C print selected parton flavours
33401 WRITE(LO,'(1X,A,I4)') 'selected soft flavours: ',KSOFT
33403 WRITE(LO,'(10X,2I5)') IJSI1(I),IJSI2(I)
33405 WRITE(LO,'(1X,A,I4)') 'selected hard flavours: ',KHARD
33408 WRITE(LO,'(10X,A,I5)') 'process:',NPROHD(I)
33409 WRITE(LO,'(10X,A,2I4,7X,A,2I4)') 'initial:',NINHD(I,1),
33410 & NINHD(I,2),'final:',NOUTHD(I,1),NOUTHD(I,2)
33412 C print selected parton momenta
33413 WRITE(LO,'(1X,A,I4)') 'selected soft momenta: ',KSOFT
33415 WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PSOFT1(II,I),II=1,4)
33416 WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PSOFT2(II,I),II=1,4)
33418 WRITE(LO,'(1X,A,I4)') 'selected hard momenta: ',KHARD
33422 WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PPH(I3+II,1),II=1,4)
33423 WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PPH(I3+II,2),II=1,4)
33429 C fragmentation process
33433 IF(ISWMDL(6).GE.0) CALL PYLIST(1)
33437 WRITE(LO,'(////5X,A,///5X,A,///)')
33438 & 'PHO_ABORT: execution terminated due to fatal error',
33439 &'*** Simulating division by zero to get traceback information ***'
33440 ISTR = 100/IPAMDL(100)
33444 *$ CREATE PHO_TRACE.FOR
33446 CDECK ID>, PHO_TRACE
33447 SUBROUTINE PHO_TRACE(ISTART,ISWI,LEVEL)
33448 C**********************************************************************
33450 C trace program subroutines according to level,
33451 C original output levels will be saved
33453 C input: ISTART first event to trace
33454 C ISWI number of events to trace
33455 C 0 loop call, use old values
33456 C -1 restore original output levels
33457 C 1 store level and wait for event
33458 C LEVEL desired output level
33459 C 0 standard output
33460 C 3 internal rejections
33461 C 5 cross sections, slopes etc.
33462 C 10 parameter of subroutines and
33464 C 20 huge amount of debug output
33465 C 30 maximal possible output
33467 C**********************************************************************
33468 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33471 C input/output channels
33473 COMMON /POINOU/ LI,LO
33474 C event debugging information
33476 PARAMETER (NMAXD=100)
33477 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33478 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33479 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33480 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33482 DIMENSION IMEM(NMAXD)
33488 IF(KEVENT.LT.ION) THEN
33490 ELSE IF(KEVENT.EQ.ION) THEN
33491 WRITE(LO,'(///,1X,A,///)')
33492 & 'PHO_TRACE: trace mode switched on'
33495 IDEB(I) = MAX(ILEVEL,IMEM(I))
33497 ELSE IF(KEVENT.EQ.IOFF) THEN
33498 WRITE(LO,'(//,1X,A,///)')
33499 & 'PHO_TRACE: trace mode switched off'
33504 ELSE IF(ISW.EQ.-1) THEN
33514 C check coincidence
33523 *$ CREATE PHO_PRSTRG.FOR
33525 CDECK ID>, PHO_PRSTRG
33526 SUBROUTINE PHO_PRSTRG
33527 C**********************************************************************
33529 C print information of /POSTRG/
33531 C**********************************************************************
33532 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33535 C input/output channels
33537 COMMON /POINOU/ LI,LO
33538 C event debugging information
33540 PARAMETER (NMAXD=100)
33541 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33542 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33543 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33544 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33545 C standard particle data interface
33547 PARAMETER (NMXHEP=4000)
33548 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33549 DOUBLE PRECISION PHEP,VHEP
33550 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33551 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33553 C extension to standard particle data interface (PHOJET specific)
33554 INTEGER IMPART,IPHIST,ICOLOR
33555 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33556 C color string configurations including collapsed strings and hadrons
33558 PARAMETER (MSTR=500)
33559 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33560 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33561 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33562 & NNCH(MSTR),IBHAD(MSTR),ISTR
33564 WRITE(LO,'(/,1X,A,I5)')
33565 & 'PHO_PRSTRG: number of strings soft+hard:',ISTR
33566 WRITE(LO,'(/,1X,A/,1X,A)') 'COMMON /POSTRG/:',
33567 & ' NOBAM ID1 ID2 ID3 ID4 NPO1/2/3/4 MASS'
33569 & ' ======================================================='
33571 WRITE(LO,'(1X,9I5,1P,E11.3)')
33572 & NCODE(I),IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),NPOS(1,I),
33573 & NPOS(2,I),NPOS(3,I),NPOS(4,I),PHEP(5,NPOS(1,I))
33578 *$ CREATE PHO_PREVNT.FOR
33580 CDECK ID>, PHO_PREVNT
33581 SUBROUTINE PHO_PREVNT(NPART)
33582 C**********************************************************************
33584 C print all information of event generation and history
33586 C input: NPART -1 minimal output: process IDs
33587 C 0 additional output of /POEVT1/
33588 C 1 additional output of /POSTRG/
33589 C 2 additional output of /HEPEVT/
33592 C**********************************************************************
33593 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33596 C input/output channels
33598 COMMON /POINOU/ LI,LO
33599 C event debugging information
33601 PARAMETER (NMAXD=100)
33602 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33603 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33604 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33605 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33606 C model switches and parameters
33608 INTEGER ISWMDL,IPAMDL
33609 DOUBLE PRECISION PARMDL
33610 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33611 C global event kinematics and particle IDs
33612 INTEGER IFPAP,IFPAB
33613 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
33614 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
33615 C general process information
33616 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
33617 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
33618 C standard particle data interface
33620 PARAMETER (NMXHEP=4000)
33621 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33622 DOUBLE PRECISION PHEP,VHEP
33623 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33624 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33626 C extension to standard particle data interface (PHOJET specific)
33627 INTEGER IMPART,IPHIST,ICOLOR
33628 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33629 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
33630 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
33631 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
33632 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
33633 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
33635 CHARACTER*15 PHO_PNAME
33637 IF(NPART.GE.0) WRITE(LO,'(/)')
33638 WRITE(LO,'(1X,A,1PE10.3)')
33639 & 'PHO_PREVNT: c.m. energy',ECM
33640 CALL PHO_SETPAR(-2,IH,NPART,0.D0)
33641 WRITE(LO,'(6X,A,A,/1X,I10,10I6)')
33642 & 'EV-CALL,ISPOM,IHPOM,ISREG,IHDIR,KSTRG,',
33643 & 'KHTRG,KSLOO,KHLOO,KSDPO,KHDPO',
33644 & KEVENT,KSPOM,KHPOM,KSREG,KHDIR,KSTRG,KHTRG,KSLOO,KHLOO,KSDPO,
33646 WRITE(LO,'(6X,A,I4,4I3)')
33647 & 'PROCESS-ID,IDNODF,IDIFF1,IDIFF2,IDDPOM',IPROCE,IDNODF,IDIFR1,
33650 IF(IPAMDL(13).GT.0) THEN
33651 WRITE(LO,'(1X,A)') 'PHO_PREVNT: DPMJET special settings:'
33652 WRITE(LO,'(5X,A,1P,4E11.3)') 'ECMN,PCMN,SECM,SPCM',
33653 & ECMN,PCMN,SECM,SPCM
33654 WRITE(LO,'(5X,A,1P,2E11.3)') 'XPSUB,XTSUB',XPSUB,XTSUB
33657 IF(NPART.LT.0) RETURN
33659 IF(NPART.GE.1) CALL PHO_PRSTRG
33661 WRITE(LO,'(/1X,A)') 'COMMON /POEVT1/:'
33666 WRITE(LO,'(/1X,A,A,/,1X,A,A)')
33667 & ' NO IST NAME MO-1 MO-2 DA-1 DA-2 CHA BAR',
33668 & ' IH1 IH2 CO1 CO2',
33669 & '========================================================',
33670 & '===================='
33672 CH = DBLE(IPHO_CHR3(IH,2)/3.D0)
33673 BA = DBLE(IPHO_BAR3(IH,2)/3.D0)
33674 WRITE(LO,'(1X,2I5,1X,A15,4I5,2F5.1,2I5,2I5)')
33675 & IH,ISTHEP(IH),PHO_PNAME(IH,2),
33676 & JMOHEP(1,IH),JMOHEP(2,IH),JDAHEP(1,IH),JDAHEP(2,IH),
33677 & CH,BA,IPHIST(1,IH),IPHIST(2,IH),
33678 & ICOLOR(1,IH),ICOLOR(2,IH)
33679 IF(ABS(ISTHEP(IH)).EQ.1) THEN
33680 ICHAS = ICHAS + IPHO_CHR3(IH,2)
33681 IBARFS = IBARFS + IPHO_BAR3(IH,2)
33683 IF(ABS(ISTHEP(IH)).EQ.1) THEN
33684 IF(IPHO_CHR3(IH,2).NE.0) IMULC = IMULC+1
33688 WRITE(LO,'(1X,2(3X,A,I3),2X,2(5X,A,I5))') 'sum charge:',ICHAS/3,
33689 & 'baryon:',IBARFS/3,'chr.mult:',IMULC,'tot.mult:',IMUL
33697 IF( (ABS(PHEP(3,IN)).LT.99999.D0)
33698 & .AND.(PHEP(4,IN).LT.99999.D0)) THEN
33699 WRITE(LO,8) IN,ISTHEP(IN),PHO_PNAME(IN,2),
33700 & (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
33702 WRITE(LO,11) IN,ISTHEP(IN),PHO_PNAME(IN,2),
33703 & (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
33705 IF(ABS(ISTHEP(IN)).EQ.1) THEN
33706 PXS = PXS + PHEP(1,IN)
33707 PYS = PYS + PHEP(2,IN)
33708 PZS = PZS + PHEP(3,IN)
33709 P0S = P0S + PHEP(4,IN)
33712 AMFS = P0S**2-PXS**2-PYS**2-PZS**2
33713 AMFS = SIGN(SQRT(ABS(AMFS)),AMFS)
33714 IF(P0S.LT.99999.D0) THEN
33715 WRITE(LO,10) ' sum: ',PXS,PYS,PZS,P0S,AMFS
33717 WRITE(LO,12) ' sum: ',PXS,PYS,PZS,P0S,AMFS
33721 5 FORMAT(2X,8H NUMBER ,8H STATUS ,8H IDENT. ,
33722 & 8H 1.MOTH.,8H 2.MOTH.,8H 1.DAUG.,8H L.DAUG.,
33723 & 8H CHARGE ,8H BARYON ,/)
33724 6 FORMAT(7I8,2F8.3)
33725 7 FORMAT(/,2X,' NR STAT NAME X-MOMENTA',
33726 & ' Y-MOMENTA Z-MOMENTA ENERGY MASS PT',/,
33727 & 2X,'-------------------------------',
33728 & '--------------------------------------------')
33729 8 FORMAT(I5,I4,1X,A15,2F8.3,3F10.3,F8.3)
33730 9 FORMAT(I10,14X,5F10.3)
33731 10 FORMAT(10X,A14,1X,2F8.3,3F10.3)
33732 11 FORMAT(I5,I4,1X,A15,2F8.2,2F10.1,F10.3,F8.3)
33733 12 FORMAT(10X,A14,1X,2F8.2,2F10.1,F10.3)
33735 IF(NPART.GE.2) CALL PYLIST(1)
33739 *$ CREATE PHO_LTRHEP.FOR
33741 CDECK ID>, PHO_LTRHEP
33742 SUBROUTINE PHO_LTRHEP(I1,I2,COD,SID,COF,SIF,GAM,BGX,BGY,BGZ)
33743 C*******************************************************************
33745 C Lorentz transformation of entries I1 to I2 in /POEVT1/
33747 C********************************************************************
33748 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33751 PARAMETER ( DIFF = 0.001D0,
33754 C input/output channels
33756 COMMON /POINOU/ LI,LO
33757 C event debugging information
33759 PARAMETER (NMAXD=100)
33760 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33761 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33762 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33763 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33764 C standard particle data interface
33766 PARAMETER (NMXHEP=4000)
33767 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33768 DOUBLE PRECISION PHEP,VHEP
33769 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33770 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33772 C extension to standard particle data interface (PHOJET specific)
33773 INTEGER IMPART,IPHIST,ICOLOR
33774 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33776 DO 100 I=I1,MIN(I2,NHEP)
33777 IF((ABS(ISTHEP(I)).LE.10).OR.(ISTHEP(I).EQ.21)) THEN
33778 CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
33781 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
33782 & PHEP(1,I),PHEP(2,I),PHEP(3,I),PHEP(4,I))
33783 ELSE IF(ISTHEP(I).EQ.20) THEN
33784 EE=SQRT(PHEP(1,I)**2+PHEP(2,I)**2+PHEP(3,I)**2)
33785 CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
33787 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
33788 & PHEP(1,I),PHEP(2,I),PHEP(3,I),PMASS)
33793 IF(IDEB(70).LT.1) RETURN
33794 DO 200 I=I1,MIN(NHEP,I2)
33795 IF(ABS(ISTHEP(I)).GT.10) GOTO 190
33796 PMASS = PHEP(4,I)**2-PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
33797 PMASS = SIGN(SQRT(ABS(PMASS)),PMASS)
33798 IF((ABS(PMASS-PHEP(5,I))/MAX(PHEP(5,I),1.D0)).GT.DIFF) THEN
33799 WRITE(LO,'(1X,A,I5,2E13.4)')
33800 & 'PHO_LTRHEP: inconsistent masses:',I,PMASS,PHEP(5,I)
33807 *$ CREATE PHO_PECMS.FOR
33809 CDECK ID>, PHO_PECMS
33810 SUBROUTINE PHO_PECMS(ID,PMASS1,PMASS2,ECM,PP,EE)
33811 C*******************************************************************
33813 C calculation of cms momentum and energy of massive particle
33814 C (ID= 1 using PMASS1, 2 using PMASS2)
33816 C output: PP cms momentum
33817 C EE energy in CMS of particle ID
33819 C********************************************************************
33820 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33823 C input/output channels
33825 COMMON /POINOU/ LI,LO
33826 C event debugging information
33828 PARAMETER (NMAXD=100)
33829 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33830 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33831 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33832 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33834 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
33835 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
33836 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
33839 PM1 = SIGN(PMASS1**2,PMASS1)
33840 PM2 = SIGN(PMASS2**2,PMASS2)
33841 PP = SQRT(S**2 - 2.D0*PM1*S - 2.D0*PM2*S - 2.D0*PM1*PM2
33842 & + PM1**2 + PM2**2)/(2.D0*ECM)
33845 EE = SQRT( PM1 + PP**2 )
33846 ELSE IF(ID.EQ.2) THEN
33847 EE = SQRT( PM2 + PP**2 )
33849 WRITE(LO,'(/1X,A,I3,/)')
33850 & 'PHO_PECMS:ERROR: invalid ID number:',ID
33856 *$ CREATE PHO_FRAINI.FOR
33858 CDECK ID>, PHO_FRAINI
33859 SUBROUTINE PHO_FRAINI(IDEFAU)
33860 C***********************************************************************
33862 C initialization of fragmentation packages
33863 C (currently LUND JETSET)
33865 C initialization for JETSET call in DTUNUC 1.04 (J.R. 6/93)
33866 C changed to work in PHOJET (R.E. 1/94)
33868 C input: IDEFAU 0 no hadronization at all
33869 C 1 do not touch any parameter of JETSET
33870 C 2 default parameters kept, decay length 10mm to
33871 C define stable particles
33872 C 3 load tuned parameters for JETSET 7.3
33873 C neg. value: prevent strange/charm hadrons from decaying
33875 C***********************************************************************
33876 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33879 PARAMETER (EPS=1.D-10)
33881 C input/output channels
33883 COMMON /POINOU/ LI,LO
33885 DOUBLE PRECISION P,V
33886 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
33888 DOUBLE PRECISION PARU,PARJ
33889 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33891 DOUBLE PRECISION PMAS,PARF,VCKM
33892 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33893 INTEGER MDCY,MDME,KFDP
33894 DOUBLE PRECISION BRAT
33895 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
33899 IDEFAB = ABS(IDEFAU)
33901 IF(IDEFAB.EQ.0) THEN
33902 WRITE(LO,'(/1X,A)') 'PHO_FRAINI: hadronization switched off'
33913 C declare stable particles
33914 c IF(IDEFAB.GE.2) MSTJ(22) = 2
33916 C load optimized parameters
33917 IF(IDEFAB.GE.3) THEN
33925 C Lund sigma parameter in pt distribution
33930 C prevent particles decaying
33931 IF(IDEFAU.LT.0) THEN
34039 WRITE(LO,2355) IDEFAU,DEF2,PARJ(2),IDEF12,MSTJ(12),
34040 & DEF19,PARJ(19),DEF41,PARJ(41),DEF42,PARJ(42),DEF21,PARJ(21)
34041 2355 FORMAT(/' PHO_FRAINI: fragmentation initialization ISWMDL(6)',I3/,
34042 & ' --------------------------------------------------',/,
34043 & 5X,'parameter description default / current',/,
34044 & 5X,'PARJ( 2) strangeness suppression : ',2F7.3,/,
34045 & 5X,'MSTJ(12) popcorn : ',2I7,/,
34046 & 5X,'PARJ(19) popcorn : ',2F7.3,/,
34047 & 5X,'PARJ(41) Lund a : ',2F7.3,/,
34048 & 5X,'PARJ(42) Lund b : ',2F7.3,/,
34049 & 5X,'PARJ(21) sigma in pt distribution: ',2F7.3,/)
34053 *$ CREATE PHO_SETPAR.FOR
34055 CDECK ID>, PHO_SETPAR
34056 SUBROUTINE pho_setpar(Iside,IDpdg,IDcpc,Pvir)
34057 C**********************************************************************
34059 C assign a particle to either side 1 or 2
34060 C (including special treatment for remnants)
34062 C input: Iside 1,2 side selected for the particle
34063 C -2 output of current settings
34066 C 0 CPC determination in subroutine
34067 C -1 special particle remnant, IDPDG
34068 C is the particle number the remnant
34069 C corresponds to (see /POHDFL/)
34071 C**********************************************************************
34075 integer Iside,IDpdg,IDcpc
34076 double precision Pvir
34078 C input/output channels
34080 COMMON /POINOU/ LI,LO
34081 C event debugging information
34083 PARAMETER (NMAXD=100)
34084 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
34085 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34086 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
34087 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34088 C global event kinematics and particle IDs
34089 INTEGER IFPAP,IFPAB
34090 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
34091 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
34092 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
34093 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
34094 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
34095 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
34096 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
34097 C particle ID translation table
34098 integer ID_pdg_list,ID_list,ID_pdg_max
34099 character*12 name_list
34100 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
34102 C general particle data
34103 double precision xm_list,tau_list,gam_list,
34104 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
34105 & xm_bb82_list,xm_bb102_list
34106 integer ich3_list,iba3_list,iq_list,
34107 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
34108 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
34109 & xm_psm2_list(6,6),xm_vem2_list(6,6),
34110 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
34111 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
34112 & ich3_list(300),iba3_list(300),iq_list(3,300),
34113 & id_psm_list(6,6),id_vem_list(6,6),
34114 & id_b8_list(6,6,6),id_b10_list(6,6,6)
34115 C particle decay data
34116 double precision wg_sec_list
34117 integer idec_list,isec_list
34118 COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
34121 C external functions
34122 integer ipho_pdg2id,ipho_chr3,ipho_bar3
34123 double precision pho_pmass
34126 integer i,IDcpcN,IDcpcR,IDpdgN,IDpdgR,IDB,IFL1,IFL2,IFL3
34128 IF((Iside.EQ.1).OR.(Iside.EQ.2)) THEN
34131 IF(IDcpc.EQ.-1) THEN
34132 IF(Iside.EQ.1) THEN
34137 IDcpcR = ipho_pdg2id(IDpdgR)
34138 IDEQB(Iside) = ipho_pdg2id(IDpdg)
34139 IDEQP(Iside) = IDpdg
34140 C copy particle properties
34141 IDB = abs(IDEQB(Iside))
34142 xm_list(IDcpcR) = xm_list(IDB)
34143 tau_list(IDcpcR) = tau_list(IDB)
34144 gam_list(IDcpcR) = gam_list(IDB)
34145 IF(IHFLS(Iside).EQ.1) THEN
34146 ich3_list(IDcpcR) = ipho_chr3(IDEQB(Iside),0)
34147 iba3_list(IDcpcR) = ipho_bar3(IDEQB(Iside),0)
34149 ich3_list(IDcpcR) = 0
34150 iba3_list(IDcpcR) = 0
34153 IFL1 = IHFLD(Iside,1)
34154 IFL2 = IHFLD(Iside,2)
34156 IF(IHFLS(Iside).EQ.1) THEN
34157 IF(ABS(IHFLD(Iside,1)).GT.1000) THEN
34158 IFL1 = IHFLD(Iside,1)/1000
34159 IFL2 = MOD(IHFLD(Iside,1)/100,10)
34160 IFL3 = IHFLD(Iside,2)
34161 ELSE IF(ABS(IHFLD(Iside,2)).GT.1000) THEN
34162 IFL1 = IHFLD(Iside,1)
34163 IFL2 = IHFLD(Iside,2)/1000
34164 IFL3 = MOD(IHFLD(Iside,2)/100,10)
34167 iq_list(1,IDcpcR) = IFL1
34168 iq_list(2,IDcpcR) = IFL2
34169 iq_list(3,IDcpcR) = IFL3
34174 IF(IDEB(87).GE.5) THEN
34175 WRITE(LO,'(1X,A,I2,/5X,A,I7,4I6)')
34176 & 'pho_setpar: remnant assignment side',Iside,
34177 & 'IDPDG,IFL1,2,3,IVAL',IDPDGN,IFL1,IFL2,IFL3,IHFLS(Iside)
34179 ELSE IF(IDcpc.EQ.0) THEN
34184 IDcpcN = ipho_pdg2id(IDpdg)
34188 C initialize /POGCMS/
34189 IFPAP(Iside) = IDpdgN
34190 IFPAB(Iside) = IDcpcN
34191 PMASS(Iside) = pho_pmass(IDcpcN,0)
34192 IF(IFPAP(Iside).EQ.22) THEN
34193 PVIRT(Iside) = ABS(PVIR)
34195 PVIRT(Iside) = 0.D0
34198 ELSE IF(Iside.EQ.-2) THEN
34199 C output of current settings
34201 WRITE(LO,'(1X,A,I2,1X,A,I7,I4,1X,1P2E10.3)')
34202 & 'PHO_SETPAR: side',
34203 & I,'IDPDG,IDcpc,PMASS,PVIRT',IFPAP(I),IFPAB(I),PMASS(I),
34205 IF((IFPAP(I).EQ.81).OR.(IFPAP(I).EQ.82)) THEN
34206 WRITE(LO,'(5X,A,I7,I4,I2,3I5)')
34207 & 'remnant:IDPDG,IDcpc,IVAL,IFLA1,2',IDEQP(I),IDEQB(I),
34208 & IHFLS(I),IHFLD(I,1),IHFLD(I,2)
34212 WRITE(LO,'(/1X,A,I8)')
34213 & 'pho_setpar: invalid argument (Iside)',Iside
34218 *$ CREATE PHO_XLAM.FOR
34220 CDECK ID>, PHO_XLAM
34221 DOUBLE PRECISION FUNCTION PHO_XLAM(X,Y,Z)
34222 C**********************************************************************
34224 C auxiliary function for two/three particle decay mode
34225 C (standard LAMBDA**(1/2) function)
34227 C**********************************************************************
34228 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34232 XLAM=X*X-2.D0*X*(Y+Z)+YZ*YZ
34233 IF(XLAM.LT.0.D0) XLAM=-XLAM
34234 PHO_XLAM=SQRT(XLAM)
34237 *$ CREATE PHO_BESSJ0.FOR
34239 CDECK ID>, PHO_BESSJ0
34240 DOUBLE PRECISION FUNCTION PHO_BESSJ0(DX)
34241 C**********************************************************************
34243 C CERN (KERN) LIB function C312
34245 C modified by R. Engel (03/02/93)
34247 C**********************************************************************
34248 DOUBLE PRECISION DX
34249 DOUBLE PRECISION X,Y,V,H,ALFA,EIGHT
34250 DOUBLE PRECISION PI1,PI2,C1(0:14),C2(0:9),C3(0:10),B0,B1,B2,P,Q,R
34254 DATA PI1 /0.79788 45608 0287D0/, PI2 /0.78539 81633 9745D0/
34256 DATA C1( 0) /+0.15772 79714 7489D0/
34257 DATA C1( 1) /-0.00872 34423 5285D0/
34258 DATA C1( 2) /+0.26517 86132 0334D0/
34259 DATA C1( 3) /-0.37009 49938 7265D0/
34260 DATA C1( 4) /+0.15806 71023 3210D0/
34261 DATA C1( 5) /-0.03489 37694 1141D0/
34262 DATA C1( 6) /+0.00481 91800 6947D0/
34263 DATA C1( 7) /-0.00046 06261 6621D0/
34264 DATA C1( 8) /+0.00003 24603 2882D0/
34265 DATA C1( 9) /-0.00000 17619 4691D0/
34266 DATA C1(10) /+0.00000 00760 8164D0/
34267 DATA C1(11) /-0.00000 00026 7925D0/
34268 DATA C1(12) /+0.00000 00000 7849D0/
34269 DATA C1(13) /-0.00000 00000 0194D0/
34270 DATA C1(14) /+0.00000 00000 0004D0/
34272 DATA C2( 0) /+0.99946 03493 4752D0/
34273 DATA C2( 1) /-0.00053 65220 4681D0/
34274 DATA C2( 2) /+0.00000 30751 8479D0/
34275 DATA C2( 3) /-0.00000 00517 0595D0/
34276 DATA C2( 4) /+0.00000 00016 3065D0/
34277 DATA C2( 5) /-0.00000 00000 7864D0/
34278 DATA C2( 6) /+0.00000 00000 0517D0/
34279 DATA C2( 7) /-0.00000 00000 0043D0/
34280 DATA C2( 8) /+0.00000 00000 0004D0/
34281 DATA C2( 9) /-0.00000 00000 0001D0/
34283 DATA C3( 0) /-0.01555 58546 05337D0/
34284 DATA C3( 1) /+0.00006 83851 99426D0/
34285 DATA C3( 2) /-0.00000 07414 49841D0/
34286 DATA C3( 3) /+0.00000 00179 72457D0/
34287 DATA C3( 4) /-0.00000 00007 27192D0/
34288 DATA C3( 5) /+0.00000 00000 42201D0/
34289 DATA C3( 6) /-0.00000 00000 03207D0/
34290 DATA C3( 7) /+0.00000 00000 00301D0/
34291 DATA C3( 8) /-0.00000 00000 00033D0/
34292 DATA C3( 9) /+0.00000 00000 00004D0/
34293 DATA C3(10) /-0.00000 00000 00001D0/
34297 IF(V .LT. EIGHT) THEN
34304 B0=C1(I)-ALFA*B1-B2
34316 B0=C2(I)-ALFA*B1-B2
34323 B0=C3(I)-ALFA*B1-B2
34328 B1=PI1*SQRT(R)*(P*COS(B0)-Q*SIN(B0))
34334 *$ CREATE PHO_BESSI0.FOR
34336 CDECK ID>, PHO_BESSI0
34337 DOUBLE PRECISION FUNCTION PHO_BESSI0(X)
34338 C**********************************************************************
34340 C Bessel Function I0
34342 C**********************************************************************
34343 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34347 IF (AX .LT. 3.75D0) THEN
34350 & 1.0D0+Y*(3.5156229D0+Y*(3.0899424D0+Y*(1.2067492D0
34351 & +Y*(0.2659732D0+Y*(0.360768D-1+Y*0.45813D-2)))))
34355 & (EXP(AX)/SQRT(AX))*(0.39894228D0+Y*(0.1328592D-1
34356 & +Y*(0.225319D-2+Y*(-0.157565D-2+Y*(0.916281D-2
34357 & +Y*(-0.2057706D-1+Y*(0.2635537D-1+Y*(-0.1647633D-1
34358 & +Y*0.392377D-2))))))))
34363 *$ CREATE PHO_BESSI1.FOR
34365 CDECK ID>, PHO_BESSI1
34366 DOUBLE PRECISION FUNCTION PHO_BESSI1(X)
34367 C**********************************************************************
34369 C Bessel Function I1
34371 C**********************************************************************
34372 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34377 IF (AX .LT. 3.75D0) THEN
34380 & AX*(0.5D0+Y*(0.87890594D0+Y*(0.51498869D0+Y*(0.15084934D0
34381 & +Y*(0.2658733D-1+Y*(0.301532D-2+Y*0.32411D-3))))))
34385 & 0.2282967D-1+Y*(-0.2895312D-1+Y*(0.1787654D-1
34388 & 0.39894228D0+Y*(-0.3988024D-1+Y*(-0.362018D-2
34389 & +Y*(0.163801D-2+Y*(-0.1031555D-1+Y*BESLI1))))
34390 BESLI1 = BESLI1 * EXP(AX)/SQRT(AX)
34392 IF (X .LT. 0.D0) BESLI1 = -BESLI1
34394 PHO_BESSI1 = BESLI1
34398 *$ CREATE PHO_BESSK0.FOR
34400 CDECK ID>, PHO_BESSK0
34401 DOUBLE PRECISION FUNCTION PHO_BESSK0(X)
34402 C**********************************************************************
34404 C Modified Bessel Function K0
34406 C**********************************************************************
34407 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34410 IF (X .LT. 2.D0) THEN
34413 & (-LOG(X/2.D0)*PHO_BESSI0(X))+(-.57721566D0+Y*(0.42278420D0
34414 & +Y*(0.23069756D0+Y*(0.3488590D-1+Y*(0.262698D-2
34415 & +Y*(0.10750D-3+Y*0.740D-5))))))
34419 & (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(-0.7832358D-1
34420 & +Y*(0.2189568D-1+Y*(-0.1062446D-1+Y*(0.587872D-2
34421 & +Y*(-0.251540D-2+Y*0.53208D-3))))))
34426 *$ CREATE PHO_BESSK1.FOR
34428 CDECK ID>, PHO_BESSK1
34429 DOUBLE PRECISION FUNCTION PHO_BESSK1(X)
34430 C**********************************************************************
34432 C Modified Bessel Function K1
34434 C**********************************************************************
34435 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34438 IF (X .LT. 2.D0) THEN
34441 & (LOG(X/2.D0)*PHO_BESSI1(X))+(1.D0/X)*(1.D0+Y*(0.15443144D0
34442 & +Y*(-0.67278579D0+Y*(-0.18156897D0+Y*(-0.1919402D-1
34443 & +Y*(-0.110404D-2+Y*(-0.4686D-4)))))))
34447 & (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(0.23498619D0
34448 & +Y*(-0.3655620D-1+Y*(0.1504268D-1+Y*(-0.780353D-2
34449 & +Y*(0.325614D-2+Y*(-0.68245D-3)))))))
34454 *$ CREATE PHO_GAUSET.FOR
34456 CDECK ID>, PHO_GAUSET
34457 SUBROUTINE PHO_GAUSET(AX,BX,NX,Z,W)
34458 C********************************************************************
34460 C N-point gauss zeros and weights for the interval (AX,BX) are
34461 C stored in arrays Z and W respectively.
34463 C*********************************************************************
34464 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34467 COMMON /POGDAT/A(273),X(273),KTAB(96)
34468 DIMENSION Z(NX),W(NX)
34481 1 IF((N.LE.16).AND.(N.GT.1)) GO TO 2
34482 IF(N.EQ.20) GO TO 2
34483 IF(N.EQ.24) GO TO 2
34484 IF(N.EQ.32) GO TO 2
34485 IF(N.EQ.40) GO TO 2
34486 IF(N.EQ.48) GO TO 2
34487 IF(N.EQ.64) GO TO 2
34488 IF(N.EQ.80) GO TO 2
34489 IF(N.EQ.96) GO TO 2
34491 C the extended Gauss cases:
34492 IF((N/96)*96.EQ.N) GO TO 3
34494 C jump to center of intervall intrgration:
34497 C get Gauss point array
34500 C extract real points
34504 C extract values from big array
34508 C store them backward
34511 C store them forward
34516 C store central point (odd N)
34517 IF((N-M-M).EQ.0) RETURN
34520 W(M+1)=BETA*A(JMID)
34523 C get ND96 times chained 96 Gauss point array
34526 C print out message
34527 C -extract real points
34531 C extract values from big array
34537 DO 32 JD96=0,ND96-1
34538 ZCNTR= (ALPHA-BETA)+ BETA*FLOAT(2*JD96+1)/FLOAT(ND96)
34539 C store them backward
34540 Z(J+JD96*96)=ZCNTR-DELTA
34542 C store them forward
34544 Z(JP+JD96*96)=ZCNTR+DELTA
34545 W(JP+JD96*96)=WTEMP
34550 C the center of intervall cases:
34552 C put in constant weight and equally spaced central points
34555 WIN=(BX-AX)/FLOAT(N)
34556 Z(IN)=AX + (FLOAT(IN)-.5)*WIN
34561 *$ CREATE PHO_GAUDAT.FOR
34563 CDECK ID>, PHO_GAUDAT
34564 SUBROUTINE PHO_GAUDAT
34565 C*********************************************************************
34567 C store big arrays needed for Gauss integral, CERNLIB D106BD
34568 C (arrays A,X,ITAB copied on B,Y,LTAB)
34570 C*********************************************************************
34571 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34574 COMMON /POGDAT/ B(273),Y(273),LTAB(96)
34575 DIMENSION A(273),X(273),KTAB(96)
34577 C-----TABLE OF INITIAL SUBSCRIPTS FOR N=2(1)16(4)96
34614 C-----TABLE OF ABSCISSAE (X) AND WEIGHTS (A) FOR INTERVAL (-1,+1).
34617 DATA X(1)/0.577350269189626D0 /, A(1)/1.000000000000000D0 /
34619 DATA X(2)/0.774596669241483D0 /, A(2)/0.555555555555556D0 /
34620 DATA X(3)/0.000000000000000D0 /, A(3)/0.888888888888889D0 /
34622 DATA X(4)/0.861136311594053D0 /, A(4)/0.347854845137454D0 /
34623 DATA X(5)/0.339981043584856D0 /, A(5)/0.652145154862546D0 /
34625 DATA X(6)/0.906179845938664D0 /, A(6)/0.236926885056189D0 /
34626 DATA X(7)/0.538469310105683D0 /, A(7)/0.478628670499366D0 /
34627 DATA X(8)/0.000000000000000D0 /, A(8)/0.568888888888889D0 /
34629 DATA X(9)/0.932469514203152D0 /, A(9)/0.171324492379170D0 /
34630 DATA X(10)/0.661209386466265D0 /, A(10)/0.360761573048139D0 /
34631 DATA X(11)/0.238619186083197D0 /, A(11)/0.467913934572691D0 /
34633 DATA X(12)/0.949107912342759D0 /, A(12)/0.129484966168870D0 /
34634 DATA X(13)/0.741531185599394D0 /, A(13)/0.279705391489277D0 /
34635 DATA X(14)/0.405845151377397D0 /, A(14)/0.381830050505119D0 /
34636 DATA X(15)/0.000000000000000D0 /, A(15)/0.417959183673469D0 /
34638 DATA X(16)/0.960289856497536D0 /, A(16)/0.101228536290376D0 /
34639 DATA X(17)/0.796666477413627D0 /, A(17)/0.222381034453374D0 /
34640 DATA X(18)/0.525532409916329D0 /, A(18)/0.313706645877887D0 /
34641 DATA X(19)/0.183434642495650D0 /, A(19)/0.362683783378362D0 /
34643 DATA X(20)/0.968160239507626D0 /, A(20)/0.081274388361574D0 /
34644 DATA X(21)/0.836031107326636D0 /, A(21)/0.180648160694857D0 /
34645 DATA X(22)/0.613371432700590D0 /, A(22)/0.260610696402935D0 /
34646 DATA X(23)/0.324253423403809D0 /, A(23)/0.312347077040003D0 /
34647 DATA X(24)/0.000000000000000D0 /, A(24)/0.330239355001260D0 /
34649 DATA X(25)/0.973906528517172D0 /, A(25)/0.066671344308688D0 /
34650 DATA X(26)/0.865063366688985D0 /, A(26)/0.149451349150581D0 /
34651 DATA X(27)/0.679409568299024D0 /, A(27)/0.219086362515982D0 /
34652 DATA X(28)/0.433395394129247D0 /, A(28)/0.269266719309996D0 /
34653 DATA X(29)/0.148874338981631D0 /, A(29)/0.295524224714753D0 /
34655 DATA X(30)/0.978228658146057D0 /, A(30)/0.055668567116174D0 /
34656 DATA X(31)/0.887062599768095D0 /, A(31)/0.125580369464905D0 /
34657 DATA X(32)/0.730152005574049D0 /, A(32)/0.186290210927734D0 /
34658 DATA X(33)/0.519096129206812D0 /, A(33)/0.233193764591990D0 /
34659 DATA X(34)/0.269543155952345D0 /, A(34)/0.262804544510247D0 /
34660 DATA X(35)/0.000000000000000D0 /, A(35)/0.272925086777901D0 /
34662 DATA X(36)/0.981560634246719D0 /, A(36)/0.047175336386512D0 /
34663 DATA X(37)/0.904117256370475D0 /, A(37)/0.106939325995318D0 /
34664 DATA X(38)/0.769902674194305D0 /, A(38)/0.160078328543346D0 /
34665 DATA X(39)/0.587317954286617D0 /, A(39)/0.203167426723066D0 /
34666 DATA X(40)/0.367831498998180D0 /, A(40)/0.233492536538355D0 /
34667 DATA X(41)/0.125233408511469D0 /, A(41)/0.249147045813403D0 /
34669 DATA X(42)/0.984183054718588D0 /, A(42)/0.040484004765316D0 /
34670 DATA X(43)/0.917598399222978D0 /, A(43)/0.092121499837728D0 /
34671 DATA X(44)/0.801578090733310D0 /, A(44)/0.138873510219787D0 /
34672 DATA X(45)/0.642349339440340D0 /, A(45)/0.178145980761946D0 /
34673 DATA X(46)/0.448492751036447D0 /, A(46)/0.207816047536889D0 /
34674 DATA X(47)/0.230458315955135D0 /, A(47)/0.226283180262897D0 /
34675 DATA X(48)/0.000000000000000D0 /, A(48)/0.232551553230874D0 /
34677 DATA X(49)/0.986283808696812D0 /, A(49)/0.035119460331752D0 /
34678 DATA X(50)/0.928434883663574D0 /, A(50)/0.080158087159760D0 /
34679 DATA X(51)/0.827201315069765D0 /, A(51)/0.121518570687903D0 /
34680 DATA X(52)/0.687292904811685D0 /, A(52)/0.157203167158194D0 /
34681 DATA X(53)/0.515248636358154D0 /, A(53)/0.185538397477938D0 /
34682 DATA X(54)/0.319112368927890D0 /, A(54)/0.205198463721296D0 /
34683 DATA X(55)/0.108054948707344D0 /, A(55)/0.215263853463158D0 /
34685 DATA X(56)/0.987992518020485D0 /, A(56)/0.030753241996117D0 /
34686 DATA X(57)/0.937273392400706D0 /, A(57)/0.070366047488108D0 /
34687 DATA X(58)/0.848206583410427D0 /, A(58)/0.107159220467172D0 /
34688 DATA X(59)/0.724417731360170D0 /, A(59)/0.139570677926154D0 /
34689 DATA X(60)/0.570972172608539D0 /, A(60)/0.166269205816994D0 /
34690 DATA X(61)/0.394151347077563D0 /, A(61)/0.186161000015562D0 /
34691 DATA X(62)/0.201194093997435D0 /, A(62)/0.198431485327111D0 /
34692 DATA X(63)/0.000000000000000D0 /, A(63)/0.202578241925561D0 /
34694 DATA X(64)/0.989400934991650D0 /, A(64)/0.027152459411754D0 /
34695 DATA X(65)/0.944575023073233D0 /, A(65)/0.062253523938648D0 /
34696 DATA X(66)/0.865631202387832D0 /, A(66)/0.095158511682493D0 /
34697 DATA X(67)/0.755404408355003D0 /, A(67)/0.124628971255534D0 /
34698 DATA X(68)/0.617876244402644D0 /, A(68)/0.149595988816577D0 /
34699 DATA X(69)/0.458016777657227D0 /, A(69)/0.169156519395003D0 /
34700 DATA X(70)/0.281603550779259D0 /, A(70)/0.182603415044924D0 /
34701 DATA X(71)/0.095012509837637D0 /, A(71)/0.189450610455069D0 /
34703 DATA X(72)/0.993128599185094D0 /, A(72)/0.017614007139152D0 /
34704 DATA X(73)/0.963971927277913D0 /, A(73)/0.040601429800386D0 /
34705 DATA X(74)/0.912234428251325D0 /, A(74)/0.062672048334109D0 /
34706 DATA X(75)/0.839116971822218D0 /, A(75)/0.083276741576704D0 /
34707 DATA X(76)/0.746331906460150D0 /, A(76)/0.101930119817240D0 /
34708 DATA X(77)/0.636053680726515D0 /, A(77)/0.118194531961518D0 /
34709 DATA X(78)/0.510867001950827D0 /, A(78)/0.131688638449176D0 /
34710 DATA X(79)/0.373706088715419D0 /, A(79)/0.142096109318382D0 /
34711 DATA X(80)/0.227785851141645D0 /, A(80)/0.149172986472603D0 /
34712 DATA X(81)/0.076526521133497D0 /, A(81)/0.152753387130725D0 /
34714 DATA X(82)/0.995187219997021D0 /, A(82)/0.012341229799987D0 /
34715 DATA X(83)/0.974728555971309D0 /, A(83)/0.028531388628933D0 /
34716 DATA X(84)/0.938274552002732D0 /, A(84)/0.044277438817419D0 /
34717 DATA X(85)/0.886415527004401D0 /, A(85)/0.059298584915436D0 /
34718 DATA X(86)/0.820001985973902D0 /, A(86)/0.073346481411080D0 /
34719 DATA X(87)/0.740124191578554D0 /, A(87)/0.086190161531953D0 /
34720 DATA X(88)/0.648093651936975D0 /, A(88)/0.097618652104113D0 /
34721 DATA X(89)/0.545421471388839D0 /, A(89)/0.107444270115965D0 /
34722 DATA X(90)/0.433793507626045D0 /, A(90)/0.115505668053725D0 /
34723 DATA X(91)/0.315042679696163D0 /, A(91)/0.121670472927803D0 /
34724 DATA X(92)/0.191118867473616D0 /, A(92)/0.125837456346828D0 /
34725 DATA X(93)/0.064056892862605D0 /, A(93)/0.127938195346752D0 /
34727 DATA X(94)/0.997263861849481D0 /, A(94)/0.007018610009470D0 /
34728 DATA X(95)/0.985611511545268D0 /, A(95)/0.016274394730905D0 /
34729 DATA X(96)/0.964762255587506D0 /, A(96)/0.025392065309262D0 /
34730 DATA X(97)/0.934906075937739D0 /, A(97)/0.034273862913021D0 /
34731 DATA X(98)/0.896321155766052D0 /, A(98)/0.042835898022226D0 /
34732 DATA X(99)/0.849367613732569D0 /, A(99)/0.050998059262376D0 /
34733 DATA X(100)/0.794483795967942D0/, A(100)/0.058684093478535D0/
34734 DATA X(101)/0.732182118740289D0/, A(101)/0.065822222776361D0/
34735 DATA X(102)/0.663044266930215D0/, A(102)/0.072345794108848D0/
34736 DATA X(103)/0.587715757240762D0/, A(103)/0.078193895787070D0/
34737 DATA X(104)/0.506899908932229D0/, A(104)/0.083311924226946D0/
34738 DATA X(105)/0.421351276130635D0/, A(105)/0.087652093004403D0/
34739 DATA X(106)/0.331868602282127D0/, A(106)/0.091173878695763D0/
34740 DATA X(107)/0.239287362252137D0/, A(107)/0.093844399080804D0/
34741 DATA X(108)/0.144471961582796D0/, A(108)/0.095638720079274D0/
34742 DATA X(109)/0.048307665687738D0/, A(109)/0.096540088514727D0/
34744 DATA X(110)/0.998237709710559D0/, A(110)/0.004521277098533D0/
34745 DATA X(111)/0.990726238699457D0/, A(111)/0.010498284531152D0/
34746 DATA X(112)/0.977259949983774D0/, A(112)/0.016421058381907D0/
34747 DATA X(113)/0.957916819213791D0/, A(113)/0.022245849194166D0/
34748 DATA X(114)/0.932812808278676D0/, A(114)/0.027937006980023D0/
34749 DATA X(115)/0.902098806968874D0/, A(115)/0.033460195282547D0/
34750 DATA X(116)/0.865959503212259D0/, A(116)/0.038782167974472D0/
34751 DATA X(117)/0.824612230833311D0/, A(117)/0.043870908185673D0/
34752 DATA X(118)/0.778305651426519D0/, A(118)/0.048695807635072D0/
34753 DATA X(119)/0.727318255189927D0/, A(119)/0.053227846983936D0/
34754 DATA X(120)/0.671956684614179D0/, A(120)/0.057439769099391D0/
34755 DATA X(121)/0.612553889667980D0/, A(121)/0.061306242492928D0/
34756 DATA X(122)/0.549467125095128D0/, A(122)/0.064804013456601D0/
34757 DATA X(123)/0.483075801686178D0/, A(123)/0.067912045815233D0/
34758 DATA X(124)/0.413779204371605D0/, A(124)/0.070611647391286D0/
34759 DATA X(125)/0.341994090825758D0/, A(125)/0.072886582395804D0/
34760 DATA X(126)/0.268152185007253D0/, A(126)/0.074723169057968D0/
34761 DATA X(127)/0.192697580701371D0/, A(127)/0.076110361900626D0/
34762 DATA X(128)/0.116084070675255D0/, A(128)/0.077039818164247D0/
34763 DATA X(129)/0.038772417506050D0/, A(129)/0.077505947978424D0/
34765 DATA X(130)/0.998771007252426D0/, A(130)/0.003153346052305D0/
34766 DATA X(131)/0.993530172266350D0/, A(131)/0.007327553901276D0/
34767 DATA X(132)/0.984124583722826D0/, A(132)/0.011477234579234D0/
34768 DATA X(133)/0.970591592546247D0/, A(133)/0.015579315722943D0/
34769 DATA X(134)/0.952987703160430D0/, A(134)/0.019616160457355D0/
34770 DATA X(135)/0.931386690706554D0/, A(135)/0.023570760839324D0/
34771 DATA X(136)/0.905879136715569D0/, A(136)/0.027426509708356D0/
34772 DATA X(137)/0.876572020274247D0/, A(137)/0.031167227832798D0/
34773 DATA X(138)/0.843588261624393D0/, A(138)/0.034777222564770D0/
34774 DATA X(139)/0.807066204029442D0/, A(139)/0.038241351065830D0/
34775 DATA X(140)/0.767159032515740D0/, A(140)/0.041545082943464D0/
34776 DATA X(141)/0.724034130923814D0/, A(141)/0.044674560856694D0/
34777 DATA X(142)/0.677872379632663D0/, A(142)/0.047616658492490D0/
34778 DATA X(143)/0.628867396776513D0/, A(143)/0.050359035553854D0/
34779 DATA X(144)/0.577224726083972D0/, A(144)/0.052890189485193D0/
34780 DATA X(145)/0.523160974722233D0/, A(145)/0.055199503699984D0/
34781 DATA X(146)/0.466902904750958D0/, A(146)/0.057277292100403D0/
34782 DATA X(147)/0.408686481990716D0/, A(147)/0.059114839698395D0/
34783 DATA X(148)/0.348755886292160D0/, A(148)/0.060704439165893D0/
34784 DATA X(149)/0.287362487355455D0/, A(149)/0.062039423159892D0/
34785 DATA X(150)/0.224763790394689D0/, A(150)/0.063114192286254D0/
34786 DATA X(151)/0.161222356068891D0/, A(151)/0.063924238584648D0/
34787 DATA X(152)/0.097004699209462D0/, A(152)/0.064466164435950D0/
34788 DATA X(153)/0.032380170962869D0/, A(153)/0.064737696812683D0/
34790 DATA X(154)/0.999305041735772D0/, A(154)/0.001783280721696D0/
34791 DATA X(155)/0.996340116771955D0/, A(155)/0.004147033260562D0/
34792 DATA X(156)/0.991013371476744D0/, A(156)/0.006504457968978D0/
34793 DATA X(157)/0.983336253884625D0/, A(157)/0.008846759826363D0/
34794 DATA X(158)/0.973326827789910D0/, A(158)/0.011168139460131D0/
34795 DATA X(159)/0.961008799652053D0/, A(159)/0.013463047896718D0/
34796 DATA X(160)/0.946411374858402D0/, A(160)/0.015726030476024D0/
34797 DATA X(161)/0.929569172131939D0/, A(161)/0.017951715775697D0/
34798 DATA X(162)/0.910522137078502D0/, A(162)/0.020134823153530D0/
34799 DATA X(163)/0.889315445995114D0/, A(163)/0.022270173808383D0/
34800 DATA X(164)/0.865999398154092D0/, A(164)/0.024352702568710D0/
34801 DATA X(165)/0.840629296252580D0/, A(165)/0.026377469715054D0/
34802 DATA X(166)/0.813265315122797D0/, A(166)/0.028339672614259D0/
34803 DATA X(167)/0.783972358943341D0/, A(167)/0.030234657072402D0/
34804 DATA X(168)/0.752819907260531D0/, A(168)/0.032057928354851D0/
34805 DATA X(169)/0.719881850171610D0/, A(169)/0.033805161837141D0/
34806 DATA X(170)/0.685236313054233D0/, A(170)/0.035472213256882D0/
34807 DATA X(171)/0.648965471254657D0/, A(171)/0.037055128540240D0/
34808 DATA X(172)/0.611155355172393D0/, A(172)/0.038550153178615D0/
34809 DATA X(173)/0.571895646202634D0/, A(173)/0.039953741132720D0/
34810 DATA X(174)/0.531279464019894D0/, A(174)/0.041262563242623D0/
34811 DATA X(175)/0.489403145707052D0/, A(175)/0.042473515123653D0/
34812 DATA X(176)/0.446366017253464D0/, A(176)/0.043583724529323D0/
34813 DATA X(177)/0.402270157963991D0/, A(177)/0.044590558163756D0/
34814 DATA X(178)/0.357220158337668D0/, A(178)/0.045491627927418D0/
34815 DATA X(179)/0.311322871990210D0/, A(179)/0.046284796581314D0/
34816 DATA X(180)/0.264687162208767D0/, A(180)/0.046968182816210D0/
34817 DATA X(181)/0.217423643740007D0/, A(181)/0.047540165714830D0/
34818 DATA X(182)/0.169644420423992D0/, A(182)/0.047999388596458D0/
34819 DATA X(183)/0.121462819296120D0/, A(183)/0.048344762234802D0/
34820 DATA X(184)/0.072993121787799D0/, A(184)/0.048575467441503D0/
34821 DATA X(185)/0.024350292663424D0/, A(185)/0.048690957009139D0/
34823 DATA X(186)/0.999553822651630D0/, A(186)/0.001144950003186D0/
34824 DATA X(187)/0.997649864398237D0/, A(187)/0.002663533589512D0/
34825 DATA X(188)/0.994227540965688D0/, A(188)/0.004180313124694D0/
34826 DATA X(189)/0.989291302499755D0/, A(189)/0.005690922451403D0/
34827 DATA X(190)/0.982848572738629D0/, A(190)/0.007192904768117D0/
34828 DATA X(191)/0.974909140585727D0/, A(191)/0.008683945269260D0/
34829 DATA X(192)/0.965485089043799D0/, A(192)/0.010161766041103D0/
34830 DATA X(193)/0.954590766343634D0/, A(193)/0.011624114120797D0/
34831 DATA X(194)/0.942242761309872D0/, A(194)/0.013068761592401D0/
34832 DATA X(195)/0.928459877172445D0/, A(195)/0.014493508040509D0/
34833 DATA X(196)/0.913263102571757D0/, A(196)/0.015896183583725D0/
34834 DATA X(197)/0.896675579438770D0/, A(197)/0.017274652056269D0/
34835 DATA X(198)/0.878722567678213D0/, A(198)/0.018626814208299D0/
34836 DATA X(199)/0.859431406663111D0/, A(199)/0.019950610878141D0/
34837 DATA X(200)/0.838831473580255D0/, A(200)/0.021244026115782D0/
34838 DATA X(201)/0.816954138681463D0/, A(201)/0.022505090246332D0/
34839 DATA X(202)/0.793832717504605D0/, A(202)/0.023731882865930D0/
34840 DATA X(203)/0.769502420135041D0/, A(203)/0.024922535764115D0/
34841 DATA X(204)/0.744000297583597D0/, A(204)/0.026075235767565D0/
34842 DATA X(205)/0.717365185362099D0/, A(205)/0.027188227500486D0/
34843 DATA X(206)/0.689637644342027D0/, A(206)/0.028259816057276D0/
34844 DATA X(207)/0.660859898986119D0/, A(207)/0.029288369583267D0/
34845 DATA X(208)/0.631075773046871D0/, A(208)/0.030272321759557D0/
34846 DATA X(209)/0.600330622829751D0/, A(209)/0.031210174188114D0/
34847 DATA X(210)/0.568671268122709D0/, A(210)/0.032100498673487D0/
34848 DATA X(211)/0.536145920897131D0/, A(211)/0.032941939397645D0/
34849 DATA X(212)/0.502804111888784D0/, A(212)/0.033733214984611D0/
34850 DATA X(213)/0.468696615170544D0/, A(213)/0.034473120451753D0/
34851 DATA X(214)/0.433875370831756D0/, A(214)/0.035160529044747D0/
34852 DATA X(215)/0.398393405881969D0/, A(215)/0.035794393953416D0/
34853 DATA X(216)/0.362304753499487D0/, A(216)/0.036373749905835D0/
34854 DATA X(217)/0.325664370747701D0/, A(217)/0.036897714638276D0/
34855 DATA X(218)/0.288528054884511D0/, A(218)/0.037365490238730D0/
34856 DATA X(219)/0.250952358392272D0/, A(219)/0.037776364362001D0/
34857 DATA X(220)/0.212994502857666D0/, A(220)/0.038129711314477D0/
34858 DATA X(221)/0.174712291832646D0/, A(221)/0.038424993006959D0/
34859 DATA X(222)/0.136164022809143D0/, A(222)/0.038661759774076D0/
34860 DATA X(223)/0.097408398441584D0/, A(223)/0.038839651059051D0/
34861 DATA X(224)/0.058504437152420D0/, A(224)/0.038958395962769D0/
34862 DATA X(225)/0.019511383256793D0/, A(225)/0.039017813656306D0/
34864 DATA X(226)/0.999689503883230D0/, A(226)/0.000796792065552D0/
34865 DATA X(227)/0.998364375863181D0/, A(227)/0.001853960788946D0/
34866 DATA X(228)/0.995981842987209D0/, A(228)/0.002910731817934D0/
34867 DATA X(229)/0.992543900323762D0/, A(229)/0.003964554338444D0/
34868 DATA X(230)/0.988054126329623D0/, A(230)/0.005014202742927D0/
34869 DATA X(231)/0.982517263563014D0/, A(231)/0.006058545504235D0/
34870 DATA X(232)/0.975939174585136D0/, A(232)/0.007096470791153D0/
34871 DATA X(233)/0.968326828463264D0/, A(233)/0.008126876925698D0/
34872 DATA X(234)/0.959688291448742D0/, A(234)/0.009148671230783D0/
34873 DATA X(235)/0.950032717784437D0/, A(235)/0.010160770535008D0/
34874 DATA X(236)/0.939370339752755D0/, A(236)/0.011162102099838D0/
34875 DATA X(237)/0.927712456722308D0/, A(237)/0.012151604671088D0/
34876 DATA X(238)/0.915071423120898D0/, A(238)/0.013128229566961D0/
34877 DATA X(239)/0.901460635315852D0/, A(239)/0.014090941772314D0/
34878 DATA X(240)/0.886894517402420D0/, A(240)/0.015038721026994D0/
34879 DATA X(241)/0.871388505909296D0/, A(241)/0.015970562902562D0/
34880 DATA X(242)/0.854959033434601D0/, A(242)/0.016885479864245D0/
34881 DATA X(243)/0.837623511228187D0/, A(243)/0.017782502316045D0/
34882 DATA X(244)/0.819400310737931D0/, A(244)/0.018660679627411D0/
34883 DATA X(245)/0.800308744139140D0/, A(245)/0.019519081140145D0/
34884 DATA X(246)/0.780369043867433D0/, A(246)/0.020356797154333D0/
34885 DATA X(247)/0.759602341176647D0/, A(247)/0.021172939892191D0/
34886 DATA X(248)/0.738030643744400D0/, A(248)/0.021966644438744D0/
34887 DATA X(249)/0.715676812348967D0/, A(249)/0.022737069658329D0/
34888 DATA X(250)/0.692564536642171D0/, A(250)/0.023483399085926D0/
34889 DATA X(251)/0.668718310043916D0/, A(251)/0.024204841792364D0/
34890 DATA X(252)/0.644163403784967D0/, A(252)/0.024900633222483D0/
34891 DATA X(253)/0.618925840125468D0/, A(253)/0.025570036005349D0/
34892 DATA X(254)/0.593032364777572D0/, A(254)/0.026212340735672D0/
34893 DATA X(255)/0.566510418561397D0/, A(255)/0.026826866725591D0/
34894 DATA X(256)/0.539388108324357D0/, A(256)/0.027412962726029D0/
34895 DATA X(257)/0.511694177154667D0/, A(257)/0.027970007616848D0/
34896 DATA X(258)/0.483457973920596D0/, A(258)/0.028497411065085D0/
34897 DATA X(259)/0.454709422167743D0/, A(259)/0.028994614150555D0/
34898 DATA X(260)/0.425478988407300D0/, A(260)/0.029461089958167D0/
34899 DATA X(261)/0.395797649828908D0/, A(261)/0.029896344136328D0/
34900 DATA X(262)/0.365696861472313D0/, A(262)/0.030299915420827D0/
34901 DATA X(263)/0.335208522892625D0/, A(263)/0.030671376123669D0/
34902 DATA X(264)/0.304364944354496D0/, A(264)/0.031010332586313D0/
34903 DATA X(265)/0.273198812591049D0/, A(265)/0.031316425596861D0/
34904 DATA X(266)/0.241743156163840D0/, A(266)/0.031589330770727D0/
34905 DATA X(267)/0.210031310460567D0/, A(267)/0.031828758894411D0/
34906 DATA X(268)/0.178096882367618D0/, A(268)/0.032034456231992D0/
34907 DATA X(269)/0.145973714654896D0/, A(269)/0.032206204794030D0/
34908 DATA X(270)/0.113695850110665D0/, A(270)/0.032343822568575D0/
34909 DATA X(271)/0.081297495464425D0/, A(271)/0.032447163714064D0/
34910 DATA X(272)/0.048812985136049D0/, A(272)/0.032516118713868D0/
34911 DATA X(273)/0.016276744849602D0/, A(273)/0.032550614492363D0/
34913 IF(IBD.NE.0) RETURN
34924 *$ CREATE PHO_DZEROX.FOR
34926 CDECK ID>, PHO_DZEROX
34927 DOUBLE PRECISION FUNCTION PHO_DZEROX(A0,B0,EPS,MAXF,F,MODE)
34928 C**********************************************************************
34932 C J.C.P. Bus and T.J. Dekker, Two Efficient Algorithms with
34933 C Guaranteed Convergence for Finding a Zero of a Function,
34934 C ACM Trans. Math. Software 1 (1975) 330-345.
34936 C (MODE = 1: Algorithm M; MODE = 2: Algorithm R)
34940 C***********************************************************************
34941 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34944 C input/output channels
34946 COMMON /POINOU/ LI,LO
34949 PARAMETER (NAME = 'PHO_DZEROX')
34951 DIMENSION IM1(2),IM2(2),LMT(2)
34954 PARAMETER (Z1 = 1, HALF = Z1/2)
34956 DATA IM1 /2,3/, IM2 /-1,3/
34958 IF(MODE .NE. 1 .AND. MODE .NE. 2) THEN
34960 WRITE(LO,100) NAME,MODE
34965 IF(FA*FB .GT. 0) THEN
34978 3 IF(ABS(FC) .LT. ABS(FB)) THEN
34993 IF(ABS(HB) .GT. TOL) THEN
34994 IF(IE .GT. IM1(MODE)) THEN
34997 TOL=TOL*SIGN(Z1,HB)
35013 IF(IE .EQ. IM2(MODE)) P=P+P
35014 IF(P .EQ. 0 .OR. P .LE. Q*TOL) THEN
35016 ELSEIF(P .LT. HB*Q) THEN
35028 IF(MF .GT. MAXF) THEN
35033 IF(FB .EQ. 0 .OR. SIGN(Z1,FC) .EQ. SIGN(Z1,FB)) GO TO 1
35034 IF(W .EQ. HB) GO TO 2
35041 100 FORMAT(1X,A,': mode = ',I3,' illegal')
35042 101 FORMAT(1X,A,': F(A) and F(B) have the same sign')
35043 102 FORMAT(1X,A,': too many function calls')
35047 *$ CREATE PHO_EXPINT.FOR
35049 CDECK ID>, PHO_EXPINT
35050 DOUBLE PRECISION FUNCTION PHO_EXPINT(RXM)
35051 C***********************************************************************
35053 C function to calculate E_i(x) = -E_1(-x)
35055 C based on CERNLIB C337 (changed by R.Engel 10/1993)
35057 C***********************************************************************
35058 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35061 C input/output channels
35063 COMMON /POINOU/ LI,LO
35065 DOUBLE PRECISION P1(5),Q1(5),P2(7),Q2(7),P3(6),Q3(6),P4(8),Q4(8)
35066 DOUBLE PRECISION A1(8),B1(8),A2(8),B2(8),A3(6),B3(6),XL(6)
35067 DOUBLE PRECISION X,Y,AP,BP,DP,AQ,BQ,DQ,X0,V
35069 DATA X0 /0.37250 74107 8137D0/
35070 DATA XL /-24.0D0,-12.0D0,-6.0D0,0.0D0,1.0D0,4.0D0/
35072 1/+4.29312 52343 210D+0, +3.98941 53870 321D+1,
35073 2 +2.92525 18866 921D+2, +4.25696 82638 592D+2,
35074 3 -4.34981 43832 952D+2/
35076 1/+1.00000 00000 000D+0, +1.88992 88395 003D+1,
35077 2 +1.50950 38744 251D+2, +5.68052 52718 987D+2,
35078 3 +7.53585 64359 843D+2/
35080 1/+4.30967 83946 939D-1, +6.90522 52278 444D+0,
35081 2 +2.30192 55939 133D+1, +2.43784 08879 132D+1,
35082 3 +9.04161 55694 633D+0, +9.99979 57705 159D-1,
35083 4 +4.65627 10797 510D-7/
35085 1/+1.03400 13040 487D-1, +3.31909 21359 330D+0,
35086 2 +2.04494 78501 379D+1, +4.12807 84189 142D+1,
35087 3 +3.24264 21069 514D+1, +1.00411 64382 905D+1,
35088 4 +1.00000 00000 000D+0/
35090 1/-2.39099 64453 136D+0, -1.47982 19500 504D+2,
35091 2 -2.54376 33976 890D+2, -1.19557 61038 372D+2,
35092 3 -1.96304 08535 939D+1, -9.99999 99990 360D-1/
35094 1/+1.77600 70940 351D+2, +5.30685 09610 812D+2,
35095 2 +4.62230 27156 148D+2, +1.56818 43364 539D+2,
35096 3 +2.16304 08494 238D+1, +1.00000 00000 000D+0/
35098 1/-8.66937 33995 107D+0, -5.49142 26552 109D+2,
35099 2 -4.21001 61535 707D+3, -2.49301 39345 865D+5,
35100 3 -1.19623 66934 925D+5, -2.21744 62775 885D+7,
35101 4 +3.89280 42131 120D+6, -3.91546 07380 910D+8/
35103 1/+3.41718 75000 000D+1, -1.60708 92658 722D+3,
35104 2 +3.57300 29805 851D+4, -4.83547 43616 216D+5,
35105 3 +4.28559 62461 175D+6, -2.49033 37574 054D+7,
35106 4 +8.91925 76757 561D+7, -1.65254 29972 521D+8/
35108 1/-2.18086 38152 072D+0, -2.19010 23385 488D+1,
35109 2 +9.30816 38566 217D+0, +2.50762 81129 356D+1,
35110 3 -3.31842 53199 722D+1, +6.01217 99083 008D+1,
35111 4 -4.32531 13287 813D+1, +1.00443 10922 808D+0/
35113 1/+0.00000 00000 000D+0, +3.93707 70185 272D+0,
35114 2 +3.00892 64837 292D+2, -6.25041 16167 188D+0,
35115 3 +1.00367 43951 673D+3, +1.43256 73812 194D+1,
35116 4 +2.73624 11988 933D+3, +5.27468 85196 291D-1/
35118 1/-3.48334 65360 285D+0, -1.86545 45488 340D+1,
35119 2 -8.28561 99414 064D+0, -3.23467 33030 540D+1,
35120 3 +1.79601 68876 925D+1, +1.75656 31546 961D+0,
35121 4 -1.95022 32128 966D+0, +9.99994 29607 471D-1/
35123 1/+0.00000 00000 000D+0, +6.95000 65588 743D+1,
35124 2 +5.72837 19383 732D+1, +2.57776 38423 844D+1,
35125 3 +7.60761 14800 773D+2, +2.89516 72792 514D+1,
35126 4 -3.43942 26689 987D+0, +1.00083 86740 264D+0/
35128 1/-2.77809 28934 438D+1, -1.01047 90815 760D+1,
35129 2 -9.14830 08216 736D+0, -5.02233 17461 851D+0,
35130 3 -3.00000 77799 358D+0, +1.00000 00000 704D+0/
35132 1/+0.00000 00000 000D+0, +1.22399 93926 823D+2,
35133 2 +2.72761 00778 779D+0, -7.18975 18395 045D+0,
35134 3 -2.99901 18065 262D+0, +1.99999 99428 260D+0/
35136 C conversion to E_i function
35139 IF(X .LE. XL(1)) THEN
35142 1 AP=A3(I)-X+B3(I)/AP
35143 Y=(EXP(-X)/X)*(1.D0-(A3(6)+B3(6)/AP)/X)
35144 ELSEIF(X .LE. XL(2)) THEN
35147 2 AP=A2(I)-X+B2(I)/AP
35148 Y=(EXP(-X)/X)*(A2(8)+B2(8)/AP)
35149 ELSEIF(X .LE. XL(3)) THEN
35152 3 AP=A1(I)-X+B1(I)/AP
35153 Y=(EXP(-X)/X)*(A1(8)+B1(8)/AP)
35154 ELSEIF(X .LT. XL(4)) THEN
35155 V=-2.D0*(X/3.D0+1.D0)
35167 14 DQ=Q4(I)-AQ+V*BQ
35168 Y=-LOG(-X/X0)+(X+X0)*(DP-AP)/(DQ-AQ)
35169 ELSEIF(X .EQ. XL(4)) THEN
35170 * CALL KERMTR('C337.1',LGFILE,MFLAG,RFLAG)
35172 * IF(LGFILE .EQ. 0) THEN
35173 * WRITE(LO,100) ENAME
35175 * WRITE(LGFILE,100) ENAME
35178 * IF(.NOT.RFLAG) CALL ABEND
35181 ELSEIF(X .LT. XL(5)) THEN
35188 ELSEIF(X .LE. XL(6)) THEN
35203 Y=EXP(-X)*Y*(1.D0+Y*AP/AQ)
35205 C sign conversion to E_i
35210 *$ CREATE PHO_RNDBET.FOR
35212 CDECK ID>, PHO_RNDBET
35213 DOUBLE PRECISION FUNCTION PHO_RNDBET(GAM,ETA)
35214 C********************************************************************
35216 C RANDOM NUMBER GENERATION FROM BETA
35217 C DISTRIBUTION IN REGION 0 < X < 1.
35218 C F(X) = X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM) / (GAMM(GAM
35221 C********************************************************************
35222 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35225 Y = PHO_RNDGAM(1.D0,GAM)
35226 Z = PHO_RNDGAM(1.D0,ETA)
35228 PHO_RNDBET = Y/(Y+Z)
35232 *$ CREATE PHO_RNDGAM.FOR
35234 CDECK ID>, PHO_RNDGAM
35235 DOUBLE PRECISION FUNCTION PHO_RNDGAM(ALAM,ETA)
35236 C********************************************************************
35238 C RANDOM NUMBER SELECTION FROM GAMMA DISTRIBUTION
35239 C F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)
35241 C********************************************************************
35242 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35248 IF(F.EQ.0.D0) GOTO 20
35249 10 R = DT_RNDM(ETA)
35251 IF (NCOU.GE.11) GOTO 20
35252 IF(R.LT.F/(F+2.71828D0)) GOTO 30
35253 YYY=LOG(DT_RNDM(F)+1.0D-9)/F
35254 IF(ABS(YYY).GT.50.D0) GOTO 20
35256 IF(LOG(DT_RNDM(Y)+1.0D-9).GT.-Y) GOTO 10
35260 30 Y = 1.D0-LOG(DT_RNDM(R)+1.0D-9)
35261 IF(DT_RNDM(Y).GT.Y**(F-1.D0)) GOTO 10
35262 40 IF(N.EQ.0) GOTO 70
35265 60 Z = Z*DT_RNDM(Y)
35266 Y = Y-LOG(Z+1.0D-9)
35267 70 PHO_RNDGAM = Y/ALAM
35271 *$ CREATE PHO_SFECFE.FOR
35273 CDECK ID>, PHO_SFECFE
35274 SUBROUTINE PHO_SFECFE(SFE,CFE)
35275 C**********************************************************************
35277 C fast random SIN(X) COS(X) selection
35279 C**********************************************************************
35280 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35289 IF(XY.GT.1.D0) GOTO 1
35292 IF(DT_RNDM(XY).LT.0.5D0) THEN
35297 *$ CREATE PHO_SWAPD.FOR
35299 CDECK ID>, PHO_SWAPD
35300 SUBROUTINE PHO_SWAPD(D1,D2)
35301 C********************************************************************
35303 C exchange of argument values (double precision)
35305 C********************************************************************
35306 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35312 *$ CREATE PHO_SWAPI.FOR
35314 CDECK ID>, PHO_SWAPI
35315 SUBROUTINE PHO_SWAPI(I1,I2)
35316 C********************************************************************
35318 C exchange of argument values (integer)
35320 C********************************************************************
35321 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35327 *$ CREATE PHO_HADCSL.FOR
35329 CDECK ID>, PHO_HADCSL
35330 SUBROUTINE PHO_HADCSL(ID1,ID2,ECM,PLAB,IMODE,
35331 & SIGTOT,SIGEL,SIGDIF,SLOPE,RHO)
35332 C***********************************************************************
35334 C low-energy cross section parametrizations
35336 C input: ID1,ID2 PDG IDs of particles (meson first)
35337 C ECM c.m. energy (GeV)
35338 C PLAB lab. momentum (second particle at rest)
35339 C IMODE 1 ECM given, PLAB ignored
35340 C 2 PLAB given, ECM ignored
35342 C output: SIGTOT total cross section (mb)
35343 C SIGEL elastic cross section (mb)
35344 C SIGDIF diffracive cross section (sd-1,sd-2,dd), (mb)
35345 C SLOPE forward elastic slope (GeV**-2)
35346 C RHO real/imaginary part of elastic amplitude
35350 C - low-energy data interpolation uses PDG fits from 1992 issue
35351 C - high-energy extrapolation by Donnachie-Landshoff like fit made
35353 C - analytic extension of amplitude to calculate rho
35355 C***********************************************************************
35359 INTEGER ID1,ID2,IMODE
35360 DOUBLE PRECISION ECM,PLAB,SIGTOT,SIGEL,SIGDIF(3),SLOPE,RHO
35362 C input/output channels
35364 COMMON /POINOU/ LI,LO
35366 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
35367 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
35368 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
35369 C model switches and parameters
35371 INTEGER ISWMDL,IPAMDL
35372 DOUBLE PRECISION PARMDL
35373 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
35376 DOUBLE PRECISION SIGTO1,SIGTO2,SIGEL1,SIGEL2,
35377 & SS,PL,PLL,E1,XP,YP,YM,PHR,PHP,X1,X2
35379 DOUBLE PRECISION TPDG92(7,2,6),TPDG96(9,6),BURQ83(3,6),XMA(6)
35382 & 3.D0, 2100.D0, 48.D0, 0.D0, 1.D0, 0.522D0, -4.51D0,
35383 & 3.D0, 2100.D0, 11.9D0, 26.9D0, -1.21D0, 0.169D0, -1.85D0,
35384 & 5.D0, 2100.D0, 38.4D0, 77.6D0, -0.64D0, 0.26D0, -1.2D0,
35385 & 5.D0, 2100.D0, 10.2D0, 52.7D0, -1.16D0, 0.125D0, -1.28D0,
35386 & 4.D0, 340.D0, 16.4D0, 19.3D0, -0.42D0, 0.19D0, 0.D0,
35387 & 4.D0, 340.D0, 0.D0, 11.4D0, -0.4D0, 0.079D0, 0.D0,
35388 & 2.5D0, 370.D0, 33.D0, 14.D0, -1.36D0, 0.456D0, -4.03D0,
35389 & 2.5D0, 370.D0, 1.76D0, 11.2D0, -0.64D0, 0.043D0, 0.D0,
35390 & 2.D0, 310.D0, 18.1D0, 0.D0, 1.D0, 0.26D0, -1.D0,
35391 & 2.D0, 310.D0, 5.D0, 8.1D0, -1.8D0, 0.16D0, -1.3D0,
35392 & 3.D0, 310.D0, 32.1D0, 0.D0, 1.D0, 0.66D0, -5.6D0,
35393 & 3.D0, 310.D0, 7.3D0, 0.D0, 1.D0, 0.29D0, -2.4D0 /
35396 & 50.D0, 22.D0,0.079D0,0.25D0,0.D0,
35397 & 77.15D0,-21.05D0,0.46D0,0.9D0,
35398 & 50.D0, 22.D0,0.079D0,0.25D0,0.D0,
35399 & 77.15D0,21.05D0,0.46D0,0.9D0,
35400 & 10.D0, 13.70,0.079D0,0.25D0,0.D0,
35401 & 31.85D0,-4.05D0,0.45D0,0.9D0,
35402 & 10.D0, 13.70,0.079D0,0.25D0,0.D0,
35403 & 31.85D0,4.05D0,0.45D0,0.9D0,
35404 & 10.D0, 12.20,0.079D0,0.25D0,0.D0,
35405 & 17.35D0,-9.05D0,0.50D0,0.9D0,
35406 & 10.D0, 12.20,0.079D0,0.25D0,0.D0,
35407 & 17.35D0,9.05D0,0.50D0,0.9D0 /
35410 & 11.13D0, -6.21D0, 0.30D0,
35411 & 11.13D0, 7.23D0, 0.30D0,
35412 & 9.11D0, -0.73D0, 0.28D0,
35413 & 9.11D0, 0.65D0, 0.28D0,
35414 & 8.55D0, -5.98D0, 0.28D0,
35415 & 8.55D0, 1.60D0, 0.28D0 /
35418 & 2*0.93956563D0, 2*0.13956995D0, 2*0.493677D0 /
35421 IF(ID2.NE.2212) THEN
35423 ELSE IF(ID1.EQ.2212) THEN
35425 ELSE IF(ID1.EQ.-2212) THEN
35427 ELSE IF(ID1.EQ.211) THEN
35429 ELSE IF(ID1.EQ.-211) THEN
35431 ELSE IF(ID1.EQ.321) THEN
35433 ELSE IF(ID1.EQ.-321) THEN
35439 C calculate lab momentum
35440 IF(IMODE.EQ.1) THEN
35442 E1 = 0.5D0/XMA(1)*(SS-XMA(1)**2-XMA(K)**2)
35443 PL = SQRT(E1*E1-XMA(K)**2)
35444 ELSE IF(IMODE.EQ.2) THEN
35446 SS = XMA(1)**2+XMA(K)**2+2.D0*XMA(1)*SQRT(PL**2+XMA(K)**2)
35449 WRITE(LO,'(1X,A,I5)') 'PHO_HADCSL:ERROR: invalid IMODE: ',IMODE
35454 C check against lower limit
35455 IF(ECM.LE.XMA(1)+XMA(K)) GOTO 200
35457 XP = TPDG96(2,K)*SS**TPDG96(3,K)
35458 YP = TPDG96(6,K)/SS**TPDG96(8,K)
35459 YM = TPDG96(7,K)/SS**TPDG96(8,K)
35461 PHR = TAN(PI/2.D0*(1.-TPDG96(8,K)))
35462 PHP = TAN(PI/2.D0*(1.+TPDG96(3,K)))
35463 RHO = (-YP/PHR + YM*PHR - XP/PHP)/(YP+YM+XP)
35464 SLOPE = BURQ83(1,K)+BURQ83(2,K)/SQRT(PL)+BURQ83(3,K)*PLL
35466 C select energy range and interpolation method
35467 IF(PL.LT.TPDG96(1,K)) THEN
35468 SIGTOT = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
35469 & + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
35470 SIGEL = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
35471 & + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
35472 ELSE IF(PL.LT.TPDG92(2,1,K)) THEN
35473 SIGTO1 = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
35474 & + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
35475 SIGEL1 = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
35476 & + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
35478 SIGEL2 = SIGTO2**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
35479 X2 = LOG(PL/TPDG96(1,K))/LOG(TPDG92(2,1,K)/TPDG96(1,K))
35481 SIGTOT = SIGTO2*X2 + SIGTO1*X1
35482 SIGEL = SIGEL2*X2 + SIGEL1*X1
35485 SIGEL = SIGTOT**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
35488 C no parametrization of diffraction implemented
35496 WRITE(LO,'(1X,2A,2I7)') 'PHO_HADCSL:ERROR: ',
35497 & 'invalid particle combination: ',ID1,ID2
35501 WRITE(LO,'(1X,2A,1P,2E12.4)') 'PHO_HADCSL:ERROR: ',
35502 & 'energy too small (Ecm,Plab): ',ECM,PLAB
35506 *$ CREATE PHO_CSDIFF.FOR
35508 CDECK ID>, PHO_CSDIFF
35509 SUBROUTINE PHO_CSDIFF(Id1,Id2,SS,Xi_min,Xi_max,
35510 & sig_sd1,sig_sd2,sig_dd)
35511 C***********************************************************************
35513 C cross section for diffraction dissociation according to
35514 C Goulianos' parametrization (Ref: PL B358 (1995) 379)
35516 C in addition rescaling for different particles is applied using
35517 C internal rescaling tables (not implemented yet)
35519 C input: Id1/2 PDG ID's of incoming particles
35520 C SS squared c.m. energy (GeV**2)
35521 C Xi_min min. diff mass (squared) = Xi_min*SS
35522 C Xi_max max. diff mass (squared) = Xi_max*SS
35524 C output: sig_sd1 cross section for diss. of particle 1 (mb)
35525 C sig_sd2 cross section for diss. of particle 2 (mb)
35526 C sig_dd cross section for diss. of both particles
35528 C***********************************************************************
35533 DOUBLE PRECISION SS,Xi_min,Xi_max,sig_sd1,sig_sd2,sig_dd
35535 C input/output channels
35537 COMMON /POINOU/ LI,LO
35539 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
35540 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
35541 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
35543 DOUBLE PRECISION xpos1(96),xwgh1(96),xpos2(96),xwgh2(96)
35544 DOUBLE PRECISION delta,alphap,beta0,gpom0,xm_p,x_rad2,xm4_p2,
35545 & fac,tt,t1,t2,tl,tu,Xnorm,xi,xil,xiu,w_xi,alpha_t,f2_t,
35546 & xms_1,xms_2,CSdiff
35548 INTEGER Ngau1,Ngau2,i1,i2
35552 DATA delta / 0.104d0 /
35553 DATA alphap / 0.25d0 /
35554 DATA beta0 / 6.56d0 /
35555 DATA gpom0 / 1.21d0 /
35556 DATA xm_p / 0.938d0 /
35557 DATA x_rad2 / 0.71d0 /
35559 C integration precision
35568 IF ((ABS(id1).EQ.2212).AND.(ABS(id2).EQ.2212)) THEN
35570 xm4_p2 = 4.D0*xm_p**2
35571 fac = beta0**2/(16.D0*PI)
35575 tl = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
35576 tu = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
35578 C flux renormalization and cross section
35582 xil = log(1.5d0/SS)
35585 IF(xiu.LE.xil) goto 1000
35587 CALL PHO_GAUSET(xil,xiu,Ngau1,xpos1,xwgh1)
35588 CALL PHO_GAUSET(tl,tu,Ngau2,xpos2,xwgh2)
35592 xi = exp(xpos1(i1))
35597 tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
35599 alpha_t = 1.D0+delta+alphap*tt
35600 f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
35603 & + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
35618 TL = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
35619 TU = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
35621 C single diffraction diss. cross section
35625 IF(XIU.LE.XIL) goto 2000
35627 CALL PHO_GAUSET(XIL,XIU,NGAU1,XPOS1,XWGH1)
35628 CALL PHO_GAUSET(TL,TU,NGAU2,XPOS2,XWGH2)
35632 xi = exp(xpos1(i1))
35633 w_xi = Xwgh1(i1)*beta0*gpom0*(xi*ss)**delta
35637 tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
35639 alpha_t = 1.D0+delta+alphap*tt
35640 f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
35643 & + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
35648 CSdiff = CSdiff*fac*GEV2MB/MAX(1.d0,Xnorm)
35650 * WRITE(LO,'(1x,1p,4e14.3)')
35651 * & sqrt(SS),Xnorm,2.*CSdiff*MAX(1.d0,Xnorm),2.*CSdiff
35658 C double diffraction dissociation cross section
35662 xil = log(1.5d0/SS)
35663 xiu = log(Xi_max/1.5d0)
35665 IF(xiu.LE.xil) goto 3000
35667 fac = (beta0*gpom0*SS**delta
35668 & /(4.d0*sqrt(PI)*MAX(1.d0,Xnorm)))**2
35671 CALL PHO_GAUSET(xil,xiu,ngau1,xpos1,xwgh1)
35675 xi = exp(xpos1(i1))
35678 xiu = log(Xi_max/(xi*SS))
35680 if(xil.lt.xiu) then
35682 CALL PHO_GAUSET(xil,xiu,Ngau2,xpos2,xwgh2)
35686 xms_2 = exp(xpos2(i2))*SS
35688 & + 1.d0/((xms_1*xms_2)**delta*log(SS/(xms_1*xms_2)))
35689 & *xwgh1(i1)*xwgh2(i2)
35697 sig_dd = CSdiff*fac*GEV2MB
35703 WRITE(LO,'(1x,2a,2I8)') 'PHO_CSDIFF: ',
35704 & 'invalid particle combination (Id1/2)',Id1,Id2
35710 *$ CREATE PHO_ALLM97.FOR
35712 CDECK ID>, PHO_ALLM97
35713 DOUBLE PRECISION FUNCTION PHO_ALLM97(Q2,W)
35714 C**********************************************************************
35716 C ALLM97 parametrization for gamma*-p cross section
35717 C (for F2 see comments, code adapted from V. Shekelyan, H1)
35719 C**********************************************************************
35723 C input/output channels
35725 COMMON /POINOU/ LI,LO
35727 DOUBLE PRECISION Q2,W
35728 DOUBLE PRECISION M02,M12,LAM2,M22
35729 DOUBLE PRECISION S11,S12,S13,A11,A12,A13,B11,B12,B13
35730 DOUBLE PRECISION S21,S22,S23,A21,A22,A23,B21,B22,B23
35731 DOUBLE PRECISION ALFA,XMP2,W2,Q02,S,T,T0,Z,CIN,
35732 & AP,BP,AR,BR,XP,XR,SR,SP,F2P,F2R
35733 DATA ALFA,XMP2 /112.2D0 , .8802D0 /
35764 Q02 = 0.46017D0 +LAM2
35768 T=LOG((Q2+Q02)/LAM2)
35770 IF(Q2.GT.0.D0) S=LOG(T/T0)
35773 IF(Q2.GT.0.D0) Z=(W2-XMP2)/(Q2+W2-XMP2)
35775 IF(S.LT.0.01D0) THEN
35779 XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
35785 F2P=SP*XP**AP*Z**BP
35789 XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
35795 F2R=SR*XR**AR*Z**BR
35801 XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
35803 AP=A11+(A11-A12)*(1.D0 /(1.D0 +S**A13)-1.D0 )
35805 BP=B11**2+B12**2*S**B13
35807 SP=S11+(S11-S12)*(1.D0 /(1.D0 +S**S13)-1.D0 )
35809 F2P=SP*XP**AP*Z**BP
35813 XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
35816 BR=B21**2+B22**2*S**B23
35819 F2R=SR*XR**AR*Z**BR
35823 * F2 = (F2P+F2R)*Q2/(Q2+M02)
35825 CIN=ALFA/(Q2+M02)*(1.D0 +4.D0*XMP2*Q2/(Q2+W2-XMP2)**2)/Z
35826 PHO_ALLM97 = CIN*(F2P+F2R)
35830 *$ CREATE PHO_DOR98LO.FOR
35832 CDECK ID>, PHO_DOR98LO
35833 SUBROUTINE PHO_DOR98LO (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
35834 C***********************************************************************
35836 C GRV98 parton densities, leading order set
35838 C For a detailed explanation see
35839 C M. Glueck, E. Reya, A. Vogt :
35840 C hep-ph/9806404 = DO-TH 98/07 = WUE-ITP-98-019
35841 C (To appear in Eur. Phys. J. C)
35843 C interpolation routine based on the original GRV98PA routine,
35844 C adapted to define interpolation table as DATA statements
35849 C INPUT: X = Bjorken-x (between 1.E-9 and 1.)
35850 C Q2 = scale in GeV**2 (between 0.8 and 1.E6)
35852 C OUTPUT: UV = u - u(bar), DV = d - d(bar), US = u(bar),
35853 C DS = d(bar), SS = s = s(bar), GL = gluon.
35854 C Always x times the distribution is returned.
35856 C******************************************************i****************
35857 IMPLICIT DOUBLE PRECISION (A-H, O-Z)
35860 C input/output channels
35862 COMMON /POINOU/ LI,LO
35864 PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
35865 DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
35866 1 XSF(NX,NQ), XGF(NX,NQ),
35867 2 XT(NARG), NA(NARG), ARRF(NX+NQ)
35869 DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
35870 & XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
35872 EQUIVALENCE (XUVF(1,1),XUVF_L(1))
35873 EQUIVALENCE (XDVF(1,1),XDVF_L(1))
35874 EQUIVALENCE (XDEF(1,1),XDEF_L(1))
35875 EQUIVALENCE (XUDF(1,1),XUDF_L(1))
35876 EQUIVALENCE (XSF(1,1),XSF_L(1))
35877 EQUIVALENCE (XGF(1,1),XGF_L(1))
35879 DATA (ARRF(K),K= 1, 95) /
35880 & -2.0723E+01,-2.0135E+01,-1.9560E+01,-1.8983E+01,-1.8421E+01,
35881 & -1.7833E+01,-1.7258E+01,-1.6680E+01,-1.6118E+01,-1.5530E+01,
35882 & -1.4955E+01,-1.4378E+01,-1.3816E+01,-1.3479E+01,-1.3122E+01,
35883 & -1.2717E+01,-1.2311E+01,-1.1913E+01,-1.1513E+01,-1.1176E+01,
35884 & -1.0820E+01,-1.0414E+01,-1.0009E+01,-9.6108E+00,-9.2103E+00,
35885 & -8.8739E+00,-8.5172E+00,-8.1117E+00,-7.7063E+00,-7.3082E+00,
35886 & -6.9078E+00,-6.5713E+00,-6.2146E+00,-5.8091E+00,-5.4037E+00,
35887 & -5.0056E+00,-4.6052E+00,-4.2687E+00,-3.9120E+00,-3.5066E+00,
35888 & -3.1011E+00,-2.8134E+00,-2.5257E+00,-2.3026E+00,-2.0794E+00,
35889 & -1.8971E+00,-1.7430E+00,-1.6094E+00,-1.4917E+00,-1.3863E+00,
35890 & -1.2910E+00,-1.2040E+00,-1.1239E+00,-1.0498E+00,-9.8083E-01,
35891 & -9.1629E-01,-7.9851E-01,-6.9315E-01,-5.9784E-01,-5.1083E-01,
35892 & -4.3078E-01,-3.5667E-01,-2.8768E-01,-2.2314E-01,-1.6252E-01,
35893 & -1.0536E-01,-5.1293E-02, 0.0000E+00,-2.2314E-01, 0.0000E+00,
35894 & 2.6236E-01, 5.8779E-01, 9.9325E-01, 1.3863E+00, 1.8563E+00,
35895 & 2.3026E+00, 2.7726E+00, 3.2189E+00, 3.6889E+00, 4.1589E+00,
35896 & 4.6052E+00, 5.1930E+00, 5.7683E+00, 6.3456E+00, 6.9078E+00,
35897 & 7.4955E+00, 8.0709E+00, 8.6482E+00, 9.2103E+00, 9.9988E+00,
35898 & 1.0736E+01, 1.1513E+01, 1.2301E+01, 1.3039E+01, 1.3816E+01/
35899 DATA (XUVF_L(K),K= 1, 114) /
35900 &2.3186E+00,2.2915E+00,2.2645E+00,2.2385E+00,2.2140E+00,2.1876E+00,
35901 &2.1623E+00,2.1366E+00,2.1121E+00,2.0862E+00,2.0612E+00,2.0358E+00,
35902 &2.0110E+00,1.9963E+00,1.9806E+00,1.9624E+00,1.9446E+00,1.9263E+00,
35903 &1.9072E+00,1.8904E+00,1.8724E+00,1.8515E+00,1.8294E+00,1.8085E+00,
35904 &1.7865E+00,1.7680E+00,1.7483E+00,1.7249E+00,1.6993E+00,1.6715E+00,
35905 &1.6385E+00,1.6141E+00,1.5884E+00,1.5597E+00,1.5337E+00,1.5121E+00,
35906 &1.4985E+00,1.4980E+00,1.5116E+00,1.5555E+00,1.6432E+00,1.7434E+00,
35907 &1.8861E+00,2.0327E+00,2.2174E+00,2.4015E+00,2.5849E+00,2.7671E+00,
35908 &2.9488E+00,3.1308E+00,3.3142E+00,3.4998E+00,3.6885E+00,3.8826E+00,
35909 &4.0815E+00,4.2069E+00,4.5481E+00,4.8830E+00,5.2116E+00,5.5351E+00,
35910 &5.8553E+00,6.1665E+00,6.4745E+00,6.7767E+00,7.0735E+00,7.3628E+00,
35911 &7.6283E+00,0.0000E+00,2.3948E+00,2.3665E+00,2.3388E+00,2.3126E+00,
35912 &2.2860E+00,2.2592E+00,2.2327E+00,2.2065E+00,2.1810E+00,2.1541E+00,
35913 &2.1284E+00,2.1020E+00,2.0760E+00,2.0605E+00,2.0443E+00,2.0259E+00,
35914 &2.0068E+00,1.9873E+00,1.9676E+00,1.9500E+00,1.9312E+00,1.9081E+00,
35915 &1.8860E+00,1.8635E+00,1.8406E+00,1.8221E+00,1.8007E+00,1.7764E+00,
35916 &1.7489E+00,1.7195E+00,1.6855E+00,1.6600E+00,1.6332E+00,1.6031E+00,
35917 &1.5760E+00,1.5532E+00,1.5397E+00,1.5376E+00,1.5507E+00,1.5929E+00,
35918 &1.6784E+00,1.7759E+00,1.9129E+00,2.0531E+00,2.2292E+00,2.4032E+00/
35919 DATA (XUVF_L(K),K= 115, 228) /
35920 &2.5752E+00,2.7449E+00,2.9135E+00,3.0810E+00,3.2491E+00,3.4183E+00,
35921 &3.5898E+00,3.7650E+00,3.9437E+00,4.0443E+00,4.3402E+00,4.6262E+00,
35922 &4.9009E+00,5.1640E+00,5.4156E+00,5.6530E+00,5.8759E+00,6.0779E+00,
35923 &6.2540E+00,6.3836E+00,6.4062E+00,0.0000E+00,2.4808E+00,2.4513E+00,
35924 &2.4236E+00,2.3948E+00,2.3680E+00,2.3397E+00,2.3127E+00,2.2853E+00,
35925 &2.2585E+00,2.2307E+00,2.2026E+00,2.1762E+00,2.1490E+00,2.1332E+00,
35926 &2.1164E+00,2.0964E+00,2.0766E+00,2.0565E+00,2.0353E+00,2.0171E+00,
35927 &1.9969E+00,1.9738E+00,1.9501E+00,1.9258E+00,1.9026E+00,1.8821E+00,
35928 &1.8594E+00,1.8330E+00,1.8046E+00,1.7734E+00,1.7378E+00,1.7112E+00,
35929 &1.6829E+00,1.6514E+00,1.6228E+00,1.5994E+00,1.5840E+00,1.5808E+00,
35930 &1.5927E+00,1.6334E+00,1.7157E+00,1.8093E+00,1.9406E+00,2.0735E+00,
35931 &2.2394E+00,2.4019E+00,2.5615E+00,2.7178E+00,2.8718E+00,3.0246E+00,
35932 &3.1766E+00,3.3284E+00,3.4820E+00,3.6370E+00,3.7952E+00,3.8716E+00,
35933 &4.1225E+00,4.3580E+00,4.5798E+00,4.7847E+00,4.9730E+00,5.1395E+00,
35934 &5.2832E+00,5.3945E+00,5.4634E+00,5.4612E+00,5.2940E+00,0.0000E+00,
35935 &2.5823E+00,2.5527E+00,2.5226E+00,2.4928E+00,2.4650E+00,2.4358E+00,
35936 &2.4071E+00,2.3783E+00,2.3505E+00,2.3212E+00,2.2928E+00,2.2636E+00,
35937 &2.2360E+00,2.2185E+00,2.2005E+00,2.1801E+00,2.1591E+00,2.1376E+00,
35938 &2.1153E+00,2.0960E+00,2.0747E+00,2.0505E+00,2.0247E+00,1.9991E+00/
35939 DATA (XUVF_L(K),K= 229, 342) /
35940 &1.9746E+00,1.9523E+00,1.9287E+00,1.9000E+00,1.8693E+00,1.8361E+00,
35941 &1.7994E+00,1.7711E+00,1.7409E+00,1.7076E+00,1.6772E+00,1.6517E+00,
35942 &1.6345E+00,1.6302E+00,1.6408E+00,1.6789E+00,1.7574E+00,1.8457E+00,
35943 &1.9692E+00,2.0939E+00,2.2474E+00,2.3969E+00,2.5419E+00,2.6837E+00,
35944 &2.8216E+00,2.9573E+00,3.0915E+00,3.2246E+00,3.3583E+00,3.4917E+00,
35945 &3.6273E+00,3.6791E+00,3.8823E+00,4.0673E+00,4.2350E+00,4.3813E+00,
35946 &4.5072E+00,4.6083E+00,4.6757E+00,4.7055E+00,4.6825E+00,4.5674E+00,
35947 &4.2566E+00,0.0000E+00,2.7025E+00,2.6705E+00,2.6393E+00,2.6093E+00,
35948 &2.5790E+00,2.5484E+00,2.5184E+00,2.4880E+00,2.4590E+00,2.4277E+00,
35949 &2.3971E+00,2.3669E+00,2.3380E+00,2.3200E+00,2.3002E+00,2.2782E+00,
35950 &2.2557E+00,2.2331E+00,2.2092E+00,2.1887E+00,2.1660E+00,2.1400E+00,
35951 &2.1126E+00,2.0859E+00,2.0586E+00,2.0351E+00,2.0094E+00,1.9786E+00,
35952 &1.9453E+00,1.9096E+00,1.8707E+00,1.8406E+00,1.8084E+00,1.7728E+00,
35953 &1.7392E+00,1.7128E+00,1.6933E+00,1.6875E+00,1.6949E+00,1.7295E+00,
35954 &1.8023E+00,1.8845E+00,1.9991E+00,2.1134E+00,2.2525E+00,2.3868E+00,
35955 &2.5160E+00,2.6405E+00,2.7609E+00,2.8781E+00,2.9929E+00,3.1059E+00,
35956 &3.2180E+00,3.3292E+00,3.4407E+00,3.4675E+00,3.6225E+00,3.7573E+00,
35957 &3.8710E+00,3.9617E+00,4.0270E+00,4.0642E+00,4.0675E+00,4.0263E+00,
35958 &3.9240E+00,3.7262E+00,3.3217E+00,0.0000E+00,2.8135E+00,2.7813E+00/
35959 DATA (XUVF_L(K),K= 343, 456) /
35960 &2.7489E+00,2.7166E+00,2.6850E+00,2.6527E+00,2.6212E+00,2.5898E+00,
35961 &2.5592E+00,2.5267E+00,2.4943E+00,2.4636E+00,2.4320E+00,2.4129E+00,
35962 &2.3929E+00,2.3695E+00,2.3453E+00,2.3211E+00,2.2959E+00,2.2740E+00,
35963 &2.2496E+00,2.2221E+00,2.1931E+00,2.1653E+00,2.1356E+00,2.1112E+00,
35964 &2.0830E+00,2.0503E+00,2.0147E+00,1.9766E+00,1.9361E+00,1.9037E+00,
35965 &1.8696E+00,1.8318E+00,1.7966E+00,1.7677E+00,1.7459E+00,1.7378E+00,
35966 &1.7430E+00,1.7738E+00,1.8407E+00,1.9169E+00,2.0223E+00,2.1273E+00,
35967 &2.2537E+00,2.3742E+00,2.4892E+00,2.5990E+00,2.7043E+00,2.8056E+00,
35968 &2.9038E+00,3.0000E+00,3.0936E+00,3.1864E+00,3.2782E+00,3.2867E+00,
35969 &3.4021E+00,3.4971E+00,3.5691E+00,3.6188E+00,3.6422E+00,3.6335E+00,
35970 &3.5908E+00,3.5036E+00,3.3552E+00,3.1085E+00,2.6634E+00,0.0000E+00,
35971 &2.9406E+00,2.9062E+00,2.8726E+00,2.8385E+00,2.8060E+00,2.7720E+00,
35972 &2.7392E+00,2.7058E+00,2.6734E+00,2.6399E+00,2.6057E+00,2.5722E+00,
35973 &2.5390E+00,2.5194E+00,2.4975E+00,2.4728E+00,2.4471E+00,2.4216E+00,
35974 &2.3945E+00,2.3712E+00,2.3458E+00,2.3152E+00,2.2856E+00,2.2545E+00,
35975 &2.2237E+00,2.1966E+00,2.1672E+00,2.1312E+00,2.0926E+00,2.0521E+00,
35976 &2.0093E+00,1.9748E+00,1.9384E+00,1.8975E+00,1.8601E+00,1.8275E+00,
35977 &1.8036E+00,1.7924E+00,1.7948E+00,1.8206E+00,1.8808E+00,1.9499E+00,
35978 &2.0450E+00,2.1390E+00,2.2512E+00,2.3570E+00,2.4564E+00,2.5501E+00/
35979 DATA (XUVF_L(K),K= 457, 570) /
35980 &2.6391E+00,2.7240E+00,2.8053E+00,2.8834E+00,2.9590E+00,3.0326E+00,
35981 &3.1042E+00,3.0942E+00,3.1727E+00,3.2289E+00,3.2628E+00,3.2739E+00,
35982 &3.2574E+00,3.2103E+00,3.1297E+00,3.0047E+00,2.8211E+00,2.5467E+00,
35983 &2.0897E+00,0.0000E+00,3.0557E+00,3.0193E+00,2.9840E+00,2.9497E+00,
35984 &2.9150E+00,2.8801E+00,2.8454E+00,2.8109E+00,2.7771E+00,2.7412E+00,
35985 &2.7065E+00,2.6716E+00,2.6360E+00,2.6149E+00,2.5923E+00,2.5663E+00,
35986 &2.5395E+00,2.5120E+00,2.4834E+00,2.4589E+00,2.4330E+00,2.4011E+00,
35987 &2.3676E+00,2.3363E+00,2.3027E+00,2.2736E+00,2.2422E+00,2.2040E+00,
35988 &2.1629E+00,2.1194E+00,2.0750E+00,2.0384E+00,1.9996E+00,1.9565E+00,
35989 &1.9160E+00,1.8811E+00,1.8541E+00,1.8409E+00,1.8399E+00,1.8611E+00,
35990 &1.9143E+00,1.9764E+00,2.0622E+00,2.1459E+00,2.2457E+00,2.3385E+00,
35991 &2.4249E+00,2.5051E+00,2.5806E+00,2.6515E+00,2.7182E+00,2.7823E+00,
35992 &2.8427E+00,2.9008E+00,2.9564E+00,2.9332E+00,2.9828E+00,3.0094E+00,
35993 &3.0142E+00,2.9955E+00,2.9537E+00,2.8796E+00,2.7735E+00,2.6260E+00,
35994 &2.4242E+00,2.1388E+00,1.6900E+00,0.0000E+00,3.1718E+00,3.1348E+00,
35995 &3.0971E+00,3.0610E+00,3.0260E+00,2.9896E+00,2.9533E+00,2.9173E+00,
35996 &2.8818E+00,2.8449E+00,2.8072E+00,2.7709E+00,2.7340E+00,2.7121E+00,
35997 &2.6877E+00,2.6605E+00,2.6319E+00,2.6032E+00,2.5732E+00,2.5471E+00,
35998 &2.5180E+00,2.4851E+00,2.4511E+00,2.4170E+00,2.3817E+00,2.3505E+00/
35999 DATA (XUVF_L(K),K= 571, 684) /
36000 &2.3172E+00,2.2762E+00,2.2328E+00,2.1868E+00,2.1400E+00,2.1012E+00,
36001 &2.0601E+00,2.0136E+00,1.9704E+00,1.9335E+00,1.9035E+00,1.8868E+00,
36002 &1.8827E+00,1.8990E+00,1.9452E+00,2.0005E+00,2.0763E+00,2.1507E+00,
36003 &2.2377E+00,2.3179E+00,2.3917E+00,2.4592E+00,2.5218E+00,2.5799E+00,
36004 &2.6336E+00,2.6843E+00,2.7314E+00,2.7753E+00,2.8166E+00,2.7824E+00,
36005 &2.8054E+00,2.8081E+00,2.7893E+00,2.7474E+00,2.6818E+00,2.5888E+00,
36006 &2.4646E+00,2.3032E+00,2.0902E+00,1.8025E+00,1.3740E+00,0.0000E+00,
36007 &3.2793E+00,3.2385E+00,3.2014E+00,3.1643E+00,3.1270E+00,3.0888E+00,
36008 &3.0517E+00,3.0141E+00,2.9773E+00,2.9392E+00,2.9009E+00,2.8610E+00,
36009 &2.8230E+00,2.8000E+00,2.7754E+00,2.7459E+00,2.7163E+00,2.6858E+00,
36010 &2.6545E+00,2.6270E+00,2.5962E+00,2.5617E+00,2.5271E+00,2.4903E+00,
36011 &2.4527E+00,2.4207E+00,2.3851E+00,2.3421E+00,2.2960E+00,2.2476E+00,
36012 &2.1987E+00,2.1578E+00,2.1146E+00,2.0670E+00,2.0202E+00,1.9796E+00,
36013 &1.9468E+00,1.9282E+00,1.9203E+00,1.9319E+00,1.9712E+00,2.0197E+00,
36014 &2.0872E+00,2.1524E+00,2.2288E+00,2.2981E+00,2.3606E+00,2.4177E+00,
36015 &2.4692E+00,2.5159E+00,2.5591E+00,2.5981E+00,2.6339E+00,2.6669E+00,
36016 &2.6962E+00,2.6528E+00,2.6566E+00,2.6395E+00,2.6028E+00,2.5437E+00,
36017 &2.4622E+00,2.3555E+00,2.2200E+00,2.0488E+00,1.8335E+00,1.5506E+00,
36018 &1.1442E+00,0.0000E+00,3.3868E+00,3.3470E+00,3.3075E+00,3.2689E+00/
36019 DATA (XUVF_L(K),K= 685, 798) /
36020 &3.2300E+00,3.1909E+00,3.1517E+00,3.1129E+00,3.0747E+00,3.0335E+00,
36021 &2.9946E+00,2.9537E+00,2.9140E+00,2.8896E+00,2.8638E+00,2.8337E+00,
36022 &2.8021E+00,2.7705E+00,2.7373E+00,2.7075E+00,2.6767E+00,2.6403E+00,
36023 &2.6031E+00,2.5649E+00,2.5258E+00,2.4917E+00,2.4537E+00,2.4080E+00,
36024 &2.3597E+00,2.3091E+00,2.2580E+00,2.2150E+00,2.1692E+00,2.1186E+00,
36025 &2.0701E+00,2.0257E+00,1.9901E+00,1.9679E+00,1.9571E+00,1.9629E+00,
36026 &1.9955E+00,2.0378E+00,2.0963E+00,2.1529E+00,2.2178E+00,2.2766E+00,
36027 &2.3287E+00,2.3749E+00,2.4162E+00,2.4529E+00,2.4850E+00,2.5140E+00,
36028 &2.5392E+00,2.5617E+00,2.5798E+00,2.5298E+00,2.5151E+00,2.4811E+00,
36029 &2.4282E+00,2.3561E+00,2.2611E+00,2.1439E+00,2.0005E+00,1.8252E+00,
36030 &1.6091E+00,1.3345E+00,9.5375E-01,0.0000E+00,3.4912E+00,3.4507E+00,
36031 &3.4100E+00,3.3696E+00,3.3310E+00,3.2893E+00,3.2496E+00,3.2088E+00,
36032 &3.1686E+00,3.1278E+00,3.0865E+00,3.0438E+00,3.0020E+00,2.9766E+00,
36033 &2.9494E+00,2.9180E+00,2.8850E+00,2.8520E+00,2.8174E+00,2.7877E+00,
36034 &2.7550E+00,2.7169E+00,2.6762E+00,2.6369E+00,2.5958E+00,2.5594E+00,
36035 &2.5195E+00,2.4721E+00,2.4211E+00,2.3680E+00,2.3145E+00,2.2695E+00,
36036 &2.2214E+00,2.1684E+00,2.1154E+00,2.0706E+00,2.0303E+00,2.0058E+00,
36037 &1.9909E+00,1.9920E+00,2.0177E+00,2.0531E+00,2.1031E+00,2.1511E+00,
36038 &2.2060E+00,2.2548E+00,2.2972E+00,2.3339E+00,2.3655E+00,2.3927E+00/
36039 DATA (XUVF_L(K),K= 799, 912) /
36040 &2.4159E+00,2.4357E+00,2.4520E+00,2.4644E+00,2.4735E+00,2.4171E+00,
36041 &2.3878E+00,2.3397E+00,2.2743E+00,2.1907E+00,2.0861E+00,1.9611E+00,
36042 &1.8128E+00,1.6351E+00,1.4227E+00,1.1584E+00,8.0371E-01,0.0000E+00,
36043 &3.5892E+00,3.5473E+00,3.5055E+00,3.4637E+00,3.4230E+00,3.3809E+00,
36044 &3.3396E+00,3.2976E+00,3.2571E+00,3.2126E+00,3.1696E+00,3.1272E+00,
36045 &3.0840E+00,3.0569E+00,3.0286E+00,2.9959E+00,2.9619E+00,2.9273E+00,
36046 &2.8910E+00,2.8598E+00,2.8266E+00,2.7863E+00,2.7448E+00,2.7029E+00,
36047 &2.6598E+00,2.6219E+00,2.5804E+00,2.5305E+00,2.4773E+00,2.4214E+00,
36048 &2.3662E+00,2.3191E+00,2.2698E+00,2.2126E+00,2.1577E+00,2.1092E+00,
36049 &2.0674E+00,2.0393E+00,2.0210E+00,2.0173E+00,2.0367E+00,2.0654E+00,
36050 &2.1076E+00,2.1485E+00,2.1942E+00,2.2338E+00,2.2678E+00,2.2959E+00,
36051 &2.3193E+00,2.3386E+00,2.3539E+00,2.3660E+00,2.3738E+00,2.3789E+00,
36052 &2.3799E+00,2.3197E+00,2.2776E+00,2.2186E+00,2.1426E+00,2.0495E+00,
36053 &1.9397E+00,1.8097E+00,1.6583E+00,1.4814E+00,1.2736E+00,1.0200E+00,
36054 &6.8880E-01,0.0000E+00,3.7157E+00,3.6699E+00,3.6275E+00,3.5842E+00,
36055 &3.5420E+00,3.4972E+00,3.4542E+00,3.4107E+00,3.3678E+00,3.3234E+00,
36056 &3.2774E+00,3.2332E+00,3.1870E+00,3.1600E+00,3.1297E+00,3.0952E+00,
36057 &3.0595E+00,3.0231E+00,2.9850E+00,2.9534E+00,2.9160E+00,2.8740E+00,
36058 &2.8312E+00,2.7872E+00,2.7408E+00,2.7014E+00,2.6568E+00,2.6045E+00/
36059 DATA (XUVF_L(K),K= 913, 1026) /
36060 &2.5481E+00,2.4895E+00,2.4315E+00,2.3817E+00,2.3283E+00,2.2697E+00,
36061 &2.2106E+00,2.1591E+00,2.1128E+00,2.0807E+00,2.0578E+00,2.0477E+00,
36062 &2.0583E+00,2.0796E+00,2.1122E+00,2.1433E+00,2.1777E+00,2.2069E+00,
36063 &2.2299E+00,2.2483E+00,2.2618E+00,2.2718E+00,2.2778E+00,2.2803E+00,
36064 &2.2797E+00,2.2749E+00,2.2668E+00,2.2019E+00,2.1468E+00,2.0761E+00,
36065 &1.9902E+00,1.8883E+00,1.7711E+00,1.6370E+00,1.4847E+00,1.3103E+00,
36066 &1.1091E+00,8.7047E-01,5.6856E-01,0.0000E+00,3.8327E+00,3.7877E+00,
36067 &3.7424E+00,3.6981E+00,3.6540E+00,3.6083E+00,3.5637E+00,3.5184E+00,
36068 &3.4753E+00,3.4271E+00,3.3800E+00,3.3325E+00,3.2860E+00,3.2564E+00,
36069 &3.2258E+00,3.1893E+00,3.1519E+00,3.1135E+00,3.0738E+00,3.0389E+00,
36070 &3.0010E+00,2.9580E+00,2.9118E+00,2.8654E+00,2.8178E+00,2.7758E+00,
36071 &2.7289E+00,2.6738E+00,2.6146E+00,2.5530E+00,2.4924E+00,2.4399E+00,
36072 &2.3845E+00,2.3213E+00,2.2605E+00,2.2040E+00,2.1540E+00,2.1186E+00,
36073 &2.0908E+00,2.0749E+00,2.0772E+00,2.0914E+00,2.1145E+00,2.1368E+00,
36074 &2.1613E+00,2.1804E+00,2.1941E+00,2.2037E+00,2.2088E+00,2.2101E+00,
36075 &2.2083E+00,2.2031E+00,2.1942E+00,2.1826E+00,2.1665E+00,2.0987E+00,
36076 &2.0321E+00,1.9516E+00,1.8571E+00,1.7497E+00,1.6281E+00,1.4923E+00,
36077 &1.3406E+00,1.1697E+00,9.7635E-01,7.5209E-01,4.7638E-01,0.0000E+00,
36078 &3.9497E+00,3.9009E+00,3.8555E+00,3.8080E+00,3.7630E+00,3.7163E+00/
36079 DATA (XUVF_L(K),K= 1027, 1140) /
36080 &3.6699E+00,3.6231E+00,3.5765E+00,3.5285E+00,3.4807E+00,3.4305E+00,
36081 &3.3810E+00,3.3511E+00,3.3185E+00,3.2805E+00,3.2414E+00,3.2016E+00,
36082 &3.1598E+00,3.1244E+00,3.0837E+00,3.0383E+00,2.9908E+00,2.9424E+00,
36083 &2.8919E+00,2.8477E+00,2.7990E+00,2.7403E+00,2.6784E+00,2.6142E+00,
36084 &2.5507E+00,2.4960E+00,2.4362E+00,2.3710E+00,2.3058E+00,2.2463E+00,
36085 &2.1931E+00,2.1539E+00,2.1216E+00,2.0996E+00,2.0940E+00,2.1012E+00,
36086 &2.1154E+00,2.1294E+00,2.1444E+00,2.1543E+00,2.1597E+00,2.1610E+00,
36087 &2.1585E+00,2.1523E+00,2.1432E+00,2.1307E+00,2.1155E+00,2.0964E+00,
36088 &2.0742E+00,2.0035E+00,1.9273E+00,1.8396E+00,1.7387E+00,1.6273E+00,
36089 &1.5032E+00,1.3665E+00,1.2164E+00,1.0501E+00,8.6515E-01,6.5470E-01,
36090 &4.0284E-01,0.0000E+00,4.0572E+00,4.0093E+00,3.9616E+00,3.9140E+00,
36091 &3.8670E+00,3.8185E+00,3.7706E+00,3.7224E+00,3.6746E+00,3.6251E+00,
36092 &3.5744E+00,3.5233E+00,3.4720E+00,3.4406E+00,3.4062E+00,3.3671E+00,
36093 &3.3263E+00,3.2847E+00,3.2414E+00,3.2046E+00,3.1620E+00,3.1150E+00,
36094 &3.0653E+00,3.0145E+00,2.9619E+00,2.9153E+00,2.8641E+00,2.8032E+00,
36095 &2.7388E+00,2.6715E+00,2.6056E+00,2.5481E+00,2.4880E+00,2.4171E+00,
36096 &2.3496E+00,2.2862E+00,2.2282E+00,2.1865E+00,2.1502E+00,2.1217E+00,
36097 &2.1086E+00,2.1086E+00,2.1149E+00,2.1216E+00,2.1275E+00,2.1295E+00,
36098 &2.1273E+00,2.1212E+00,2.1119E+00,2.0992E+00,2.0837E+00,2.0653E+00/
36099 DATA (XUVF_L(K),K= 1141, 1254) /
36100 &2.0442E+00,2.0194E+00,1.9912E+00,1.9193E+00,1.8359E+00,1.7412E+00,
36101 &1.6366E+00,1.5214E+00,1.3956E+00,1.2594E+00,1.1115E+00,9.5033E-01,
36102 &7.7356E-01,5.7585E-01,3.4506E-01,0.0000E+00,4.1710E+00,4.1201E+00,
36103 &4.0712E+00,4.0213E+00,3.9730E+00,3.9228E+00,3.8734E+00,3.8233E+00,
36104 &3.7726E+00,3.7217E+00,3.6699E+00,3.6160E+00,3.5640E+00,3.5311E+00,
36105 &3.4960E+00,3.4549E+00,3.4121E+00,3.3689E+00,3.3237E+00,3.2848E+00,
36106 &3.2425E+00,3.1917E+00,3.1399E+00,3.0866E+00,3.0319E+00,2.9838E+00,
36107 &2.9306E+00,2.8668E+00,2.7992E+00,2.7291E+00,2.6605E+00,2.6007E+00,
36108 &2.5375E+00,2.4631E+00,2.3919E+00,2.3261E+00,2.2643E+00,2.2183E+00,
36109 &2.1772E+00,2.1426E+00,2.1222E+00,2.1155E+00,2.1135E+00,2.1130E+00,
36110 &2.1102E+00,2.1039E+00,2.0941E+00,2.0815E+00,2.0652E+00,2.0466E+00,
36111 &2.0251E+00,2.0014E+00,1.9746E+00,1.9450E+00,1.9116E+00,1.8381E+00,
36112 &1.7481E+00,1.6484E+00,1.5404E+00,1.4225E+00,1.2963E+00,1.1611E+00,
36113 &1.0161E+00,8.6047E-01,6.9193E-01,5.0691E-01,2.9581E-01,0.0000E+00,
36114 &4.2754E+00,4.2238E+00,4.1737E+00,4.1233E+00,4.0740E+00,4.0219E+00,
36115 &3.9713E+00,3.9196E+00,3.8675E+00,3.8160E+00,3.7618E+00,3.7060E+00,
36116 &3.6510E+00,3.6173E+00,3.5808E+00,3.5380E+00,3.4941E+00,3.4493E+00,
36117 &3.4027E+00,3.3623E+00,3.3163E+00,3.2647E+00,3.2114E+00,3.1563E+00,
36118 &3.0989E+00,3.0489E+00,2.9929E+00,2.9263E+00,2.8563E+00,2.7837E+00/
36119 DATA (XUVF_L(K),K= 1255, 1368) /
36120 &2.7122E+00,2.6501E+00,2.5825E+00,2.5073E+00,2.4327E+00,2.3623E+00,
36121 &2.2962E+00,2.2474E+00,2.2020E+00,2.1616E+00,2.1335E+00,2.1209E+00,
36122 &2.1113E+00,2.1034E+00,2.0929E+00,2.0795E+00,2.0634E+00,2.0439E+00,
36123 &2.0222E+00,1.9982E+00,1.9716E+00,1.9428E+00,1.9113E+00,1.8773E+00,
36124 &1.8394E+00,1.7649E+00,1.6692E+00,1.5658E+00,1.4547E+00,1.3360E+00,
36125 &1.2095E+00,1.0761E+00,9.3485E-01,7.8430E-01,6.2380E-01,4.5010E-01,
36126 &2.5625E-01,0.0000E+00,4.3798E+00,4.3275E+00,4.2762E+00,4.2239E+00,
36127 &4.1730E+00,4.1196E+00,4.0674E+00,4.0143E+00,3.9623E+00,3.9056E+00,
36128 &3.8502E+00,3.7935E+00,3.7370E+00,3.7018E+00,3.6642E+00,3.6200E+00,
36129 &3.5742E+00,3.5277E+00,3.4786E+00,3.4371E+00,3.3901E+00,3.3359E+00,
36130 &3.2800E+00,3.2235E+00,3.1639E+00,3.1115E+00,3.0537E+00,2.9847E+00,
36131 &2.9116E+00,2.8364E+00,2.7623E+00,2.6973E+00,2.6275E+00,2.5497E+00,
36132 &2.4705E+00,2.3972E+00,2.3281E+00,2.2747E+00,2.2253E+00,2.1793E+00,
36133 &2.1444E+00,2.1253E+00,2.1081E+00,2.0939E+00,2.0755E+00,2.0555E+00,
36134 &2.0332E+00,2.0081E+00,1.9814E+00,1.9522E+00,1.9205E+00,1.8875E+00,
36135 &1.8520E+00,1.8139E+00,1.7725E+00,1.6968E+00,1.5976E+00,1.4911E+00,
36136 &1.3772E+00,1.2577E+00,1.1320E+00,1.0005E+00,8.6242E-01,7.1750E-01,
36137 &5.6466E-01,4.0150E-01,2.2333E-01,0.0000E+00,4.4809E+00,4.4265E+00,
36138 &4.3735E+00,4.3193E+00,4.2670E+00,4.2128E+00,4.1585E+00,4.1039E+00/
36139 DATA (XUVF_L(K),K= 1369, 1482) /
36140 &4.0509E+00,3.9928E+00,3.9351E+00,3.8769E+00,3.8180E+00,3.7821E+00,
36141 &3.7434E+00,3.6974E+00,3.6501E+00,3.6019E+00,3.5513E+00,3.5093E+00,
36142 &3.4594E+00,3.4035E+00,3.3456E+00,3.2870E+00,3.2250E+00,3.1715E+00,
36143 &3.1110E+00,3.0396E+00,2.9639E+00,2.8863E+00,2.8096E+00,2.7429E+00,
36144 &2.6702E+00,2.5884E+00,2.5068E+00,2.4296E+00,2.3560E+00,2.3003E+00,
36145 &2.2464E+00,2.1951E+00,2.1530E+00,2.1283E+00,2.1045E+00,2.0843E+00,
36146 &2.0591E+00,2.0328E+00,2.0047E+00,1.9749E+00,1.9429E+00,1.9096E+00,
36147 &1.8740E+00,1.8369E+00,1.7978E+00,1.7560E+00,1.7116E+00,1.6360E+00,
36148 &1.5322E+00,1.4233E+00,1.3084E+00,1.1885E+00,1.0637E+00,9.3449E-01,
36149 &7.9961E-01,6.6020E-01,5.1453E-01,3.6103E-01,1.9641E-01,0.0000E+00,
36150 &4.6169E+00,4.5608E+00,4.5060E+00,4.4504E+00,4.3960E+00,4.3395E+00,
36151 &4.2837E+00,4.2262E+00,4.1710E+00,4.1106E+00,4.0517E+00,3.9908E+00,
36152 &3.9300E+00,3.8920E+00,3.8509E+00,3.8030E+00,3.7538E+00,3.7035E+00,
36153 &3.6494E+00,3.6055E+00,3.5556E+00,3.4966E+00,3.4351E+00,3.3738E+00,
36154 &3.3090E+00,3.2518E+00,3.1888E+00,3.1141E+00,3.0348E+00,2.9533E+00,
36155 &2.8730E+00,2.8020E+00,2.7264E+00,2.6400E+00,2.5551E+00,2.4732E+00,
36156 &2.3941E+00,2.3329E+00,2.2742E+00,2.2147E+00,2.1644E+00,2.1317E+00,
36157 &2.0986E+00,2.0700E+00,2.0363E+00,2.0021E+00,1.9668E+00,1.9299E+00,
36158 &1.8922E+00,1.8532E+00,1.8125E+00,1.7704E+00,1.7270E+00,1.6809E+00/
36159 DATA (XUVF_L(K),K= 1483, 1596) /
36160 &1.6327E+00,1.5570E+00,1.4497E+00,1.3373E+00,1.2215E+00,1.1020E+00,
36161 &9.7897E-01,8.5304E-01,7.2349E-01,5.9074E-01,4.5411E-01,3.1307E-01,
36162 &1.6547E-01,0.0000E+00,4.7403E+00,4.6834E+00,4.6262E+00,4.5696E+00,
36163 &4.5140E+00,4.4557E+00,4.3978E+00,4.3393E+00,4.2817E+00,4.2191E+00,
36164 &4.1578E+00,4.0941E+00,4.0310E+00,3.9917E+00,3.9492E+00,3.8995E+00,
36165 &3.8481E+00,3.7958E+00,3.7411E+00,3.6937E+00,3.6405E+00,3.5806E+00,
36166 &3.5171E+00,3.4520E+00,3.3840E+00,3.3254E+00,3.2596E+00,3.1812E+00,
36167 &3.0985E+00,3.0137E+00,2.9301E+00,2.8556E+00,2.7782E+00,2.6879E+00,
36168 &2.5974E+00,2.5119E+00,2.4281E+00,2.3629E+00,2.2982E+00,2.2324E+00,
36169 &2.1730E+00,2.1332E+00,2.0922E+00,2.0570E+00,2.0152E+00,1.9739E+00,
36170 &1.9323E+00,1.8902E+00,1.8474E+00,1.8039E+00,1.7589E+00,1.7129E+00,
36171 &1.6654E+00,1.6163E+00,1.5652E+00,1.4896E+00,1.3789E+00,1.2649E+00,
36172 &1.1487E+00,1.0300E+00,9.0896E-01,7.8619E-01,6.6149E-01,5.3498E-01,
36173 &4.0654E-01,2.7586E-01,1.4208E-01,0.0000E+00,4.8699E+00,4.8107E+00,
36174 &4.7518E+00,4.6928E+00,4.6350E+00,4.5750E+00,4.5152E+00,4.4524E+00,
36175 &4.3956E+00,4.3299E+00,4.2674E+00,4.2014E+00,4.1350E+00,4.0939E+00,
36176 &4.0503E+00,3.9982E+00,3.9448E+00,3.8905E+00,3.8328E+00,3.7846E+00,
36177 &3.7300E+00,3.6664E+00,3.5991E+00,3.5326E+00,3.4620E+00,3.3998E+00,
36178 &3.3311E+00,3.2494E+00,3.1632E+00,3.0752E+00,2.9881E+00,2.9120E+00/
36179 DATA (XUVF_L(K),K= 1597, 1710) /
36180 &2.8299E+00,2.7339E+00,2.6398E+00,2.5493E+00,2.4611E+00,2.3911E+00,
36181 &2.3215E+00,2.2482E+00,2.1812E+00,2.1342E+00,2.0854E+00,2.0427E+00,
36182 &1.9932E+00,1.9453E+00,1.8978E+00,1.8504E+00,1.8030E+00,1.7545E+00,
36183 &1.7059E+00,1.6565E+00,1.6056E+00,1.5535E+00,1.4989E+00,1.4245E+00,
36184 &1.3108E+00,1.1959E+00,1.0798E+00,9.6219E-01,8.4358E-01,7.2422E-01,
36185 &6.0451E-01,4.8425E-01,3.6380E-01,2.4286E-01,1.2189E-01,0.0000E+00,
36186 &4.9964E+00,4.9356E+00,4.8755E+00,4.8147E+00,4.7550E+00,4.6935E+00,
36187 &4.6315E+00,4.5697E+00,4.5062E+00,4.4406E+00,4.3752E+00,4.3061E+00,
36188 &4.2380E+00,4.1962E+00,4.1500E+00,4.0963E+00,4.0405E+00,3.9832E+00,
36189 &3.9245E+00,3.8728E+00,3.8172E+00,3.7504E+00,3.6811E+00,3.6108E+00,
36190 &3.5381E+00,3.4734E+00,3.4018E+00,3.3164E+00,3.2269E+00,3.1352E+00,
36191 &3.0446E+00,2.9657E+00,2.8794E+00,2.7800E+00,2.6821E+00,2.5867E+00,
36192 &2.4930E+00,2.4184E+00,2.3433E+00,2.2634E+00,2.1877E+00,2.1342E+00,
36193 &2.0772E+00,2.0279E+00,1.9713E+00,1.9172E+00,1.8642E+00,1.8120E+00,
36194 &1.7600E+00,1.7076E+00,1.6553E+00,1.6027E+00,1.5491E+00,1.4938E+00,
36195 &1.4374E+00,1.3637E+00,1.2481E+00,1.1325E+00,1.0166E+00,9.0047E-01,
36196 &7.8428E-01,6.6889E-01,5.5381E-01,4.3953E-01,3.2652E-01,2.1461E-01,
36197 &1.0498E-01,0.0000E+00,5.1134E+00,5.0511E+00,4.9886E+00,4.9273E+00,
36198 &4.8660E+00,4.8016E+00,4.7382E+00,4.6744E+00,4.6106E+00,4.5420E+00/
36199 DATA (XUVF_L(K),K= 1711, 1824) /
36200 &4.4742E+00,4.4028E+00,4.3320E+00,4.2892E+00,4.2413E+00,4.1858E+00,
36201 &4.1281E+00,4.0682E+00,4.0067E+00,3.9556E+00,3.8955E+00,3.8271E+00,
36202 &3.7556E+00,3.6829E+00,3.6071E+00,3.5401E+00,3.4662E+00,3.3777E+00,
36203 &3.2849E+00,3.1898E+00,3.0960E+00,3.0140E+00,2.9244E+00,2.8224E+00,
36204 &2.7183E+00,2.6191E+00,2.5219E+00,2.4431E+00,2.3628E+00,2.2767E+00,
36205 &2.1931E+00,2.1332E+00,2.0695E+00,2.0145E+00,1.9514E+00,1.8920E+00,
36206 &1.8340E+00,1.7775E+00,1.7215E+00,1.6664E+00,1.6108E+00,1.5553E+00,
36207 &1.4995E+00,1.4421E+00,1.3839E+00,1.3103E+00,1.1944E+00,1.0782E+00,
36208 &9.6271E-01,8.4822E-01,7.3481E-01,6.2240E-01,5.1184E-01,4.0291E-01,
36209 &2.9618E-01,1.9206E-01,9.1846E-02,0.0000E+00,5.2367E+00,5.1713E+00,
36210 &5.1071E+00,5.0425E+00,4.9800E+00,4.9141E+00,4.8489E+00,4.7833E+00,
36211 &4.7181E+00,4.6457E+00,4.5768E+00,4.5034E+00,4.4300E+00,4.3847E+00,
36212 &4.3353E+00,4.2782E+00,4.2182E+00,4.1570E+00,4.0921E+00,4.0385E+00,
36213 &3.9782E+00,3.9074E+00,3.8331E+00,3.7575E+00,3.6781E+00,3.6086E+00,
36214 &3.5313E+00,3.4401E+00,3.3439E+00,3.2455E+00,3.1483E+00,3.0623E+00,
36215 &2.9694E+00,2.8629E+00,2.7561E+00,2.6527E+00,2.5508E+00,2.4669E+00,
36216 &2.3816E+00,2.2887E+00,2.1979E+00,2.1317E+00,2.0613E+00,2.0002E+00,
36217 &1.9307E+00,1.8659E+00,1.8033E+00,1.7426E+00,1.6834E+00,1.6247E+00,
36218 &1.5668E+00,1.5085E+00,1.4504E+00,1.3916E+00,1.3311E+00,1.2591E+00/
36219 DATA (XUVF_L(K),K= 1825, 1836) /
36220 &1.1415E+00,1.0256E+00,9.1107E-01,7.9840E-01,6.8736E-01,5.7902E-01,
36221 &4.7260E-01,3.6895E-01,2.6838E-01,1.7161E-01,8.0264E-02,0.0000E+00/
36222 DATA (XDVF_L(K),K= 1, 114) /
36223 &1.4230E+00,1.4064E+00,1.3903E+00,1.3749E+00,1.3590E+00,1.3424E+00,
36224 &1.3271E+00,1.3114E+00,1.2962E+00,1.2803E+00,1.2647E+00,1.2492E+00,
36225 &1.2340E+00,1.2246E+00,1.2155E+00,1.2044E+00,1.1927E+00,1.1814E+00,
36226 &1.1695E+00,1.1589E+00,1.1479E+00,1.1347E+00,1.1214E+00,1.1080E+00,
36227 &1.0944E+00,1.0824E+00,1.0700E+00,1.0544E+00,1.0371E+00,1.0188E+00,
36228 &9.9884E-01,9.8287E-01,9.6563E-01,9.4645E-01,9.2847E-01,9.1313E-01,
36229 &9.0246E-01,8.9955E-01,9.0461E-01,9.2737E-01,9.7648E-01,1.0343E+00,
36230 &1.1168E+00,1.2030E+00,1.3129E+00,1.4240E+00,1.5357E+00,1.6492E+00,
36231 &1.7643E+00,1.8818E+00,2.0016E+00,2.1253E+00,2.2535E+00,2.3853E+00,
36232 &2.5225E+00,2.5620E+00,2.7906E+00,3.0230E+00,3.2574E+00,3.4983E+00,
36233 &3.7459E+00,4.0062E+00,4.2803E+00,4.5790E+00,4.9150E+00,5.3263E+00,
36234 &5.9228E+00,0.0000E+00,1.4698E+00,1.4526E+00,1.4360E+00,1.4199E+00,
36235 &1.4030E+00,1.3864E+00,1.3702E+00,1.3542E+00,1.3386E+00,1.3221E+00,
36236 &1.3059E+00,1.2896E+00,1.2740E+00,1.2644E+00,1.2544E+00,1.2425E+00,
36237 &1.2309E+00,1.2185E+00,1.2061E+00,1.1953E+00,1.1836E+00,1.1697E+00,
36238 &1.1558E+00,1.1417E+00,1.1275E+00,1.1154E+00,1.1011E+00,1.0844E+00,
36239 &1.0663E+00,1.0471E+00,1.0261E+00,1.0092E+00,9.9133E-01,9.7103E-01,
36240 &9.5184E-01,9.3560E-01,9.2380E-01,9.1922E-01,9.2378E-01,9.4563E-01,
36241 &9.9235E-01,1.0474E+00,1.1262E+00,1.2078E+00,1.3110E+00,1.4146E+00/
36242 DATA (XDVF_L(K),K= 115, 228) /
36243 &1.5192E+00,1.6241E+00,1.7298E+00,1.8375E+00,1.9471E+00,2.0592E+00,
36244 &2.1741E+00,2.2925E+00,2.4144E+00,2.4425E+00,2.6407E+00,2.8375E+00,
36245 &3.0361E+00,3.2345E+00,3.4343E+00,3.6388E+00,3.8488E+00,4.0682E+00,
36246 &4.3043E+00,4.5737E+00,4.9280E+00,0.0000E+00,1.5226E+00,1.5047E+00,
36247 &1.4874E+00,1.4702E+00,1.4530E+00,1.4363E+00,1.4193E+00,1.4023E+00,
36248 &1.3860E+00,1.3690E+00,1.3520E+00,1.3351E+00,1.3190E+00,1.3083E+00,
36249 &1.2983E+00,1.2858E+00,1.2733E+00,1.2606E+00,1.2476E+00,1.2362E+00,
36250 &1.2237E+00,1.2092E+00,1.1943E+00,1.1795E+00,1.1645E+00,1.1509E+00,
36251 &1.1365E+00,1.1185E+00,1.0994E+00,1.0784E+00,1.0566E+00,1.0388E+00,
36252 &1.0195E+00,9.9801E-01,9.7765E-01,9.6019E-01,9.4712E-01,9.4158E-01,
36253 &9.4524E-01,9.6454E-01,1.0088E+00,1.0604E+00,1.1346E+00,1.2112E+00,
36254 &1.3076E+00,1.4038E+00,1.4995E+00,1.5957E+00,1.6918E+00,1.7888E+00,
36255 &1.8877E+00,1.9877E+00,2.0896E+00,2.1940E+00,2.2999E+00,2.3168E+00,
36256 &2.4844E+00,2.6497E+00,2.8098E+00,2.9678E+00,3.1219E+00,3.2743E+00,
36257 &3.4260E+00,3.5742E+00,3.7237E+00,3.8717E+00,4.0300E+00,0.0000E+00,
36258 &1.5849E+00,1.5662E+00,1.5482E+00,1.5298E+00,1.5130E+00,1.4944E+00,
36259 &1.4769E+00,1.4593E+00,1.4423E+00,1.4243E+00,1.4066E+00,1.3894E+00,
36260 &1.3720E+00,1.3607E+00,1.3499E+00,1.3366E+00,1.3237E+00,1.3101E+00,
36261 &1.2963E+00,1.2840E+00,1.2709E+00,1.2553E+00,1.2396E+00,1.2232E+00/
36262 DATA (XDVF_L(K),K= 229, 342) /
36263 &1.2075E+00,1.1932E+00,1.1776E+00,1.1584E+00,1.1377E+00,1.1152E+00,
36264 &1.0922E+00,1.0729E+00,1.0524E+00,1.0294E+00,1.0074E+00,9.8843E-01,
36265 &9.7377E-01,9.6751E-01,9.6901E-01,9.8606E-01,1.0264E+00,1.0745E+00,
36266 &1.1435E+00,1.2136E+00,1.3018E+00,1.3894E+00,1.4758E+00,1.5619E+00,
36267 &1.6474E+00,1.7332E+00,1.8194E+00,1.9063E+00,1.9941E+00,2.0832E+00,
36268 &2.1725E+00,2.1789E+00,2.3166E+00,2.4460E+00,2.5708E+00,2.6884E+00,
36269 &2.7987E+00,2.9025E+00,2.9974E+00,3.0823E+00,3.1538E+00,3.2013E+00,
36270 &3.2043E+00,0.0000E+00,1.6586E+00,1.6391E+00,1.6202E+00,1.6014E+00,
36271 &1.5830E+00,1.5638E+00,1.5457E+00,1.5267E+00,1.5087E+00,1.4899E+00,
36272 &1.4711E+00,1.4517E+00,1.4340E+00,1.4224E+00,1.4107E+00,1.3972E+00,
36273 &1.3827E+00,1.3684E+00,1.3535E+00,1.3404E+00,1.3263E+00,1.3096E+00,
36274 &1.2927E+00,1.2758E+00,1.2575E+00,1.2422E+00,1.2250E+00,1.2046E+00,
36275 &1.1821E+00,1.1579E+00,1.1331E+00,1.1127E+00,1.0905E+00,1.0655E+00,
36276 &1.0415E+00,1.0207E+00,1.0042E+00,9.9612E-01,9.9507E-01,1.0089E+00,
36277 &1.0451E+00,1.0887E+00,1.1514E+00,1.2146E+00,1.2936E+00,1.3711E+00,
36278 &1.4469E+00,1.5220E+00,1.5960E+00,1.6694E+00,1.7428E+00,1.8159E+00,
36279 &1.8894E+00,1.9620E+00,2.0344E+00,2.0313E+00,2.1357E+00,2.2333E+00,
36280 &2.3215E+00,2.4009E+00,2.4706E+00,2.5292E+00,2.5750E+00,2.6036E+00,
36281 &2.6096E+00,2.5783E+00,2.4673E+00,0.0000E+00,1.7269E+00,1.7065E+00/
36282 DATA (XDVF_L(K),K= 343, 456) /
36283 &1.6866E+00,1.6676E+00,1.6480E+00,1.6279E+00,1.6089E+00,1.5891E+00,
36284 &1.5701E+00,1.5502E+00,1.5307E+00,1.5113E+00,1.4910E+00,1.4799E+00,
36285 &1.4673E+00,1.4526E+00,1.4373E+00,1.4221E+00,1.4060E+00,1.3922E+00,
36286 &1.3771E+00,1.3596E+00,1.3414E+00,1.3234E+00,1.3045E+00,1.2879E+00,
36287 &1.2689E+00,1.2468E+00,1.2227E+00,1.1966E+00,1.1706E+00,1.1487E+00,
36288 &1.1248E+00,1.0980E+00,1.0724E+00,1.0495E+00,1.0310E+00,1.0212E+00,
36289 &1.0181E+00,1.0291E+00,1.0609E+00,1.1002E+00,1.1563E+00,1.2136E+00,
36290 &1.2840E+00,1.3528E+00,1.4201E+00,1.4854E+00,1.5492E+00,1.6125E+00,
36291 &1.6751E+00,1.7368E+00,1.7981E+00,1.8579E+00,1.9157E+00,1.9057E+00,
36292 &1.9875E+00,2.0577E+00,2.1190E+00,2.1700E+00,2.2094E+00,2.2370E+00,
36293 &2.2484E+00,2.2403E+00,2.2047E+00,2.1261E+00,1.9567E+00,0.0000E+00,
36294 &1.8047E+00,1.7833E+00,1.7626E+00,1.7418E+00,1.7220E+00,1.7009E+00,
36295 &1.6810E+00,1.6603E+00,1.6403E+00,1.6193E+00,1.5986E+00,1.5775E+00,
36296 &1.5570E+00,1.5441E+00,1.5309E+00,1.5156E+00,1.4991E+00,1.4828E+00,
36297 &1.4658E+00,1.4510E+00,1.4350E+00,1.4160E+00,1.3966E+00,1.3772E+00,
36298 &1.3565E+00,1.3386E+00,1.3184E+00,1.2942E+00,1.2680E+00,1.2404E+00,
36299 &1.2125E+00,1.1887E+00,1.1631E+00,1.1342E+00,1.1064E+00,1.0813E+00,
36300 &1.0608E+00,1.0480E+00,1.0426E+00,1.0500E+00,1.0774E+00,1.1111E+00,
36301 &1.1608E+00,1.2107E+00,1.2719E+00,1.3315E+00,1.3886E+00,1.4445E+00/
36302 DATA (XDVF_L(K),K= 457, 570) /
36303 &1.4984E+00,1.5505E+00,1.6020E+00,1.6524E+00,1.7009E+00,1.7480E+00,
36304 &1.7926E+00,1.7763E+00,1.8327E+00,1.8794E+00,1.9154E+00,1.9405E+00,
36305 &1.9531E+00,1.9537E+00,1.9362E+00,1.8986E+00,1.8325E+00,1.7203E+00,
36306 &1.5163E+00,0.0000E+00,1.8755E+00,1.8533E+00,1.8314E+00,1.8106E+00,
36307 &1.7890E+00,1.7672E+00,1.7464E+00,1.7248E+00,1.7038E+00,1.6817E+00,
36308 &1.6601E+00,1.6385E+00,1.6160E+00,1.6033E+00,1.5889E+00,1.5721E+00,
36309 &1.5552E+00,1.5380E+00,1.5199E+00,1.5042E+00,1.4871E+00,1.4670E+00,
36310 &1.4463E+00,1.4249E+00,1.4036E+00,1.3843E+00,1.3630E+00,1.3364E+00,
36311 &1.3086E+00,1.2791E+00,1.2500E+00,1.2245E+00,1.1971E+00,1.1662E+00,
36312 &1.1361E+00,1.1090E+00,1.0858E+00,1.0721E+00,1.0641E+00,1.0676E+00,
36313 &1.0898E+00,1.1195E+00,1.1627E+00,1.2069E+00,1.2603E+00,1.3118E+00,
36314 &1.3607E+00,1.4079E+00,1.4534E+00,1.4968E+00,1.5392E+00,1.5794E+00,
36315 &1.6181E+00,1.6552E+00,1.6888E+00,1.6690E+00,1.7073E+00,1.7353E+00,
36316 &1.7530E+00,1.7595E+00,1.7531E+00,1.7338E+00,1.6988E+00,1.6428E+00,
36317 &1.5583E+00,1.4293E+00,1.2136E+00,0.0000E+00,1.9470E+00,1.9238E+00,
36318 &1.9021E+00,1.8782E+00,1.8570E+00,1.8343E+00,1.8123E+00,1.7898E+00,
36319 &1.7680E+00,1.7449E+00,1.7222E+00,1.6994E+00,1.6760E+00,1.6624E+00,
36320 &1.6469E+00,1.6299E+00,1.6118E+00,1.5933E+00,1.5742E+00,1.5574E+00,
36321 &1.5392E+00,1.5179E+00,1.4955E+00,1.4738E+00,1.4506E+00,1.4300E+00/
36322 DATA (XDVF_L(K),K= 571, 684) /
36323 &1.4069E+00,1.3792E+00,1.3492E+00,1.3178E+00,1.2868E+00,1.2597E+00,
36324 &1.2307E+00,1.1976E+00,1.1654E+00,1.1363E+00,1.1108E+00,1.0945E+00,
36325 &1.0840E+00,1.0845E+00,1.1017E+00,1.1268E+00,1.1637E+00,1.2016E+00,
36326 &1.2473E+00,1.2910E+00,1.3324E+00,1.3719E+00,1.4090E+00,1.4450E+00,
36327 &1.4784E+00,1.5109E+00,1.5404E+00,1.5681E+00,1.5925E+00,1.5689E+00,
36328 &1.5916E+00,1.6043E+00,1.6067E+00,1.5981E+00,1.5779E+00,1.5449E+00,
36329 &1.4949E+00,1.4262E+00,1.3303E+00,1.1932E+00,9.7657E-01,0.0000E+00,
36330 &2.0122E+00,1.9881E+00,1.9640E+00,1.9418E+00,1.9190E+00,1.8954E+00,
36331 &1.8721E+00,1.8492E+00,1.8262E+00,1.8024E+00,1.7784E+00,1.7550E+00,
36332 &1.7300E+00,1.7157E+00,1.6999E+00,1.6818E+00,1.6627E+00,1.6435E+00,
36333 &1.6233E+00,1.6058E+00,1.5866E+00,1.5643E+00,1.5417E+00,1.5178E+00,
36334 &1.4926E+00,1.4705E+00,1.4465E+00,1.4174E+00,1.3856E+00,1.3527E+00,
36335 &1.3198E+00,1.2914E+00,1.2605E+00,1.2257E+00,1.1915E+00,1.1601E+00,
36336 &1.1326E+00,1.1142E+00,1.1016E+00,1.0982E+00,1.1114E+00,1.1321E+00,
36337 &1.1637E+00,1.1958E+00,1.2352E+00,1.2722E+00,1.3071E+00,1.3397E+00,
36338 &1.3704E+00,1.3995E+00,1.4267E+00,1.4516E+00,1.4736E+00,1.4942E+00,
36339 &1.5100E+00,1.4848E+00,1.4955E+00,1.4964E+00,1.4873E+00,1.4675E+00,
36340 &1.4366E+00,1.3933E+00,1.3349E+00,1.2585E+00,1.1565E+00,1.0171E+00,
36341 &8.0601E-01,0.0000E+00,2.0789E+00,2.0539E+00,2.0294E+00,2.0053E+00/
36342 DATA (XDVF_L(K),K= 685, 798) /
36343 &1.9820E+00,1.9581E+00,1.9336E+00,1.9096E+00,1.8860E+00,1.8609E+00,
36344 &1.8367E+00,1.8106E+00,1.7860E+00,1.7706E+00,1.7543E+00,1.7350E+00,
36345 &1.7150E+00,1.6945E+00,1.6735E+00,1.6550E+00,1.6349E+00,1.6112E+00,
36346 &1.5864E+00,1.5617E+00,1.5356E+00,1.5128E+00,1.4868E+00,1.4555E+00,
36347 &1.4224E+00,1.3876E+00,1.3532E+00,1.3231E+00,1.2904E+00,1.2536E+00,
36348 &1.2173E+00,1.1838E+00,1.1545E+00,1.1338E+00,1.1185E+00,1.1113E+00,
36349 &1.1199E+00,1.1362E+00,1.1627E+00,1.1895E+00,1.2222E+00,1.2529E+00,
36350 &1.2813E+00,1.3080E+00,1.3324E+00,1.3546E+00,1.3756E+00,1.3938E+00,
36351 &1.4103E+00,1.4232E+00,1.4319E+00,1.4055E+00,1.4052E+00,1.3959E+00,
36352 &1.3768E+00,1.3480E+00,1.3084E+00,1.2576E+00,1.1928E+00,1.1110E+00,
36353 &1.0066E+00,8.6804E-01,6.6615E-01,0.0000E+00,2.1434E+00,2.1178E+00,
36354 &2.0930E+00,2.0676E+00,2.0440E+00,2.0184E+00,1.9935E+00,1.9686E+00,
36355 &1.9439E+00,1.9179E+00,1.8915E+00,1.8663E+00,1.8400E+00,1.8239E+00,
36356 &1.8067E+00,1.7863E+00,1.7654E+00,1.7440E+00,1.7219E+00,1.7025E+00,
36357 &1.6814E+00,1.6565E+00,1.6311E+00,1.6045E+00,1.5766E+00,1.5526E+00,
36358 &1.5250E+00,1.4925E+00,1.4574E+00,1.4213E+00,1.3849E+00,1.3532E+00,
36359 &1.3191E+00,1.2800E+00,1.2418E+00,1.2062E+00,1.1743E+00,1.1517E+00,
36360 &1.1338E+00,1.1237E+00,1.1272E+00,1.1399E+00,1.1608E+00,1.1828E+00,
36361 &1.2092E+00,1.2341E+00,1.2570E+00,1.2774E+00,1.2962E+00,1.3135E+00/
36362 DATA (XDVF_L(K),K= 799, 912) /
36363 &1.3280E+00,1.3406E+00,1.3511E+00,1.3588E+00,1.3613E+00,1.3335E+00,
36364 &1.3246E+00,1.3067E+00,1.2801E+00,1.2441E+00,1.1985E+00,1.1418E+00,
36365 &1.0724E+00,9.8806E-01,8.8293E-01,7.4746E-01,5.5665E-01,0.0000E+00,
36366 &2.2035E+00,2.1769E+00,2.1514E+00,2.1259E+00,2.1000E+00,2.0743E+00,
36367 &2.0488E+00,2.0226E+00,1.9973E+00,1.9702E+00,1.9428E+00,1.9166E+00,
36368 &1.8890E+00,1.8729E+00,1.8548E+00,1.8337E+00,1.8116E+00,1.7895E+00,
36369 &1.7662E+00,1.7461E+00,1.7239E+00,1.6980E+00,1.6714E+00,1.6436E+00,
36370 &1.6146E+00,1.5889E+00,1.5604E+00,1.5266E+00,1.4895E+00,1.4515E+00,
36371 &1.4138E+00,1.3806E+00,1.3448E+00,1.3040E+00,1.2638E+00,1.2261E+00,
36372 &1.1920E+00,1.1669E+00,1.1469E+00,1.1341E+00,1.1335E+00,1.1420E+00,
36373 &1.1583E+00,1.1760E+00,1.1971E+00,1.2168E+00,1.2343E+00,1.2501E+00,
36374 &1.2640E+00,1.2762E+00,1.2866E+00,1.2942E+00,1.2996E+00,1.3020E+00,
36375 &1.3003E+00,1.2725E+00,1.2557E+00,1.2312E+00,1.1982E+00,1.1569E+00,
36376 &1.1068E+00,1.0465E+00,9.7460E-01,8.8884E-01,7.8459E-01,6.5333E-01,
36377 &4.7359E-01,0.0000E+00,2.2800E+00,2.2524E+00,2.2256E+00,2.1987E+00,
36378 &2.1730E+00,2.1459E+00,2.1192E+00,2.0922E+00,2.0656E+00,2.0374E+00,
36379 &2.0100E+00,1.9802E+00,1.9520E+00,1.9346E+00,1.9156E+00,1.8937E+00,
36380 &1.8706E+00,1.8475E+00,1.8228E+00,1.8017E+00,1.7783E+00,1.7509E+00,
36381 &1.7221E+00,1.6937E+00,1.6627E+00,1.6354E+00,1.6050E+00,1.5688E+00/
36382 DATA (XDVF_L(K),K= 913, 1026) /
36383 &1.5301E+00,1.4898E+00,1.4503E+00,1.4150E+00,1.3772E+00,1.3339E+00,
36384 &1.2911E+00,1.2510E+00,1.2138E+00,1.1866E+00,1.1637E+00,1.1458E+00,
36385 &1.1403E+00,1.1441E+00,1.1548E+00,1.1669E+00,1.1817E+00,1.1950E+00,
36386 &1.2065E+00,1.2163E+00,1.2249E+00,1.2313E+00,1.2355E+00,1.2379E+00,
36387 &1.2379E+00,1.2348E+00,1.2275E+00,1.1987E+00,1.1744E+00,1.1427E+00,
36388 &1.1035E+00,1.0570E+00,1.0018E+00,9.3862E-01,8.6494E-01,7.7913E-01,
36389 &6.7747E-01,5.5266E-01,3.8741E-01,0.0000E+00,2.3524E+00,2.3243E+00,
36390 &2.2963E+00,2.2689E+00,2.2420E+00,2.2137E+00,2.1858E+00,2.1579E+00,
36391 &2.1301E+00,2.1011E+00,2.0718E+00,2.0424E+00,2.0120E+00,1.9937E+00,
36392 &1.9743E+00,1.9509E+00,1.9267E+00,1.9020E+00,1.8763E+00,1.8541E+00,
36393 &1.8295E+00,1.8006E+00,1.7713E+00,1.7402E+00,1.7077E+00,1.6794E+00,
36394 &1.6475E+00,1.6087E+00,1.5679E+00,1.5259E+00,1.4840E+00,1.4470E+00,
36395 &1.4072E+00,1.3615E+00,1.3163E+00,1.2738E+00,1.2336E+00,1.2045E+00,
36396 &1.1783E+00,1.1563E+00,1.1459E+00,1.1457E+00,1.1504E+00,1.1577E+00,
36397 &1.1662E+00,1.1742E+00,1.1807E+00,1.1857E+00,1.1886E+00,1.1902E+00,
36398 &1.1899E+00,1.1878E+00,1.1830E+00,1.1751E+00,1.1633E+00,1.1345E+00,
36399 &1.1039E+00,1.0667E+00,1.0230E+00,9.7228E-01,9.1417E-01,8.4905E-01,
36400 &7.7478E-01,6.9004E-01,5.9155E-01,4.7371E-01,3.2191E-01,0.0000E+00,
36401 &2.4233E+00,2.3947E+00,2.3653E+00,2.3365E+00,2.3090E+00,2.2800E+00/
36402 DATA (XDVF_L(K),K= 1027, 1140) /
36403 &2.2512E+00,2.2220E+00,2.1934E+00,2.1628E+00,2.1319E+00,2.1007E+00,
36404 &2.0700E+00,2.0512E+00,2.0301E+00,2.0057E+00,1.9809E+00,1.9549E+00,
36405 &1.9281E+00,1.9049E+00,1.8791E+00,1.8497E+00,1.8175E+00,1.7854E+00,
36406 &1.7507E+00,1.7209E+00,1.6878E+00,1.6474E+00,1.6047E+00,1.5603E+00,
36407 &1.5164E+00,1.4777E+00,1.4358E+00,1.3879E+00,1.3403E+00,1.2952E+00,
36408 &1.2523E+00,1.2206E+00,1.1913E+00,1.1661E+00,1.1505E+00,1.1462E+00,
36409 &1.1460E+00,1.1481E+00,1.1518E+00,1.1545E+00,1.1559E+00,1.1562E+00,
36410 &1.1548E+00,1.1523E+00,1.1478E+00,1.1414E+00,1.1331E+00,1.1212E+00,
36411 &1.1055E+00,1.0763E+00,1.0405E+00,9.9877E-01,9.5130E-01,8.9815E-01,
36412 &8.3813E-01,7.7188E-01,6.9792E-01,6.1492E-01,5.2020E-01,4.0920E-01,
36413 &2.7020E-01,0.0000E+00,2.4906E+00,2.4607E+00,2.4307E+00,2.4014E+00,
36414 &2.3730E+00,2.3427E+00,2.3127E+00,2.2828E+00,2.2528E+00,2.2213E+00,
36415 &2.1903E+00,2.1577E+00,2.1250E+00,2.1053E+00,2.0839E+00,2.0583E+00,
36416 &2.0318E+00,2.0051E+00,1.9771E+00,1.9527E+00,1.9259E+00,1.8935E+00,
36417 &1.8607E+00,1.8269E+00,1.7917E+00,1.7606E+00,1.7253E+00,1.6833E+00,
36418 &1.6387E+00,1.5925E+00,1.5465E+00,1.5061E+00,1.4624E+00,1.4121E+00,
36419 &1.3623E+00,1.3152E+00,1.2700E+00,1.2349E+00,1.2036E+00,1.1745E+00,
36420 &1.1544E+00,1.1457E+00,1.1410E+00,1.1389E+00,1.1378E+00,1.1357E+00,
36421 &1.1332E+00,1.1290E+00,1.1244E+00,1.1176E+00,1.1099E+00,1.0996E+00/
36422 DATA (XDVF_L(K),K= 1141, 1254) /
36423 &1.0875E+00,1.0729E+00,1.0538E+00,1.0249E+00,9.8511E-01,9.3994E-01,
36424 &8.8948E-01,8.3410E-01,7.7332E-01,7.0681E-01,6.3377E-01,5.5280E-01,
36425 &4.6214E-01,3.5755E-01,2.2965E-01,0.0000E+00,2.5589E+00,2.5291E+00,
36426 &2.4979E+00,2.4676E+00,2.4370E+00,2.4060E+00,2.3753E+00,2.3443E+00,
36427 &2.3135E+00,2.2809E+00,2.2486E+00,2.2146E+00,2.1810E+00,2.1602E+00,
36428 &2.1376E+00,2.1114E+00,2.0841E+00,2.0557E+00,2.0265E+00,2.0011E+00,
36429 &1.9730E+00,1.9392E+00,1.9055E+00,1.8697E+00,1.8327E+00,1.8003E+00,
36430 &1.7635E+00,1.7197E+00,1.6727E+00,1.6246E+00,1.5770E+00,1.5346E+00,
36431 &1.4890E+00,1.4363E+00,1.3841E+00,1.3341E+00,1.2867E+00,1.2492E+00,
36432 &1.2151E+00,1.1824E+00,1.1578E+00,1.1451E+00,1.1356E+00,1.1298E+00,
36433 &1.1233E+00,1.1169E+00,1.1105E+00,1.1027E+00,1.0940E+00,1.0840E+00,
36434 &1.0726E+00,1.0592E+00,1.0444E+00,1.0265E+00,1.0045E+00,9.7613E-01,
36435 &9.3249E-01,8.8451E-01,8.3193E-01,7.7510E-01,7.1373E-01,6.4749E-01,
36436 &5.7554E-01,4.9725E-01,4.1072E-01,3.1254E-01,1.9551E-01,0.0000E+00,
36437 &2.6244E+00,2.5927E+00,2.5615E+00,2.5299E+00,2.4990E+00,2.4671E+00,
36438 &2.4356E+00,2.4034E+00,2.3717E+00,2.3377E+00,2.3034E+00,2.2689E+00,
36439 &2.2340E+00,2.2126E+00,2.1892E+00,2.1616E+00,2.1331E+00,2.1040E+00,
36440 &2.0736E+00,2.0471E+00,2.0180E+00,1.9830E+00,1.9472E+00,1.9112E+00,
36441 &1.8717E+00,1.8375E+00,1.7996E+00,1.7538E+00,1.7053E+00,1.6548E+00/
36442 DATA (XDVF_L(K),K= 1255, 1368) /
36443 &1.6053E+00,1.5612E+00,1.5138E+00,1.4590E+00,1.4045E+00,1.3516E+00,
36444 &1.3023E+00,1.2626E+00,1.2251E+00,1.1889E+00,1.1601E+00,1.1441E+00,
36445 &1.1302E+00,1.1201E+00,1.1098E+00,1.0996E+00,1.0888E+00,1.0782E+00,
36446 &1.0659E+00,1.0531E+00,1.0388E+00,1.0228E+00,1.0047E+00,9.8480E-01,
36447 &9.6040E-01,9.3234E-01,8.8589E-01,8.3563E-01,7.8162E-01,7.2366E-01,
36448 &6.6215E-01,5.9658E-01,5.2617E-01,4.5043E-01,3.6787E-01,2.7575E-01,
36449 &1.6826E-01,0.0000E+00,2.6886E+00,2.6564E+00,2.6234E+00,2.5908E+00,
36450 &2.5600E+00,2.5268E+00,2.4943E+00,2.4612E+00,2.4283E+00,2.3924E+00,
36451 &2.3582E+00,2.3219E+00,2.2860E+00,2.2642E+00,2.2394E+00,2.2113E+00,
36452 &2.1817E+00,2.1512E+00,2.1198E+00,2.0920E+00,2.0618E+00,2.0268E+00,
36453 &1.9890E+00,1.9503E+00,1.9098E+00,1.8739E+00,1.8343E+00,1.7867E+00,
36454 &1.7365E+00,1.6843E+00,1.6329E+00,1.5870E+00,1.5377E+00,1.4807E+00,
36455 &1.4239E+00,1.3692E+00,1.3169E+00,1.2751E+00,1.2350E+00,1.1954E+00,
36456 &1.1624E+00,1.1425E+00,1.1247E+00,1.1110E+00,1.0963E+00,1.0827E+00,
36457 &1.0687E+00,1.0547E+00,1.0396E+00,1.0240E+00,1.0070E+00,9.8853E-01,
36458 &9.6834E-01,9.4569E-01,9.1962E-01,8.9220E-01,8.4321E-01,7.9105E-01,
36459 &7.3592E-01,6.7777E-01,6.1620E-01,5.5143E-01,4.8272E-01,4.0962E-01,
36460 &3.3102E-01,2.4455E-01,1.4574E-01,0.0000E+00,2.7496E+00,2.7153E+00,
36461 &2.6835E+00,2.6504E+00,2.6180E+00,2.5834E+00,2.5502E+00,2.5161E+00/
36462 DATA (XDVF_L(K),K= 1369, 1482) /
36463 &2.4824E+00,2.4466E+00,2.4095E+00,2.3736E+00,2.3360E+00,2.3124E+00,
36464 &2.2875E+00,2.2580E+00,2.2274E+00,2.1960E+00,2.1631E+00,2.1347E+00,
36465 &2.1032E+00,2.0670E+00,2.0277E+00,1.9882E+00,1.9458E+00,1.9086E+00,
36466 &1.8675E+00,1.8179E+00,1.7658E+00,1.7122E+00,1.6586E+00,1.6112E+00,
36467 &1.5600E+00,1.5010E+00,1.4420E+00,1.3855E+00,1.3294E+00,1.2858E+00,
36468 &1.2435E+00,1.2006E+00,1.1641E+00,1.1410E+00,1.1193E+00,1.1023E+00,
36469 &1.0837E+00,1.0664E+00,1.0496E+00,1.0329E+00,1.0157E+00,9.9745E-01,
36470 &9.7803E-01,9.5735E-01,9.3539E-01,9.1075E-01,8.8302E-01,8.5608E-01,
36471 &8.0509E-01,7.5168E-01,6.9580E-01,6.3743E-01,5.7619E-01,5.1233E-01,
36472 &4.4547E-01,3.7496E-01,2.9995E-01,2.1862E-01,1.2745E-01,0.0000E+00,
36473 &2.8331E+00,2.7978E+00,2.7648E+00,2.7299E+00,2.6960E+00,2.6609E+00,
36474 &2.6263E+00,2.5910E+00,2.5561E+00,2.5197E+00,2.4802E+00,2.4424E+00,
36475 &2.4030E+00,2.3791E+00,2.3526E+00,2.3216E+00,2.2897E+00,2.2570E+00,
36476 &2.2225E+00,2.1925E+00,2.1595E+00,2.1199E+00,2.0799E+00,2.0383E+00,
36477 &1.9938E+00,1.9551E+00,1.9121E+00,1.8601E+00,1.8054E+00,1.7494E+00,
36478 &1.6932E+00,1.6435E+00,1.5898E+00,1.5280E+00,1.4659E+00,1.4056E+00,
36479 &1.3471E+00,1.3010E+00,1.2550E+00,1.2078E+00,1.1652E+00,1.1383E+00,
36480 &1.1114E+00,1.0902E+00,1.0668E+00,1.0451E+00,1.0248E+00,1.0039E+00,
36481 &9.8353E-01,9.6205E-01,9.4076E-01,9.1705E-01,8.9229E-01,8.6577E-01/
36482 DATA (XDVF_L(K),K= 1483, 1596) /
36483 &8.3604E-01,8.0985E-01,7.5687E-01,7.0190E-01,6.4516E-01,5.8700E-01,
36484 &5.2660E-01,4.6452E-01,3.9995E-01,3.3310E-01,2.6289E-01,1.8826E-01,
36485 &1.0655E-01,0.0000E+00,2.9096E+00,2.8732E+00,2.8390E+00,2.8027E+00,
36486 &2.7690E+00,2.7325E+00,2.6961E+00,2.6597E+00,2.6231E+00,2.5833E+00,
36487 &2.5456E+00,2.5047E+00,2.4650E+00,2.4391E+00,2.4120E+00,2.3799E+00,
36488 &2.3462E+00,2.3123E+00,2.2763E+00,2.2451E+00,2.2108E+00,2.1692E+00,
36489 &2.1276E+00,2.0835E+00,2.0378E+00,1.9974E+00,1.9525E+00,1.8983E+00,
36490 &1.8413E+00,1.7827E+00,1.7243E+00,1.6725E+00,1.6166E+00,1.5520E+00,
36491 &1.4872E+00,1.4244E+00,1.3627E+00,1.3136E+00,1.2649E+00,1.2130E+00,
36492 &1.1663E+00,1.1352E+00,1.1040E+00,1.0787E+00,1.0514E+00,1.0264E+00,
36493 &1.0021E+00,9.7883E-01,9.5548E-01,9.3171E-01,9.0763E-01,8.8283E-01,
36494 &8.5596E-01,8.2732E-01,7.9601E-01,7.7056E-01,7.1598E-01,6.6027E-01,
36495 &6.0340E-01,5.4514E-01,4.8601E-01,4.2556E-01,3.6359E-01,2.9984E-01,
36496 &2.3396E-01,1.6486E-01,9.0844E-02,0.0000E+00,2.9880E+00,2.9510E+00,
36497 &2.9150E+00,2.8782E+00,2.8430E+00,2.8048E+00,2.7677E+00,2.7301E+00,
36498 &2.6924E+00,2.6517E+00,2.6110E+00,2.5696E+00,2.5280E+00,2.5017E+00,
36499 &2.4728E+00,2.4393E+00,2.4042E+00,2.3687E+00,2.3313E+00,2.2988E+00,
36500 &2.2631E+00,2.2204E+00,2.1768E+00,2.1312E+00,2.0828E+00,2.0405E+00,
36501 &1.9928E+00,1.9364E+00,1.8772E+00,1.8164E+00,1.7558E+00,1.7018E+00/
36502 DATA (XDVF_L(K),K= 1597, 1710) /
36503 &1.6434E+00,1.5762E+00,1.5084E+00,1.4432E+00,1.3783E+00,1.3261E+00,
36504 &1.2741E+00,1.2182E+00,1.1669E+00,1.1315E+00,1.0961E+00,1.0671E+00,
36505 &1.0360E+00,1.0071E+00,9.7992E-01,9.5371E-01,9.2801E-01,9.0200E-01,
36506 &8.7588E-01,8.4862E-01,8.2038E-01,7.9020E-01,7.5770E-01,7.3298E-01,
36507 &6.7721E-01,6.2090E-01,5.6394E-01,5.0631E-01,4.4841E-01,3.8970E-01,
36508 &3.3019E-01,2.6973E-01,2.0791E-01,1.4420E-01,7.7416E-02,0.0000E+00,
36509 &3.0661E+00,3.0288E+00,2.9911E+00,2.9537E+00,2.9160E+00,2.8778E+00,
36510 &2.8392E+00,2.8000E+00,2.7610E+00,2.7200E+00,2.6782E+00,2.6345E+00,
36511 &2.5900E+00,2.5625E+00,2.5329E+00,2.4982E+00,2.4617E+00,2.4247E+00,
36512 &2.3857E+00,2.3518E+00,2.3145E+00,2.2697E+00,2.2245E+00,2.1764E+00,
36513 &2.1269E+00,2.0819E+00,2.0331E+00,1.9746E+00,1.9126E+00,1.8497E+00,
36514 &1.7862E+00,1.7303E+00,1.6696E+00,1.5995E+00,1.5285E+00,1.4608E+00,
36515 &1.3929E+00,1.3377E+00,1.2826E+00,1.2228E+00,1.1669E+00,1.1279E+00,
36516 &1.0882E+00,1.0555E+00,1.0205E+00,9.8876E-01,9.5876E-01,9.2969E-01,
36517 &9.0171E-01,8.7356E-01,8.4551E-01,8.1668E-01,7.8701E-01,7.5564E-01,
36518 &7.2196E-01,6.9797E-01,6.4121E-01,5.8469E-01,5.2810E-01,4.7131E-01,
36519 &4.1460E-01,3.5783E-01,3.0063E-01,2.4338E-01,1.8544E-01,1.2660E-01,
36520 &6.6270E-02,0.0000E+00,3.1379E+00,3.0995E+00,3.0600E+00,3.0213E+00,
36521 &2.9840E+00,2.9442E+00,2.9047E+00,2.8641E+00,2.8239E+00,2.7813E+00/
36522 DATA (XDVF_L(K),K= 1711, 1824) /
36523 &2.7383E+00,2.6928E+00,2.6470E+00,2.6191E+00,2.5880E+00,2.5519E+00,
36524 &2.5145E+00,2.4761E+00,2.4357E+00,2.4004E+00,2.3615E+00,2.3153E+00,
36525 &2.2678E+00,2.2180E+00,2.1669E+00,2.1208E+00,2.0699E+00,2.0087E+00,
36526 &1.9447E+00,1.8795E+00,1.8139E+00,1.7558E+00,1.6930E+00,1.6205E+00,
36527 &1.5467E+00,1.4759E+00,1.4054E+00,1.3484E+00,1.2895E+00,1.2267E+00,
36528 &1.1663E+00,1.1242E+00,1.0808E+00,1.0449E+00,1.0065E+00,9.7194E-01,
36529 &9.3967E-01,9.0840E-01,8.7834E-01,8.4891E-01,8.1928E-01,7.8930E-01,
36530 &7.5803E-01,7.2562E-01,6.9124E-01,6.6796E-01,6.1058E-01,5.5392E-01,
36531 &4.9752E-01,4.4176E-01,3.8633E-01,3.3127E-01,2.7648E-01,2.2186E-01,
36532 &1.6735E-01,1.1268E-01,5.7652E-02,0.0000E+00,3.2129E+00,3.1726E+00,
36533 &3.1325E+00,3.0928E+00,3.0540E+00,3.0127E+00,2.9717E+00,2.9303E+00,
36534 &2.8887E+00,2.8449E+00,2.8001E+00,2.7537E+00,2.7060E+00,2.6766E+00,
36535 &2.6453E+00,2.6073E+00,2.5683E+00,2.5286E+00,2.4866E+00,2.4501E+00,
36536 &2.4107E+00,2.3628E+00,2.3125E+00,2.2620E+00,2.2079E+00,2.1597E+00,
36537 &2.1067E+00,2.0440E+00,1.9778E+00,1.9097E+00,1.8421E+00,1.7819E+00,
36538 &1.7169E+00,1.6416E+00,1.5664E+00,1.4922E+00,1.4189E+00,1.3583E+00,
36539 &1.2971E+00,1.2300E+00,1.1652E+00,1.1200E+00,1.0729E+00,1.0343E+00,
36540 &9.9254E-01,9.5513E-01,9.2006E-01,8.8711E-01,8.5555E-01,8.2426E-01,
36541 &7.9305E-01,7.6193E-01,7.2963E-01,6.9636E-01,6.6128E-01,6.3868E-01/
36542 DATA (XDVF_L(K),K= 1825, 1836) /
36543 &5.8093E-01,5.2428E-01,4.6858E-01,4.1372E-01,3.5972E-01,3.0648E-01,
36544 &2.5392E-01,2.0208E-01,1.5083E-01,1.0018E-01,5.0068E-02,0.0000E+00/
36545 DATA (XDEF_L(K),K= 1, 114) /
36546 &4.3007E-01,4.2474E-01,4.1967E-01,4.1458E-01,4.0970E-01,4.0443E-01,
36547 &3.9925E-01,3.9397E-01,3.8864E-01,3.8302E-01,3.7707E-01,3.7100E-01,
36548 &3.6470E-01,3.6080E-01,3.5639E-01,3.5109E-01,3.4531E-01,3.3914E-01,
36549 &3.3238E-01,3.2609E-01,3.1913E-01,3.1062E-01,3.0152E-01,2.9176E-01,
36550 &2.8100E-01,2.7114E-01,2.5952E-01,2.4467E-01,2.2784E-01,2.0937E-01,
36551 &1.9117E-01,1.7470E-01,1.5685E-01,1.3678E-01,1.1825E-01,1.0349E-01,
36552 &9.4854E-02,9.5054E-02,1.0589E-01,1.3527E-01,1.8584E-01,2.3426E-01,
36553 &2.9021E-01,3.3527E-01,3.7670E-01,4.0255E-01,4.1326E-01,4.0880E-01,
36554 &3.8831E-01,3.5045E-01,2.9287E-01,2.1298E-01,1.0773E-01,0.0000E+00,
36555 &0.0000E+00,2.0644E-01,1.5422E-01,1.0950E-01,7.3614E-02,4.6726E-02,
36556 &2.7433E-02,1.4144E-02,6.5080E-03,2.4719E-03,0.0000E+00,0.0000E+00,
36557 &0.0000E+00,0.0000E+00,4.4398E-01,4.3864E-01,4.3346E-01,4.2809E-01,
36558 &4.2290E-01,4.1747E-01,4.1205E-01,4.0650E-01,4.0098E-01,3.9480E-01,
36559 &3.8873E-01,3.8226E-01,3.7560E-01,3.7145E-01,3.6678E-01,3.6108E-01,
36560 &3.5488E-01,3.4833E-01,3.4123E-01,3.3464E-01,3.2718E-01,3.1811E-01,
36561 &3.0838E-01,2.9811E-01,2.8670E-01,2.7630E-01,2.6412E-01,2.4861E-01,
36562 &2.3110E-01,2.1209E-01,1.9355E-01,1.7681E-01,1.5878E-01,1.3870E-01,
36563 &1.2044E-01,1.0620E-01,9.8341E-02,9.9345E-02,1.1086E-01,1.4055E-01,
36564 &1.9033E-01,2.3696E-01,2.8983E-01,3.3137E-01,3.6834E-01,3.8982E-01/
36565 DATA (XDEF_L(K),K= 115, 228) /
36566 &3.9672E-01,3.8896E-01,3.6609E-01,3.2678E-01,2.6933E-01,1.9181E-01,
36567 &9.1683E-02,0.0000E+00,0.0000E+00,1.8955E-01,1.4041E-01,9.8873E-02,
36568 &6.5928E-02,4.1462E-02,2.3905E-02,1.2324E-02,5.6113E-03,2.1050E-03,
36569 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,4.5980E-01,4.5420E-01,
36570 &4.4884E-01,4.4319E-01,4.3780E-01,4.3208E-01,4.2642E-01,4.2053E-01,
36571 &4.1457E-01,4.0824E-01,4.0181E-01,3.9484E-01,3.8780E-01,3.8328E-01,
36572 &3.7831E-01,3.7223E-01,3.6559E-01,3.5853E-01,3.5072E-01,3.4400E-01,
36573 &3.3590E-01,3.2633E-01,3.1598E-01,3.0508E-01,2.9301E-01,2.8197E-01,
36574 &2.6915E-01,2.5289E-01,2.3470E-01,2.1511E-01,1.9623E-01,1.7918E-01,
36575 &1.6098E-01,1.4092E-01,1.2294E-01,1.0928E-01,1.0224E-01,1.0401E-01,
36576 &1.1623E-01,1.4620E-01,1.9488E-01,2.3948E-01,2.8894E-01,3.2681E-01,
36577 &3.5905E-01,3.7613E-01,3.7908E-01,3.6817E-01,3.4299E-01,3.0266E-01,
36578 &2.4596E-01,1.7115E-01,7.6792E-02,0.0000E+00,0.0000E+00,1.7267E-01,
36579 &1.2670E-01,8.8446E-02,5.8458E-02,3.6380E-02,2.0551E-02,1.0608E-02,
36580 &4.7732E-03,1.7670E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36581 &4.7845E-01,4.7258E-01,4.6687E-01,4.6107E-01,4.5540E-01,4.4938E-01,
36582 &4.4336E-01,4.3728E-01,4.3070E-01,4.2403E-01,4.1702E-01,4.0968E-01,
36583 &4.0210E-01,3.9723E-01,3.9181E-01,3.8522E-01,3.7808E-01,3.7047E-01,
36584 &3.6211E-01,3.5469E-01,3.4619E-01,3.3582E-01,3.2478E-01,3.1314E-01/
36585 DATA (XDEF_L(K),K= 229, 342) /
36586 &3.0021E-01,2.8848E-01,2.7488E-01,2.5781E-01,2.3886E-01,2.1865E-01,
36587 &1.9932E-01,1.8196E-01,1.6359E-01,1.4359E-01,1.2596E-01,1.1295E-01,
36588 &1.0678E-01,1.0933E-01,1.2234E-01,1.5242E-01,1.9969E-01,2.4187E-01,
36589 &2.8742E-01,3.2112E-01,3.4825E-01,3.6067E-01,3.5959E-01,3.4546E-01,
36590 &3.1813E-01,2.7719E-01,2.2151E-01,1.5037E-01,6.2862E-02,0.0000E+00,
36591 &0.0000E+00,1.5516E-01,1.1270E-01,7.7856E-02,5.0916E-02,3.1337E-02,
36592 &1.7279E-02,8.9355E-03,3.9672E-03,1.4465E-03,0.0000E+00,0.0000E+00,
36593 &0.0000E+00,0.0000E+00,5.0059E-01,4.9450E-01,4.8826E-01,4.8213E-01,
36594 &4.7610E-01,4.6972E-01,4.6326E-01,4.5655E-01,4.4999E-01,4.4265E-01,
36595 &4.3505E-01,4.2703E-01,4.1870E-01,4.1345E-01,4.0758E-01,4.0034E-01,
36596 &3.9260E-01,3.8434E-01,3.7539E-01,3.6725E-01,3.5804E-01,3.4696E-01,
36597 &3.3492E-01,3.2231E-01,3.0852E-01,2.9601E-01,2.8154E-01,2.6348E-01,
36598 &2.4363E-01,2.2272E-01,2.0295E-01,1.8526E-01,1.6669E-01,1.4678E-01,
36599 &1.2956E-01,1.1726E-01,1.1212E-01,1.1548E-01,1.2910E-01,1.5906E-01,
36600 &2.0458E-01,2.4395E-01,2.8508E-01,3.1418E-01,3.3593E-01,3.4343E-01,
36601 &3.3827E-01,3.2104E-01,2.9189E-01,2.5067E-01,1.9688E-01,1.3016E-01,
36602 &5.0498E-02,0.0000E+00,0.0000E+00,1.3742E-01,9.8602E-02,6.7357E-02,
36603 &4.3555E-02,2.6444E-02,1.4175E-02,7.3561E-03,3.2181E-03,1.1530E-03,
36604 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.2114E-01,5.1454E-01/
36605 DATA (XDEF_L(K),K= 343, 456) /
36606 &5.0806E-01,5.0160E-01,4.9520E-01,4.8843E-01,4.8165E-01,4.7456E-01,
36607 &4.6738E-01,4.5962E-01,4.5149E-01,4.4293E-01,4.3400E-01,4.2833E-01,
36608 &4.2194E-01,4.1420E-01,4.0580E-01,3.9678E-01,3.8741E-01,3.7848E-01,
36609 &3.6878E-01,3.5682E-01,3.4416E-01,3.3062E-01,3.1602E-01,3.0269E-01,
36610 &2.8749E-01,2.6857E-01,2.4798E-01,2.2641E-01,2.0626E-01,1.8828E-01,
36611 &1.6960E-01,1.4976E-01,1.3293E-01,1.2126E-01,1.1684E-01,1.2099E-01,
36612 &1.3505E-01,1.6471E-01,2.0841E-01,2.4521E-01,2.8248E-01,3.0770E-01,
36613 &3.2484E-01,3.2845E-01,3.1999E-01,3.0047E-01,2.7030E-01,2.2924E-01,
36614 &1.7739E-01,1.1482E-01,4.2174E-02,0.0000E+00,0.0000E+00,1.2330E-01,
36615 &8.7586E-02,5.9211E-02,3.7890E-02,2.2733E-02,1.1877E-02,6.1865E-03,
36616 &2.6713E-03,9.4247E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36617 &5.4423E-01,5.3740E-01,5.3068E-01,5.2385E-01,5.1700E-01,5.0982E-01,
36618 &5.0256E-01,4.9509E-01,4.8731E-01,4.7895E-01,4.7023E-01,4.6094E-01,
36619 &4.5130E-01,4.4506E-01,4.3820E-01,4.2973E-01,4.2069E-01,4.1108E-01,
36620 &4.0069E-01,3.9131E-01,3.8063E-01,3.6796E-01,3.5430E-01,3.3991E-01,
36621 &3.2433E-01,3.1014E-01,2.9407E-01,2.7418E-01,2.5281E-01,2.3056E-01,
36622 &2.0999E-01,1.9171E-01,1.7291E-01,1.5321E-01,1.3677E-01,1.2578E-01,
36623 &1.2220E-01,1.2696E-01,1.4132E-01,1.7056E-01,2.1212E-01,2.4603E-01,
36624 &2.7912E-01,3.0023E-01,3.1274E-01,3.1234E-01,3.0087E-01,2.7925E-01/
36625 DATA (XDEF_L(K),K= 457, 570) /
36626 &2.4820E-01,2.0782E-01,1.5841E-01,1.0056E-01,3.5470E-02,0.0000E+00,
36627 &0.0000E+00,1.0941E-01,7.6864E-02,5.1391E-02,3.2506E-02,1.9250E-02,
36628 &9.7741E-03,5.1192E-03,2.1775E-03,0.0000E+00,0.0000E+00,0.0000E+00,
36629 &0.0000E+00,0.0000E+00,5.6542E-01,5.5814E-01,5.5101E-01,5.4385E-01,
36630 &5.3670E-01,5.2913E-01,5.2140E-01,5.1352E-01,5.0533E-01,4.9639E-01,
36631 &4.8702E-01,4.7710E-01,4.6670E-01,4.6011E-01,4.5270E-01,4.4365E-01,
36632 &4.3394E-01,4.2383E-01,4.1271E-01,4.0253E-01,3.9137E-01,3.7783E-01,
36633 &3.6325E-01,3.4810E-01,3.3163E-01,3.1674E-01,2.9988E-01,2.7922E-01,
36634 &2.5706E-01,2.3429E-01,2.1333E-01,1.9484E-01,1.7592E-01,1.5634E-01,
36635 &1.4028E-01,1.2985E-01,1.2692E-01,1.3218E-01,1.4678E-01,1.7535E-01,
36636 &2.1492E-01,2.4628E-01,2.7582E-01,2.9349E-01,3.0215E-01,2.9865E-01,
36637 &2.8479E-01,2.6176E-01,2.3025E-01,1.9073E-01,1.4372E-01,9.0030E-02,
36638 &3.1431E-02,0.0000E+00,0.0000E+00,9.8561E-02,6.8571E-02,4.5400E-02,
36639 &2.8439E-02,1.6650E-02,8.2414E-03,4.3377E-03,1.8226E-03,0.0000E+00,
36640 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.8660E-01,5.7912E-01,
36641 &5.7170E-01,5.6412E-01,5.5660E-01,5.4858E-01,5.4040E-01,5.3194E-01,
36642 &5.2336E-01,5.1383E-01,5.0381E-01,4.9326E-01,4.8220E-01,4.7515E-01,
36643 &4.6719E-01,4.5756E-01,4.4719E-01,4.3619E-01,4.2441E-01,4.1376E-01,
36644 &4.0188E-01,3.8750E-01,3.7220E-01,3.5617E-01,3.3884E-01,3.2317E-01/
36645 DATA (XDEF_L(K),K= 571, 684) /
36646 &3.0561E-01,2.8413E-01,2.6132E-01,2.3801E-01,2.1667E-01,1.9794E-01,
36647 &1.7898E-01,1.5951E-01,1.4381E-01,1.3395E-01,1.3154E-01,1.3722E-01,
36648 &1.5183E-01,1.7978E-01,2.1726E-01,2.4615E-01,2.7227E-01,2.8668E-01,
36649 &2.9185E-01,2.8560E-01,2.6981E-01,2.4566E-01,2.1405E-01,1.7560E-01,
36650 &1.3093E-01,8.1317E-02,2.8821E-02,0.0000E+00,0.0000E+00,8.9016E-02,
36651 &6.1335E-02,4.0241E-02,2.4960E-02,1.4451E-02,6.9787E-03,3.6912E-03,
36652 &1.5320E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36653 &6.0621E-01,5.9821E-01,5.9043E-01,5.8253E-01,5.7470E-01,5.6625E-01,
36654 &5.5768E-01,5.4870E-01,5.3948E-01,5.2962E-01,5.1919E-01,5.0796E-01,
36655 &4.9620E-01,4.8867E-01,4.8027E-01,4.7003E-01,4.5907E-01,4.4740E-01,
36656 &4.3484E-01,4.2392E-01,4.1127E-01,3.9627E-01,3.8010E-01,3.6326E-01,
36657 &3.4524E-01,3.2900E-01,3.1064E-01,2.8853E-01,2.6510E-01,2.4135E-01,
36658 &2.1970E-01,2.0080E-01,1.8175E-01,1.6242E-01,1.4701E-01,1.3753E-01,
36659 &1.3572E-01,1.4160E-01,1.5623E-01,1.8343E-01,2.1902E-01,2.4571E-01,
36660 &2.6885E-01,2.8059E-01,2.8292E-01,2.7441E-01,2.5704E-01,2.3223E-01,
36661 &2.0062E-01,1.6317E-01,1.2079E-01,7.4733E-02,2.7461E-02,0.0000E+00,
36662 &0.0000E+00,8.1334E-02,5.5577E-02,3.6150E-02,2.2243E-02,1.2749E-02,
36663 &6.0264E-03,3.2009E-03,1.3143E-03,0.0000E+00,0.0000E+00,0.0000E+00,
36664 &0.0000E+00,0.0000E+00,6.2581E-01,6.1778E-01,6.0953E-01,6.0134E-01/
36665 DATA (XDEF_L(K),K= 685, 798) /
36666 &5.9310E-01,5.8428E-01,5.7523E-01,5.6587E-01,5.5625E-01,5.4565E-01,
36667 &5.3457E-01,5.2280E-01,5.1030E-01,5.0236E-01,4.9350E-01,4.8267E-01,
36668 &4.7104E-01,4.5899E-01,4.4560E-01,4.3381E-01,4.2066E-01,4.0485E-01,
36669 &3.8801E-01,3.7047E-01,3.5165E-01,3.3476E-01,3.1574E-01,2.9293E-01,
36670 &2.6889E-01,2.4469E-01,2.2279E-01,2.0369E-01,1.8458E-01,1.6537E-01,
36671 &1.5025E-01,1.4125E-01,1.3980E-01,1.4589E-01,1.6046E-01,1.8686E-01,
36672 &2.2052E-01,2.4502E-01,2.6530E-01,2.7444E-01,2.7406E-01,2.6361E-01,
36673 &2.4491E-01,2.1954E-01,1.8819E-01,1.5193E-01,1.1170E-01,6.9146E-02,
36674 &2.6829E-02,0.0000E+00,0.0000E+00,7.4387E-02,5.0398E-02,3.2529E-02,
36675 &1.9840E-02,1.1260E-02,5.2109E-03,2.7796E-03,1.1291E-03,0.0000E+00,
36676 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,6.4510E-01,6.3663E-01,
36677 &6.2809E-01,6.1948E-01,6.1090E-01,6.0165E-01,5.9256E-01,5.8263E-01,
36678 &5.7237E-01,5.6121E-01,5.4960E-01,5.3710E-01,5.2390E-01,5.1555E-01,
36679 &5.0615E-01,4.9474E-01,4.8273E-01,4.6980E-01,4.5603E-01,4.4343E-01,
36680 &4.2983E-01,4.1325E-01,3.9561E-01,3.7731E-01,3.5765E-01,3.4017E-01,
36681 &3.2063E-01,2.9709E-01,2.7258E-01,2.4795E-01,2.2572E-01,2.0647E-01,
36682 &1.8735E-01,1.6824E-01,1.5339E-01,1.4470E-01,1.4366E-01,1.4990E-01,
36683 &1.6437E-01,1.8986E-01,2.2169E-01,2.4408E-01,2.6175E-01,2.6863E-01,
36684 &2.6585E-01,2.5363E-01,2.3397E-01,2.0813E-01,1.7714E-01,1.4205E-01/
36685 DATA (XDEF_L(K),K= 799, 912) /
36686 &1.0396E-01,6.4602E-02,2.6785E-02,0.0000E+00,0.0000E+00,6.8343E-02,
36687 &4.5962E-02,2.9434E-02,1.7812E-02,1.0015E-02,4.5458E-03,2.4331E-03,
36688 &9.7866E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36689 &6.6281E-01,6.5407E-01,6.4523E-01,6.3631E-01,6.2740E-01,6.1775E-01,
36690 &6.0821E-01,5.9770E-01,5.8724E-01,5.7535E-01,5.6321E-01,5.5021E-01,
36691 &5.3640E-01,5.2763E-01,5.1775E-01,5.0583E-01,4.9310E-01,4.7946E-01,
36692 &4.6520E-01,4.5225E-01,4.3811E-01,4.2074E-01,4.0247E-01,3.8355E-01,
36693 &3.6315E-01,3.4516E-01,3.2502E-01,3.0091E-01,2.7589E-01,2.5090E-01,
36694 &2.2842E-01,2.0903E-01,1.8987E-01,1.7087E-01,1.5631E-01,1.4790E-01,
36695 &1.4709E-01,1.5345E-01,1.6771E-01,1.9243E-01,2.2253E-01,2.4307E-01,
36696 &2.5846E-01,2.6327E-01,2.5857E-01,2.4493E-01,2.2441E-01,1.9832E-01,
36697 &1.6773E-01,1.3380E-01,9.7606E-02,6.1077E-02,2.7123E-02,4.1687E-04,
36698 &0.0000E+00,6.3316E-02,4.2290E-02,2.6899E-02,1.6166E-02,9.0143E-03,
36699 &4.0214E-03,2.1587E-03,8.6042E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36700 &0.0000E+00,0.0000E+00,6.8558E-01,6.7623E-01,6.6716E-01,6.5776E-01,
36701 &6.4840E-01,6.3825E-01,6.2778E-01,6.1697E-01,6.0589E-01,5.9350E-01,
36702 &5.8071E-01,5.6677E-01,5.5220E-01,5.4293E-01,5.3246E-01,5.1980E-01,
36703 &5.0630E-01,4.9221E-01,4.7690E-01,4.6348E-01,4.4839E-01,4.3024E-01,
36704 &4.1112E-01,3.9125E-01,3.7016E-01,3.5134E-01,3.3054E-01,3.0571E-01/
36705 DATA (XDEF_L(K),K= 913, 1026) /
36706 &2.8005E-01,2.5463E-01,2.3186E-01,2.1230E-01,1.9311E-01,1.7422E-01,
36707 &1.5985E-01,1.5187E-01,1.5138E-01,1.5783E-01,1.7178E-01,1.9543E-01,
36708 &2.2331E-01,2.4162E-01,2.5415E-01,2.5666E-01,2.4964E-01,2.3438E-01,
36709 &2.1293E-01,1.8681E-01,1.5680E-01,1.2430E-01,9.0488E-02,5.7352E-02,
36710 &2.7942E-02,7.0995E-03,2.4780E-03,5.7612E-02,3.8138E-02,2.4057E-02,
36711 &1.4329E-02,7.9111E-03,3.4566E-03,1.8603E-03,7.3347E-04,0.0000E+00,
36712 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.0709E-01,6.9744E-01,
36713 &6.8784E-01,6.7803E-01,6.6830E-01,6.5763E-01,6.4678E-01,6.3540E-01,
36714 &6.2360E-01,6.1071E-01,5.9715E-01,5.8240E-01,5.6710E-01,5.5722E-01,
36715 &5.4625E-01,5.3291E-01,5.1856E-01,5.0380E-01,4.8797E-01,4.7363E-01,
36716 &4.5801E-01,4.3900E-01,4.1917E-01,3.9846E-01,3.7656E-01,3.5717E-01,
36717 &3.3564E-01,3.1017E-01,2.8397E-01,2.5816E-01,2.3508E-01,2.1538E-01,
36718 &1.9615E-01,1.7737E-01,1.6324E-01,1.5559E-01,1.5535E-01,1.6175E-01,
36719 &1.7537E-01,1.9793E-01,2.2384E-01,2.4005E-01,2.5009E-01,2.5051E-01,
36720 &2.4150E-01,2.2495E-01,2.0291E-01,1.7668E-01,1.4739E-01,1.1625E-01,
36721 &8.4583E-02,5.4470E-02,2.9013E-02,1.3147E-02,1.4553E-02,5.2777E-02,
36722 &3.4672E-02,2.1686E-02,1.2821E-02,7.0105E-03,3.0093E-03,1.6226E-03,
36723 &6.3321E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36724 &7.2796E-01,7.1795E-01,7.0799E-01,6.9776E-01,6.8760E-01,6.7649E-01/
36725 DATA (XDEF_L(K),K= 1027, 1140) /
36726 &6.6523E-01,6.5299E-01,6.4099E-01,6.2720E-01,6.1289E-01,5.9763E-01,
36727 &5.8140E-01,5.7108E-01,5.5954E-01,5.4555E-01,5.3082E-01,5.1501E-01,
36728 &4.9841E-01,4.8352E-01,4.6718E-01,4.4758E-01,4.2678E-01,4.0543E-01,
36729 &3.8267E-01,3.6267E-01,3.4052E-01,3.1445E-01,2.8771E-01,2.6154E-01,
36730 &2.3817E-01,2.1835E-01,1.9910E-01,1.8043E-01,1.6662E-01,1.5905E-01,
36731 &1.5900E-01,1.6548E-01,1.7871E-01,2.0015E-01,2.2403E-01,2.3835E-01,
36732 &2.4610E-01,2.4469E-01,2.3394E-01,2.1634E-01,1.9372E-01,1.6761E-01,
36733 &1.3910E-01,1.0920E-01,7.9530E-02,5.2165E-02,3.0250E-02,1.8723E-02,
36734 &2.5275E-02,4.8575E-02,3.1676E-02,1.9677E-02,1.1540E-02,6.2533E-03,
36735 &2.6411E-03,1.4253E-03,5.5072E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36736 &0.0000E+00,0.0000E+00,7.4788E-01,7.3751E-01,7.2708E-01,7.1644E-01,
36737 &7.0580E-01,6.9430E-01,6.8256E-01,6.6975E-01,6.5712E-01,6.4276E-01,
36738 &6.2791E-01,6.1180E-01,5.9490E-01,5.8409E-01,5.7199E-01,5.5739E-01,
36739 &5.4166E-01,5.2544E-01,5.0821E-01,4.9288E-01,4.7590E-01,4.5544E-01,
36740 &4.3393E-01,4.1178E-01,3.8837E-01,3.6775E-01,3.4513E-01,3.1844E-01,
36741 &2.9125E-01,2.6472E-01,2.4110E-01,2.2115E-01,2.0189E-01,1.8330E-01,
36742 &1.6955E-01,1.6237E-01,1.6243E-01,1.6875E-01,1.8164E-01,2.0201E-01,
36743 &2.2410E-01,2.3665E-01,2.4236E-01,2.3927E-01,2.2710E-01,2.0852E-01,
36744 &1.8563E-01,1.5962E-01,1.3170E-01,1.0314E-01,7.5292E-02,5.0347E-02/
36745 DATA (XDEF_L(K),K= 1141, 1254) /
36746 &3.1513E-02,2.3688E-02,3.4520E-02,4.4988E-02,2.9140E-02,1.7975E-02,
36747 &1.0472E-02,5.6268E-03,2.3442E-03,1.2646E-03,4.8432E-04,0.0000E+00,
36748 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.6812E-01,7.5731E-01,
36749 &7.4653E-01,7.3551E-01,7.2440E-01,7.1234E-01,6.9989E-01,6.8692E-01,
36750 &6.7357E-01,6.5855E-01,6.4312E-01,6.2624E-01,6.0850E-01,5.9719E-01,
36751 &5.8457E-01,5.6934E-01,5.5297E-01,5.3626E-01,5.1802E-01,5.0223E-01,
36752 &4.8440E-01,4.6329E-01,4.4109E-01,4.1826E-01,3.9408E-01,3.7291E-01,
36753 &3.4966E-01,3.2243E-01,2.9475E-01,2.6790E-01,2.4406E-01,2.2399E-01,
36754 &2.0470E-01,1.8621E-01,1.7262E-01,1.6558E-01,1.6576E-01,1.7201E-01,
36755 &1.8441E-01,2.0372E-01,2.2403E-01,2.3482E-01,2.3856E-01,2.3398E-01,
36756 &2.2040E-01,2.0103E-01,1.7782E-01,1.5205E-01,1.2492E-01,9.7540E-02,
36757 &7.1452E-02,4.8817E-02,3.2832E-02,2.8412E-02,4.3068E-02,4.1684E-02,
36758 &2.6819E-02,1.6431E-02,9.5049E-03,5.0674E-03,2.0840E-03,1.1231E-03,
36759 &4.2643E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36760 &7.8709E-01,7.7617E-01,7.6509E-01,7.5353E-01,7.4210E-01,7.2955E-01,
36761 &7.1666E-01,7.0326E-01,6.8906E-01,6.7364E-01,6.5743E-01,6.3988E-01,
36762 &6.2140E-01,6.0962E-01,5.9645E-01,5.8083E-01,5.6382E-01,5.4630E-01,
36763 &5.2750E-01,5.1079E-01,4.9267E-01,4.7078E-01,4.4780E-01,4.2425E-01,
36764 &3.9948E-01,3.7773E-01,3.5398E-01,3.2619E-01,2.9811E-01,2.7093E-01/
36765 DATA (XDEF_L(K),K= 1255, 1368) /
36766 &2.4686E-01,2.2668E-01,2.0735E-01,1.8888E-01,1.7555E-01,1.6865E-01,
36767 &1.6887E-01,1.7500E-01,1.8693E-01,2.0522E-01,2.2377E-01,2.3300E-01,
36768 &2.3501E-01,2.2902E-01,2.1428E-01,1.9427E-01,1.7084E-01,1.4533E-01,
36769 &1.1889E-01,9.2655E-02,6.8174E-02,4.7575E-02,3.4123E-02,3.2605E-02,
36770 &5.0454E-02,3.8820E-02,2.4822E-02,1.5113E-02,8.6857E-03,4.5962E-03,
36771 &1.8704E-03,1.0050E-03,3.7856E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36772 &0.0000E+00,0.0000E+00,8.0606E-01,7.9455E-01,7.8312E-01,7.7128E-01,
36773 &7.5940E-01,7.4610E-01,7.3287E-01,7.1917E-01,7.0456E-01,6.8825E-01,
36774 &6.7140E-01,6.5313E-01,6.3390E-01,6.2170E-01,6.0798E-01,5.9180E-01,
36775 &5.7419E-01,5.5596E-01,5.3636E-01,5.1934E-01,5.0050E-01,4.7790E-01,
36776 &4.5436E-01,4.3012E-01,4.0458E-01,3.8238E-01,3.5808E-01,3.2984E-01,
36777 &3.0133E-01,2.7388E-01,2.4957E-01,2.2930E-01,2.0996E-01,1.9168E-01,
36778 &1.7832E-01,1.7159E-01,1.7177E-01,1.7770E-01,1.8921E-01,2.0651E-01,
36779 &2.2344E-01,2.3117E-01,2.3152E-01,2.2426E-01,2.0844E-01,1.8790E-01,
36780 &1.6440E-01,1.3914E-01,1.1342E-01,8.8280E-02,6.5276E-02,4.6578E-02,
36781 &3.5360E-02,3.6411E-02,5.6986E-02,3.6256E-02,2.3040E-02,1.3948E-02,
36782 &7.9676E-03,4.1856E-03,1.6876E-03,9.0394E-04,3.3789E-04,0.0000E+00,
36783 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.2409E-01,8.1223E-01,
36784 &8.0027E-01,7.8810E-01,7.7580E-01,7.6250E-01,7.4852E-01,7.3383E-01/
36785 DATA (XDEF_L(K),K= 1369, 1482) /
36786 &7.1879E-01,7.0216E-01,6.8466E-01,6.6571E-01,6.4580E-01,6.3303E-01,
36787 &6.1887E-01,6.0161E-01,5.8362E-01,5.6485E-01,5.4490E-01,5.2736E-01,
36788 &5.0788E-01,4.8465E-01,4.6048E-01,4.3549E-01,4.0949E-01,3.8678E-01,
36789 &3.6198E-01,3.3325E-01,3.0435E-01,2.7667E-01,2.5212E-01,2.3179E-01,
36790 &2.1241E-01,1.9410E-01,1.8093E-01,1.7428E-01,1.7445E-01,1.8022E-01,
36791 &1.9133E-01,2.0758E-01,2.2299E-01,2.2941E-01,2.2823E-01,2.1990E-01,
36792 &2.0319E-01,1.8211E-01,1.5852E-01,1.3371E-01,1.0856E-01,8.4430E-02,
36793 &6.2776E-02,4.5758E-02,3.6514E-02,3.9756E-02,6.2597E-02,3.4019E-02,
36794 &2.1502E-02,1.2943E-02,7.3506E-03,3.8366E-03,1.5351E-03,8.1923E-04,
36795 &3.0383E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36796 &8.4844E-01,8.3627E-01,8.2378E-01,8.1114E-01,7.9820E-01,7.8411E-01,
36797 &7.6977E-01,7.5436E-01,7.3871E-01,7.2101E-01,7.0269E-01,6.8280E-01,
36798 &6.6180E-01,6.4849E-01,6.3365E-01,6.1605E-01,5.9682E-01,5.7721E-01,
36799 &5.5628E-01,5.3805E-01,5.1772E-01,4.9378E-01,4.6868E-01,4.4295E-01,
36800 &4.1599E-01,3.9262E-01,3.6722E-01,3.3788E-01,3.0847E-01,2.8040E-01,
36801 &2.5562E-01,2.3513E-01,2.1572E-01,1.9746E-01,1.8447E-01,1.7787E-01,
36802 &1.7810E-01,1.8358E-01,1.9394E-01,2.0894E-01,2.2227E-01,2.2689E-01,
36803 &2.2385E-01,2.1408E-01,1.9620E-01,1.7461E-01,1.5108E-01,1.2667E-01,
36804 &1.0243E-01,7.9635E-02,5.9715E-02,4.4804E-02,3.7997E-02,4.3894E-02/
36805 DATA (XDEF_L(K),K= 1483, 1596) /
36806 &6.9391E-02,3.1240E-02,1.9603E-02,1.1712E-02,6.6036E-03,3.4150E-03,
36807 &1.3549E-03,7.1812E-04,2.6373E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36808 &0.0000E+00,0.0000E+00,8.7089E-01,8.5819E-01,8.4535E-01,8.3207E-01,
36809 &8.1860E-01,8.0424E-01,7.8877E-01,7.7320E-01,7.5642E-01,7.3822E-01,
36810 &7.1895E-01,6.9816E-01,6.7640E-01,6.6244E-01,6.4701E-01,6.2817E-01,
36811 &6.0860E-01,5.8841E-01,5.6672E-01,5.4767E-01,5.2667E-01,5.0182E-01,
36812 &4.7599E-01,4.4955E-01,4.2190E-01,3.9787E-01,3.7196E-01,3.4199E-01,
36813 &3.1220E-01,2.8382E-01,2.5874E-01,2.3816E-01,2.1874E-01,2.0063E-01,
36814 &1.8770E-01,1.8107E-01,1.8121E-01,1.8638E-01,1.9622E-01,2.0994E-01,
36815 &2.2156E-01,2.2456E-01,2.1986E-01,2.0892E-01,1.9015E-01,1.6817E-01,
36816 &1.4465E-01,1.2070E-01,9.7309E-02,7.5665E-02,5.7234E-02,4.4095E-02,
36817 &3.9289E-02,4.7307E-02,7.4739E-02,2.8958E-02,1.8046E-02,1.0716E-02,
36818 &6.0010E-03,3.0801E-03,1.2145E-03,6.3833E-04,2.3251E-04,0.0000E+00,
36819 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.9366E-01,8.8058E-01,
36820 &8.6727E-01,8.5353E-01,8.3950E-01,8.2436E-01,8.0890E-01,7.9205E-01,
36821 &7.7476E-01,7.5566E-01,7.3557E-01,7.1393E-01,6.9120E-01,6.7672E-01,
36822 &6.6059E-01,6.4145E-01,6.2086E-01,5.9962E-01,5.7716E-01,5.5756E-01,
36823 &5.3584E-01,5.1022E-01,4.8344E-01,4.5615E-01,4.2780E-01,4.0320E-01,
36824 &3.7671E-01,3.4621E-01,3.1594E-01,2.8727E-01,2.6196E-01,2.4126E-01/
36825 DATA (XDEF_L(K),K= 1597, 1710) /
36826 &2.2177E-01,2.0361E-01,1.9078E-01,1.8427E-01,1.8432E-01,1.8918E-01,
36827 &1.9834E-01,2.1079E-01,2.2065E-01,2.2210E-01,2.1587E-01,2.0383E-01,
36828 &1.8424E-01,1.6197E-01,1.3849E-01,1.1505E-01,9.2463E-02,7.1949E-02,
36829 &5.4952E-02,4.3474E-02,4.0525E-02,5.0376E-02,7.9517E-02,2.6835E-02,
36830 &1.6616E-02,9.8004E-03,5.4489E-03,2.7768E-03,1.0900E-03,5.6728E-04,
36831 &2.0489E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36832 &9.1643E-01,9.0298E-01,8.8901E-01,8.7472E-01,8.6030E-01,8.4449E-01,
36833 &8.2790E-01,8.1090E-01,7.9278E-01,7.7287E-01,7.5201E-01,7.2942E-01,
36834 &7.0580E-01,6.9067E-01,6.7395E-01,6.5357E-01,6.3264E-01,6.1082E-01,
36835 &5.8728E-01,5.6718E-01,5.4478E-01,5.1825E-01,4.9075E-01,4.6263E-01,
36836 &4.3360E-01,4.0844E-01,3.8138E-01,3.5032E-01,3.1963E-01,2.9065E-01,
36837 &2.6511E-01,2.4428E-01,2.2479E-01,2.0678E-01,1.9385E-01,1.8735E-01,
36838 &1.8722E-01,1.9179E-01,2.0029E-01,2.1158E-01,2.1961E-01,2.1971E-01,
36839 &2.1194E-01,1.9894E-01,1.7862E-01,1.5609E-01,1.3279E-01,1.0972E-01,
36840 &8.8007E-02,6.8578E-02,5.2905E-02,4.2942E-02,4.1624E-02,5.3065E-02,
36841 &8.3506E-02,2.4920E-02,1.5334E-02,8.9876E-03,4.9653E-03,2.5112E-03,
36842 &9.8300E-04,5.0629E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36843 &0.0000E+00,0.0000E+00,9.3762E-01,9.2325E-01,9.0916E-01,8.9432E-01,
36844 &8.7930E-01,8.6312E-01,8.4579E-01,8.2807E-01,8.0954E-01,7.8866E-01/
36845 DATA (XDEF_L(K),K= 1711, 1824) /
36846 &7.6704E-01,7.4360E-01,7.1911E-01,7.0343E-01,6.8612E-01,6.6512E-01,
36847 &6.4349E-01,6.2048E-01,5.9676E-01,5.7574E-01,5.5261E-01,5.2556E-01,
36848 &4.9731E-01,4.6862E-01,4.3881E-01,4.1318E-01,3.8556E-01,3.5408E-01,
36849 &3.2299E-01,2.9375E-01,2.6794E-01,2.4706E-01,2.2744E-01,2.0939E-01,
36850 &1.9662E-01,1.9016E-01,1.8990E-01,1.9412E-01,2.0192E-01,2.1208E-01,
36851 &2.1863E-01,2.1745E-01,2.0845E-01,1.9458E-01,1.7365E-01,1.5094E-01,
36852 &1.2783E-01,1.0526E-01,8.4228E-02,6.5746E-02,5.1203E-02,4.2521E-02,
36853 &4.2531E-02,5.5238E-02,8.6619E-02,2.3321E-02,1.4266E-02,8.3142E-03,
36854 &4.5684E-03,2.2945E-03,8.9721E-04,4.5700E-04,0.0000E+00,0.0000E+00,
36855 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,9.5912E-01,9.4446E-01,
36856 &9.2967E-01,9.1446E-01,8.9890E-01,8.8176E-01,8.6424E-01,8.4567E-01,
36857 &8.2630E-01,8.0492E-01,7.8242E-01,7.5817E-01,7.3271E-01,7.1653E-01,
36858 &6.9849E-01,6.7725E-01,6.5433E-01,6.3091E-01,6.0625E-01,5.8456E-01,
36859 &5.6088E-01,5.3305E-01,5.0402E-01,4.7461E-01,4.4411E-01,4.1800E-01,
36860 &3.8988E-01,3.5790E-01,3.2644E-01,2.9690E-01,2.7087E-01,2.4987E-01,
36861 &2.3039E-01,2.1219E-01,1.9955E-01,1.9298E-01,1.9248E-01,1.9636E-01,
36862 &2.0355E-01,2.1258E-01,2.1752E-01,2.1512E-01,2.0490E-01,1.9021E-01,
36863 &1.6876E-01,1.4586E-01,1.2296E-01,1.0090E-01,8.0587E-02,6.3034E-02,
36864 &4.9591E-02,4.2122E-02,4.3355E-02,5.7203E-02,8.9336E-02,2.1802E-02/
36865 DATA (XDEF_L(K),K= 1825, 1836) /
36866 &1.3258E-02,7.6843E-03,4.1967E-03,2.0952E-03,8.1932E-04,4.1202E-04,
36867 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00/
36868 DATA (XUDF_L(K),K= 1, 114) /
36869 &1.8987E-02,1.9947E-02,2.0980E-02,2.2068E-02,2.3225E-02,2.4540E-02,
36870 &2.5957E-02,2.7526E-02,2.9229E-02,3.1232E-02,3.3453E-02,3.6003E-02,
36871 &3.8855E-02,4.0763E-02,4.2980E-02,4.5778E-02,4.8895E-02,5.2320E-02,
36872 &5.6174E-02,5.9765E-02,6.3980E-02,6.9315E-02,7.5299E-02,8.1888E-02,
36873 &8.9292E-02,9.6162E-02,1.0414E-01,1.1410E-01,1.2505E-01,1.3674E-01,
36874 &1.4937E-01,1.6060E-01,1.7296E-01,1.8730E-01,2.0166E-01,2.1531E-01,
36875 &2.2821E-01,2.3833E-01,2.4848E-01,2.6049E-01,2.7586E-01,2.9166E-01,
36876 &3.1456E-01,3.3942E-01,3.7230E-01,4.0597E-01,4.3921E-01,4.7071E-01,
36877 &4.9846E-01,5.2057E-01,5.3433E-01,5.3610E-01,5.2141E-01,4.8433E-01,
36878 &4.1719E-01,6.3794E-01,6.7411E-01,7.2040E-01,7.8812E-01,8.9495E-01,
36879 &1.0702E+00,1.3629E+00,1.8763E+00,2.8399E+00,4.8968E+00,1.0506E+01,
36880 &3.7793E+01,0.0000E+00,3.1111E-02,3.2336E-02,3.3580E-02,3.4906E-02,
36881 &3.6247E-02,3.7773E-02,3.9337E-02,4.1056E-02,4.2876E-02,4.5001E-02,
36882 &4.7299E-02,4.9897E-02,5.2761E-02,5.4666E-02,5.6867E-02,5.9620E-02,
36883 &6.2679E-02,6.6018E-02,6.9775E-02,7.3275E-02,7.7353E-02,8.2522E-02,
36884 &8.8327E-02,9.4694E-02,1.0184E-01,1.0846E-01,1.1615E-01,1.2575E-01,
36885 &1.3628E-01,1.4752E-01,1.5964E-01,1.7036E-01,1.8215E-01,1.9580E-01,
36886 &2.0933E-01,2.2213E-01,2.3411E-01,2.4341E-01,2.5275E-01,2.6387E-01,
36887 &2.7831E-01,2.9333E-01,3.1510E-01,3.3876E-01,3.6995E-01,4.0170E-01/
36888 DATA (XUDF_L(K),K= 115, 228) /
36889 &4.3298E-01,4.6172E-01,4.8742E-01,5.0700E-01,5.1856E-01,5.1873E-01,
36890 &5.0352E-01,4.6746E-01,4.0418E-01,6.1801E-01,6.5339E-01,6.9923E-01,
36891 &7.6627E-01,8.7125E-01,1.0408E+00,1.3199E+00,1.8020E+00,2.6920E+00,
36892 &4.5574E+00,9.5310E+00,3.2877E+01,0.0000E+00,5.1176E-02,5.2640E-02,
36893 &5.4100E-02,5.5603E-02,5.7095E-02,5.8737E-02,6.0416E-02,6.2154E-02,
36894 &6.4016E-02,6.6046E-02,6.8273E-02,7.0765E-02,7.3444E-02,7.5182E-02,
36895 &7.7263E-02,7.9781E-02,8.2626E-02,8.5707E-02,8.9176E-02,9.2402E-02,
36896 &9.6182E-02,1.0098E-01,1.0635E-01,1.1227E-01,1.1893E-01,1.2513E-01,
36897 &1.3230E-01,1.4128E-01,1.5115E-01,1.6164E-01,1.7300E-01,1.8301E-01,
36898 &1.9397E-01,2.0660E-01,2.1907E-01,2.3072E-01,2.4154E-01,2.4985E-01,
36899 &2.5817E-01,2.6810E-01,2.8136E-01,2.9535E-01,3.1585E-01,3.3824E-01,
36900 &3.6743E-01,3.9701E-01,4.2565E-01,4.5205E-01,4.7460E-01,4.9184E-01,
36901 &5.0110E-01,4.9954E-01,4.8363E-01,4.4878E-01,3.8940E-01,5.9452E-01,
36902 &6.2820E-01,6.7181E-01,7.3612E-01,8.3598E-01,9.9560E-01,1.2543E+00,
36903 &1.6953E+00,2.4947E+00,4.1415E+00,8.4275E+00,2.7797E+01,0.0000E+00,
36904 &8.6266E-02,8.7847E-02,8.9380E-02,9.0869E-02,9.2337E-02,9.3826E-02,
36905 &9.5315E-02,9.6842E-02,9.8333E-02,1.0003E-01,1.0178E-01,1.0370E-01,
36906 &1.0575E-01,1.0710E-01,1.0872E-01,1.1075E-01,1.1295E-01,1.1538E-01,
36907 &1.1821E-01,1.2088E-01,1.2396E-01,1.2796E-01,1.3252E-01,1.3756E-01/
36908 DATA (XUDF_L(K),K= 229, 342) /
36909 &1.4331E-01,1.4870E-01,1.5500E-01,1.6291E-01,1.7166E-01,1.8100E-01,
36910 &1.9111E-01,2.0002E-01,2.0977E-01,2.2095E-01,2.3189E-01,2.4200E-01,
36911 &2.5123E-01,2.5821E-01,2.6512E-01,2.7351E-01,2.8514E-01,2.9789E-01,
36912 &3.1683E-01,3.3731E-01,3.6424E-01,3.9124E-01,4.1697E-01,4.4030E-01,
36913 &4.6002E-01,4.7419E-01,4.8085E-01,4.7740E-01,4.6086E-01,4.2728E-01,
36914 &3.7241E-01,5.6656E-01,5.9684E-01,6.3694E-01,6.9622E-01,7.8804E-01,
36915 &9.3343E-01,1.1653E+00,1.5545E+00,2.2504E+00,3.6537E+00,7.2124E+00,
36916 &2.2653E+01,0.0000E+00,1.4838E-01,1.4960E-01,1.5068E-01,1.5161E-01,
36917 &1.5242E-01,1.5316E-01,1.5373E-01,1.5426E-01,1.5470E-01,1.5511E-01,
36918 &1.5554E-01,1.5602E-01,1.5660E-01,1.5698E-01,1.5750E-01,1.5830E-01,
36919 &1.5923E-01,1.6034E-01,1.6181E-01,1.6324E-01,1.6509E-01,1.6746E-01,
36920 &1.7054E-01,1.7402E-01,1.7811E-01,1.8208E-01,1.8687E-01,1.9296E-01,
36921 &1.9986E-01,2.0734E-01,2.1554E-01,2.2281E-01,2.3075E-01,2.3983E-01,
36922 &2.4863E-01,2.5660E-01,2.6366E-01,2.6883E-01,2.7387E-01,2.8026E-01,
36923 &2.8982E-01,3.0088E-01,3.1780E-01,3.3626E-01,3.6021E-01,3.8399E-01,
36924 &4.0666E-01,4.2682E-01,4.4278E-01,4.5386E-01,4.5774E-01,4.5230E-01,
36925 &4.3509E-01,4.0314E-01,3.5321E-01,5.3325E-01,5.5916E-01,5.9448E-01,
36926 &6.4707E-01,7.2797E-01,8.5557E-01,1.0563E+00,1.3882E+00,1.9717E+00,
36927 &3.1223E+00,5.9601E+00,1.7750E+01,0.0000E+00,2.3139E-01,2.3138E-01/
36928 DATA (XUDF_L(K),K= 343, 456) /
36929 &2.3120E-01,2.3076E-01,2.3006E-01,2.2907E-01,2.2788E-01,2.2645E-01,
36930 &2.2489E-01,2.2308E-01,2.2120E-01,2.1929E-01,2.1743E-01,2.1630E-01,
36931 &2.1526E-01,2.1411E-01,2.1311E-01,2.1231E-01,2.1171E-01,2.1148E-01,
36932 &2.1150E-01,2.1182E-01,2.1271E-01,2.1412E-01,2.1601E-01,2.1822E-01,
36933 &2.2096E-01,2.2496E-01,2.2961E-01,2.3481E-01,2.4086E-01,2.4622E-01,
36934 &2.5214E-01,2.5891E-01,2.6537E-01,2.7104E-01,2.7588E-01,2.7922E-01,
36935 &2.8235E-01,2.8664E-01,2.9413E-01,3.0352E-01,3.1845E-01,3.3481E-01,
36936 &3.5617E-01,3.7737E-01,3.9689E-01,4.1403E-01,4.2736E-01,4.3558E-01,
36937 &4.3712E-01,4.3016E-01,4.1245E-01,3.8197E-01,3.3645E-01,5.0322E-01,
36938 &5.2507E-01,5.5559E-01,6.0172E-01,6.7286E-01,7.8413E-01,9.5797E-01,
36939 &1.2422E+00,1.7341E+00,2.6883E+00,4.9868E+00,1.4177E+01,0.0000E+00,
36940 &3.6389E-01,3.6098E-01,3.5780E-01,3.5400E-01,3.5016E-01,3.4553E-01,
36941 &3.4044E-01,3.3521E-01,3.2971E-01,3.2369E-01,3.1755E-01,3.1120E-01,
36942 &3.0494E-01,3.0120E-01,2.9724E-01,2.9287E-01,2.8855E-01,2.8449E-01,
36943 &2.8072E-01,2.7770E-01,2.7469E-01,2.7175E-01,2.6933E-01,2.6740E-01,
36944 &2.6613E-01,2.6556E-01,2.6563E-01,2.6631E-01,2.6763E-01,2.6975E-01,
36945 &2.7268E-01,2.7539E-01,2.7857E-01,2.8224E-01,2.8565E-01,2.8841E-01,
36946 &2.9040E-01,2.9139E-01,2.9220E-01,2.9395E-01,2.9888E-01,3.0633E-01,
36947 &3.1877E-01,3.3296E-01,3.5147E-01,3.6947E-01,3.8604E-01,3.9986E-01/
36948 DATA (XUDF_L(K),K= 457, 570) /
36949 &4.1008E-01,4.1548E-01,4.1467E-01,4.0620E-01,3.8830E-01,3.5965E-01,
36950 &3.1902E-01,4.7020E-01,4.8772E-01,5.1303E-01,5.5185E-01,6.1224E-01,
36951 &7.0699E-01,8.5323E-01,1.0903E+00,1.4950E+00,2.2640E+00,4.0723E+00,
36952 &0.0000E+00,0.0000E+00,5.2666E-01,5.1909E-01,5.1100E-01,5.0238E-01,
36953 &4.9333E-01,4.8312E-01,4.7293E-01,4.6180E-01,4.5066E-01,4.3890E-01,
36954 &4.2692E-01,4.1467E-01,4.0262E-01,3.9542E-01,3.8784E-01,3.7925E-01,
36955 &3.7080E-01,3.6267E-01,3.5482E-01,3.4841E-01,3.4190E-01,3.3492E-01,
36956 &3.2852E-01,3.2287E-01,3.1768E-01,3.1409E-01,3.1066E-01,3.0785E-01,
36957 &3.0564E-01,3.0446E-01,3.0380E-01,3.0388E-01,3.0402E-01,3.0458E-01,
36958 &3.0488E-01,3.0475E-01,3.0386E-01,3.0263E-01,3.0116E-01,3.0045E-01,
36959 &3.0296E-01,3.0852E-01,3.1888E-01,3.3085E-01,3.4677E-01,3.6222E-01,
36960 &3.7600E-01,3.8707E-01,3.9488E-01,3.9799E-01,3.9530E-01,3.8568E-01,
36961 &3.6791E-01,3.4080E-01,3.0424E-01,4.4195E-01,4.5570E-01,4.7648E-01,
36962 &5.0935E-01,5.6099E-01,6.4225E-01,7.6680E-01,9.6736E-01,1.3053E+00,
36963 &1.9393E+00,3.3976E+00,0.0000E+00,0.0000E+00,7.4015E-01,7.2498E-01,
36964 &7.0940E-01,6.9297E-01,6.7620E-01,6.5800E-01,6.3935E-01,6.2047E-01,
36965 &6.0114E-01,5.8076E-01,5.6065E-01,5.4030E-01,5.2035E-01,5.0839E-01,
36966 &4.9583E-01,4.8167E-01,4.6773E-01,4.5434E-01,4.4113E-01,4.3035E-01,
36967 &4.1922E-01,4.0719E-01,3.9582E-01,3.8536E-01,3.7557E-01,3.6805E-01/
36968 DATA (XUDF_L(K),K= 571, 684) /
36969 &3.6079E-01,3.5336E-01,3.4710E-01,3.4173E-01,3.3719E-01,3.3400E-01,
36970 &3.3124E-01,3.2819E-01,3.2494E-01,3.2158E-01,3.1765E-01,3.1400E-01,
36971 &3.1011E-01,3.0684E-01,3.0682E-01,3.1046E-01,3.1856E-01,3.2861E-01,
36972 &3.4189E-01,3.5475E-01,3.6597E-01,3.7463E-01,3.8003E-01,3.8108E-01,
36973 &3.7681E-01,3.6631E-01,3.4865E-01,3.2327E-01,2.9078E-01,4.1488E-01,
36974 &4.2529E-01,4.4193E-01,4.6945E-01,5.1322E-01,5.8236E-01,6.8846E-01,
36975 &8.5739E-01,1.1394E+00,1.6617E+00,2.8395E+00,0.0000E+00,0.0000E+00,
36976 &9.8501E-01,9.5975E-01,9.3420E-01,9.0757E-01,8.8092E-01,8.5237E-01,
36977 &8.2383E-01,7.9445E-01,7.6556E-01,7.3524E-01,7.0484E-01,6.7495E-01,
36978 &6.4547E-01,6.2798E-01,6.0969E-01,5.8904E-01,5.6882E-01,5.4932E-01,
36979 &5.3014E-01,5.1443E-01,4.9826E-01,4.8058E-01,4.6380E-01,4.4815E-01,
36980 &4.3330E-01,4.2167E-01,4.1020E-01,3.9827E-01,3.8748E-01,3.7784E-01,
36981 &3.6931E-01,3.6303E-01,3.5669E-01,3.4992E-01,3.4358E-01,3.3710E-01,
36982 &3.3025E-01,3.2429E-01,3.1817E-01,3.1242E-01,3.1001E-01,3.1195E-01,
36983 &3.1802E-01,3.2610E-01,3.3719E-01,3.4770E-01,3.5674E-01,3.6357E-01,
36984 &3.6695E-01,3.6631E-01,3.6075E-01,3.4960E-01,3.3214E-01,3.0855E-01,
36985 &2.7931E-01,3.9198E-01,3.9931E-01,4.1263E-01,4.3550E-01,4.7310E-01,
36986 &5.3259E-01,6.2375E-01,7.6876E-01,1.0087E+00,1.4464E+00,2.4185E+00,
36987 &0.0000E+00,0.0000E+00,1.2917E+00,1.2523E+00,1.2128E+00,1.1722E+00/
36988 DATA (XUDF_L(K),K= 685, 798) /
36989 &1.1321E+00,1.0894E+00,1.0473E+00,1.0044E+00,9.6262E-01,9.1838E-01,
36990 &8.7565E-01,8.3283E-01,7.9186E-01,7.6734E-01,7.4146E-01,7.1300E-01,
36991 &6.8484E-01,6.5787E-01,6.3134E-01,6.0963E-01,5.8730E-01,5.6294E-01,
36992 &5.3947E-01,5.1767E-01,4.9689E-01,4.8039E-01,4.6398E-01,4.4675E-01,
36993 &4.3087E-01,4.1650E-01,4.0371E-01,3.9342E-01,3.8361E-01,3.7293E-01,
36994 &3.6284E-01,3.5305E-01,3.4307E-01,3.3468E-01,3.2613E-01,3.1788E-01,
36995 &3.1306E-01,3.1309E-01,3.1715E-01,3.2346E-01,3.3232E-01,3.4066E-01,
36996 &3.4779E-01,3.5251E-01,3.5401E-01,3.5184E-01,3.4519E-01,3.3347E-01,
36997 &3.1650E-01,2.9433E-01,2.6872E-01,3.6968E-01,3.7446E-01,3.8477E-01,
36998 &4.0368E-01,4.3551E-01,4.8654E-01,5.6457E-01,6.8832E-01,8.9135E-01,
36999 &1.2583E+00,2.0601E+00,0.0000E+00,0.0000E+00,1.6499E+00,1.5928E+00,
37000 &1.5356E+00,1.4773E+00,1.4202E+00,1.3601E+00,1.3009E+00,1.2413E+00,
37001 &1.1836E+00,1.1235E+00,1.0650E+00,1.0076E+00,9.5212E-01,9.1919E-01,
37002 &8.8569E-01,8.4733E-01,8.1006E-01,7.7436E-01,7.3955E-01,7.1104E-01,
37003 &6.8173E-01,6.4966E-01,6.1893E-01,5.9026E-01,5.6287E-01,5.4114E-01,
37004 &5.1941E-01,4.9621E-01,4.7490E-01,4.5564E-01,4.3786E-01,4.2408E-01,
37005 &4.1024E-01,3.9562E-01,3.8175E-01,3.6853E-01,3.5541E-01,3.4455E-01,
37006 &3.3366E-01,3.2286E-01,3.1565E-01,3.1397E-01,3.1618E-01,3.2069E-01,
37007 &3.2744E-01,3.3383E-01,3.3911E-01,3.4194E-01,3.4194E-01,3.3844E-01/
37008 DATA (XUDF_L(K),K= 799, 912) /
37009 &3.3088E-01,3.1887E-01,3.0224E-01,2.8177E-01,2.5901E-01,3.4945E-01,
37010 &3.5200E-01,3.5959E-01,3.7518E-01,4.0212E-01,4.4590E-01,5.1305E-01,
37011 &6.1934E-01,7.9273E-01,1.1025E+00,1.7693E+00,0.0000E+00,0.0000E+00,
37012 &2.0413E+00,1.9626E+00,1.8840E+00,1.8053E+00,1.7284E+00,1.6480E+00,
37013 &1.5697E+00,1.4911E+00,1.4157E+00,1.3375E+00,1.2620E+00,1.1875E+00,
37014 &1.1168E+00,1.0751E+00,1.0321E+00,9.8410E-01,9.3682E-01,8.9196E-01,
37015 &8.4816E-01,8.1245E-01,7.7582E-01,7.3576E-01,6.9745E-01,6.6154E-01,
37016 &6.2742E-01,6.0036E-01,5.7319E-01,5.4409E-01,5.1721E-01,4.9291E-01,
37017 &4.7049E-01,4.5284E-01,4.3541E-01,4.1671E-01,3.9926E-01,3.8274E-01,
37018 &3.6660E-01,3.5348E-01,3.4035E-01,3.2727E-01,3.1788E-01,3.1459E-01,
37019 &3.1499E-01,3.1792E-01,3.2291E-01,3.2764E-01,3.3124E-01,3.3250E-01,
37020 &3.3120E-01,3.2663E-01,3.1834E-01,3.0608E-01,2.8998E-01,2.7085E-01,
37021 &2.5085E-01,3.3191E-01,3.3258E-01,3.3808E-01,3.5072E-01,3.7379E-01,
37022 &4.1182E-01,4.7005E-01,5.6257E-01,7.1233E-01,9.7788E-01,1.5412E+00,
37023 &0.0000E+00,0.0000E+00,2.6325E+00,2.5188E+00,2.4060E+00,2.2942E+00,
37024 &2.1863E+00,2.0740E+00,1.9650E+00,1.8571E+00,1.7537E+00,1.6473E+00,
37025 &1.5453E+00,1.4458E+00,1.3515E+00,1.2965E+00,1.2394E+00,1.1767E+00,
37026 &1.1150E+00,1.0560E+00,9.9927E-01,9.5301E-01,9.0565E-01,8.5400E-01,
37027 &8.0462E-01,7.5858E-01,7.1481E-01,6.7994E-01,6.4502E-01,6.0799E-01/
37028 DATA (XUDF_L(K),K= 913, 1026) /
37029 &5.7349E-01,5.4206E-01,5.1299E-01,4.9028E-01,4.6789E-01,4.4387E-01,
37030 &4.2168E-01,4.0096E-01,3.8070E-01,3.6457E-01,3.4857E-01,3.3249E-01,
37031 &3.2026E-01,3.1503E-01,3.1326E-01,3.1423E-01,3.1703E-01,3.1974E-01,
37032 &3.2120E-01,3.2086E-01,3.1799E-01,3.1221E-01,3.0315E-01,2.9072E-01,
37033 &2.7522E-01,2.5796E-01,2.4114E-01,3.1079E-01,3.0956E-01,3.1267E-01,
37034 &3.2223E-01,3.4089E-01,3.7246E-01,4.2134E-01,4.9853E-01,6.2305E-01,
37035 &8.4191E-01,1.2983E+00,0.0000E+00,0.0000E+00,3.2997E+00,3.1427E+00,
37036 &2.9900E+00,2.8374E+00,2.6927E+00,2.5421E+00,2.3973E+00,2.2549E+00,
37037 &2.1191E+00,1.9809E+00,1.8488E+00,1.7209E+00,1.6001E+00,1.5300E+00,
37038 &1.4576E+00,1.3771E+00,1.2999E+00,1.2268E+00,1.1551E+00,1.0975E+00,
37039 &1.0385E+00,9.7437E-01,9.1327E-01,8.5649E-01,8.0236E-01,7.5952E-01,
37040 &7.1667E-01,6.7091E-01,6.2847E-01,5.9005E-01,5.5422E-01,5.2636E-01,
37041 &4.9890E-01,4.6976E-01,4.4269E-01,4.1752E-01,3.9377E-01,3.7477E-01,
37042 &3.5594E-01,3.3710E-01,3.2226E-01,3.1511E-01,3.1131E-01,3.1067E-01,
37043 &3.1132E-01,3.1227E-01,3.1198E-01,3.1021E-01,3.0606E-01,2.9926E-01,
37044 &2.8958E-01,2.7716E-01,2.6233E-01,2.4655E-01,2.3275E-01,2.9229E-01,
37045 &2.8941E-01,2.9061E-01,2.9753E-01,3.1273E-01,3.3909E-01,3.8034E-01,
37046 &4.4548E-01,5.5028E-01,7.3256E-01,1.1074E+00,0.0000E+00,0.0000E+00,
37047 &4.0557E+00,3.8486E+00,3.6460E+00,3.4480E+00,3.2579E+00,3.0626E+00/
37048 DATA (XUDF_L(K),K= 1027, 1140) /
37049 &2.8756E+00,2.6929E+00,2.5196E+00,2.3441E+00,2.1778E+00,2.0170E+00,
37050 &1.8670E+00,1.7797E+00,1.6902E+00,1.5909E+00,1.4960E+00,1.4058E+00,
37051 &1.3191E+00,1.2484E+00,1.1764E+00,1.0991E+00,1.0253E+00,9.5689E-01,
37052 &8.9197E-01,8.4046E-01,7.8904E-01,7.3442E-01,6.8367E-01,6.3780E-01,
37053 &5.9520E-01,5.6218E-01,5.2934E-01,4.9500E-01,4.6300E-01,4.3370E-01,
37054 &4.0611E-01,3.8431E-01,3.6284E-01,3.4121E-01,3.2389E-01,3.1494E-01,
37055 &3.0926E-01,3.0697E-01,3.0594E-01,3.0501E-01,3.0330E-01,3.0019E-01,
37056 &2.9492E-01,2.8734E-01,2.7718E-01,2.6476E-01,2.5057E-01,2.3646E-01,
37057 &2.2503E-01,2.7558E-01,2.7132E-01,2.7089E-01,2.7569E-01,2.8794E-01,
37058 &3.1000E-01,3.4491E-01,4.0016E-01,4.8886E-01,6.4191E-01,9.5232E-01,
37059 &0.0000E+00,0.0000E+00,4.8799E+00,4.6116E+00,4.3560E+00,4.1035E+00,
37060 &3.8608E+00,3.6163E+00,3.3822E+00,3.1557E+00,2.9412E+00,2.7247E+00,
37061 &2.5209E+00,2.3248E+00,2.1421E+00,2.0368E+00,1.9287E+00,1.8094E+00,
37062 &1.6955E+00,1.5877E+00,1.4841E+00,1.4003E+00,1.3154E+00,1.2237E+00,
37063 &1.1368E+00,1.0563E+00,9.8015E-01,9.2005E-01,8.5978E-01,7.9615E-01,
37064 &7.3715E-01,6.8369E-01,6.3441E-01,5.9609E-01,5.5830E-01,5.1865E-01,
37065 &4.8192E-01,4.4872E-01,4.1747E-01,3.9300E-01,3.6895E-01,3.4483E-01,
37066 &3.2508E-01,3.1459E-01,3.0709E-01,3.0328E-01,3.0056E-01,2.9840E-01,
37067 &2.9543E-01,2.9107E-01,2.8485E-01,2.7655E-01,2.6610E-01,2.5368E-01/
37068 DATA (XUDF_L(K),K= 1141, 1254) /
37069 &2.4019E-01,2.2736E-01,2.1837E-01,2.6080E-01,2.5542E-01,2.5362E-01,
37070 &2.5693E-01,2.6661E-01,2.8505E-01,3.1490E-01,3.6226E-01,4.3798E-01,
37071 &5.6769E-01,8.2836E-01,0.0000E+00,0.0000E+00,5.8340E+00,5.4940E+00,
37072 &5.1700E+00,4.8532E+00,4.5515E+00,4.2463E+00,3.9559E+00,3.6752E+00,
37073 &3.4138E+00,3.1496E+00,2.9022E+00,2.6648E+00,2.4450E+00,2.3189E+00,
37074 &2.1896E+00,2.0476E+00,1.9120E+00,1.7843E+00,1.6621E+00,1.5639E+00,
37075 &1.4648E+00,1.3569E+00,1.2556E+00,1.1618E+00,1.0734E+00,1.0037E+00,
37076 &9.3416E-01,8.6065E-01,7.9257E-01,7.3145E-01,6.7463E-01,6.3082E-01,
37077 &5.8786E-01,5.4262E-01,5.0118E-01,4.6374E-01,4.2883E-01,4.0146E-01,
37078 &3.7490E-01,3.4814E-01,3.2612E-01,3.1397E-01,3.0482E-01,2.9958E-01,
37079 &2.9536E-01,2.9178E-01,2.8756E-01,2.8208E-01,2.7504E-01,2.6611E-01,
37080 &2.5539E-01,2.4319E-01,2.3031E-01,2.1877E-01,2.1195E-01,2.4673E-01,
37081 &2.4036E-01,2.3746E-01,2.3912E-01,2.4677E-01,2.6223E-01,2.8748E-01,
37082 &3.2792E-01,3.9255E-01,5.0271E-01,7.2095E-01,0.0000E+00,0.0000E+00,
37083 &6.8578E+00,6.4388E+00,6.0380E+00,5.6501E+00,5.2825E+00,4.9103E+00,
37084 &4.5613E+00,4.2230E+00,3.9070E+00,3.5911E+00,3.2966E+00,3.0156E+00,
37085 &2.7567E+00,2.6078E+00,2.4563E+00,2.2905E+00,2.1319E+00,1.9837E+00,
37086 &1.8421E+00,1.7287E+00,1.6141E+00,1.4902E+00,1.3730E+00,1.2663E+00,
37087 &1.1652E+00,1.0858E+00,1.0067E+00,9.2337E-01,8.4648E-01,7.7710E-01/
37088 DATA (XUDF_L(K),K= 1255, 1368) /
37089 &7.1333E-01,6.6392E-01,6.1566E-01,5.6531E-01,5.1904E-01,4.7761E-01,
37090 &4.3908E-01,4.0927E-01,3.8022E-01,3.5109E-01,3.2686E-01,3.1318E-01,
37091 &3.0244E-01,2.9602E-01,2.9031E-01,2.8538E-01,2.8024E-01,2.7382E-01,
37092 &2.6607E-01,2.5668E-01,2.4571E-01,2.3364E-01,2.2155E-01,2.1116E-01,
37093 &2.0617E-01,2.3421E-01,2.2704E-01,2.2320E-01,2.2366E-01,2.2952E-01,
37094 &2.4241E-01,2.6402E-01,2.9884E-01,3.5437E-01,4.4860E-01,6.3331E-01,
37095 &0.0000E+00,0.0000E+00,7.9784E+00,7.4673E+00,6.9820E+00,6.5121E+00,
37096 &6.0712E+00,5.6250E+00,5.2080E+00,4.8065E+00,4.4309E+00,4.0590E+00,
37097 &3.7131E+00,3.3843E+00,3.0816E+00,2.9094E+00,2.7332E+00,2.5420E+00,
37098 &2.3595E+00,2.1895E+00,2.0271E+00,1.8966E+00,1.7658E+00,1.6248E+00,
37099 &1.4933E+00,1.3718E+00,1.2579E+00,1.1683E+00,1.0795E+00,9.8589E-01,
37100 &8.9996E-01,8.2253E-01,7.5153E-01,6.9648E-01,6.4287E-01,5.8736E-01,
37101 &5.3655E-01,4.9109E-01,4.4891E-01,4.1655E-01,3.8518E-01,3.5367E-01,
37102 &3.2738E-01,3.1221E-01,3.0006E-01,2.9246E-01,2.8544E-01,2.7940E-01,
37103 &2.7319E-01,2.6601E-01,2.5763E-01,2.4782E-01,2.3676E-01,2.2486E-01,
37104 &2.1329E-01,2.0405E-01,2.0083E-01,2.2267E-01,2.1489E-01,2.1027E-01,
37105 &2.0967E-01,2.1409E-01,2.2473E-01,2.4320E-01,2.7316E-01,3.2113E-01,
37106 &4.0209E-01,5.5899E-01,0.0000E+00,0.0000E+00,9.1575E+00,8.5458E+00,
37107 &7.9700E+00,7.4123E+00,6.8876E+00,6.3653E+00,5.8736E+00,5.4042E+00/
37108 DATA (XUDF_L(K),K= 1369, 1482) /
37109 &4.9684E+00,4.5359E+00,4.1366E+00,3.7576E+00,3.4110E+00,3.2138E+00,
37110 &3.0122E+00,2.7943E+00,2.5871E+00,2.3944E+00,2.2102E+00,2.0646E+00,
37111 &1.9163E+00,1.7581E+00,1.6109E+00,1.4753E+00,1.3483E+00,1.2486E+00,
37112 &1.1500E+00,1.0462E+00,9.5130E-01,8.6585E-01,7.8770E-01,7.2741E-01,
37113 &6.6891E-01,6.0781E-01,5.5266E-01,5.0342E-01,4.5788E-01,4.2322E-01,
37114 &3.8960E-01,3.5594E-01,3.2768E-01,3.1125E-01,2.9779E-01,2.8890E-01,
37115 &2.8091E-01,2.7385E-01,2.6670E-01,2.5886E-01,2.4989E-01,2.3976E-01,
37116 &2.2861E-01,2.1703E-01,2.0604E-01,1.9777E-01,1.9598E-01,2.1238E-01,
37117 &2.0408E-01,1.9879E-01,1.9735E-01,2.0048E-01,2.0933E-01,2.2523E-01,
37118 &2.5120E-01,2.9296E-01,3.6305E-01,4.9711E-01,0.0000E+00,0.0000E+00,
37119 &1.0956E+01,1.0188E+01,9.4660E+00,8.7704E+00,8.1209E+00,7.4727E+00,
37120 &6.8721E+00,6.2972E+00,5.7646E+00,5.2434E+00,4.7595E+00,4.3051E+00,
37121 &3.8911E+00,3.6559E+00,3.4174E+00,3.1598E+00,2.9153E+00,2.6889E+00,
37122 &2.4732E+00,2.3031E+00,2.1311E+00,1.9475E+00,1.7771E+00,1.6202E+00,
37123 &1.4748E+00,1.3609E+00,1.2481E+00,1.1301E+00,1.0222E+00,9.2549E-01,
37124 &8.3728E-01,7.6947E-01,7.0373E-01,6.3561E-01,5.7438E-01,5.1959E-01,
37125 &4.6984E-01,4.3187E-01,3.9529E-01,3.5864E-01,3.2783E-01,3.0967E-01,
37126 &2.9444E-01,2.8428E-01,2.7469E-01,2.6638E-01,2.5813E-01,2.4942E-01,
37127 &2.3986E-01,2.2937E-01,2.1819E-01,2.0682E-01,1.9665E-01,1.8966E-01/
37128 DATA (XUDF_L(K),K= 1483, 1596) /
37129 &1.8971E-01,1.9926E-01,1.9036E-01,1.8442E-01,1.8192E-01,1.8362E-01,
37130 &1.9037E-01,2.0318E-01,2.2459E-01,2.5904E-01,3.1665E-01,4.2407E-01,
37131 &0.0000E+00,0.0000E+00,1.2798E+01,1.1861E+01,1.0986E+01,1.0144E+01,
37132 &9.3643E+00,8.5887E+00,7.8706E+00,7.1866E+00,6.5568E+00,5.9419E+00,
37133 &5.3754E+00,4.8419E+00,4.3593E+00,4.0864E+00,3.8109E+00,3.5127E+00,
37134 &3.2315E+00,2.9714E+00,2.7252E+00,2.5309E+00,2.3356E+00,2.1269E+00,
37135 &1.9338E+00,1.7578E+00,1.5939E+00,1.4656E+00,1.3394E+00,1.2075E+00,
37136 &1.0875E+00,9.8023E-01,8.8256E-01,8.0772E-01,7.3533E-01,6.6054E-01,
37137 &5.9364E-01,5.3423E-01,4.8009E-01,4.3930E-01,4.0003E-01,3.6079E-01,
37138 &3.2768E-01,3.0809E-01,2.9130E-01,2.7993E-01,2.6898E-01,2.5976E-01,
37139 &2.5062E-01,2.4123E-01,2.3116E-01,2.2040E-01,2.0917E-01,1.9814E-01,
37140 &1.8865E-01,1.8272E-01,1.8428E-01,1.8820E-01,1.7883E-01,1.7238E-01,
37141 &1.6914E-01,1.6979E-01,1.7482E-01,1.8534E-01,2.0325E-01,2.3214E-01,
37142 &2.8022E-01,3.6659E-01,0.0000E+00,0.0000E+00,1.4900E+01,1.3767E+01,
37143 &1.2708E+01,1.1700E+01,1.0766E+01,9.8403E+00,8.9832E+00,8.1757E+00,
37144 &7.4366E+00,6.7121E+00,6.0486E+00,5.4300E+00,4.8704E+00,4.5555E+00,
37145 &4.2371E+00,3.8955E+00,3.5734E+00,3.2760E+00,2.9952E+00,2.7738E+00,
37146 &2.5528E+00,2.3175E+00,2.1001E+00,1.9012E+00,1.7176E+00,1.5750E+00,
37147 &1.4344E+00,1.2880E+00,1.1547E+00,1.0364E+00,9.2859E-01,8.4652E-01/
37148 DATA (XUDF_L(K),K= 1597, 1710) /
37149 &7.6723E-01,6.8578E-01,6.1255E-01,5.4848E-01,4.9034E-01,4.4649E-01,
37150 &4.0456E-01,3.6275E-01,3.2738E-01,3.0624E-01,2.8805E-01,2.7544E-01,
37151 &2.6343E-01,2.5315E-01,2.4318E-01,2.3314E-01,2.2263E-01,2.1166E-01,
37152 &2.0051E-01,1.8983E-01,1.8102E-01,1.7610E-01,1.7901E-01,1.7764E-01,
37153 &1.6791E-01,1.6102E-01,1.5715E-01,1.5684E-01,1.6056E-01,1.6899E-01,
37154 &1.8376E-01,2.0786E-01,2.4776E-01,3.1470E-01,0.0000E+00,0.0000E+00,
37155 &1.7212E+01,1.5853E+01,1.4590E+01,1.3390E+01,1.2283E+01,1.1191E+01,
37156 &1.0185E+01,9.2395E+00,8.3762E+00,7.5315E+00,6.7670E+00,6.0503E+00,
37157 &5.4086E+00,5.0481E+00,4.6843E+00,4.2940E+00,3.9280E+00,3.5917E+00,
37158 &3.2752E+00,3.0252E+00,2.7768E+00,2.5132E+00,2.2690E+00,2.0490E+00,
37159 &1.8445E+00,1.6857E+00,1.5301E+00,1.3685E+00,1.2219E+00,1.0920E+00,
37160 &9.7438E-01,8.8478E-01,7.9825E-01,7.1007E-01,6.3111E-01,5.6196E-01,
37161 &5.0016E-01,4.5321E-01,4.0867E-01,3.6435E-01,3.2686E-01,3.0431E-01,
37162 &2.8470E-01,2.7109E-01,2.5789E-01,2.4674E-01,2.3605E-01,2.2547E-01,
37163 &2.1459E-01,2.0348E-01,1.9237E-01,1.8201E-01,1.7376E-01,1.6982E-01,
37164 &1.7398E-01,1.6789E-01,1.5795E-01,1.5065E-01,1.4630E-01,1.4521E-01,
37165 &1.4773E-01,1.5443E-01,1.6659E-01,1.8664E-01,2.1966E-01,2.6878E-01,
37166 &0.0000E+00,0.0000E+00,1.9526E+01,1.7951E+01,1.6470E+01,1.5074E+01,
37167 &1.3790E+01,1.2527E+01,1.1370E+01,1.0282E+01,9.2958E+00,8.3330E+00/
37168 DATA (XUDF_L(K),K= 1711, 1824) /
37169 &7.4603E+00,6.6536E+00,5.9285E+00,5.5219E+00,5.1141E+00,4.6768E+00,
37170 &4.2681E+00,3.8926E+00,3.5402E+00,3.2626E+00,2.9882E+00,2.6963E+00,
37171 &2.4284E+00,2.1851E+00,1.9619E+00,1.7885E+00,1.6187E+00,1.4429E+00,
37172 &1.2838E+00,1.1431E+00,1.0159E+00,9.1924E-01,8.2663E-01,7.3180E-01,
37173 &6.4793E-01,5.7429E-01,5.0828E-01,4.5904E-01,4.1215E-01,3.6558E-01,
37174 &3.2620E-01,3.0238E-01,2.8167E-01,2.6700E-01,2.5302E-01,2.4098E-01,
37175 &2.2975E-01,2.1873E-01,2.0756E-01,1.9633E-01,1.8532E-01,1.7533E-01,
37176 &1.6763E-01,1.6450E-01,1.6959E-01,1.5953E-01,1.4943E-01,1.4185E-01,
37177 &1.3716E-01,1.3545E-01,1.3705E-01,1.4238E-01,1.5258E-01,1.6945E-01,
37178 &1.9705E-01,2.3049E-01,0.0000E+00,0.0000E+00,2.2141E+01,2.0286E+01,
37179 &1.8570E+01,1.6948E+01,1.5466E+01,1.4010E+01,1.2679E+01,1.1431E+01,
37180 &1.0303E+01,9.2106E+00,8.2239E+00,7.3077E+00,6.4926E+00,6.0348E+00,
37181 &5.5765E+00,5.0879E+00,4.6321E+00,4.2138E+00,3.8233E+00,3.5162E+00,
37182 &3.2122E+00,2.8907E+00,2.5960E+00,2.3300E+00,2.0856E+00,1.8954E+00,
37183 &1.7110E+00,1.5199E+00,1.3476E+00,1.1955E+00,1.0584E+00,9.5478E-01,
37184 &8.5531E-01,7.5417E-01,6.6439E-01,5.8623E-01,5.1682E-01,4.6468E-01,
37185 &4.1541E-01,3.6662E-01,3.2538E-01,3.0035E-01,2.7843E-01,2.6291E-01,
37186 &2.4798E-01,2.3522E-01,2.2346E-01,2.1203E-01,2.0062E-01,1.8935E-01,
37187 &1.7843E-01,1.6874E-01,1.6163E-01,1.5920E-01,1.6520E-01,1.5147E-01/
37188 DATA (XUDF_L(K),K= 1825, 1836) /
37189 &1.4120E-01,1.3349E-01,1.2844E-01,1.2620E-01,1.2701E-01,1.3118E-01,
37190 &1.3954E-01,1.5369E-01,1.7631E-01,1.9416E-01,0.0000E+00,0.0000E+00/
37191 DATA (XSF_L(K),K= 1, 114) /
37192 &8.9277E-03,9.2838E-03,9.6380E-03,9.9960E-03,1.0349E-02,1.0719E-02,
37193 &1.1082E-02,1.1442E-02,1.1792E-02,1.2148E-02,1.2489E-02,1.2817E-02,
37194 &1.3124E-02,1.3295E-02,1.3474E-02,1.3661E-02,1.3835E-02,1.3985E-02,
37195 &1.4121E-02,1.4217E-02,1.4303E-02,1.4379E-02,1.4419E-02,1.4434E-02,
37196 &1.4412E-02,1.4366E-02,1.4286E-02,1.4158E-02,1.3991E-02,1.3790E-02,
37197 &1.3553E-02,1.3335E-02,1.3094E-02,1.2821E-02,1.2580E-02,1.2410E-02,
37198 &1.2357E-02,1.2459E-02,1.2790E-02,1.3571E-02,1.5018E-02,1.6665E-02,
37199 &1.9113E-02,2.1832E-02,2.5587E-02,2.9818E-02,3.4535E-02,3.9813E-02,
37200 &4.5737E-02,5.2358E-02,5.9765E-02,6.8021E-02,7.7185E-02,8.7258E-02,
37201 &9.8198E-02,1.1073E-01,1.4216E-01,1.8364E-01,2.3959E-01,3.1758E-01,
37202 &4.3050E-01,6.0203E-01,8.8214E-01,1.3845E+00,2.4294E+00,5.2463E+00,
37203 &1.8903E+01,0.0000E+00,1.4987E-02,1.5468E-02,1.5936E-02,1.6403E-02,
37204 &1.6855E-02,1.7319E-02,1.7760E-02,1.8194E-02,1.8600E-02,1.9008E-02,
37205 &1.9382E-02,1.9730E-02,2.0033E-02,2.0199E-02,2.0359E-02,2.0523E-02,
37206 &2.0654E-02,2.0760E-02,2.0831E-02,2.0870E-02,2.0886E-02,2.0858E-02,
37207 &2.0798E-02,2.0680E-02,2.0523E-02,2.0363E-02,2.0127E-02,1.9825E-02,
37208 &1.9464E-02,1.9060E-02,1.8607E-02,1.8200E-02,1.7750E-02,1.7240E-02,
37209 &1.6759E-02,1.6362E-02,1.6103E-02,1.6050E-02,1.6240E-02,1.6916E-02,
37210 &1.8336E-02,2.0030E-02,2.2586E-02,2.5447E-02,2.9418E-02,3.3874E-02/
37211 DATA (XSF_L(K),K= 115, 228) /
37212 &3.8821E-02,4.4375E-02,5.0509E-02,5.7343E-02,6.4974E-02,7.3385E-02,
37213 &8.2640E-02,9.2732E-02,1.0354E-01,1.1667E-01,1.4809E-01,1.8910E-01,
37214 &2.4387E-01,3.1940E-01,4.2764E-01,5.9054E-01,8.5228E-01,1.3150E+00,
37215 &2.2623E+00,4.7596E+00,1.6445E+01,0.0000E+00,2.5010E-02,2.5616E-02,
37216 &2.6180E-02,2.6758E-02,2.7279E-02,2.7792E-02,2.8274E-02,2.8729E-02,
37217 &2.9134E-02,2.9513E-02,2.9836E-02,3.0110E-02,3.0324E-02,3.0417E-02,
37218 &3.0492E-02,3.0537E-02,3.0551E-02,3.0517E-02,3.0432E-02,3.0326E-02,
37219 &3.0181E-02,2.9954E-02,2.9663E-02,2.9316E-02,2.8913E-02,2.8508E-02,
37220 &2.8021E-02,2.7422E-02,2.6741E-02,2.5997E-02,2.5204E-02,2.4500E-02,
37221 &2.3734E-02,2.2858E-02,2.2019E-02,2.1281E-02,2.0698E-02,2.0402E-02,
37222 &2.0365E-02,2.0844E-02,2.2137E-02,2.3807E-02,2.6404E-02,2.9338E-02,
37223 &3.3433E-02,3.8036E-02,4.3135E-02,4.8799E-02,5.5061E-02,6.1999E-02,
37224 &6.9633E-02,7.8024E-02,8.7156E-02,9.6998E-02,1.0742E-01,1.2099E-01,
37225 &1.5162E-01,1.9121E-01,2.4363E-01,3.1510E-01,4.1638E-01,5.6669E-01,
37226 &8.0557E-01,1.2216E+00,2.0572E+00,4.2084E+00,1.3911E+01,0.0000E+00,
37227 &4.2554E-02,4.3210E-02,4.3820E-02,4.4379E-02,4.4862E-02,4.5317E-02,
37228 &4.5708E-02,4.6037E-02,4.6300E-02,4.6434E-02,4.6540E-02,4.6530E-02,
37229 &4.6426E-02,4.6317E-02,4.6155E-02,4.5919E-02,4.5622E-02,4.5267E-02,
37230 &4.4833E-02,4.4425E-02,4.3932E-02,4.3298E-02,4.2582E-02,4.1785E-02/
37231 DATA (XSF_L(K),K= 229, 342) /
37232 &4.0903E-02,4.0097E-02,3.9179E-02,3.8047E-02,3.6815E-02,3.5547E-02,
37233 &3.4199E-02,3.3020E-02,3.1748E-02,3.0298E-02,2.8905E-02,2.7644E-02,
37234 &2.6563E-02,2.5882E-02,2.5485E-02,2.5614E-02,2.6651E-02,2.8199E-02,
37235 &3.0731E-02,3.3652E-02,3.7768E-02,4.2390E-02,4.7530E-02,5.3188E-02,
37236 &5.9436E-02,6.6257E-02,7.3734E-02,8.1918E-02,9.0696E-02,1.0004E-01,
37237 &1.0978E-01,1.2357E-01,1.5274E-01,1.8999E-01,2.3888E-01,3.0452E-01,
37238 &3.9656E-01,5.3136E-01,7.4246E-01,1.1043E+00,1.8158E+00,3.6023E+00,
37239 &0.0000E+00,0.0000E+00,7.3602E-02,7.4085E-02,7.4460E-02,7.4729E-02,
37240 &7.4904E-02,7.4982E-02,7.4902E-02,7.4713E-02,7.4446E-02,7.3972E-02,
37241 &7.3397E-02,7.2626E-02,7.1803E-02,7.1200E-02,7.0479E-02,6.9610E-02,
37242 &6.8654E-02,6.7624E-02,6.6495E-02,6.5467E-02,6.4313E-02,6.2898E-02,
37243 &6.1380E-02,5.9788E-02,5.8079E-02,5.6557E-02,5.4876E-02,5.2866E-02,
37244 &5.0733E-02,4.8592E-02,4.6341E-02,4.4415E-02,4.2370E-02,4.0073E-02,
37245 &3.7825E-02,3.5778E-02,3.3956E-02,3.2702E-02,3.1749E-02,3.1334E-02,
37246 &3.1922E-02,3.3216E-02,3.5534E-02,3.8322E-02,4.2321E-02,4.6830E-02,
37247 &5.1816E-02,5.7335E-02,6.3369E-02,6.9947E-02,7.7109E-02,8.4752E-02,
37248 &9.2948E-02,1.0153E-01,1.1031E-01,1.2405E-01,1.5100E-01,1.8509E-01,
37249 &2.2905E-01,2.8761E-01,3.6847E-01,4.8537E-01,6.6543E-01,9.6831E-01,
37250 &1.5524E+00,2.9766E+00,0.0000E+00,0.0000E+00,1.1509E-01,1.1500E-01/
37251 DATA (XSF_L(K),K= 343, 456) /
37252 &1.1474E-01,1.1430E-01,1.1371E-01,1.1292E-01,1.1196E-01,1.1079E-01,
37253 &1.0948E-01,1.0791E-01,1.0620E-01,1.0426E-01,1.0215E-01,1.0076E-01,
37254 &9.9224E-02,9.7466E-02,9.5472E-02,9.3507E-02,9.1346E-02,8.9460E-02,
37255 &8.7382E-02,8.4914E-02,8.2326E-02,7.9663E-02,7.6874E-02,7.4459E-02,
37256 &7.1794E-02,6.8694E-02,6.5489E-02,6.2266E-02,5.8964E-02,5.6164E-02,
37257 &5.3226E-02,4.9916E-02,4.6721E-02,4.3794E-02,4.1128E-02,3.9225E-02,
37258 &3.7654E-02,3.6613E-02,3.6666E-02,3.7626E-02,3.9655E-02,4.2227E-02,
37259 &4.6000E-02,5.0288E-02,5.5044E-02,6.0308E-02,6.6020E-02,7.2218E-02,
37260 &7.8943E-02,8.6079E-02,9.3611E-02,1.0141E-01,1.0925E-01,1.2274E-01,
37261 &1.4748E-01,1.7840E-01,2.1791E-01,2.6997E-01,3.4109E-01,4.4280E-01,
37262 &5.9706E-01,8.5325E-01,1.3371E+00,2.4909E+00,0.0000E+00,0.0000E+00,
37263 &1.8131E-01,1.7986E-01,1.7802E-01,1.7597E-01,1.7372E-01,1.7110E-01,
37264 &1.6825E-01,1.6515E-01,1.6187E-01,1.5820E-01,1.5428E-01,1.5016E-01,
37265 &1.4582E-01,1.4314E-01,1.4017E-01,1.3677E-01,1.3315E-01,1.2951E-01,
37266 &1.2571E-01,1.2248E-01,1.1891E-01,1.1472E-01,1.1045E-01,1.0615E-01,
37267 &1.0173E-01,9.7944E-02,9.3854E-02,8.9131E-02,8.4347E-02,7.9597E-02,
37268 &7.4799E-02,7.0788E-02,6.6599E-02,6.1932E-02,5.7438E-02,5.3307E-02,
37269 &4.9546E-02,4.6816E-02,4.4417E-02,4.2536E-02,4.1862E-02,4.2361E-02,
37270 &4.3960E-02,4.6198E-02,4.9612E-02,5.3553E-02,5.7974E-02,6.2830E-02/
37271 DATA (XSF_L(K),K= 457, 570) /
37272 &6.8141E-02,7.3865E-02,7.9970E-02,8.6422E-02,9.3160E-02,1.0006E-01,
37273 &1.0685E-01,1.1989E-01,1.4199E-01,1.6937E-01,2.0407E-01,2.4925E-01,
37274 &3.1029E-01,3.9635E-01,5.2529E-01,7.3579E-01,1.1263E+00,2.0347E+00,
37275 &0.0000E+00,0.0000E+00,2.6278E-01,2.5883E-01,2.5460E-01,2.5007E-01,
37276 &2.4526E-01,2.3995E-01,2.3437E-01,2.2848E-01,2.2242E-01,2.1578E-01,
37277 &2.0894E-01,2.0181E-01,1.9465E-01,1.9018E-01,1.8540E-01,1.7984E-01,
37278 &1.7415E-01,1.6846E-01,1.6261E-01,1.5768E-01,1.5234E-01,1.4615E-01,
37279 &1.3987E-01,1.3368E-01,1.2736E-01,1.2199E-01,1.1628E-01,1.0975E-01,
37280 &1.0321E-01,9.6788E-02,9.0380E-02,8.5059E-02,7.9532E-02,7.3436E-02,
37281 &6.7594E-02,6.2243E-02,5.7363E-02,5.3720E-02,5.0502E-02,4.7772E-02,
37282 &4.6346E-02,4.6358E-02,4.7497E-02,4.9377E-02,5.2401E-02,5.5965E-02,
37283 &6.0009E-02,6.4489E-02,6.9334E-02,7.4546E-02,8.0117E-02,8.5936E-02,
37284 &9.1972E-02,9.8056E-02,1.0398E-01,1.1644E-01,1.3628E-01,1.6068E-01,
37285 &1.9127E-01,2.3085E-01,2.8377E-01,3.5756E-01,4.6698E-01,6.4315E-01,
37286 &9.6485E-01,1.6969E+00,0.0000E+00,0.0000E+00,3.6944E-01,3.6187E-01,
37287 &3.5380E-01,3.4525E-01,3.3659E-01,3.2716E-01,3.1761E-01,3.0767E-01,
37288 &2.9759E-01,2.8675E-01,2.7586E-01,2.6462E-01,2.5339E-01,2.4660E-01,
37289 &2.3933E-01,2.3101E-01,2.2257E-01,2.1415E-01,2.0571E-01,1.9854E-01,
37290 &1.9083E-01,1.8216E-01,1.7338E-01,1.6480E-01,1.5613E-01,1.4885E-01/
37291 DATA (XSF_L(K),K= 571, 684) /
37292 &1.4115E-01,1.3244E-01,1.2380E-01,1.1542E-01,1.0713E-01,1.0031E-01,
37293 &9.3226E-02,8.5515E-02,7.8171E-02,7.1449E-02,6.5307E-02,6.0723E-02,
37294 &5.6523E-02,5.2878E-02,5.0622E-02,5.0109E-02,5.0720E-02,5.2187E-02,
37295 &5.4770E-02,5.7950E-02,6.1582E-02,6.5595E-02,6.9997E-02,7.4716E-02,
37296 &7.9677E-02,8.4886E-02,9.0221E-02,9.5543E-02,1.0065E-01,1.1245E-01,
37297 &1.3012E-01,1.5166E-01,1.7859E-01,2.1305E-01,2.5881E-01,3.2188E-01,
37298 &4.1454E-01,5.6186E-01,8.2718E-01,1.4188E+00,0.0000E+00,0.0000E+00,
37299 &4.9195E-01,4.7916E-01,4.6620E-01,4.5277E-01,4.3908E-01,4.2463E-01,
37300 &4.0985E-01,3.9491E-01,3.7975E-01,3.6377E-01,3.4790E-01,3.3178E-01,
37301 &3.1592E-01,3.0640E-01,2.9622E-01,2.8462E-01,2.7303E-01,2.6160E-01,
37302 &2.5012E-01,2.4047E-01,2.3023E-01,2.1867E-01,2.0717E-01,1.9597E-01,
37303 &1.8477E-01,1.7546E-01,1.6568E-01,1.5468E-01,1.4387E-01,1.3343E-01,
37304 &1.2319E-01,1.1482E-01,1.0622E-01,9.6828E-02,8.7978E-02,7.9884E-02,
37305 &7.2526E-02,6.6973E-02,6.1948E-02,5.7359E-02,5.4304E-02,5.3263E-02,
37306 &5.3381E-02,5.4456E-02,5.6601E-02,5.9380E-02,6.2613E-02,6.6252E-02,
37307 &7.0174E-02,7.4432E-02,7.8943E-02,8.3559E-02,8.8282E-02,9.2963E-02,
37308 &9.7382E-02,1.0858E-01,1.2441E-01,1.4363E-01,1.6745E-01,1.9778E-01,
37309 &2.3771E-01,2.9246E-01,3.7200E-01,4.9738E-01,7.2010E-01,1.2083E+00,
37310 &0.0000E+00,0.0000E+00,6.4521E-01,6.2534E-01,6.0540E-01,5.8499E-01/
37311 DATA (XSF_L(K),K= 685, 798) /
37312 &5.6467E-01,5.4301E-01,5.2143E-01,4.9951E-01,4.7813E-01,4.5538E-01,
37313 &4.3325E-01,4.1083E-01,3.8899E-01,3.7591E-01,3.6210E-01,3.4648E-01,
37314 &3.3091E-01,3.1578E-01,3.0062E-01,2.8797E-01,2.7469E-01,2.5979E-01,
37315 &2.4501E-01,2.3066E-01,2.1649E-01,2.0481E-01,1.9252E-01,1.7884E-01,
37316 &1.6549E-01,1.5274E-01,1.4029E-01,1.3018E-01,1.1985E-01,1.0865E-01,
37317 &9.8135E-02,8.8550E-02,7.9829E-02,7.3318E-02,6.7269E-02,6.1748E-02,
37318 &5.7838E-02,5.6250E-02,5.5826E-02,5.6474E-02,5.8181E-02,6.0533E-02,
37319 &6.3373E-02,6.6563E-02,7.0085E-02,7.3865E-02,7.7842E-02,8.1937E-02,
37320 &8.6092E-02,9.0169E-02,9.3962E-02,1.0448E-01,1.1858E-01,1.3561E-01,
37321 &1.5663E-01,1.8318E-01,2.1803E-01,2.6529E-01,3.3349E-01,4.3985E-01,
37322 &6.2661E-01,1.0291E+00,0.0000E+00,0.0000E+00,8.2462E-01,7.9558E-01,
37323 &7.6680E-01,7.3764E-01,7.0860E-01,6.7834E-01,6.4822E-01,6.1798E-01,
37324 &5.8880E-01,5.5792E-01,5.2800E-01,4.9801E-01,4.6912E-01,4.5197E-01,
37325 &4.3393E-01,4.1360E-01,3.9348E-01,3.7394E-01,3.5462E-01,3.3856E-01,
37326 &3.2180E-01,3.0303E-01,2.8460E-01,2.6681E-01,2.4932E-01,2.3502E-01,
37327 &2.2005E-01,2.0359E-01,1.8747E-01,1.7224E-01,1.5746E-01,1.4551E-01,
37328 &1.3337E-01,1.2028E-01,1.0805E-01,9.6986E-02,8.6877E-02,7.9334E-02,
37329 &7.2326E-02,6.5799E-02,6.1060E-02,5.8911E-02,5.7957E-02,5.8189E-02,
37330 &5.9441E-02,6.1387E-02,6.3834E-02,6.6632E-02,6.9732E-02,7.3070E-02/
37331 DATA (XSF_L(K),K= 799, 912) /
37332 &7.6595E-02,8.0190E-02,8.3816E-02,8.7358E-02,9.0631E-02,1.0046E-01,
37333 &1.1304E-01,1.2815E-01,1.4670E-01,1.7006E-01,2.0049E-01,2.4154E-01,
37334 &3.0039E-01,3.9121E-01,5.4894E-01,8.8378E-01,0.0000E+00,0.0000E+00,
37335 &1.0199E+00,9.8025E-01,9.4100E-01,9.0151E-01,8.6283E-01,8.2243E-01,
37336 &7.8262E-01,7.4321E-01,7.0465E-01,6.6494E-01,6.2647E-01,5.8811E-01,
37337 &5.5152E-01,5.2985E-01,5.0721E-01,4.8183E-01,4.5681E-01,4.3274E-01,
37338 &4.0883E-01,3.8916E-01,3.6878E-01,3.4589E-01,3.2366E-01,3.0238E-01,
37339 &2.8152E-01,2.6437E-01,2.4685E-01,2.2733E-01,2.0858E-01,1.9085E-01,
37340 &1.7375E-01,1.6000E-01,1.4607E-01,1.3115E-01,1.1722E-01,1.0469E-01,
37341 &9.3284E-02,8.4739E-02,7.6803E-02,6.9420E-02,6.3844E-02,6.1178E-02,
37342 &5.9720E-02,5.9561E-02,6.0398E-02,6.1984E-02,6.4051E-02,6.6494E-02,
37343 &6.9202E-02,7.2161E-02,7.5274E-02,7.8453E-02,8.1651E-02,8.4728E-02,
37344 &8.7564E-02,9.6777E-02,1.0806E-01,1.2157E-01,1.3806E-01,1.5882E-01,
37345 &1.8566E-01,2.2170E-01,2.7301E-01,3.5168E-01,4.8696E-01,7.7010E-01,
37346 &0.0000E+00,0.0000E+00,1.3158E+00,1.2585E+00,1.2024E+00,1.1462E+00,
37347 &1.0919E+00,1.0352E+00,9.8042E-01,9.2608E-01,8.7345E-01,8.1987E-01,
37348 &7.6814E-01,7.1724E-01,6.6882E-01,6.4053E-01,6.1093E-01,5.7796E-01,
37349 &5.4572E-01,5.1470E-01,4.8433E-01,4.5934E-01,4.3358E-01,4.0495E-01,
37350 &3.7717E-01,3.5082E-01,3.2513E-01,3.0408E-01,2.8258E-01,2.5918E-01/
37351 DATA (XSF_L(K),K= 913, 1026) /
37352 &2.3648E-01,2.1538E-01,1.9510E-01,1.7888E-01,1.6255E-01,1.4508E-01,
37353 &1.2895E-01,1.1443E-01,1.0131E-01,9.1507E-02,8.2387E-02,7.3778E-02,
37354 &6.7147E-02,6.3813E-02,6.1721E-02,6.1065E-02,6.1373E-02,6.2475E-02,
37355 &6.4105E-02,6.6079E-02,6.8362E-02,7.0856E-02,7.3440E-02,7.6143E-02,
37356 &7.8812E-02,8.1388E-02,8.3726E-02,9.2167E-02,1.0190E-01,1.1355E-01,
37357 &1.2780E-01,1.4554E-01,1.6841E-01,1.9900E-01,2.4223E-01,3.0775E-01,
37358 &4.1920E-01,6.4849E-01,0.0000E+00,0.0000E+00,1.6483E+00,1.5703E+00,
37359 &1.4940E+00,1.4180E+00,1.3449E+00,1.2694E+00,1.1966E+00,1.1250E+00,
37360 &1.0566E+00,9.8644E-01,9.1985E-01,8.5482E-01,7.9312E-01,7.5722E-01,
37361 &7.1986E-01,6.7849E-01,6.3821E-01,5.9972E-01,5.6214E-01,5.3143E-01,
37362 &4.9987E-01,4.6500E-01,4.3136E-01,3.9956E-01,3.6875E-01,3.4379E-01,
37363 &3.1832E-01,2.9044E-01,2.6397E-01,2.3923E-01,2.1580E-01,1.9706E-01,
37364 &1.7829E-01,1.5838E-01,1.3999E-01,1.2356E-01,1.0875E-01,9.7664E-02,
37365 &8.7392E-02,7.7645E-02,7.0035E-02,6.6062E-02,6.3365E-02,6.2239E-02,
37366 &6.2062E-02,6.2731E-02,6.3942E-02,6.5526E-02,6.7390E-02,6.9436E-02,
37367 &7.1635E-02,7.3891E-02,7.6122E-02,7.8246E-02,8.0196E-02,8.7884E-02,
37368 &9.6357E-02,1.0648E-01,1.1880E-01,1.3413E-01,1.5386E-01,1.7993E-01,
37369 &2.1655E-01,2.7189E-01,3.6486E-01,5.5332E-01,0.0000E+00,0.0000E+00,
37370 &2.0271E+00,1.9234E+00,1.8224E+00,1.7226E+00,1.6272E+00,1.5293E+00/
37371 DATA (XSF_L(K),K= 1027, 1140) /
37372 &1.4356E+00,1.3438E+00,1.2568E+00,1.1682E+00,1.0841E+00,1.0026E+00,
37373 &9.2625E-01,8.8207E-01,8.3568E-01,7.8523E-01,7.3607E-01,6.8926E-01,
37374 &6.4385E-01,6.0685E-01,5.6892E-01,5.2730E-01,4.8731E-01,4.4961E-01,
37375 &4.1331E-01,3.8417E-01,3.5441E-01,3.2210E-01,2.9168E-01,2.6323E-01,
37376 &2.3631E-01,2.1500E-01,1.9374E-01,1.7129E-01,1.5067E-01,1.3231E-01,
37377 &1.1579E-01,1.0349E-01,9.2080E-02,8.1205E-02,7.2626E-02,6.8039E-02,
37378 &6.4761E-02,6.3188E-02,6.2549E-02,6.2795E-02,6.3617E-02,6.4835E-02,
37379 &6.6329E-02,6.8017E-02,6.9809E-02,7.1667E-02,7.3520E-02,7.5270E-02,
37380 &7.6864E-02,8.3899E-02,9.1206E-02,1.0002E-01,1.1070E-01,1.2399E-01,
37381 &1.4094E-01,1.6341E-01,1.9474E-01,2.4163E-01,3.1971E-01,4.7587E-01,
37382 &0.0000E+00,0.0000E+00,2.4392E+00,2.3049E+00,2.1760E+00,2.0502E+00,
37383 &1.9296E+00,1.8065E+00,1.6895E+00,1.5750E+00,1.4674E+00,1.3585E+00,
37384 &1.2554E+00,1.1565E+00,1.0638E+00,1.0103E+00,9.5527E-01,8.9449E-01,
37385 &8.3572E-01,7.8018E-01,7.2635E-01,6.8280E-01,6.3819E-01,5.8948E-01,
37386 &5.4299E-01,4.9923E-01,4.5740E-01,4.2371E-01,3.8978E-01,3.5296E-01,
37387 &3.1832E-01,2.8629E-01,2.5599E-01,2.3212E-01,2.0840E-01,1.8346E-01,
37388 &1.6065E-01,1.4043E-01,1.2229E-01,1.0880E-01,9.6294E-02,8.4335E-02,
37389 &7.4905E-02,6.9717E-02,6.5897E-02,6.3914E-02,6.2851E-02,6.2731E-02,
37390 &6.3183E-02,6.4075E-02,6.5225E-02,6.6597E-02,6.8048E-02,6.9577E-02/
37391 DATA (XSF_L(K),K= 1141, 1254) /
37392 &7.1093E-02,7.2525E-02,7.3842E-02,8.0241E-02,8.6615E-02,9.4292E-02,
37393 &1.0360E-01,1.1517E-01,1.2992E-01,1.4936E-01,1.7633E-01,2.1652E-01,
37394 &2.8294E-01,4.1389E-01,0.0000E+00,0.0000E+00,2.9162E+00,2.7470E+00,
37395 &2.5840E+00,2.4244E+00,2.2743E+00,2.1215E+00,1.9764E+00,1.8358E+00,
37396 &1.7035E+00,1.5708E+00,1.4463E+00,1.3268E+00,1.2152E+00,1.1514E+00,
37397 &1.0857E+00,1.0132E+00,9.4449E-01,8.7867E-01,8.1556E-01,7.6453E-01,
37398 &7.1252E-01,6.5602E-01,6.0218E-01,5.5192E-01,5.0387E-01,4.6545E-01,
37399 &4.2679E-01,3.8521E-01,3.4602E-01,3.1005E-01,2.7623E-01,2.4962E-01,
37400 &2.2332E-01,1.9577E-01,1.7070E-01,1.4856E-01,1.2874E-01,1.1402E-01,
37401 &1.0040E-01,8.7343E-02,7.6984E-02,7.1254E-02,6.6892E-02,6.4508E-02,
37402 &6.3019E-02,6.2518E-02,6.2667E-02,6.3211E-02,6.4031E-02,6.5064E-02,
37403 &6.6243E-02,6.7458E-02,6.8679E-02,6.9830E-02,7.0885E-02,7.6672E-02,
37404 &8.2192E-02,8.8844E-02,9.6930E-02,1.0696E-01,1.1972E-01,1.3654E-01,
37405 &1.5978E-01,1.9411E-01,2.5048E-01,3.6023E-01,0.0000E+00,0.0000E+00,
37406 &3.4281E+00,3.2194E+00,3.0180E+00,2.8239E+00,2.6400E+00,2.4537E+00,
37407 &2.2781E+00,2.1087E+00,1.9503E+00,1.7915E+00,1.6433E+00,1.5021E+00,
37408 &1.3711E+00,1.2958E+00,1.2191E+00,1.1350E+00,1.0536E+00,9.7846E-01,
37409 &9.0526E-01,8.4668E-01,7.8697E-01,7.2243E-01,6.6110E-01,6.0402E-01,
37410 &5.4971E-01,5.0652E-01,4.6307E-01,4.1647E-01,3.7287E-01,3.3288E-01/
37411 DATA (XSF_L(K),K= 1255, 1368) /
37412 &2.9545E-01,2.6636E-01,2.3751E-01,2.0740E-01,1.8012E-01,1.5611E-01,
37413 &1.3467E-01,1.1881E-01,1.0414E-01,9.0105E-02,7.8839E-02,7.2563E-02,
37414 &6.7703E-02,6.4930E-02,6.3070E-02,6.2241E-02,6.2071E-02,6.2347E-02,
37415 &6.2882E-02,6.3645E-02,6.4526E-02,6.5473E-02,6.6427E-02,6.7333E-02,
37416 &6.8194E-02,7.3430E-02,7.8217E-02,8.3974E-02,9.1017E-02,9.9745E-02,
37417 &1.1088E-01,1.2552E-01,1.4563E-01,1.7528E-01,2.2351E-01,3.1636E-01,
37418 &0.0000E+00,0.0000E+00,3.9892E+00,3.7328E+00,3.4900E+00,3.2549E+00,
37419 &3.0344E+00,2.8108E+00,2.6014E+00,2.4001E+00,2.2123E+00,2.0253E+00,
37420 &1.8518E+00,1.6860E+00,1.5339E+00,1.4463E+00,1.3575E+00,1.2608E+00,
37421 &1.1678E+00,1.0809E+00,9.9767E-01,9.3087E-01,8.6314E-01,7.8996E-01,
37422 &7.2083E-01,6.5671E-01,5.9602E-01,5.4775E-01,4.9935E-01,4.4773E-01,
37423 &3.9951E-01,3.5571E-01,3.1467E-01,2.8272E-01,2.5135E-01,2.1871E-01,
37424 &1.8923E-01,1.6331E-01,1.4031E-01,1.2332E-01,1.0762E-01,9.2560E-02,
37425 &8.0473E-02,7.3714E-02,6.8385E-02,6.5246E-02,6.3019E-02,6.1878E-02,
37426 &6.1420E-02,6.1413E-02,6.1734E-02,6.2226E-02,6.2861E-02,6.3564E-02,
37427 &6.4288E-02,6.4985E-02,6.5657E-02,7.0367E-02,7.4522E-02,7.9506E-02,
37428 &8.5651E-02,9.3297E-02,1.0298E-01,1.1572E-01,1.3323E-01,1.5884E-01,
37429 &2.0039E-01,2.7925E-01,0.0000E+00,0.0000E+00,4.5788E+00,4.2729E+00,
37430 &3.9840E+00,3.7039E+00,3.4438E+00,3.1812E+00,2.9349E+00,2.6996E+00/
37431 DATA (XSF_L(K),K= 1369, 1482) /
37432 &2.4810E+00,2.2644E+00,2.0633E+00,1.8732E+00,1.6979E+00,1.5988E+00,
37433 &1.4974E+00,1.3865E+00,1.2812E+00,1.1834E+00,1.0891E+00,1.0143E+00,
37434 &9.3839E-01,8.5662E-01,7.7948E-01,7.0838E-01,6.4106E-01,5.8780E-01,
37435 &5.3454E-01,4.7781E-01,4.2528E-01,3.7737E-01,3.3289E-01,2.9818E-01,
37436 &2.6446E-01,2.2932E-01,1.9770E-01,1.7005E-01,1.4552E-01,1.2746E-01,
37437 &1.1078E-01,9.4770E-02,8.1957E-02,7.4689E-02,6.8915E-02,6.5457E-02,
37438 &6.2902E-02,6.1493E-02,6.0768E-02,6.0515E-02,6.0585E-02,6.0863E-02,
37439 &6.1298E-02,6.1789E-02,6.2311E-02,6.2835E-02,6.3340E-02,6.7601E-02,
37440 &7.1162E-02,7.5516E-02,8.0878E-02,8.7566E-02,9.6095E-02,1.0725E-01,
37441 &1.2258E-01,1.4495E-01,1.8090E-01,2.4841E-01,0.0000E+00,0.0000E+00,
37442 &5.4774E+00,5.0929E+00,4.7320E+00,4.3841E+00,4.0592E+00,3.7350E+00,
37443 &3.4329E+00,3.1454E+00,2.8799E+00,2.6172E+00,2.3747E+00,2.1466E+00,
37444 &1.9383E+00,1.8195E+00,1.6996E+00,1.5689E+00,1.4457E+00,1.3301E+00,
37445 &1.2211E+00,1.1339E+00,1.0456E+00,9.5119E-01,8.6259E-01,7.8097E-01,
37446 &7.0419E-01,6.4380E-01,5.8358E-01,5.1955E-01,4.6051E-01,4.0719E-01,
37447 &3.5768E-01,3.1962E-01,2.8220E-01,2.4360E-01,2.0909E-01,1.7895E-01,
37448 &1.5240E-01,1.3282E-01,1.1484E-01,9.7655E-02,8.3739E-02,7.5857E-02,
37449 &6.9509E-02,6.5616E-02,6.2633E-02,6.0853E-02,5.9819E-02,5.9271E-02,
37450 &5.9038E-02,5.9046E-02,5.9192E-02,5.9432E-02,5.9709E-02,6.0008E-02/
37451 DATA (XSF_L(K),K= 1483, 1596) /
37452 &6.0340E-02,6.4032E-02,6.6851E-02,7.0446E-02,7.4870E-02,8.0457E-02,
37453 &8.7554E-02,9.6862E-02,1.0964E-01,1.2821E-01,1.5779E-01,2.1189E-01,
37454 &0.0000E+00,0.0000E+00,6.3982E+00,5.9307E+00,5.4920E+00,5.0710E+00,
37455 &4.6822E+00,4.2915E+00,3.9337E+00,3.5898E+00,3.2756E+00,2.9660E+00,
37456 &2.6817E+00,2.4150E+00,2.1724E+00,2.0348E+00,1.8961E+00,1.7457E+00,
37457 &1.6034E+00,1.4714E+00,1.3471E+00,1.2473E+00,1.1476E+00,1.0408E+00,
37458 &9.4083E-01,8.4932E-01,7.6350E-01,6.9606E-01,6.2897E-01,5.5833E-01,
37459 &4.9315E-01,4.3444E-01,3.8044E-01,3.3861E-01,2.9817E-01,2.5642E-01,
37460 &2.1917E-01,1.8685E-01,1.5838E-01,1.3752E-01,1.1831E-01,9.9987E-02,
37461 &8.5224E-02,7.6762E-02,6.9910E-02,6.5655E-02,6.2297E-02,6.0213E-02,
37462 &5.8897E-02,5.8096E-02,5.7624E-02,5.7400E-02,5.7322E-02,5.7351E-02,
37463 &5.7432E-02,5.7560E-02,5.7758E-02,6.0939E-02,6.3212E-02,6.6167E-02,
37464 &6.9884E-02,7.4560E-02,8.0552E-02,8.8432E-02,9.9242E-02,1.1491E-01,
37465 &1.3966E-01,1.8320E-01,0.0000E+00,0.0000E+00,7.4490E+00,6.8826E+00,
37466 &6.3540E+00,5.8477E+00,5.3805E+00,4.9187E+00,4.4884E+00,4.0843E+00,
37467 &3.7147E+00,3.3516E+00,3.0193E+00,2.7088E+00,2.4279E+00,2.2696E+00,
37468 &2.1091E+00,1.9368E+00,1.7739E+00,1.6237E+00,1.4821E+00,1.3692E+00,
37469 &1.2557E+00,1.1358E+00,1.0238E+00,9.2133E-01,8.2567E-01,7.5070E-01,
37470 &6.7656E-01,5.9850E-01,5.2688E-01,4.6263E-01,4.0371E-01,3.5842E-01/
37471 DATA (XSF_L(K),K= 1597, 1710) /
37472 &3.1427E-01,2.6933E-01,2.2930E-01,1.9466E-01,1.6427E-01,1.4208E-01,
37473 &1.2168E-01,1.0226E-01,8.6560E-02,7.7553E-02,7.0202E-02,6.5576E-02,
37474 &6.1860E-02,5.9487E-02,5.7920E-02,5.6852E-02,5.6166E-02,5.5736E-02,
37475 &5.5458E-02,5.5289E-02,5.5193E-02,5.5163E-02,5.5243E-02,5.7935E-02,
37476 &5.9740E-02,6.2111E-02,6.5158E-02,6.9050E-02,7.4078E-02,8.0683E-02,
37477 &8.9776E-02,1.0288E-01,1.2351E-01,1.5725E-01,0.0000E+00,0.0000E+00,
37478 &8.6044E+00,7.9255E+00,7.2940E+00,6.6940E+00,6.1391E+00,5.5940E+00,
37479 &5.0907E+00,4.6180E+00,4.1841E+00,3.7622E+00,3.3775E+00,3.0195E+00,
37480 &2.6967E+00,2.5153E+00,2.3331E+00,2.1364E+00,1.9521E+00,1.7815E+00,
37481 &1.6211E+00,1.4944E+00,1.3683E+00,1.2334E+00,1.1084E+00,9.9465E-01,
37482 &8.8864E-01,8.0585E-01,7.2432E-01,6.3866E-01,5.6038E-01,4.9058E-01,
37483 &4.2648E-01,3.7768E-01,3.3036E-01,2.8189E-01,2.3907E-01,2.0214E-01,
37484 &1.6987E-01,1.4635E-01,1.2479E-01,1.0428E-01,8.7748E-02,7.8203E-02,
37485 &7.0386E-02,6.5431E-02,6.1373E-02,5.8719E-02,5.6916E-02,5.5642E-02,
37486 &5.4751E-02,5.4118E-02,5.3653E-02,5.3314E-02,5.3067E-02,5.2897E-02,
37487 &5.2861E-02,5.5140E-02,5.6493E-02,5.8378E-02,6.0860E-02,6.4090E-02,
37488 &6.8261E-02,7.3828E-02,8.1439E-02,9.2423E-02,1.0952E-01,1.3424E-01,
37489 &0.0000E+00,0.0000E+00,9.7645E+00,8.9701E+00,8.2340E+00,7.5357E+00,
37490 &6.8926E+00,6.2607E+00,5.6834E+00,5.1374E+00,4.6459E+00,4.1625E+00/
37491 DATA (XSF_L(K),K= 1711, 1824) /
37492 &3.7261E+00,3.3206E+00,2.9567E+00,2.7529E+00,2.5476E+00,2.3274E+00,
37493 &2.1217E+00,1.9320E+00,1.7541E+00,1.6131E+00,1.4740E+00,1.3257E+00,
37494 &1.1879E+00,1.0631E+00,9.4732E-01,8.5726E-01,7.6844E-01,6.7586E-01,
37495 &5.9131E-01,5.1597E-01,4.4748E-01,3.9504E-01,3.4470E-01,2.9317E-01,
37496 &2.4779E-01,2.0880E-01,1.7478E-01,1.5007E-01,1.2748E-01,1.0600E-01,
37497 &8.8713E-02,7.8704E-02,7.0472E-02,6.5220E-02,6.0885E-02,5.7993E-02,
37498 &5.5967E-02,5.4536E-02,5.3470E-02,5.2665E-02,5.2054E-02,5.1577E-02,
37499 &5.1203E-02,5.0930E-02,5.0809E-02,5.2731E-02,5.3716E-02,5.5192E-02,
37500 &5.7203E-02,5.9902E-02,6.3412E-02,6.8123E-02,7.4602E-02,8.3905E-02,
37501 &9.8185E-02,1.1515E-01,0.0000E+00,0.0000E+00,1.1069E+01,1.0141E+01,
37502 &9.2840E+00,8.4741E+00,7.7316E+00,7.0038E+00,6.3364E+00,5.7137E+00,
37503 &5.1475E+00,4.6031E+00,4.1059E+00,3.6477E+00,3.2381E+00,3.0086E+00,
37504 &2.7788E+00,2.5333E+00,2.3033E+00,2.0926E+00,1.8951E+00,1.7404E+00,
37505 &1.5854E+00,1.4229E+00,1.2715E+00,1.1352E+00,1.0089E+00,9.1089E-01,
37506 &8.1457E-01,7.1424E-01,6.2332E-01,5.4229E-01,4.6872E-01,4.1295E-01,
37507 &3.5903E-01,3.0454E-01,2.5654E-01,2.1539E-01,1.7965E-01,1.5373E-01,
37508 &1.3011E-01,1.0766E-01,8.9530E-02,7.9108E-02,7.0483E-02,6.4943E-02,
37509 &6.0331E-02,5.7203E-02,5.4990E-02,5.3395E-02,5.2144E-02,5.1206E-02,
37510 &5.0454E-02,4.9840E-02,4.9351E-02,4.8978E-02,4.8801E-02,5.0351E-02/
37511 DATA (XSF_L(K),K= 1825, 1836) /
37512 &5.1017E-02,5.2127E-02,5.3737E-02,5.5934E-02,5.8835E-02,6.2800E-02,
37513 &6.8260E-02,7.6135E-02,8.7873E-02,0.0000E+00,0.0000E+00,0.0000E+00/
37514 DATA (XGF_L(K),K= 1, 114) /
37515 &1.0646E+00,1.0934E+00,1.1214E+00,1.1484E+00,1.1741E+00,1.1999E+00,
37516 &1.2242E+00,1.2466E+00,1.2676E+00,1.2873E+00,1.3042E+00,1.3194E+00,
37517 &1.3313E+00,1.3376E+00,1.3430E+00,1.3472E+00,1.3502E+00,1.3504E+00,
37518 &1.3501E+00,1.3478E+00,1.3430E+00,1.3356E+00,1.3267E+00,1.3149E+00,
37519 &1.3003E+00,1.2857E+00,1.2680E+00,1.2451E+00,1.2189E+00,1.1899E+00,
37520 &1.1575E+00,1.1282E+00,1.0947E+00,1.0543E+00,1.0121E+00,9.6983E-01,
37521 &9.2809E-01,8.9556E-01,8.6663E-01,8.4606E-01,8.4971E-01,8.7714E-01,
37522 &9.3569E-01,1.0140E+00,1.1325E+00,1.2706E+00,1.4268E+00,1.6005E+00,
37523 &1.7918E+00,2.0014E+00,2.2301E+00,2.4791E+00,2.7490E+00,3.0404E+00,
37524 &3.3541E+00,3.5718E+00,4.2579E+00,5.0478E+00,5.9674E+00,7.0458E+00,
37525 &8.3375E+00,9.9284E+00,1.1949E+01,1.4650E+01,1.8560E+01,2.5096E+01,
37526 &4.0067E+01,0.0000E+00,1.6404E+00,1.6723E+00,1.7014E+00,1.7287E+00,
37527 &1.7533E+00,1.7768E+00,1.7973E+00,1.8152E+00,1.8297E+00,1.8417E+00,
37528 &1.8498E+00,1.8540E+00,1.8544E+00,1.8526E+00,1.8489E+00,1.8424E+00,
37529 &1.8335E+00,1.8221E+00,1.8091E+00,1.7949E+00,1.7784E+00,1.7555E+00,
37530 &1.7310E+00,1.7034E+00,1.6713E+00,1.6428E+00,1.6093E+00,1.5680E+00,
37531 &1.5230E+00,1.4754E+00,1.4241E+00,1.3785E+00,1.3278E+00,1.2681E+00,
37532 &1.2068E+00,1.1462E+00,1.0867E+00,1.0400E+00,9.9665E-01,9.6041E-01,
37533 &9.4923E-01,9.6563E-01,1.0117E+00,1.0781E+00,1.1816E+00,1.3028E+00/
37534 DATA (XGF_L(K),K= 115, 228) /
37535 &1.4397E+00,1.5912E+00,1.7573E+00,1.9376E+00,2.1326E+00,2.3425E+00,
37536 &2.5677E+00,2.8078E+00,3.0611E+00,3.2398E+00,3.7904E+00,4.4126E+00,
37537 &5.1162E+00,5.9322E+00,6.8841E+00,8.0278E+00,9.4403E+00,1.1276E+01,
37538 &1.3844E+01,1.7948E+01,2.6821E+01,0.0000E+00,2.5295E+00,2.5563E+00,
37539 &2.5800E+00,2.5995E+00,2.6174E+00,2.6286E+00,2.6363E+00,2.6395E+00,
37540 &2.6379E+00,2.6306E+00,2.6184E+00,2.6000E+00,2.5768E+00,2.5598E+00,
37541 &2.5397E+00,2.5137E+00,2.4839E+00,2.4516E+00,2.4161E+00,2.3833E+00,
37542 &2.3459E+00,2.3000E+00,2.2499E+00,2.1966E+00,2.1407E+00,2.0900E+00,
37543 &2.0320E+00,1.9647E+00,1.8929E+00,1.8190E+00,1.7411E+00,1.6734E+00,
37544 &1.5997E+00,1.5142E+00,1.4279E+00,1.3438E+00,1.2617E+00,1.1967E+00,
37545 &1.1353E+00,1.0800E+00,1.0501E+00,1.0526E+00,1.0849E+00,1.1369E+00,
37546 &1.2228E+00,1.3250E+00,1.4410E+00,1.5691E+00,1.7085E+00,1.8587E+00,
37547 &2.0200E+00,2.1915E+00,2.3728E+00,2.5633E+00,2.7603E+00,2.9047E+00,
37548 &3.3315E+00,3.8026E+00,4.3243E+00,4.9121E+00,5.5828E+00,6.3648E+00,
37549 &7.3038E+00,8.4817E+00,1.0068E+01,1.2484E+01,1.7398E+01,0.0000E+00,
37550 &3.9781E+00,3.9859E+00,3.9880E+00,3.9845E+00,3.9763E+00,3.9582E+00,
37551 &3.9337E+00,3.9028E+00,3.8636E+00,3.8159E+00,3.7613E+00,3.6984E+00,
37552 &3.6287E+00,3.5836E+00,3.5326E+00,3.4703E+00,3.4046E+00,3.3350E+00,
37553 &3.2612E+00,3.1962E+00,3.1248E+00,3.0388E+00,2.9485E+00,2.8565E+00/
37554 DATA (XGF_L(K),K= 229, 342) /
37555 &2.7591E+00,2.6752E+00,2.5823E+00,2.4756E+00,2.3627E+00,2.2510E+00,
37556 &2.1352E+00,2.0365E+00,1.9308E+00,1.8097E+00,1.6896E+00,1.5737E+00,
37557 &1.4618E+00,1.3735E+00,1.2886E+00,1.2087E+00,1.1551E+00,1.1411E+00,
37558 &1.1545E+00,1.1903E+00,1.2550E+00,1.3356E+00,1.4282E+00,1.5306E+00,
37559 &1.6419E+00,1.7606E+00,1.8869E+00,2.0194E+00,2.1574E+00,2.2992E+00,
37560 &2.4432E+00,2.5568E+00,2.8674E+00,3.2008E+00,3.5626E+00,3.9572E+00,
37561 &4.3932E+00,4.8857E+00,5.4544E+00,6.1386E+00,7.0188E+00,8.2895E+00,
37562 &1.0709E+01,0.0000E+00,6.3697E+00,6.3265E+00,6.2740E+00,6.2091E+00,
37563 &6.1391E+00,6.0517E+00,5.9560E+00,5.8525E+00,5.7367E+00,5.6106E+00,
37564 &5.4709E+00,5.3235E+00,5.1695E+00,5.0724E+00,4.9662E+00,4.8411E+00,
37565 &4.7105E+00,4.5784E+00,4.4412E+00,4.3226E+00,4.1943E+00,4.0442E+00,
37566 &3.8903E+00,3.7360E+00,3.5773E+00,3.4420E+00,3.2967E+00,3.1301E+00,
37567 &2.9593E+00,2.7916E+00,2.6229E+00,2.4802E+00,2.3301E+00,2.1613E+00,
37568 &1.9957E+00,1.8382E+00,1.6875E+00,1.5691E+00,1.4545E+00,1.3433E+00,
37569 &1.2614E+00,1.2264E+00,1.2177E+00,1.2342E+00,1.2749E+00,1.3313E+00,
37570 &1.3987E+00,1.4740E+00,1.5559E+00,1.6431E+00,1.7346E+00,1.8295E+00,
37571 &1.9260E+00,2.0232E+00,2.1174E+00,2.2034E+00,2.4118E+00,2.6289E+00,
37572 &2.8563E+00,3.0948E+00,3.3486E+00,3.6231E+00,3.9250E+00,4.2677E+00,
37573 &4.6847E+00,5.2492E+00,6.2650E+00,0.0000E+00,9.3778E+00,9.2428E+00/
37574 DATA (XGF_L(K),K= 343, 456) /
37575 &9.0960E+00,8.9365E+00,8.7665E+00,8.5746E+00,8.3714E+00,8.1544E+00,
37576 &7.9343E+00,7.6882E+00,7.4352E+00,7.1724E+00,6.9027E+00,6.7360E+00,
37577 &6.5571E+00,6.3494E+00,6.1374E+00,5.9260E+00,5.7093E+00,5.5249E+00,
37578 &5.3270E+00,5.0995E+00,4.8700E+00,4.6419E+00,4.4114E+00,4.2173E+00,
37579 &4.0129E+00,3.7786E+00,3.5451E+00,3.3173E+00,3.0900E+00,2.9004E+00,
37580 &2.7040E+00,2.4853E+00,2.2734E+00,2.0742E+00,1.8851E+00,1.7372E+00,
37581 &1.5941E+00,1.4536E+00,1.3433E+00,1.2893E+00,1.2607E+00,1.2587E+00,
37582 &1.2792E+00,1.3153E+00,1.3616E+00,1.4149E+00,1.4736E+00,1.5361E+00,
37583 &1.6012E+00,1.6677E+00,1.7344E+00,1.7990E+00,1.8589E+00,1.9261E+00,
37584 &2.0646E+00,2.2044E+00,2.3456E+00,2.4882E+00,2.6342E+00,2.7823E+00,
37585 &2.9370E+00,3.1022E+00,3.2902E+00,3.5288E+00,3.9528E+00,0.0000E+00,
37586 &1.3926E+01,1.3617E+01,1.3298E+01,1.2959E+01,1.2612E+01,1.2230E+01,
37587 &1.1845E+01,1.1442E+01,1.1036E+01,1.0599E+01,1.0158E+01,9.7041E+00,
37588 &9.2562E+00,8.9827E+00,8.6974E+00,8.3632E+00,8.0255E+00,7.6946E+00,
37589 &7.3614E+00,7.0802E+00,6.7814E+00,6.4439E+00,6.1064E+00,5.7775E+00,
37590 &5.4468E+00,5.1723E+00,4.8858E+00,4.5617E+00,4.2425E+00,3.9361E+00,
37591 &3.6353E+00,3.3874E+00,3.1301E+00,2.8506E+00,2.5816E+00,2.3318E+00,
37592 &2.0965E+00,1.9136E+00,1.7368E+00,1.5622E+00,1.4211E+00,1.3452E+00,
37593 &1.2937E+00,1.2737E+00,1.2719E+00,1.2868E+00,1.3119E+00,1.3437E+00/
37594 DATA (XGF_L(K),K= 457, 570) /
37595 &1.3799E+00,1.4189E+00,1.4596E+00,1.5003E+00,1.5401E+00,1.5761E+00,
37596 &1.6073E+00,1.6574E+00,1.7377E+00,1.8158E+00,1.8902E+00,1.9601E+00,
37597 &2.0263E+00,2.0884E+00,2.1452E+00,2.1990E+00,2.2512E+00,2.3118E+00,
37598 &2.4354E+00,0.0000E+00,1.9256E+01,1.8699E+01,1.8142E+01,1.7563E+01,
37599 &1.6980E+01,1.6355E+01,1.5725E+01,1.5081E+01,1.4443E+01,1.3769E+01,
37600 &1.3097E+01,1.2422E+01,1.1755E+01,1.1358E+01,1.0937E+01,1.0454E+01,
37601 &9.9818E+00,9.5167E+00,9.0465E+00,8.6570E+00,8.2473E+00,7.7870E+00,
37602 &7.3320E+00,6.8911E+00,6.4569E+00,6.0969E+00,5.7223E+00,5.3051E+00,
37603 &4.8992E+00,4.5131E+00,4.1351E+00,3.8285E+00,3.5148E+00,3.1749E+00,
37604 &2.8517E+00,2.5534E+00,2.2748E+00,2.0598E+00,1.8527E+00,1.6465E+00,
37605 &1.4780E+00,1.3832E+00,1.3129E+00,1.2758E+00,1.2566E+00,1.2544E+00,
37606 &1.2628E+00,1.2778E+00,1.2971E+00,1.3186E+00,1.3412E+00,1.3637E+00,
37607 &1.3845E+00,1.4021E+00,1.4142E+00,1.4518E+00,1.4945E+00,1.5327E+00,
37608 &1.5661E+00,1.5941E+00,1.6160E+00,1.6309E+00,1.6386E+00,1.6381E+00,
37609 &1.6291E+00,1.6176E+00,1.6271E+00,0.0000E+00,2.5945E+01,2.5063E+01,
37610 &2.4160E+01,2.3234E+01,2.2336E+01,2.1370E+01,2.0417E+01,1.9450E+01,
37611 &1.8508E+01,1.7517E+01,1.6548E+01,1.5580E+01,1.4645E+01,1.4085E+01,
37612 &1.3496E+01,1.2836E+01,1.2181E+01,1.1547E+01,1.0921E+01,1.0404E+01,
37613 &9.8614E+00,9.2547E+00,8.6616E+00,8.0926E+00,7.5352E+00,7.0774E+00/
37614 DATA (XGF_L(K),K= 571, 684) /
37615 &6.6043E+00,6.0842E+00,5.5816E+00,5.1040E+00,4.6450E+00,4.2749E+00,
37616 &3.8995E+00,3.4941E+00,3.1134E+00,2.7651E+00,2.4423E+00,2.1941E+00,
37617 &1.9564E+00,1.7198E+00,1.5241E+00,1.4112E+00,1.3220E+00,1.2705E+00,
37618 &1.2348E+00,1.2175E+00,1.2113E+00,1.2119E+00,1.2167E+00,1.2238E+00,
37619 &1.2321E+00,1.2398E+00,1.2460E+00,1.2491E+00,1.2470E+00,1.2752E+00,
37620 &1.2894E+00,1.2998E+00,1.3055E+00,1.3049E+00,1.2991E+00,1.2860E+00,
37621 &1.2655E+00,1.2370E+00,1.1998E+00,1.1564E+00,1.1181E+00,0.0000E+00,
37622 &3.3362E+01,3.2051E+01,3.0740E+01,2.9429E+01,2.8133E+01,2.6758E+01,
37623 &2.5422E+01,2.4082E+01,2.2784E+01,2.1435E+01,2.0130E+01,1.8839E+01,
37624 &1.7597E+01,1.6865E+01,1.6098E+01,1.5241E+01,1.4397E+01,1.3587E+01,
37625 &1.2791E+01,1.2130E+01,1.1444E+01,1.0687E+01,9.9507E+00,9.2501E+00,
37626 &8.5659E+00,8.0104E+00,7.4390E+00,6.8118E+00,6.2125E+00,5.6506E+00,
37627 &5.1096E+00,4.6780E+00,4.2434E+00,3.7769E+00,3.3424E+00,2.9475E+00,
37628 &2.5842E+00,2.3061E+00,2.0409E+00,1.7770E+00,1.5572E+00,1.4290E+00,
37629 &1.3248E+00,1.2609E+00,1.2112E+00,1.1814E+00,1.1636E+00,1.1530E+00,
37630 &1.1469E+00,1.1433E+00,1.1407E+00,1.1378E+00,1.1337E+00,1.1269E+00,
37631 &1.1152E+00,1.1360E+00,1.1320E+00,1.1243E+00,1.1127E+00,1.0960E+00,
37632 &1.0739E+00,1.0461E+00,1.0122E+00,9.7100E-01,9.2292E-01,8.6909E-01,
37633 &8.1432E-01,0.0000E+00,4.2364E+01,4.0483E+01,3.8640E+01,3.6792E+01/
37634 DATA (XGF_L(K),K= 685, 798) /
37635 &3.4991E+01,3.3112E+01,3.1295E+01,2.9487E+01,2.7748E+01,2.5953E+01,
37636 &2.4235E+01,2.2543E+01,2.0935E+01,1.9990E+01,1.9011E+01,1.7921E+01,
37637 &1.6852E+01,1.5830E+01,1.4831E+01,1.4013E+01,1.3165E+01,1.2236E+01,
37638 &1.1337E+01,1.0485E+01,9.6616E+00,8.9943E+00,8.3137E+00,7.5711E+00,
37639 &6.8670E+00,6.2090E+00,5.5842E+00,5.0866E+00,4.5873E+00,4.0564E+00,
37640 &3.5646E+00,3.1234E+00,2.7185E+00,2.4107E+00,2.1172E+00,1.8273E+00,
37641 &1.5836E+00,1.4407E+00,1.3211E+00,1.2459E+00,1.1839E+00,1.1433E+00,
37642 &1.1153E+00,1.0949E+00,1.0794E+00,1.0667E+00,1.0555E+00,1.0443E+00,
37643 &1.0317E+00,1.0172E+00,9.9883E-01,1.0131E+00,9.9503E-01,9.7446E-01,
37644 &9.5064E-01,9.2316E-01,8.9156E-01,8.5528E-01,8.1439E-01,7.6837E-01,
37645 &7.1718E-01,6.6210E-01,6.0243E-01,0.0000E+00,5.2603E+01,5.0038E+01,
37646 &4.7540E+01,4.5053E+01,4.2652E+01,4.0175E+01,3.7784E+01,3.5407E+01,
37647 &3.3154E+01,3.0851E+01,2.8651E+01,2.6507E+01,2.4488E+01,2.3310E+01,
37648 &2.2084E+01,2.0735E+01,1.9418E+01,1.8166E+01,1.6951E+01,1.5960E+01,
37649 &1.4935E+01,1.3817E+01,1.2742E+01,1.1732E+01,1.0759E+01,9.9749E+00,
37650 &9.1794E+00,8.3186E+00,7.5044E+00,6.7510E+00,6.0386E+00,5.4762E+00,
37651 &4.9137E+00,4.3200E+00,3.7728E+00,3.2842E+00,2.8391E+00,2.5026E+00,
37652 &2.1835E+00,1.8677E+00,1.6033E+00,1.4461E+00,1.3138E+00,1.2277E+00,
37653 &1.1557E+00,1.1057E+00,1.0689E+00,1.0407E+00,1.0176E+00,9.9768E-01/
37654 DATA (XGF_L(K),K= 799, 912) /
37655 &9.7951E-01,9.6199E-01,9.4331E-01,9.2359E-01,9.0058E-01,9.0921E-01,
37656 &8.8156E-01,8.5244E-01,8.2081E-01,7.8702E-01,7.5025E-01,7.1005E-01,
37657 &6.6667E-01,6.1984E-01,5.6969E-01,5.1748E-01,4.5895E-01,0.0000E+00,
37658 &6.3459E+01,6.0127E+01,5.6900E+01,5.3695E+01,5.0615E+01,4.7464E+01,
37659 &4.4440E+01,4.1483E+01,3.8684E+01,3.5826E+01,3.3122E+01,3.0500E+01,
37660 &2.8040E+01,2.6617E+01,2.5143E+01,2.3518E+01,2.1950E+01,2.0455E+01,
37661 &1.9011E+01,1.7842E+01,1.6646E+01,1.5337E+01,1.4094E+01,1.2920E+01,
37662 &1.1799E+01,1.0903E+01,9.9940E+00,9.0166E+00,8.0967E+00,7.2512E+00,
37663 &6.4551E+00,5.8279E+00,5.2081E+00,4.5519E+00,3.9568E+00,3.4237E+00,
37664 &2.9425E+00,2.5798E+00,2.2371E+00,1.8995E+00,1.6161E+00,1.4477E+00,
37665 &1.3046E+00,1.2096E+00,1.1285E+00,1.0709E+00,1.0274E+00,9.9290E-01,
37666 &9.6399E-01,9.3860E-01,9.1550E-01,8.9324E-01,8.7036E-01,8.4674E-01,
37667 &8.2129E-01,8.2506E-01,7.9094E-01,7.5633E-01,7.2031E-01,6.8307E-01,
37668 &6.4387E-01,6.0237E-01,5.5907E-01,5.1344E-01,4.6618E-01,4.1810E-01,
37669 &3.6329E-01,0.0000E+00,7.9498E+01,7.4941E+01,7.0580E+01,6.6266E+01,
37670 &6.2169E+01,5.8002E+01,5.4045E+01,5.0164E+01,4.6539E+01,4.2847E+01,
37671 &3.9386E+01,3.6065E+01,3.2968E+01,3.1180E+01,2.9347E+01,2.7330E+01,
37672 &2.5394E+01,2.3566E+01,2.1811E+01,2.0388E+01,1.8944E+01,1.7368E+01,
37673 &1.5877E+01,1.4488E+01,1.3164E+01,1.2111E+01,1.1051E+01,9.9162E+00/
37674 DATA (XGF_L(K),K= 913, 1026) /
37675 &8.8542E+00,7.8839E+00,6.9777E+00,6.2689E+00,5.5695E+00,4.8410E+00,
37676 &4.1789E+00,3.5909E+00,3.0635E+00,2.6689E+00,2.2973E+00,1.9324E+00,
37677 &1.6270E+00,1.4446E+00,1.2882E+00,1.1839E+00,1.0926E+00,1.0266E+00,
37678 &9.7585E-01,9.3473E-01,8.9976E-01,8.6898E-01,8.4068E-01,8.1374E-01,
37679 &7.8714E-01,7.6011E-01,7.3262E-01,7.3148E-01,6.9170E-01,6.5270E-01,
37680 &6.1357E-01,5.7426E-01,5.3417E-01,4.9316E-01,4.5166E-01,4.0914E-01,
37681 &3.6649E-01,3.2429E-01,2.7651E-01,0.0000E+00,9.7091E+01,9.1127E+01,
37682 &8.5440E+01,7.9869E+01,7.4603E+01,6.9275E+01,6.4220E+01,5.9343E+01,
37683 &5.4780E+01,5.0195E+01,4.5912E+01,4.1816E+01,3.8028E+01,3.5857E+01,
37684 &3.3637E+01,3.1205E+01,2.8880E+01,2.6695E+01,2.4601E+01,2.2923E+01,
37685 &2.1219E+01,1.9374E+01,1.7634E+01,1.6009E+01,1.4488E+01,1.3276E+01,
37686 &1.2064E+01,1.0772E+01,9.5709E+00,8.4795E+00,7.4649E+00,6.6775E+00,
37687 &5.9046E+00,5.1015E+00,4.3733E+00,3.7372E+00,3.1677E+00,2.7434E+00,
37688 &2.3459E+00,1.9566E+00,1.6317E+00,1.4368E+00,1.2699E+00,1.1572E+00,
37689 &1.0581E+00,9.8558E-01,9.2913E-01,8.8297E-01,8.4349E-01,8.0862E-01,
37690 &7.7667E-01,7.4686E-01,7.1760E-01,6.8906E-01,6.6005E-01,6.5493E-01,
37691 &6.1209E-01,5.7080E-01,5.3038E-01,4.9085E-01,4.5137E-01,4.1231E-01,
37692 &3.7316E-01,3.3442E-01,2.9613E-01,2.5928E-01,2.1912E-01,0.0000E+00,
37693 &1.1660E+02,1.0899E+02,1.0178E+02,9.4752E+01,8.8142E+01,8.1480E+01/
37694 DATA (XGF_L(K),K= 1027, 1140) /
37695 &7.5219E+01,6.9198E+01,6.3578E+01,5.7986E+01,5.2800E+01,4.7867E+01,
37696 &4.3328E+01,4.0736E+01,3.8088E+01,3.5213E+01,3.2469E+01,2.9907E+01,
37697 &2.7451E+01,2.5501E+01,2.3516E+01,2.1392E+01,1.9391E+01,1.7546E+01,
37698 &1.5800E+01,1.4426E+01,1.3057E+01,1.1607E+01,1.0266E+01,9.0517E+00,
37699 &7.9294E+00,7.0617E+00,6.2165E+00,5.3397E+00,4.5572E+00,3.8687E+00,
37700 &3.2598E+00,2.8078E+00,2.3859E+00,1.9745E+00,1.6317E+00,1.4267E+00,
37701 &1.2497E+00,1.1305E+00,1.0247E+00,9.4657E-01,8.8556E-01,8.3542E-01,
37702 &7.9253E-01,7.5465E-01,7.2037E-01,6.8840E-01,6.5775E-01,6.2793E-01,
37703 &5.9852E-01,5.9015E-01,5.4553E-01,5.0339E-01,4.6306E-01,4.2411E-01,
37704 &3.8622E-01,3.4909E-01,3.1294E-01,2.7773E-01,2.4373E-01,2.1150E-01,
37705 &1.7848E-01,0.0000E+00,1.3738E+02,1.2796E+02,1.1904E+02,1.1042E+02,
37706 &1.0233E+02,9.4222E+01,8.6662E+01,7.9409E+01,7.2655E+01,6.6001E+01,
37707 &5.9833E+01,5.4007E+01,4.8672E+01,4.5642E+01,4.2552E+01,3.9214E+01,
37708 &3.6040E+01,3.3082E+01,3.0272E+01,2.8026E+01,2.5779E+01,2.3361E+01,
37709 &2.1093E+01,1.9009E+01,1.7062E+01,1.5526E+01,1.4003E+01,1.2396E+01,
37710 &1.0916E+01,9.5845E+00,8.3611E+00,7.4188E+00,6.5021E+00,5.5589E+00,
37711 &4.7169E+00,3.9865E+00,3.3389E+00,2.8617E+00,2.4178E+00,1.9872E+00,
37712 &1.6283E+00,1.4143E+00,1.2296E+00,1.1049E+00,9.9315E-01,9.1079E-01,
37713 &8.4623E-01,7.9317E-01,7.4768E-01,7.0802E-01,6.7178E-01,6.3836E-01/
37714 DATA (XGF_L(K),K= 1141, 1254) /
37715 &6.0703E-01,5.7658E-01,5.4733E-01,5.3630E-01,4.9100E-01,4.4879E-01,
37716 &4.0920E-01,3.7138E-01,3.3521E-01,3.0054E-01,2.6721E-01,2.3523E-01,
37717 &2.0485E-01,1.7634E-01,1.4852E-01,0.0000E+00,1.6103E+02,1.4938E+02,
37718 &1.3848E+02,1.2798E+02,1.1818E+02,1.0840E+02,9.9309E+01,9.0651E+01,
37719 &8.2647E+01,7.4733E+01,6.7469E+01,6.0672E+01,5.4433E+01,5.0913E+01,
37720 &4.7343E+01,4.3482E+01,3.9833E+01,3.6452E+01,3.3242E+01,3.0689E+01,
37721 &2.8134E+01,2.5404E+01,2.2863E+01,2.0531E+01,1.8362E+01,1.6652E+01,
37722 &1.4967E+01,1.3197E+01,1.1573E+01,1.0120E+01,8.7877E+00,7.7679E+00,
37723 &6.7819E+00,5.7685E+00,4.8731E+00,4.0967E+00,3.4122E+00,2.9097E+00,
37724 &2.4451E+00,1.9953E+00,1.6222E+00,1.3995E+00,1.2076E+00,1.0771E+00,
37725 &9.6151E-01,8.7563E-01,8.0819E-01,7.5269E-01,7.0548E-01,6.6395E-01,
37726 &6.2666E-01,5.9253E-01,5.6034E-01,5.3005E-01,5.0122E-01,4.8790E-01,
37727 &4.4273E-01,4.0115E-01,3.6251E-01,3.2632E-01,2.9224E-01,2.5988E-01,
37728 &2.2931E-01,2.0039E-01,1.7324E-01,1.4805E-01,1.2201E-01,0.0000E+00,
37729 &1.8591E+02,1.7193E+02,1.5886E+02,1.4632E+02,1.3469E+02,1.2310E+02,
37730 &1.1237E+02,1.0218E+02,9.2839E+01,8.3643E+01,7.5256E+01,6.7382E+01,
37731 &6.0231E+01,5.6204E+01,5.2127E+01,4.7743E+01,4.3601E+01,3.9784E+01,
37732 &3.6172E+01,3.3310E+01,3.0455E+01,2.7410E+01,2.4579E+01,2.2009E+01,
37733 &1.9599E+01,1.7727E+01,1.5886E+01,1.3956E+01,1.2193E+01,1.0620E+01/
37734 DATA (XGF_L(K),K= 1255, 1368) /
37735 &9.1866E+00,8.0925E+00,7.0383E+00,5.9623E+00,5.0119E+00,4.1917E+00,
37736 &3.4750E+00,2.9503E+00,2.4663E+00,1.9999E+00,1.6141E+00,1.3840E+00,
37737 &1.1856E+00,1.0518E+00,9.3192E-01,8.4324E-01,7.7348E-01,7.1642E-01,
37738 &6.6779E-01,6.2531E-01,5.8732E-01,5.5231E-01,5.2039E-01,4.9037E-01,
37739 &4.6218E-01,4.4711E-01,4.0225E-01,3.6159E-01,3.2438E-01,2.8982E-01,
37740 &2.5765E-01,2.2765E-01,1.9954E-01,1.7331E-01,1.4889E-01,1.2621E-01,
37741 &9.6984E-02,0.0000E+00,2.1269E+02,1.9609E+02,1.8060E+02,1.6582E+02,
37742 &1.5214E+02,1.3863E+02,1.2613E+02,1.1431E+02,1.0351E+02,9.2957E+01,
37743 &8.3294E+01,7.4318E+01,6.6188E+01,6.1617E+01,5.7019E+01,5.2073E+01,
37744 &4.7428E+01,4.3153E+01,3.9122E+01,3.5941E+01,3.2764E+01,2.9404E+01,
37745 &2.6282E+01,2.3458E+01,2.0836E+01,1.8796E+01,1.6786E+01,1.4693E+01,
37746 &1.2792E+01,1.1101E+01,9.5678E+00,8.4010E+00,7.2773E+00,6.1402E+00,
37747 &5.1403E+00,4.2791E+00,3.5311E+00,2.9851E+00,2.4835E+00,2.0017E+00,
37748 &1.6039E+00,1.3677E+00,1.1646E+00,1.0265E+00,9.0375E-01,8.1271E-01,
37749 &7.4135E-01,6.8280E-01,6.3328E-01,5.9018E-01,5.5184E-01,5.1677E-01,
37750 &4.8494E-01,4.5537E-01,4.2797E-01,4.1146E-01,3.6736E-01,3.2788E-01,
37751 &2.9207E-01,2.5923E-01,2.2901E-01,2.0110E-01,1.7527E-01,1.5131E-01,
37752 &1.2926E-01,1.0839E-01,6.9776E-02,0.0000E+00,2.4043E+02,2.2104E+02,
37753 &2.0300E+02,1.8582E+02,1.7003E+02,1.5443E+02,1.4007E+02,1.2658E+02/
37754 DATA (XGF_L(K),K= 1369, 1482) /
37755 &1.1426E+02,1.0227E+02,9.1332E+01,8.1197E+01,7.2119E+01,6.6989E+01,
37756 &6.1846E+01,5.6342E+01,5.1188E+01,4.6448E+01,4.2002E+01,3.8498E+01,
37757 &3.5016E+01,3.1335E+01,2.7931E+01,2.4848E+01,2.2009E+01,1.9797E+01,
37758 &1.7637E+01,1.5389E+01,1.3354E+01,1.1550E+01,9.9187E+00,8.6824E+00,
37759 &7.4988E+00,6.3022E+00,5.2549E+00,4.3589E+00,3.5788E+00,3.0139E+00,
37760 &2.4962E+00,2.0005E+00,1.5931E+00,1.3514E+00,1.1435E+00,1.0028E+00,
37761 &8.7751E-01,7.8479E-01,7.1218E-01,6.5272E-01,6.0250E-01,5.5920E-01,
37762 &5.2061E-01,4.8590E-01,4.5422E-01,4.2519E-01,3.9858E-01,3.8094E-01,
37763 &3.3789E-01,2.9975E-01,2.6524E-01,2.3401E-01,2.0560E-01,1.7956E-01,
37764 &1.5565E-01,1.3374E-01,1.1354E-01,9.4096E-02,3.9275E-02,0.0000E+00,
37765 &2.8195E+02,2.5830E+02,2.3640E+02,2.1554E+02,1.9645E+02,1.7774E+02,
37766 &1.6058E+02,1.4448E+02,1.2990E+02,1.1575E+02,1.0299E+02,9.1121E+01,
37767 &8.0574E+01,7.4642E+01,6.8724E+01,6.2402E+01,5.6498E+01,5.1101E+01,
37768 &4.6042E+01,4.2081E+01,3.8152E+01,3.4014E+01,3.0201E+01,2.6780E+01,
37769 &2.3611E+01,2.1171E+01,1.8789E+01,1.6329E+01,1.4107E+01,1.2148E+01,
37770 &1.0386E+01,9.0557E+00,7.7874E+00,6.5118E+00,5.4006E+00,4.4539E+00,
37771 &3.6370E+00,3.0467E+00,2.5088E+00,1.9959E+00,1.5762E+00,1.3274E+00,
37772 &1.1142E+00,9.7065E-01,8.4265E-01,7.4825E-01,6.7451E-01,6.1445E-01,
37773 &5.6374E-01,5.2024E-01,4.8166E-01,4.4741E-01,4.1643E-01,3.8830E-01/
37774 DATA (XGF_L(K),K= 1483, 1596) /
37775 &3.6282E-01,3.4411E-01,3.0249E-01,2.6607E-01,2.3369E-01,2.0474E-01,
37776 &1.7852E-01,1.5489E-01,1.3341E-01,1.1384E-01,9.5862E-02,7.7509E-02,
37777 &0.0000E+00,0.0000E+00,3.2379E+02,2.9556E+02,2.6960E+02,2.4513E+02,
37778 &2.2265E+02,2.0073E+02,1.8071E+02,1.6202E+02,1.4515E+02,1.2887E+02,
37779 &1.1419E+02,1.0071E+02,8.8650E+01,8.1931E+01,7.5233E+01,6.8140E+01,
37780 &6.1510E+01,5.5467E+01,4.9832E+01,4.5419E+01,4.1070E+01,3.6493E+01,
37781 &3.2295E+01,2.8536E+01,2.5086E+01,2.2426E+01,1.9846E+01,1.7175E+01,
37782 &1.4781E+01,1.2681E+01,1.0797E+01,9.3831E+00,8.0380E+00,6.6897E+00,
37783 &5.5221E+00,4.5337E+00,3.6831E+00,3.0714E+00,2.5159E+00,1.9884E+00,
37784 &1.5586E+00,1.3048E+00,1.0886E+00,9.4191E-01,8.1217E-01,7.1679E-01,
37785 &6.4238E-01,5.8194E-01,5.3136E-01,4.8766E-01,4.4965E-01,4.1594E-01,
37786 &3.8570E-01,3.5847E-01,3.3403E-01,3.1456E-01,2.7454E-01,2.3977E-01,
37787 &2.0922E-01,1.8216E-01,1.5795E-01,1.3622E-01,1.1669E-01,9.9012E-02,
37788 &8.2668E-02,6.4604E-02,0.0000E+00,0.0000E+00,3.7071E+02,3.3727E+02,
37789 &3.0660E+02,2.7790E+02,2.5169E+02,2.2608E+02,2.0283E+02,1.8123E+02,
37790 &1.6179E+02,1.4311E+02,1.2635E+02,1.1097E+02,9.7357E+01,8.9759E+01,
37791 &8.2263E+01,7.4239E+01,6.6821E+01,6.0073E+01,5.3813E+01,4.8927E+01,
37792 &4.4114E+01,3.9072E+01,3.4471E+01,3.0351E+01,2.6592E+01,2.3699E+01,
37793 &2.0903E+01,1.8031E+01,1.5459E+01,1.3211E+01,1.1204E+01,9.7024E+00/
37794 DATA (XGF_L(K),K= 1597, 1710) /
37795 &8.2828E+00,6.8644E+00,5.6367E+00,4.6059E+00,3.7241E+00,3.0915E+00,
37796 &2.5189E+00,1.9786E+00,1.5396E+00,1.2816E+00,1.0611E+00,9.1306E-01,
37797 &7.8207E-01,6.8594E-01,6.1118E-01,5.5075E-01,5.0031E-01,4.5732E-01,
37798 &4.1996E-01,3.8671E-01,3.5732E-01,3.3101E-01,3.0775E-01,2.8769E-01,
37799 &2.4931E-01,2.1637E-01,1.8763E-01,1.6241E-01,1.4002E-01,1.2013E-01,
37800 &1.0238E-01,8.6311E-02,7.1348E-02,5.2982E-02,0.0000E+00,0.0000E+00,
37801 &4.2142E+02,3.8237E+02,3.4660E+02,3.1292E+02,2.8259E+02,2.5300E+02,
37802 &2.2626E+02,2.0148E+02,1.7927E+02,1.5797E+02,1.3896E+02,1.2163E+02,
37803 &1.0632E+02,9.7858E+01,8.9366E+01,8.0488E+01,7.2234E+01,6.4771E+01,
37804 &5.7843E+01,5.2468E+01,4.7182E+01,4.1663E+01,3.6633E+01,3.2165E+01,
37805 &2.8082E+01,2.4971E+01,2.1960E+01,1.8866E+01,1.6118E+01,1.3723E+01,
37806 &1.1595E+01,1.0008E+01,8.5101E+00,7.0232E+00,5.7443E+00,4.6705E+00,
37807 &3.7584E+00,3.1066E+00,2.5189E+00,1.9659E+00,1.5193E+00,1.2575E+00,
37808 &1.0346E+00,8.8517E-01,7.5338E-01,6.5695E-01,5.8219E-01,5.2200E-01,
37809 &4.7218E-01,4.2954E-01,3.9258E-01,3.6043E-01,3.3190E-01,3.0663E-01,
37810 &2.8431E-01,2.6413E-01,2.2746E-01,1.9612E-01,1.6912E-01,1.4557E-01,
37811 &1.2488E-01,1.0660E-01,9.0362E-02,7.5731E-02,6.1890E-02,4.2720E-02,
37812 &0.0000E+00,0.0000E+00,4.7166E+02,4.2676E+02,3.8580E+02,3.4749E+02,
37813 &3.1273E+02,2.7927E+02,2.4899E+02,2.2108E+02,1.9611E+02,1.7230E+02/
37814 DATA (XGF_L(K),K= 1711, 1824) /
37815 &1.5107E+02,1.3178E+02,1.1483E+02,1.0548E+02,9.6179E+01,8.6383E+01,
37816 &7.7331E+01,6.9156E+01,6.1613E+01,5.5763E+01,5.0019E+01,4.4056E+01,
37817 &3.8633E+01,3.3819E+01,2.9446E+01,2.6108E+01,2.2889E+01,1.9617E+01,
37818 &1.6706E+01,1.4179E+01,1.1938E+01,1.0276E+01,8.7112E+00,7.1630E+00,
37819 &5.8345E+00,4.7275E+00,3.7856E+00,3.1171E+00,2.5164E+00,1.9532E+00,
37820 &1.4997E+00,1.2350E+00,1.0108E+00,8.6027E-01,7.2804E-01,6.3166E-01,
37821 &5.5726E-01,4.9745E-01,4.4802E-01,4.0623E-01,3.7002E-01,3.3850E-01,
37822 &3.1081E-01,2.8644E-01,2.6509E-01,2.4476E-01,2.0951E-01,1.7979E-01,
37823 &1.5426E-01,1.3217E-01,1.1290E-01,9.5951E-02,8.0975E-02,6.7483E-02,
37824 &5.4483E-02,3.4309E-02,0.0000E+00,0.0000E+00,5.2745E+02,4.7595E+02,
37825 &4.2900E+02,3.8543E+02,3.4589E+02,3.0795E+02,2.7377E+02,2.4235E+02,
37826 &2.1434E+02,1.8771E+02,1.6408E+02,1.4266E+02,1.2392E+02,1.1358E+02,
37827 &1.0335E+02,9.2593E+01,8.2702E+01,7.3780E+01,6.5553E+01,5.9207E+01,
37828 &5.2983E+01,4.6535E+01,4.0700E+01,3.5531E+01,3.0842E+01,2.7278E+01,
37829 &2.3855E+01,2.0386E+01,1.7301E+01,1.4635E+01,1.2282E+01,1.0538E+01,
37830 &8.9065E+00,7.2932E+00,5.9178E+00,4.7769E+00,3.8086E+00,3.1240E+00,
37831 &2.5114E+00,1.9387E+00,1.4794E+00,1.2125E+00,9.8604E-01,8.3538E-01,
37832 &7.0309E-01,6.0683E-01,5.3289E-01,4.7378E-01,4.2493E-01,3.8387E-01,
37833 &3.4846E-01,3.1778E-01,2.9097E-01,2.6744E-01,2.4699E-01,2.2688E-01/
37834 DATA (XGF_L(K),K= 1825, 1836) /
37835 &1.9308E-01,1.6489E-01,1.4079E-01,1.2009E-01,1.0214E-01,8.6447E-02,
37836 &7.2603E-02,6.0131E-02,4.7893E-02,2.6613E-02,0.0000E+00,0.0000E+00/
37840 *...CHECK OF X AND Q2 VALUES :
37841 IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
37843 91 FORMAT (2X,'GRV98: x out of range',1p,E12.4)
37849 IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
37851 92 FORMAT (2X,'GRV98: Q2 out of range',1p,E12.4)
37857 *...INTERPOLATION :
37865 UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
37866 DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
37867 DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
37868 UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
37869 US = 0.5 * (UD - DE)
37870 DS = 0.5 * (UD + DE)
37871 SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF) * X1**7 * XS
37872 GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF) * X1**5 * XS
37876 *$ CREATE PHO_DOR98SC.FOR
37878 CDECK ID>, PHO_DOR98SC
37879 SUBROUTINE PHO_DOR98SC (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
37880 C***********************************************************************
37882 C GRV98 parton densities, leading order set
37884 C For a detailed explanation see
37885 C M. Glueck, E. Reya, A. Vogt :
37886 C hep-ph/9806404 = DO-TH 98/07 = WUE-ITP-98-019
37887 C (To appear in Eur. Phys. J. C)
37889 C interpolation routine based on the original GRV98PA routine,
37890 C adapted to define interpolation table as DATA statements
37894 C CAUTION: this is a version with gluon shadowing corrections
37898 C INPUT: X = Bjorken-x (between 1.E-9 and 1.)
37899 C Q2 = scale in GeV**2 (between 0.8 and 1.E6)
37901 C OUTPUT: UV = u - u(bar), DV = d - d(bar), US = u(bar),
37902 C DS = d(bar), SS = s = s(bar), GL = gluon.
37903 C Always x times the distribution is returned.
37905 C******************************************************i****************
37906 IMPLICIT DOUBLE PRECISION (A-H, O-Z)
37909 C input/output channels
37911 COMMON /POINOU/ LI,LO
37913 PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
37914 DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
37915 1 XSF(NX,NQ), XGF(NX,NQ),
37916 2 XT(NARG), NA(NARG), ARRF(NX+NQ)
37918 DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
37919 & XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
37921 EQUIVALENCE (XUVF(1,1),XUVF_L(1))
37922 EQUIVALENCE (XDVF(1,1),XDVF_L(1))
37923 EQUIVALENCE (XDEF(1,1),XDEF_L(1))
37924 EQUIVALENCE (XUDF(1,1),XUDF_L(1))
37925 EQUIVALENCE (XSF(1,1),XSF_L(1))
37926 EQUIVALENCE (XGF(1,1),XGF_L(1))
37928 *#################### data statements for shadowed LO PDF ##############
37930 *#######################################################################
37933 *...CHECK OF X AND Q2 VALUES :
37934 IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
37936 91 FORMAT (2X,'GRV98_SC: x out of range',1p,E12.4)
37942 IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
37944 92 FORMAT (2X,'GRV98_SC: Q2 out of range',1p,E12.4)
37950 *...INTERPOLATION :
37958 UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
37959 DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
37960 DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
37961 UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
37962 US = 0.5 * (UD - DE)
37963 DS = 0.5 * (UD + DE)
37964 SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF) * X1**7 * XS
37965 GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF) * X1**5 * XS
37969 *$ CREATE PHO_DOR94LO.FOR
37971 CDECK ID>, PHO_DOR94LO
37972 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
37974 * 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 *
37978 * FOR A DETAILED EXPLANATION SEE *
37979 * M. GLUECK, E.REYA, A.VOGT : *
37980 * DO-TH 94/24 = DESY 94-206 *
37981 * (TO APPEAR IN Z. PHYS. C) *
37983 * THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR *
37984 * Q**2 / GEV**2 BETWEEN 0.4 AND 1.E6 *
37985 * X BETWEEN 1.E-5 AND 1. *
37986 * LARGE-X REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION *
37987 * IS NEGLIGIBLY SMALL, WERE EXCLUDED FROM THE FIT. *
37989 * HEAVY QUARK THRESHOLDS Q(H) = M(H) IN THE BETA FUNCTION : *
37990 * M(C) = 1.5, M(B) = 4.5 *
37991 * CORRESPONDING LAMBDA(F) VALUES IN GEV FOR Q**2 > M(H)**2 : *
37992 * LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
37993 * LAMBDA(5) = 0.153, *
37994 * NLO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
37995 * LAMBDA(5) = 0.131. *
37996 * THE NUMBER OF ACTIVE QUARK FLAVOURS IS NF = 3 EVERYWHERE *
37997 * EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,... *
37998 * ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION. *
37999 * IF NEEDED, HEAVY QUARK DENSITIES CAN BE TAKEN FROM THE 1991 *
38000 * GRV PARAMETRIZATION. *
38002 * NLO DISTRIBUTIONS ARE GIVEN IN MS-BAR FACTORIZATION SCHEME *
38003 * (SUBROUTINE GRV94HO) AS WELL AS IN THE DIS SCHEME (GRV94DI), *
38004 * THE LEADING ORDER PARAMETRIZATION IS PROVIDED BY "GRV94LO". *
38006 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38008 *...INPUT PARAMETERS :
38010 * X = MOMENTUM FRACTION
38011 * Q2 = SCALE Q**2 IN GEV**2
38013 *...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION) :
38015 * UV = U(VAL) = U - U(BAR)
38016 * DV = D(VAL) = D - D(BAR)
38017 * DEL = D(BAR) - U(BAR)
38018 * UDB = U(BAR) + D(BAR)
38022 *...LO PARAMETRIZATION :
38024 SUBROUTINE PHO_DOR94LO (X, Q2, UV, DV, DEL, UDB, SB, GL)
38025 IMPLICIT DOUBLE PRECISION (A - Z)
38029 LAM2 = 0.2322 * 0.2322
38030 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38035 NU = 2.284 + 0.802 * S + 0.055 * S2
38036 AKU = 0.590 - 0.024 * S
38037 BKU = 0.131 + 0.063 * S
38038 AU = -0.449 - 0.138 * S - 0.076 * S2
38039 BU = 0.213 + 2.669 * S - 0.728 * S2
38040 CU = 8.854 - 9.135 * S + 1.979 * S2
38041 DU = 2.997 + 0.753 * S - 0.076 * S2
38042 UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38044 ND = 0.371 + 0.083 * S + 0.039 * S2
38046 BKD = 0.486 + 0.062 * S
38047 AD = -0.509 + 3.310 * S - 1.248 * S2
38048 BD = 12.41 - 10.52 * S + 2.267 * S2
38049 CD = 6.373 - 6.208 * S + 1.418 * S2
38050 DD = 3.691 + 0.799 * S - 0.071 * S2
38051 DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38053 NE = 0.082 + 0.014 * S + 0.008 * S2
38054 AKE = 0.409 - 0.005 * S
38055 BKE = 0.799 + 0.071 * S
38056 AE = -38.07 + 36.13 * S - 0.656 * S2
38057 BE = 90.31 - 74.15 * S + 7.645 * S2
38059 DE = 7.486 + 1.217 * S - 0.159 * S2
38060 DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38064 AKX = 0.410 - 0.232 * S
38065 BKX = 0.534 - 0.457 * S
38066 AGX = 0.890 - 0.140 * S
38068 CX = 0.320 + 0.683 * S
38069 DX = 4.752 + 1.164 * S + 0.286 * S2
38070 EX = 4.119 + 1.713 * S
38071 ESX = 0.682 + 2.978 * S
38072 UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38076 AKS = 1.798 - 0.596 * S
38077 AS = -5.548 + 3.669 * DS - 0.616 * S
38078 BS = 18.92 - 16.73 * DS + 5.168 * S
38079 DST = 6.379 - 0.350 * S + 0.142 * S2
38080 EST = 3.981 + 1.638 * S
38082 SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38086 AKG = 1.742 - 0.930 * S
38088 AG = 7.486 - 2.185 * S
38089 BG = 16.69 - 22.74 * S + 5.779 * S2
38090 CG = -25.59 + 29.71 * S - 7.296 * S2
38091 DG = 2.792 + 2.215 * S + 0.422 * S2 - 0.104 * S3
38092 EG = 0.807 + 2.005 * S
38093 ESG = 3.841 + 0.316 * S
38094 GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38099 *...NLO PARAMETRIZATION (MS(BAR)) :
38101 *$ CREATE PHO_DOR94HO.FOR
38103 CDECK ID>, PHO_DOR94HO
38104 SUBROUTINE PHO_DOR94HO (X, Q2, UV, DV, DEL, UDB, SB, GL)
38105 IMPLICIT DOUBLE PRECISION (A - Z)
38109 LAM2 = 0.248 * 0.248
38110 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38115 NU = 1.304 + 0.863 * S
38116 AKU = 0.558 - 0.020 * S
38118 AU = -0.113 + 0.283 * S - 0.321 * S2
38119 BU = 6.843 - 5.089 * S + 2.647 * S2 - 0.527 * S3
38120 CU = 7.771 - 10.09 * S + 2.630 * S2
38121 DU = 3.315 + 1.145 * S - 0.583 * S2 + 0.154 * S3
38122 UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38124 ND = 0.102 - 0.017 * S + 0.005 * S2
38125 AKD = 0.270 - 0.019 * S
38127 AD = 2.393 + 6.228 * S - 0.881 * S2
38128 BD = 46.06 + 4.673 * S - 14.98 * S2 + 1.331 * S3
38129 CD = 17.83 - 53.47 * S + 21.24 * S2
38130 DD = 4.081 + 0.976 * S - 0.485 * S2 + 0.152 * S3
38131 DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38133 NE = 0.070 + 0.042 * S - 0.011 * S2 + 0.004 * S3
38134 AKE = 0.409 - 0.007 * S
38135 BKE = 0.782 + 0.082 * S
38136 AE = -29.65 + 26.49 * S + 5.429 * S2
38137 BE = 90.20 - 74.97 * S + 4.526 * S2
38139 DE = 8.122 + 2.120 * S - 1.088 * S2 + 0.231 * S3
38140 DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38147 BGX = 3.210 - 1.866 * S
38149 DX = 9.010 + 0.896 * DS + 0.222 * S2
38150 EX = 3.077 + 1.446 * S
38151 ESX = 3.173 - 2.445 * DS + 2.207 * S
38152 UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38156 AKS = 1.690 + 0.650 * DS - 0.922 * S
38157 AS = -4.329 + 1.131 * S
38158 BS = 9.568 - 1.744 * S
38159 DST = 9.377 + 1.088 * DS - 1.320 * S + 0.130 * S2
38160 EST = 3.031 + 1.639 * S
38161 ESS = 5.837 + 0.815 * S
38162 SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38166 AKG = 1.724 + 0.157 * S
38167 BKG = 0.800 + 1.016 * S
38168 AG = 7.517 - 2.547 * S
38169 BG = 34.09 - 52.21 * DS + 17.47 * S
38170 CG = 4.039 + 1.491 * S
38171 DG = 3.404 + 0.830 * S
38172 EG = -1.112 + 3.438 * S - 0.302 * S2
38173 ESG = 3.256 - 0.436 * S
38174 GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38178 *$ CREATE PHO_DOR94DI.FOR
38180 CDECK ID>, PHO_DOR94DI
38182 *...NLO PARAMETRIZATION (DIS) :
38184 SUBROUTINE PHO_DOR94DI (X, Q2, UV, DV, DEL, UDB, SB, GL)
38185 IMPLICIT DOUBLE PRECISION (A - Z)
38189 LAM2 = 0.248 * 0.248
38190 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38195 NU = 2.484 + 0.116 * S + 0.093 * S2
38196 AKU = 0.563 - 0.025 * S
38197 BKU = 0.054 + 0.154 * S
38198 AU = -0.326 - 0.058 * S - 0.135 * S2
38199 BU = -3.322 + 8.259 * S - 3.119 * S2 + 0.291 * S3
38200 CU = 11.52 - 12.99 * S + 3.161 * S2
38201 DU = 2.808 + 1.400 * S - 0.557 * S2 + 0.119 * S3
38202 UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38204 ND = 0.156 - 0.017 * S
38205 AKD = 0.299 - 0.022 * S
38206 BKD = 0.259 - 0.015 * S
38207 AD = 3.445 + 1.278 * S + 0.326 * S2
38208 BD = -6.934 + 37.45 * S - 18.95 * S2 + 1.463 * S3
38209 CD = 55.45 - 69.92 * S + 20.78 * S2
38210 DD = 3.577 + 1.441 * S - 0.683 * S2 + 0.179 * S3
38211 DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38213 NE = 0.099 + 0.019 * S + 0.002 * S2
38214 AKE = 0.419 - 0.013 * S
38215 BKE = 1.064 - 0.038 * S
38216 AE = -44.00 + 98.70 * S - 14.79 * S2
38217 BE = 28.59 - 40.94 * S - 13.66 * S2 + 2.523 * S3
38218 CE = 84.57 - 108.8 * S + 31.52 * S2
38219 DE = 7.469 + 2.480 * S - 0.866 * S2
38220 DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38224 AKX = 0.326 + 0.150 * S
38225 BKX = 0.956 + 0.405 * S
38227 BGX = 3.794 - 2.359 * DS
38229 DX = 7.941 + 0.534 * DS - 0.940 * S + 0.410 * S2
38230 EX = 3.049 + 1.597 * S
38231 ESX = 4.396 - 4.594 * DS + 3.268 * S
38232 UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38236 AKS = 1.415 - 0.641 * DS
38237 AS = 0.580 - 9.763 * DS + 6.795 * S - 0.558 * S2
38238 BS = 5.617 + 5.709 * DS - 3.972 * S
38239 DST = 13.78 - 9.581 * S + 5.370 * S2 - 0.996 * S3
38240 EST = 4.546 + 0.372 * S2
38241 ESS = 5.053 - 1.070 * S + 0.805 * S2
38242 SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38247 BKG = 2.427 + 1.311 * S - 0.153 * S2
38248 AG = 25.09 - 7.935 * S
38249 BG = -14.84 - 124.3 * DS + 72.18 * S
38250 CG = 590.3 - 173.8 * S
38251 DG = 5.196 + 1.857 * S
38252 EG = -1.648 + 3.988 * S - 0.432 * S2
38253 ESG = 3.232 - 0.542 * S
38254 GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38259 *...FUNCTIONAL FORMS OF THE PARAMETRIZATIONS :
38261 *$ CREATE PHO_DOR94FV.FOR
38263 CDECK ID>, PHO_DOR94FV
38264 DOUBLE PRECISION FUNCTION PHO_DOR94FV (X,N,AK,BK,A,B,C,D)
38265 IMPLICIT DOUBLE PRECISION (A - Z)
38269 PHO_DOR94FV = N*X**AK*(1.D0+A*X**BK+X*(B+C*DX))*(1.D0-X)**D
38273 *$ CREATE PHO_DOR94FW.FOR
38275 CDECK ID>, PHO_DOR94FW
38276 DOUBLE PRECISION FUNCTION PHO_DOR94FW(X,S,AL,BE,AK,BK,
38278 IMPLICIT DOUBLE PRECISION (A - Z)
38282 PHO_DOR94FW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
38283 1 * DEXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38287 *$ CREATE PHO_DOR94FS.FOR
38289 CDECK ID>, PHO_DOR94FS
38290 DOUBLE PRECISION FUNCTION PHO_DOR94FS (X,S,AL,BE,AK,AG,B,D,E,ES)
38291 IMPLICIT DOUBLE PRECISION (A - Z)
38296 PHO_DOR94FS = S**AL / LX**AK * (1.+ AG*DX + B*X) * (1.- X)**D
38297 1 * DEXP (-E + SQRT (ES * S**BE * LX))
38301 *$ CREATE PHO_DOR92LO.FOR
38303 CDECK ID>, PHO_DOR92LO
38306 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38308 * 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 *
38310 * FOR A DETAILED EXPLANATION SEE : *
38311 * M. GLUECK, E.REYA, A.VOGT: DO-TH 91/07 *
38313 * THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
38314 * FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
38315 * / HO) AND 1.E8 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
38316 * REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG- *
38317 * LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT. *
38319 * HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
38320 * M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
38322 * CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
38323 * LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
38324 * LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
38325 * HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
38326 * LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
38328 * HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL. *
38330 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38332 SUBROUTINE PHO_DOR92LO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
38333 IMPLICIT DOUBLE PRECISION (A - Z)
38337 LAM2 = 0.232 * 0.232
38338 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38341 C...X * (UV + DV) :
38342 NUD = 0.663 + 0.191 * S - 0.041 * S2 + 0.031 * S3
38344 AGUD = -1.97 + 6.74 * S - 1.96 * S2
38345 BUD = 24.4 - 20.7 * S + 4.08 * S2
38346 DUD = 2.86 + 0.70 * S - 0.02 * S2
38347 UDV = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
38349 ND = 0.579 + 0.283 * S + 0.047 * S2
38350 AKD = 0.523 - 0.015 * S
38351 AGD = 2.22 - 0.59 * S - 0.27 * S2
38352 BD = 5.95 - 6.19 * S + 1.55 * S2
38353 DD = 3.57 + 0.94 * S - 0.16 * S2
38354 DV = PHO_DOR92FV (X,ND,AKD,AGD,BD,DD)
38358 AKG = 1.00 - 0.17 * S
38360 AGG = 0.0 + 4.879 * S - 1.383 * S2
38361 BGG = 25.92 - 28.97 * S + 5.596 * S2
38362 CG = -25.69 + 23.68 * S - 1.975 * S2
38363 DG = 2.537 + 1.718 * S + 0.353 * S2
38364 EG = 0.595 + 2.138 * S
38366 GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38367 C...X * UBAR = X * DBAR :
38370 AKU = 0.412 - 0.171 * S
38371 BKU = 0.566 - 0.496 * S
38374 CU = 1.029 + 1.785 * S - 0.459 * S2
38375 DU = 4.696 + 2.109 * S
38376 EU = 3.838 + 1.944 * S
38378 UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
38379 C...X * SBAR = X * S :
38383 AKS = 2.082 - 0.577 * S
38384 AGS = -3.055 + 1.024 * S ** 0.67
38385 BS = 27.4 - 20.0 * S ** 0.154
38387 EST = 4.33 + 1.408 * S
38388 ESS = 8.27 - 0.437 * S
38389 SB = PHO_DOR92FS(X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38390 C...X * CBAR = X * C :
38396 BC = 4.24 - 0.804 * S
38397 DC = 3.46 + 1.076 * S
38398 EC = 4.61 + 1.490 * S
38399 ESC = 2.555 + 1.961 * S
38400 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38401 C...X * BBAR = X * B :
38408 DB = 2.929 + 1.396 * S
38409 EB = 4.71 + 1.514 * S
38410 ESB = 4.02 + 1.239 * S
38411 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38415 *$ CREATE PHO_DOR92HO.FOR
38417 CDECK ID>, PHO_DOR92HO
38418 SUBROUTINE PHO_DOR92HO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
38419 IMPLICIT DOUBLE PRECISION (A - Z)
38423 LAM2 = 0.248 * 0.248
38424 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38428 C...X * (UV + DV) :
38429 NUD = 0.330 + 0.151 * S - 0.059 * S2 + 0.027 * S3
38431 AGUD = -2.28 + 15.73 * S - 4.58 * S2
38432 BUD = 56.7 - 53.6 * S + 11.21 * S2
38433 DUD = 3.17 + 1.17 * S - 0.47 * S2 + 0.09 * S3
38434 UDV = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
38436 ND = 0.459 + 0.315 * DS + 0.515 * S
38437 AKD = 0.624 - 0.031 * S
38438 AGD = 8.13 - 6.77 * DS + 0.46 * S
38439 BD = 6.59 - 12.83 * DS + 5.65 * S
38440 DD = 3.98 + 1.04 * S - 0.34 * S2
38441 DV = PHO_DOR92FV (X, ND, AKD, AGD, BD, DD)
38445 AKG = 0.323 + 1.653 * S
38446 BKG = 0.811 + 2.044 * S
38447 AGG = 0.0 + 1.963 * S - 0.519 * S2
38448 BGG = 0.078 + 6.24 * S
38449 CG = 30.77 - 24.19 * S
38450 DG = 3.188 + 0.720 * S
38451 EG = -0.881 + 2.687 * S
38453 GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38454 C...X * UBAR = X * DBAR :
38457 AKU = 0.636 - 0.084 * S
38459 AGU = 1.121 - 0.193 * S
38460 BGU = 0.751 - 0.785 * S
38461 CU = 8.57 - 1.763 * S
38462 DU = 10.22 + 0.668 * S
38463 EU = 3.784 + 1.280 * S
38464 ESU = 1.808 + 0.980 * S
38465 UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
38466 C...X * SBAR = X * S :
38470 AKS = 2.942 - 1.016 * S
38471 AGS = -4.60 + 1.167 * S
38472 BS = 9.31 - 1.324 * S
38473 DS = 11.49 - 1.198 * S + 0.053 * S2
38474 EST = 2.630 + 1.729 * S
38476 SB = PHO_DOR92FS (X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38477 C...X * CBAR = X * C :
38481 AKC = -0.625 - 0.523 * S
38483 BC = 1.896 + 1.616 * S
38484 DC = 4.12 + 0.683 * S
38485 EC = 4.36 + 1.328 * S
38486 ESC = 0.677 + 0.679 * S
38487 CB = PHO_DOR92FS (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38488 C...X * BBAR = X * B :
38492 AKB = 0.0 - 0.193 * S
38495 DB = 3.447 + 0.927 * S
38496 EB = 4.68 + 1.259 * S
38497 ESB = 1.892 + 2.199 * S
38498 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38502 *$ CREATE PHO_DOR92FV.FOR
38504 CDECK ID>, PHO_DOR92FV
38505 DOUBLE PRECISION FUNCTION PHO_DOR92FV(X,N,AK,AG,B,D)
38506 IMPLICIT DOUBLE PRECISION (A - Z)
38509 PHO_DOR92FV = N * X**AK * (1.+ AG*DX + B*X) * (1.- X)**D
38513 *$ CREATE PHO_DOR92FW.FOR
38515 CDECK ID>, PHO_DOR92FW
38516 DOUBLE PRECISION FUNCTION PHO_DOR92FW(X,S,
38517 & AL,BE,AK,BK,AG,BG,C,D,E,ES)
38518 IMPLICIT DOUBLE PRECISION (A - Z)
38521 PHO_DOR92FW = (X**AK * (AG + X * (BG + X*C)) * LX**BK + S**AL
38522 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38526 *$ CREATE PHO_DOR92FS.FOR
38528 CDECK ID>, PHO_DOR92FS
38529 DOUBLE PRECISION FUNCTION PHO_DOR92FS(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
38530 IMPLICIT DOUBLE PRECISION (A - Z)
38535 IF (S .LE. ST) THEN
38538 PHO_DOR92FS = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
38539 1 * EXP (-E + SQRT (ES * S**BE * LX))
38544 *$ CREATE PHO_DORPLO.FOR
38546 CDECK ID>, PHO_DORPLO
38548 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38550 * G R V - P I O N - P A R A M E T R I Z A T I O N S *
38552 * FOR A DETAILED EXPLANATION SEE : *
38553 * M. GLUECK, E.REYA, A.VOGT: DO-TH 91/16 *
38555 * THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
38556 * FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
38557 * / HO) AND 1.E8 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
38558 * REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG- *
38559 * LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT. *
38561 * HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
38562 * M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
38564 * CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
38565 * LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
38566 * LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
38567 * HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
38568 * LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
38570 * HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL. *
38572 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38574 SUBROUTINE PHO_DORPLO (X, Q2, VAP, GLP, QBP, CBP, BBP)
38575 IMPLICIT DOUBLE PRECISION (A - Z)
38579 LAM2 = 0.232 * 0.232
38580 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38584 NV = 0.519 + 0.180 * S - 0.011 * S2
38585 AKV = 0.499 - 0.027 * S
38586 AGV = 0.381 - 0.419 * S
38587 DV = 0.367 + 0.563 * S
38588 VAP = PHO_DORFVP (X, NV, AKV, AGV, DV)
38592 AKG = 0.482 + 0.341 * DS
38594 AGG = 0.678 + 0.877 * S - 0.175 * S2
38595 BGG = 0.338 - 1.597 * S
38596 CG = 0.0 - 0.233 * S + 0.406 * S2
38597 DG = 0.390 + 1.053 * S
38598 EG = 0.618 + 2.070 * S
38600 GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38601 C...X * QBAR (SU(3)-SYMMETRIC SEA) :
38605 AKS = 2.538 - 0.763 * S
38607 BS = 0.313 + 0.935 * S
38609 EST = 4.433 + 1.301 * S
38610 ESS = 9.30 - 0.887 * S
38611 QBP = PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38612 C...X * CBAR = X * C :
38619 DC = 1.208 + 0.771 * S
38620 EC = 4.40 + 1.493 * S
38621 ESC = 2.032 + 1.901 * S
38622 CBP = PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38623 C...X * BBAR = X * B :
38630 DB = 0.697 + 0.855 * S
38631 EB = 4.51 + 1.490 * S
38632 ESB = 3.056 + 1.694 * S
38633 BBP = PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38637 *$ CREATE PHO_DORPHO.FOR
38639 CDECK ID>, PHO_DORPHO
38640 SUBROUTINE PHO_DORPHO (X, Q2, VAP, GLP, QBP, CBP, BBP)
38641 IMPLICIT DOUBLE PRECISION (A - Z)
38645 LAM2 = 0.248 * 0.248
38646 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38650 NV = 0.456 + 0.150 * DS + 0.112 * S - 0.019 * S2
38651 AKV = 0.505 - 0.033 * S
38652 AGV = 0.748 - 0.669 * DS - 0.133 * S
38653 DV = 0.365 + 0.197 * DS + 0.394 * S
38654 VAP = PHO_DORFVP (X, NV, AKV, AGV, DV)
38658 AKG = 0.437 - 0.689 * DS
38660 AGG = 1.324 - 0.441 * DS - 0.130 * S
38661 BGG = -0.955 + 0.259 * S
38662 CG = 1.075 - 0.302 * S
38663 DG = 1.158 + 1.229 * S
38664 EG = 0.0 + 2.510 * S
38665 ESG = 2.604 + 0.165 * S
38666 GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38667 C...X * QBAR (SU(3)-SYMMETRIC SEA) :
38671 AKS = -0.350 + 0.806 * S
38674 DS = 2.273 + 1.438 * S
38675 EST = 3.214 + 1.545 * S
38676 ESS = 1.341 + 1.938 * S
38677 QBP = PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38678 C...X * CBAR = X * C :
38682 AKC = 0.0 - 0.457 * S
38684 BC = -1.00 + 1.40 * S
38685 DC = 1.318 + 0.584 * S
38686 EC = 4.45 + 1.235 * S
38687 ESC = 1.496 + 1.010 * S
38688 CBP = PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38689 C...X * BBAR = X * B :
38693 AKB = 0.0 - 0.172 * S
38696 DB = 1.447 + 0.485 * S
38697 EB = 4.79 + 1.164 * S
38698 ESB = 1.724 + 2.121 * S
38699 BBP = PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38703 *$ CREATE PHO_DORFVP.FOR
38705 CDECK ID>, PHO_DORFVP
38706 DOUBLE PRECISION FUNCTION PHO_DORFVP(X,N,AK,AG,D)
38707 IMPLICIT DOUBLE PRECISION (A - Z)
38711 PHO_DORFVP = N * X**AK * (1.+ AG*DX) * (1.- X)**D
38715 *$ CREATE PHO_DORFGP.FOR
38717 CDECK ID>, PHO_DORFGP
38718 DOUBLE PRECISION FUNCTION PHO_DORFGP(X,S,AL,BE,AK,BK,AG,
38720 IMPLICIT DOUBLE PRECISION (A - Z)
38725 PHO_DORFGP = (X**AK * (AG + BG*DX + C*X) * LX**BK + S**AL
38726 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38730 *$ CREATE PHO_DORFQP.FOR
38732 CDECK ID>, PHO_DORFQP
38733 DOUBLE PRECISION FUNCTION PHO_DORFQP(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
38734 IMPLICIT DOUBLE PRECISION (A - Z)
38739 IF (S .LE. ST) THEN
38742 PHO_DORFQP = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
38743 1 * EXP (-E + SQRT (ES * S**BE * LX))
38748 *$ CREATE PHO_DORGLO.FOR
38750 CDECK ID>, PHO_DORGLO
38751 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38753 * 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 *
38755 * FOR A DETAILED EXPLANATION SEE : *
38756 * M. GLUECK, E.REYA, A.VOGT: DO-TH 91/31 *
38758 * THE OUTPUT IS ALWAYS 1./ ALPHA(EM) * X * PARTON DENSITY *
38760 * THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
38761 * FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
38762 * / HO) AND 1.E6 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
38764 * HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
38765 * M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
38767 * CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
38768 * LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
38769 * LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
38770 * HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
38771 * LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
38773 * HO DISTRIBUTIONS REFER TO THE DIS(GAMMA) SCHEME, SEE : *
38774 * M. GLUECK, E.REYA, A.VOGT: DO-TH 91/26 *
38776 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38778 SUBROUTINE PHO_DORGLO (X, Q2, UL, DL, SL, CL, BL, GL)
38779 IMPLICIT DOUBLE PRECISION (A - Z)
38783 LAM2 = 0.232 * 0.232
38784 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38787 C...X * U = X * UBAR :
38790 AK = 0.500 - 0.176 * S
38791 BK = 15.00 - 5.687 * SS - 0.552 * S2
38792 AG = 0.235 + 0.046 * SS
38793 BG = 0.082 - 0.051 * S + 0.168 * S2
38794 C = 0.0 + 0.459 * S
38795 D = 0.354 - 0.061 * S
38796 E = 4.899 + 1.678 * S
38797 ES = 2.046 + 1.389 * S
38798 UL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38799 C...X * D = X * DBAR :
38802 AK = 0.496 + 0.026 * S
38803 BK = 0.685 - 0.580 * SS + 0.608 * S2
38804 AG = 0.233 + 0.302 * S
38805 BG = 0.0 - 0.818 * S + 0.198 * S2
38806 C = 0.114 + 0.154 * S
38807 D = 0.405 - 0.195 * S + 0.046 * S2
38808 E = 4.807 + 1.226 * S
38809 ES = 2.166 + 0.664 * S
38810 DL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38814 AK = 0.462 - 0.524 * SS
38815 BK = 5.451 - 0.804 * S2
38816 AG = 0.535 - 0.504 * SS + 0.288 * S2
38817 BG = 0.364 - 0.520 * S
38818 C = -0.323 + 0.115 * S2
38819 D = 0.233 + 0.790 * S - 0.139 * S2
38820 E = 0.893 + 1.968 * S
38821 ES = 3.432 + 0.392 * S
38822 GL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38823 C...X * S = X * SBAR :
38827 AK = 0.470 - 0.099 * S2
38829 AG = 0.121 - 0.068 * SS
38830 BG = -0.090 + 0.074 * S
38831 C = 0.062 + 0.034 * S
38832 D = 0.0 + 0.226 * S - 0.060 * S2
38833 E = 4.288 + 1.707 * S
38834 ES = 2.122 + 0.656 * S
38835 SL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38836 C...X * C = X * CBAR :
38840 AK = 1.254 - 0.251 * S
38841 BK = 3.932 - 0.327 * S2
38842 AG = 0.658 + 0.202 * S
38845 D = 0.0 + 0.141 * S - 0.027 * S2
38846 E = 4.911 + 0.969 * S
38847 ES = 2.796 + 0.952 * S
38848 CL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38849 C...X * B = X * BBAR :
38853 AK = 1.961 - 0.370 * S
38854 BK = 0.923 + 0.119 * S
38855 AG = 0.815 + 0.207 * S
38858 D = -0.223 + 0.173 * S
38859 E = 5.426 + 0.623 * S
38860 ES = 3.819 + 0.901 * S
38861 BL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38865 *$ CREATE PHO_DORGHO.FOR
38867 CDECK ID>, PHO_DORGHO
38868 SUBROUTINE PHO_DORGHO (X, Q2, UH, DH, SH, CH, BH, GH)
38869 IMPLICIT DOUBLE PRECISION (A - Z)
38873 LAM2 = 0.248 * 0.248
38874 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38877 C...X * U = X * UBAR :
38880 AK = 0.449 - 0.025 * S - 0.071 * S2
38881 BK = 5.060 - 1.116 * SS
38883 BG = 0.319 + 0.422 * S
38884 C = 1.508 + 4.792 * S - 1.963 * S2
38885 D = 1.075 + 0.222 * SS - 0.193 * S2
38886 E = 4.147 + 1.131 * S
38887 ES = 1.661 + 0.874 * S
38888 UH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38889 C...X * D = X * DBAR :
38892 AK = 0.442 - 0.132 * S - 0.058 * S2
38893 BK = 5.437 - 1.916 * SS
38895 BG = 0.311 - 0.059 * S
38896 C = 0.800 + 0.078 * S - 0.100 * S2
38897 D = 0.862 + 0.294 * SS - 0.184 * S2
38898 E = 4.202 + 1.352 * S
38899 ES = 1.841 + 0.990 * S
38900 DH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38904 AK = 0.530 - 0.742 * SS + 0.025 * S2
38906 AG = 0.533 - 0.281 * SS + 0.218 * S2
38907 BG = 0.025 - 0.518 * S + 0.156 * S2
38908 C = -0.282 + 0.209 * S2
38909 D = 0.107 + 1.058 * S - 0.218 * S2
38910 E = 0.0 + 2.704 * S
38911 ES = 3.071 - 0.378 * S
38912 GH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38913 C...X * S = X * SBAR :
38917 AK = 1.770 - 0.735 * SS - 0.079 * S2
38919 AG = 0.084 - 0.023 * S
38921 C = 2.119 - 0.942 * S + 0.063 * S2
38922 D = 1.271 + 0.076 * S - 0.190 * S2
38923 E = 4.604 + 0.737 * S
38924 ES = 1.641 + 0.976 * S
38925 SH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38926 C...X * C = X * CBAR :
38930 AK = 1.142 - 0.175 * S
38932 AG = 0.504 + 0.317 * S
38935 D = 0.398 + 0.326 * S - 0.107 * S2
38936 E = 5.493 + 0.408 * S
38937 ES = 2.426 + 1.277 * S
38938 CH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38939 C...X * B = X * BBAR :
38943 AK = 1.953 - 0.391 * S
38944 BK = 1.657 - 0.161 * S
38945 AG = 1.076 + 0.034 * S
38948 D = 0.353 + 0.016 * S
38949 E = 5.713 + 0.249 * S
38950 ES = 3.456 + 0.673 * S
38951 BH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38955 *$ CREATE PHO_DORGH0.FOR
38957 CDECK ID>, PHO_DORGH0
38958 SUBROUTINE PHO_DORGH0 (X, Q2, U0, D0, S0, C0, B0, G0)
38959 IMPLICIT DOUBLE PRECISION (A - Z)
38963 LAM2 = 0.248 * 0.248
38964 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38967 C...X * U = X * UBAR :
38970 AK = 0.527 + 0.200 * S - 0.107 * S2
38971 BK = 7.106 - 0.310 * SS - 0.786 * S2
38972 AG = 0.197 + 0.533 * S
38973 BG = 0.062 - 0.398 * S + 0.109 * S2
38974 C = 0.755 * S - 0.112 * S2
38975 D = 0.318 - 0.059 * S
38976 E = 4.225 + 1.708 * S
38977 ES = 1.752 + 0.866 * S
38978 U0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38979 C...X * D = X * DBAR :
38982 AK = 0.500 + 0.067 * SS - 0.055 * S2
38983 BK = 0.376 - 0.453 * SS + 0.405 * S2
38984 AG = 0.156 + 0.184 * S
38985 BG = 0.0 - 0.528 * S + 0.146 * S2
38986 C = 0.121 + 0.092 * S
38987 D = 0.379 - 0.301 * S + 0.081 * S2
38988 E = 4.346 + 1.638 * S
38989 ES = 1.645 + 1.016 * S
38990 D0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38994 AK = 0.537 - 0.600 * SS
38995 BK = 6.389 - 0.953 * S2
38996 AG = 0.558 - 0.383 * SS + 0.261 * S2
38997 BG = 0.0 - 0.305 * S
38998 C = -0.222 + 0.078 * S2
38999 D = 0.153 + 0.978 * S - 0.209 * S2
39000 E = 1.429 + 1.772 * S
39001 ES = 3.331 + 0.806 * S
39002 G0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39003 C...X * S = X * SBAR :
39007 AK = 0.622 + 0.332 * S - 0.300 * S2
39009 AG = 0.211 - 0.064 * SS - 0.018 * S2
39010 BG = -0.215 + 0.122 * S
39012 D = 0.0 + 0.253 * S - 0.081 * S2
39013 E = 3.990 + 2.014 * S
39014 ES = 1.720 + 0.986 * S
39015 S0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39016 C...X * C = X * CBAR :
39020 AK = 1.228 - 0.231 * S
39021 BK = 3.806 - 0.337 * S2
39022 AG = 0.932 + 0.150 * S
39025 D = 0.0 + 0.138 * S - 0.028 * S2
39026 E = 5.588 + 0.628 * S
39027 ES = 2.665 + 1.054 * S
39028 C0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39029 C...X * B = X * BBAR :
39033 AK = 1.719 - 0.292 * S
39034 BK = 0.928 + 0.096 * S
39035 AG = 0.845 + 0.178 * S
39038 D = -0.191 + 0.151 * S
39039 E = 6.089 + 0.282 * S
39040 ES = 3.379 + 1.062 * S
39041 B0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39045 *$ CREATE PHO_DORGF.FOR
39047 CDECK ID>, PHO_DORGF
39048 DOUBLE PRECISION FUNCTION PHO_DORGF(X,S,AL,BE,AK,BK,
39050 IMPLICIT DOUBLE PRECISION (A - Z)
39055 PHO_DORGF = (X**AK * (AG + BG * SX + C * X**BK) + S**AL
39056 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
39060 *$ CREATE PHO_DORGFS.FOR
39062 CDECK ID>, PHO_DORGFS
39063 DOUBLE PRECISION FUNCTION PHO_DORGFS(X,S,SF,AL,BE,AK,BK,AG,BG,
39065 IMPLICIT DOUBLE PRECISION (A - Z)
39068 IF (S .LE. SF) THEN
39074 PHO_DORGFS = (DS * X**AK * (AG + BG * SX + C * X**BK) + DS**AL
39075 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
39080 *$ CREATE PHO_DORGLV.FOR
39082 CDECK ID>, PHO_DORGLV
39083 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39085 * G R S - LO - VIRTUAL PHOTON PARAMETRIZATIONS *
39087 * FOR A DETAILED EXPLANATION SEE *
39088 * M. GLUECK, E.REYA, M. STRATMANN : *
39089 * PHYS. REV. D51 (1995) 3220 *
39091 * THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR *
39092 * Q**2 / GEV**2 BETWEEN 0.6 AND 5.E4 *
39093 * AND (!) Q**2 > 5 P**2 *
39094 * P**2 / GEV**2 BETWEEN 0.0 AND 10. *
39095 * P**2 = 0 <=> REAL PHOTON *
39096 * X BETWEEN 1.E-4 AND 1. *
39098 * HEAVY QUARK THRESHOLDS Q(H) = M(H) IN THE BETA FUNCTION : *
39099 * M(C) = 1.5, M(B) = 4.5 *
39100 * CORRESPONDING LAMBDA(F) VALUES IN GEV FOR Q**2 > M(H)**2 : *
39101 * LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
39102 * LAMBDA(5) = 0.153, *
39103 * THE NUMBER OF ACTIVE QUARK FLAVOURS IS NF = 3 EVERYWHERE *
39104 * EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,... *
39105 * ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION. *
39107 * PLEASE REPORT ANY STRANGE BEHAVIOUR TO : *
39108 * Marco.Stratmann@durham.ac.uk *
39109 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39111 *...INPUT PARAMETERS :
39113 * X = MOMENTUM FRACTION
39114 * Q2 = SCALE Q**2 IN GEV**2
39115 * P2 = VIRTUALITY OF THE PHOTON IN GEV**2
39117 *...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION DIVIDED BY ALPHA_EM) :
39119 ********************************************************
39120 * subroutine grspar(x,q2,p2,ugam,dgam,sgam,ggam)
39121 subroutine PHO_DORGLV(x,q2,p2,ugam,dgam,sgam,ggam)
39122 implicit double precision (a-z)
39125 C input/output channels
39127 COMMON /POINOU/ LI,LO
39134 if(x.lt.0.0001d0) check=1
39135 if((q2.lt.0.6d0).or.(q2.gt.50000.d0)) check=1
39136 if(q2.lt.5.d0*p2) check=1
39138 c calculate distributions
39140 if(check.eq.0) then
39141 call PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
39143 WRITE(LO,*) 'GRS PDF parametrization: x/q2/p2 limits exceeded'
39144 WRITE(LO,'(1X,A,1P,3E12.3)') 'current X, Q2, P2:',x,q2,p2
39149 *$ CREATE PHO_grscalc.FOR
39151 CDECK ID>, PHO_grscalc
39152 subroutine PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
39153 implicit double precision (a-z)
39156 dimension u1(40),ds1(40),g1(40)
39157 dimension ud2(20),s2(20),g2(20)
39158 dimension up0(20),dsp0(20),gp0(20)
39159 CPH save u1,ds1,g1,ud2,s2,g2,up0,dsp0,gp0
39161 data u1/-0.139d0,0.783d0,0.132d0,0.087d0,0.003d0,-0.0134d0,
39162 & 0.009d0,-0.017d0,0.092d0,-0.516d0,-0.085d0,0.439d0,
39163 & 0.013d0,0.108d0,-0.019d0,-0.272d0,-0.167d0,0.138d0,
39164 & 0.076d0,0.026d0,-0.013d0,0.27d0,0.107d0,-0.097d0,0.04d0,
39165 & 0.064d0,0.011d0,0.002d0,0.057d0,-0.057d0,0.162d0,
39166 & -0.172d0,0.124d0,-0.016d0,-0.065d0,0.044d0,-1.009d0,
39167 & 0.622d0,0.227d0,-0.184d0/
39168 data ds1/0.033d0,0.007d0,-0.0516d0,0.12d0,0.001d0,-0.013d0,
39169 & 0.018d0,-0.028d0,0.102d0,-0.595d0,-0.114d0,0.669d0,
39170 & 0.022d0,0.001d0,-0.003d0,-0.0583d0,-0.041d0,0.035d0,
39171 & 0.009d0,0.009d0,0.004d0,0.054d0,0.025d0,-0.02d0,
39172 & 0.007d0,0.021d0,0.01d0,0.004d0,-0.067d0,0.06d0,-0.148d0,
39173 & 0.13d0,0.032d0,-0.009d0,-0.06d0,0.036d0,-0.39d0,0.033d0,
39174 & 0.245d0,-0.171d0/
39175 data g1/0.025d0,0.d0,-0.018d0,0.112d0,-0.025d0,0.177d0,
39176 & -0.022d0,0.024d0,0.001d0,-0.0104d0,0.d0,0.d0,-1.082d0,
39177 & -1.666d0,0.d0,0.086d0,0.d0,0.053d0,0.005d0,-0.058d0,
39178 & 0.034d0,0.073d0,1.08d0,1.63d0,-0.0256d0,-0.088d0,0.d0,
39179 & 0.d0,-0.004d0,0.016d0,0.007d0,-0.012d0,0.01d0,-0.673d0,
39180 & 0.126d0,-0.167d0,0.032d0,-0.227d0,0.086d0,-0.159d0/
39181 data ud2/0.756d0,0.187d0,0.109d0,-0.163d0,0.002d0,0.004d0,
39182 & 0.054d0,-0.039d0,22.53d0,-21.02d0,5.608d0,0.332d0,
39183 & -0.008d0,-0.021d0,0.381d0,0.572d0,4.774d0,1.436d0,
39184 & -0.614d0,3.548d0/
39185 data s2/0.902d0,0.182d0,0.271d0,-0.346d0,0.017d0,-0.01d0,
39186 & -0.011d0,0.0065d0,17.1d0,-13.29d0,6.519d0,0.031d0,
39187 & -0.0176d0,0.003d0,1.243d0,0.804d0,4.709d0,1.499d0,
39189 data g2/0.364d0,1.31d0,0.86d0,-0.254d0,0.611d0,0.008d0,
39190 & -0.097d0,-2.412d0,-0.843d0,2.248d0,-0.201d0,1.33d0,
39191 & 0.572d0,0.44d0,1.233d0,0.009d0,0.954d0,1.862d0,3.791d0,
39193 data up0/1.551d0,0.105d0,1.089d0,-0.172d0,3.822d0,-2.162d0,
39194 & 0.533d0,-0.467d0,-0.412d0,0.2d0,0.377d0,0.299d0,0.487d0,
39195 & 0.0766d0,0.119d0,0.063d0,7.605d0,0.234d0,-0.567d0,
39197 data dsp0/2.484d0,1.214d0,1.088d0,-0.1735d0,4.293d0,
39198 & -2.802d0,0.5975d0,-0.1193d0,-0.0872d0,0.0418d0,0.128d0,
39199 & 0.0337d0,0.127d0,0.0135d0,0.14d0,0.0423d0,6.946d0,
39200 & 0.814d0,1.531d0,0.124d0/
39201 data gp0/1.682d0,1.1d0,0.5888d0,-0.4714d0,0.5362d0,0.0127d0,
39202 & -2.438d0,0.03399d0,0.07825d0,0.05842d0,0.08393d0,2.348d0,
39203 & -0.07182d0,1.084d0,0.3098d0,-0.07514d0,3.327d0,1.1d0,
39204 & 2.264d0,0.2675d0/
39207 lam2=0.232d0*0.232d0
39209 if(p2.le.0.25d0) then
39210 s=log(log(q2/lam2)/log(mu2/lam2))
39214 s=log(log(q2/lam2)/log(p2/lam2))
39215 lp1=log(p2/mu2)*log(p2/mu2)
39216 lp2=log(p2/mu2+log(p2/mu2))
39219 alp=up0(1)+lp1*u1(1)+lp2*u1(2)
39220 bet=up0(2)+lp1*u1(3)+lp2*u1(4)
39221 a=up0(3)+lp1*u1(5)+lp2*u1(6)+
39222 & (up0(4)+lp1*u1(7)+lp2*u1(8))*s
39223 b=up0(5)+lp1*u1(9)+lp2*u1(10)+
39224 & (up0(6)+lp1*u1(11)+lp2*u1(12))*s**0.5+
39225 & (up0(7)+lp1*u1(13)+lp2*u1(14))*s**2
39226 gb=up0(8)+lp1*u1(15)+lp2*u1(16)+
39227 & (up0(9)+lp1*u1(17)+lp2*u1(18))*s+
39228 & (up0(10)+lp1*u1(19)+lp2*u1(20))*s**2
39229 ga=up0(11)+lp1*u1(21)+lp2*u1(22)+
39230 & (up0(12)+lp1*u1(23)+lp2*u1(24))*s**0.5
39231 gc=up0(13)+lp1*u1(25)+lp2*u1(33)+
39232 & (up0(14)+lp1*u1(26)+lp2*u1(34))*s
39233 gd=up0(15)+lp1*u1(27)+lp2*u1(35)+
39234 & (up0(16)+lp1*u1(28)+lp2*u1(36))*s
39235 ge=up0(17)+lp1*u1(29)+lp2*u1(37)+
39236 & (up0(18)+lp1*u1(30)+lp2*u1(38))*s
39237 gep=up0(19)+lp1*u1(31)+lp2*u1(39)+
39238 & (up0(20)+lp1*u1(32)+lp2*u1(40))*s
39239 upart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39241 alp=dsp0(1)+lp1*ds1(1)+lp2*ds1(2)
39242 bet=dsp0(2)+lp1*ds1(3)+lp2*ds1(4)
39243 a=dsp0(3)+lp1*ds1(5)+lp2*ds1(6)+
39244 & (dsp0(4)+lp1*ds1(7)+lp2*ds1(8))*s
39245 b=dsp0(5)+lp1*ds1(9)+lp2*ds1(10)+
39246 & (dsp0(6)+lp1*ds1(11)+lp2*ds1(12))*s**0.5+
39247 & (dsp0(7)+lp1*ds1(13)+lp2*ds1(14))*s**2
39248 gb=dsp0(8)+lp1*ds1(15)+lp2*ds1(16)+
39249 & (dsp0(9)+lp1*ds1(17)+lp2*ds1(18))*s+
39250 & (dsp0(10)+lp1*ds1(19)+lp2*ds1(20))*s**2
39251 ga=dsp0(11)+lp1*ds1(21)+lp2*ds1(22)+
39252 & (dsp0(12)+lp1*ds1(23)+lp2*ds1(24))*s
39253 gc=dsp0(13)+lp1*ds1(25)+lp2*ds1(33)+
39254 & (dsp0(14)+lp1*ds1(26)+lp2*ds1(34))*s
39255 gd=dsp0(15)+lp1*ds1(27)+lp2*ds1(35)+
39256 & (dsp0(16)+lp1*ds1(28)+lp2*ds1(36))*s
39257 ge=dsp0(17)+lp1*ds1(29)+lp2*ds1(37)+
39258 & (dsp0(18)+lp1*ds1(30)+lp2*ds1(38))*s
39259 gep=dsp0(19)+lp1*ds1(31)+lp2*ds1(39)+
39260 & (dsp0(20)+lp1*ds1(32)+lp2*ds1(40))*s
39261 dspart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39263 alp=gp0(1)+lp1*g1(1)+lp2*g1(2)
39264 bet=gp0(2)+lp1*g1(3)+lp2*g1(4)
39265 a=gp0(3)+lp1*g1(5)+lp2*g1(6)+
39266 & (gp0(4)+lp1*g1(7)+lp2*g1(8))*s**0.5
39267 b=gp0(5)+lp1*g1(9)+lp2*g1(10)+
39268 & (gp0(6)+lp1*g1(11)+lp2*g1(12))*s**2
39269 gb=gp0(7)+lp1*g1(13)+lp2*g1(14)+
39270 & (gp0(8)+lp1*g1(15)+lp2*g1(16))*s
39271 ga=gp0(9)+lp1*g1(17)+lp2*g1(18)+
39272 & (gp0(10)+lp1*g1(19)+lp2*g1(20))*s**0.5+
39273 & (gp0(11)+lp1*g1(21)+lp2*g1(22))*s**2
39274 gc=gp0(12)+lp1*g1(23)+lp2*g1(24)+
39275 & (gp0(13)+lp1*g1(25)+lp2*g1(26))*s**2
39276 gd=gp0(14)+lp1*g1(27)+lp2*g1(28)+
39277 & (gp0(15)+lp1*g1(29)+lp2*g1(30))*s+
39278 & (gp0(16)+lp1*g1(31)+lp2*g1(32))*s**2
39279 ge=gp0(17)+lp1*g1(33)+lp2*g1(34)+
39280 & (gp0(18)+lp1*g1(35)+lp2*g1(36))*s
39281 gep=gp0(19)+lp1*g1(37)+lp2*g1(38)+
39282 & (gp0(20)+lp1*g1(39)+lp2*g1(40))*s
39283 gpart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39285 s=log(log(q2/lam2)/log(mu2/lam2))
39286 suppr=1.d0/(1.d0+p2/0.59d0)**2
39291 ga=ud2(5)+ud2(6)*s**0.5
39293 b=ud2(9)+ud2(10)*s+ud2(11)*s**2
39294 gb=ud2(12)+ud2(13)*s+ud2(14)*s**2
39295 gd=ud2(15)+ud2(16)*s
39296 ge=ud2(17)+ud2(18)*s
39297 gep=ud2(19)+ud2(20)*s
39298 udpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39303 ga=s2(5)+s2(6)*s**0.5
39305 b=s2(9)+s2(10)*s+s2(11)*s**2
39306 gb=s2(12)+s2(13)*s+s2(14)*s**2
39309 gep=s2(19)+s2(20)*s
39310 spart2=suppr*PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39314 a=g2(3)+g2(4)*s**0.5
39317 ga=g2(9)+g2(10)*s**0.5+g2(11)*s**2
39318 gc=g2(12)+g2(13)*s**2
39319 gd=g2(14)+g2(15)*s+g2(16)*s**2
39321 gep=g2(19)+g2(20)*s
39322 gpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39324 ugam=upart1+udpart2
39325 dgam=dspart1+udpart2
39326 sgam=dspart1+spart2
39331 *$ CREATE PHO_grsf1.FOR
39333 CDECK ID>, PHO_grsf1
39334 DOUBLE PRECISION FUNCTION PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,
39336 implicit double precision (a-z)
39339 PHO_grsf1=(x**a*(ga+gb*sqrt(x)+gc*x**b)+
39340 & s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
39345 *$ CREATE PHO_grsf2.FOR
39347 CDECK ID>, PHO_grsf2
39348 DOUBLE PRECISION FUNCTION PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,
39350 implicit double precision (a-z)
39353 PHO_grsf2=(s*x**a*(ga+gb*sqrt(x)+gc*x**b)+
39354 & s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
39359 *$ CREATE PHO_CKMTPA.FOR
39361 CDECK ID>, PHO_CKMTPA
39362 SUBROUTINE PHO_CKMTPA(IPA,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
39363 C**********************************************************************
39365 C PDF based on Regge theory, evolved with .... by ....
39367 C input: IPAR 2212 proton (not installed)
39370 C output: parameters of parametrization
39372 C**********************************************************************
39373 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39378 C input/output channels
39380 COMMON /POINOU/ LI,LO
39382 REAL PROP(40),POMP(40)
39384 & .230000E+00, .200000E+01, .150200E+00, .120000E+01, .263100E+00,
39385 & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
39386 & .100000E+00, .330000E-01, .352102E-01, .200000E+01, .200000E+01,
39387 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39388 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39389 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39390 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39391 & .000000E+00, .000000E+00, .100000E+00, .200000E+01, .100000E+09/
39393 & .230000E+00, .500000E+01, .150200E+00, .120000E+01, .263100E+00,
39394 & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
39395 & .700000E-01, .700000E-01, .137161E+00, .300000E+01, .200000E+01,
39396 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39397 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39398 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39399 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39400 & .000000E+00, .000000E+00, .100000E+00, .500000E+01, .100000E+09/
39402 IF(IPA.EQ.2212) THEN
39407 ELSE IF(IPA.EQ.990) THEN
39413 WRITE(LO,'(1X,A,I7)')
39414 & 'PHO_CKMTPA:ERROR: invalid particle code',IPA
39421 *$ CREATE PHO_CKMTPD.FOR
39423 CDECK ID>, PHO_CKMTPD
39424 SUBROUTINE PHO_CKMTPD(IPAR,X,SCALE2,PD)
39425 C**********************************************************************
39427 C PDF based on Regge theory, evolved with .... by ....
39429 C input: IPAR 2212 proton (not installed)
39432 C output: PD(-6:6) x*f(x) parton distribution functions
39433 C (PDFLIB convention: d = PD(1), u = PD(2) )
39435 C**********************************************************************
39438 C input/output channels
39440 COMMON /POINOU/ LI,LO
39442 DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP
39448 C QCD lambda for evolution
39451 C Q0**2 for evolution
39455 C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
39456 C q(6)=x*charm, q(7)=x*gluon
39460 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
39462 IF(IPAR.EQ.2212) THEN
39463 * CALL PHO_CKMTPR(XX,SB,QQ
39464 WRITE(LO,'(/1X,A,I6)') 'PHO_CKMTPD:ERROR: invalid particle',IPAR
39467 CALL PHO_CKMTPO(XX,SB,QQ)
39472 PD(-4) = DBLE(QQ(6))
39473 PD(-3) = DBLE(QQ(3))
39474 PD(-2) = DBLE(QQ(4))
39475 PD(-1) = DBLE(QQ(5))
39476 PD(0) = DBLE(QQ(7))
39477 PD(1) = DBLE(QQ(2))
39478 PD(2) = DBLE(QQ(1))
39479 PD(3) = DBLE(QQ(3))
39480 PD(4) = DBLE(QQ(6))
39483 IF(IPAR.EQ.990) THEN
39484 CDN = (PD(1)-PD(-1))/2.D0
39485 CUP = (PD(2)-PD(-2))/2.D0
39486 PD(-1) = PD(-1) + CDN
39487 PD(-2) = PD(-2) + CUP
39493 *$ CREATE PHO_CKMTPO.FOR
39495 CDECK ID>, PHO_CKMTPO
39496 SUBROUTINE PHO_CKMTPO(X,S,QQ)
39497 C**********************************************************************
39499 C calculation partons in Pomeron
39501 C**********************************************************************
39506 C input/output channels
39508 COMMON /POINOU/ LI,LO
39510 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
39511 EQUIVALENCE (GF(1,1,1),DL(1))
39515 C DEU.NORM. QUARKS,GLUONS,NEW NORM .6223E+00 .2754E+00 .1372E+01
39516 C POM.NORM. QUARKS,GLUONS,ALL .132E+00 .275E+00 .407E+00
39517 DATA (DL(K),K= 1, 85) /
39518 & .324159E-01, .324159E-01, .298895E-01, .298895E-01, .298895E-01,
39519 & .298895E-01, .486150E+00,-.867362E-18, .362035E-01, .362035E-01,
39520 & .335142E-01, .335151E-01, .335151E-01, .335142E-01, .745381E+00,
39521 & .399157E-02, .417146E-01, .417146E-01, .388545E-01, .388564E-01,
39522 & .388564E-01, .388545E-01, .107588E+01, .969559E-02, .493208E-01,
39523 & .493208E-01, .462819E-01, .462849E-01, .462849E-01, .462819E-01,
39524 & .148168E+01, .174837E-01, .593251E-01, .593251E-01, .560991E-01,
39525 & .561035E-01, .561035E-01, .560991E-01, .196422E+01, .276588E-01,
39526 & .720220E-01, .720220E-01, .686007E-01, .686065E-01, .686065E-01,
39527 & .686007E-01, .252331E+01, .405154E-01, .876695E-01, .876695E-01,
39528 & .840445E-01, .840520E-01, .840520E-01, .840445E-01, .315730E+01,
39529 & .563115E-01, .106489E+00, .106489E+00, .102652E+00, .102662E+00,
39530 & .102662E+00, .102652E+00, .386313E+01, .752690E-01, .128662E+00,
39531 & .128662E+00, .124605E+00, .124616E+00, .124616E+00, .124605E+00,
39532 & .463661E+01, .975686E-01, .154326E+00, .154326E+00, .150039E+00,
39533 & .150053E+00, .150053E+00, .150039E+00, .547247E+01, .123348E+00,
39534 & .183571E+00, .183571E+00, .179048E+00, .179063E+00, .179063E+00/
39535 DATA (DL(K),K= 86, 170) /
39536 & .179048E+00, .636464E+01, .152698E+00, .216445E+00, .216445E+00,
39537 & .211676E+00, .211694E+00, .211694E+00, .211676E+00, .730631E+01,
39538 & .185666E+00, .252948E+00, .252948E+00, .247925E+00, .247946E+00,
39539 & .247946E+00, .247925E+00, .829017E+01, .222252E+00, .293037E+00,
39540 & .293037E+00, .287752E+00, .287776E+00, .287776E+00, .287752E+00,
39541 & .930850E+01, .262414E+00, .336625E+00, .336625E+00, .331070E+00,
39542 & .331097E+00, .331097E+00, .331070E+00, .103534E+02, .306065E+00,
39543 & .383587E+00, .383587E+00, .377754E+00, .377785E+00, .377785E+00,
39544 & .377754E+00, .114166E+02, .353079E+00, .433760E+00, .433760E+00,
39545 & .427641E+00, .427675E+00, .427675E+00, .427641E+00, .124903E+02,
39546 & .403294E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39547 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39548 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39549 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39550 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39551 & .296507E-01, .296507E-01, .258624E-01, .258624E-01, .258624E-01,
39552 & .258624E-01, .422709E+00,-.173472E-17, .330029E-01, .330029E-01/
39553 DATA (DL(K),K= 171, 255) /
39554 & .289773E-01, .289787E-01, .289787E-01, .289773E-01, .642996E+00,
39555 & .344499E-02, .377610E-01, .377610E-01, .334880E-01, .334910E-01,
39556 & .334910E-01, .334880E-01, .914159E+00, .828363E-02, .441590E-01,
39557 & .441590E-01, .396285E-01, .396333E-01, .396333E-01, .396285E-01,
39558 & .123635E+01, .147501E-01, .523710E-01, .523710E-01, .475730E-01,
39559 & .475798E-01, .475798E-01, .475730E-01, .160820E+01, .230185E-01,
39560 & .625514E-01, .625514E-01, .574758E-01, .574848E-01, .574848E-01,
39561 & .574758E-01, .202705E+01, .332433E-01, .748195E-01, .748195E-01,
39562 & .694563E-01, .694678E-01, .694678E-01, .694563E-01, .248945E+01,
39563 & .455440E-01, .892611E-01, .892611E-01, .836006E-01, .836147E-01,
39564 & .836147E-01, .836006E-01, .299114E+01, .600067E-01, .105928E+00,
39565 & .105928E+00, .999607E-01, .999776E-01, .999776E-01, .999607E-01,
39566 & .352735E+01, .766833E-01, .124839E+00, .124839E+00, .118555E+00,
39567 & .118575E+00, .118575E+00, .118555E+00, .409288E+01, .955921E-01,
39568 & .145978E+00, .145978E+00, .139368E+00, .139391E+00, .139391E+00,
39569 & .139368E+00, .468226E+01, .116719E+00, .169300E+00, .169300E+00,
39570 & .162355E+00, .162382E+00, .162382E+00, .162355E+00, .528987E+01/
39571 DATA (DL(K),K= 256, 340) /
39572 & .140017E+00, .194730E+00, .194730E+00, .187441E+00, .187471E+00,
39573 & .187471E+00, .187441E+00, .591007E+01, .165413E+00, .222167E+00,
39574 & .222167E+00, .214525E+00, .214559E+00, .214559E+00, .214525E+00,
39575 & .653724E+01, .192806E+00, .251486E+00, .251486E+00, .243482E+00,
39576 & .243521E+00, .243521E+00, .243482E+00, .716591E+01, .222070E+00,
39577 & .282539E+00, .282539E+00, .274165E+00, .274208E+00, .274208E+00,
39578 & .274165E+00, .779082E+01, .253058E+00, .315161E+00, .315161E+00,
39579 & .306410E+00, .306458E+00, .306458E+00, .306410E+00, .840695E+01,
39580 & .285608E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39581 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39582 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39583 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39584 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39585 & .279581E-01, .279581E-01, .222797E-01, .222797E-01, .222797E-01,
39586 & .222797E-01, .367732E+00, .867362E-18, .309604E-01, .309604E-01,
39587 & .249419E-01, .249441E-01, .249441E-01, .249419E-01, .552053E+00,
39588 & .296633E-02, .350831E-01, .350831E-01, .287126E-01, .287173E-01/
39589 DATA (DL(K),K= 341, 425) /
39590 & .287173E-01, .287126E-01, .770476E+00, .704001E-02, .404554E-01,
39591 & .404554E-01, .337212E-01, .337286E-01, .337286E-01, .337212E-01,
39592 & .102096E+01, .123504E-01, .471588E-01, .471588E-01, .400495E-01,
39593 & .400599E-01, .400599E-01, .400495E-01, .130079E+01, .189795E-01,
39594 & .552518E-01, .552518E-01, .477564E-01, .477700E-01, .477700E-01,
39595 & .477564E-01, .160637E+01, .269860E-01, .647649E-01, .647649E-01,
39596 & .568725E-01, .568897E-01, .568897E-01, .568725E-01, .193388E+01,
39597 & .364007E-01, .757021E-01, .757021E-01, .674022E-01, .674232E-01,
39598 & .674232E-01, .674022E-01, .227916E+01, .472280E-01, .880430E-01,
39599 & .880430E-01, .793257E-01, .793507E-01, .793507E-01, .793257E-01,
39600 & .263802E+01, .594481E-01, .101745E+00, .101745E+00, .926005E-01,
39601 & .926297E-01, .926297E-01, .926005E-01, .300628E+01, .730184E-01,
39602 & .116745E+00, .116745E+00, .107164E+00, .107198E+00, .107198E+00,
39603 & .107164E+00, .337982E+01, .878765E-01, .132961E+00, .132961E+00,
39604 & .122936E+00, .122974E+00, .122974E+00, .122936E+00, .375469E+01,
39605 & .103942E+00, .150298E+00, .150298E+00, .139820E+00, .139863E+00,
39606 & .139863E+00, .139820E+00, .412714E+01, .121118E+00, .168645E+00/
39607 DATA (DL(K),K= 426, 510) /
39608 & .168645E+00, .157706E+00, .157754E+00, .157754E+00, .157706E+00,
39609 & .449366E+01, .139296E+00, .187883E+00, .187883E+00, .176476E+00,
39610 & .176529E+00, .176529E+00, .176476E+00, .485100E+01, .158356E+00,
39611 & .207882E+00, .207882E+00, .196000E+00, .196059E+00, .196059E+00,
39612 & .196000E+00, .519622E+01, .178170E+00, .228506E+00, .228506E+00,
39613 & .216145E+00, .216209E+00, .216209E+00, .216145E+00, .552665E+01,
39614 & .198603E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39615 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39616 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39617 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39618 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39619 & .275294E-01, .275294E-01, .190245E-01, .190245E-01, .190245E-01,
39620 & .190245E-01, .320228E+00, .000000E+00, .302671E-01, .302671E-01,
39621 & .212851E-01, .212884E-01, .212884E-01, .212851E-01, .470861E+00,
39622 & .255059E-02, .338703E-01, .338703E-01, .243988E-01, .244059E-01,
39623 & .244059E-01, .243988E-01, .642452E+00, .595399E-02, .383922E-01,
39624 & .383922E-01, .284195E-01, .284305E-01, .284305E-01, .284195E-01/
39625 DATA (DL(K),K= 511, 595) /
39626 & .831913E+00, .102638E-01, .438519E-01, .438519E-01, .333669E-01,
39627 & .333821E-01, .333821E-01, .333669E-01, .103618E+01, .155000E-01,
39628 & .502475E-01, .502475E-01, .392399E-01, .392595E-01, .392595E-01,
39629 & .392399E-01, .125172E+01, .216612E-01, .575580E-01, .575580E-01,
39630 & .460181E-01, .460425E-01, .460425E-01, .460181E-01, .147519E+01,
39631 & .287272E-01, .657445E-01, .657445E-01, .536635E-01, .536929E-01,
39632 & .536929E-01, .536635E-01, .170330E+01, .366597E-01, .747539E-01,
39633 & .747539E-01, .621238E-01, .621582E-01, .621582E-01, .621238E-01,
39634 & .193297E+01, .454066E-01, .845205E-01, .845205E-01, .713340E-01,
39635 & .713738E-01, .713738E-01, .713340E-01, .216133E+01, .549027E-01,
39636 & .949687E-01, .949687E-01, .812194E-01, .812646E-01, .812646E-01,
39637 & .812194E-01, .238578E+01, .650733E-01, .106015E+00, .106015E+00,
39638 & .916972E-01, .917480E-01, .917480E-01, .916972E-01, .260395E+01,
39639 & .758355E-01, .117569E+00, .117569E+00, .102678E+00, .102735E+00,
39640 & .102735E+00, .102678E+00, .281373E+01, .871004E-01, .129537E+00,
39641 & .129537E+00, .114070E+00, .114133E+00, .114133E+00, .114070E+00,
39642 & .301327E+01, .987750E-01, .141824E+00, .141824E+00, .125777E+00/
39643 DATA (DL(K),K= 596, 680) /
39644 & .125846E+00, .125846E+00, .125777E+00, .320098E+01, .110764E+00,
39645 & .154331E+00, .154331E+00, .137703E+00, .137778E+00, .137778E+00,
39646 & .137703E+00, .337553E+01, .122970E+00, .166962E+00, .166962E+00,
39647 & .149753E+00, .149833E+00, .149833E+00, .149753E+00, .353582E+01,
39648 & .135299E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39649 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39650 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39651 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39652 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39653 & .286766E-01, .286766E-01, .159579E-01, .159579E-01, .159579E-01,
39654 & .159579E-01, .279430E+00,-.867362E-18, .312327E-01, .312327E-01,
39655 & .178644E-01, .178691E-01, .178691E-01, .178644E-01, .399186E+00,
39656 & .219459E-02, .344289E-01, .344289E-01, .204015E-01, .204111E-01,
39657 & .204111E-01, .204015E-01, .529978E+00, .501953E-02, .382657E-01,
39658 & .382657E-01, .235713E-01, .235860E-01, .235860E-01, .235713E-01,
39659 & .668515E+00, .847682E-02, .427243E-01, .427243E-01, .273559E-01,
39660 & .273758E-01, .273758E-01, .273559E-01, .812075E+00, .125486E-01/
39661 DATA (DL(K),K= 681, 765) /
39662 & .477691E-01, .477691E-01, .317212E-01, .317465E-01, .317465E-01,
39663 & .317212E-01, .957801E+00, .172006E-01, .533547E-01, .533547E-01,
39664 & .366231E-01, .366539E-01, .366539E-01, .366231E-01, .110327E+01,
39665 & .223886E-01, .594259E-01, .594259E-01, .420076E-01, .420441E-01,
39666 & .420441E-01, .420076E-01, .124628E+01, .280584E-01, .659213E-01,
39667 & .659213E-01, .478149E-01, .478570E-01, .478570E-01, .478149E-01,
39668 & .138496E+01, .341502E-01, .727749E-01, .727749E-01, .539803E-01,
39669 & .540280E-01, .540280E-01, .539803E-01, .151767E+01, .405990E-01,
39670 & .799178E-01, .799178E-01, .604361E-01, .604895E-01, .604895E-01,
39671 & .604361E-01, .164304E+01, .473372E-01, .872796E-01, .872796E-01,
39672 & .671134E-01, .671724E-01, .671724E-01, .671134E-01, .175992E+01,
39673 & .542955E-01, .947896E-01, .947896E-01, .739429E-01, .740075E-01,
39674 & .740075E-01, .739429E-01, .186739E+01, .614047E-01, .102378E+00,
39675 & .102378E+00, .808565E-01, .809266E-01, .809266E-01, .808565E-01,
39676 & .196473E+01, .685965E-01, .109978E+00, .109978E+00, .877881E-01,
39677 & .878637E-01, .878637E-01, .877881E-01, .205141E+01, .758045E-01,
39678 & .117525E+00, .117525E+00, .946745E-01, .947553E-01, .947553E-01/
39679 DATA (DL(K),K= 766, 850) /
39680 & .946745E-01, .212709E+01, .829655E-01, .124958E+00, .124958E+00,
39681 & .101456E+00, .101542E+00, .101542E+00, .101456E+00, .219159E+01,
39682 & .900196E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39683 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39684 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39685 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39686 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39687 & .318691E-01, .318691E-01, .129081E-01, .129081E-01, .129081E-01,
39688 & .129081E-01, .244842E+00,-.867362E-18, .343104E-01, .343104E-01,
39689 & .145076E-01, .145124E-01, .145124E-01, .145076E-01, .337040E+00,
39690 & .189443E-02, .371900E-01, .371900E-01, .165461E-01, .165557E-01,
39691 & .165557E-01, .165461E-01, .433081E+00, .422691E-02, .404763E-01,
39692 & .404763E-01, .189941E-01, .190085E-01, .190085E-01, .189941E-01,
39693 & .530109E+00, .696769E-02, .441304E-01, .441304E-01, .218150E-01,
39694 & .218342E-01, .218342E-01, .218150E-01, .626129E+00, .100799E-01,
39695 & .481031E-01, .481031E-01, .249615E-01, .249853E-01, .249853E-01,
39696 & .249615E-01, .719221E+00, .135159E-01, .523426E-01, .523426E-01/
39697 DATA (DL(K),K= 851, 935) /
39698 & .283837E-01, .284122E-01, .284122E-01, .283837E-01, .807951E+00,
39699 & .172259E-01, .567940E-01, .567940E-01, .320288E-01, .320619E-01,
39700 & .320619E-01, .320288E-01, .891154E+00, .211568E-01, .614022E-01,
39701 & .614022E-01, .358436E-01, .358811E-01, .358811E-01, .358436E-01,
39702 & .967928E+00, .252549E-01, .661122E-01, .661122E-01, .397750E-01,
39703 & .398169E-01, .398169E-01, .397750E-01, .103759E+01, .294673E-01,
39704 & .708708E-01, .708708E-01, .437716E-01, .438176E-01, .438176E-01,
39705 & .437716E-01, .109966E+01, .337422E-01, .756269E-01, .756269E-01,
39706 & .477840E-01, .478342E-01, .478342E-01, .477840E-01, .115380E+01,
39707 & .380302E-01, .803322E-01, .803322E-01, .517659E-01, .518200E-01,
39708 & .518200E-01, .517659E-01, .119986E+01, .422846E-01, .849423E-01,
39709 & .849423E-01, .556743E-01, .557322E-01, .557322E-01, .556743E-01,
39710 & .123782E+01, .464624E-01, .894164E-01, .894164E-01, .594701E-01,
39711 & .595315E-01, .595315E-01, .594701E-01, .126777E+01, .505242E-01,
39712 & .937178E-01, .937178E-01, .631181E-01, .631829E-01, .631829E-01,
39713 & .631181E-01, .128993E+01, .544348E-01, .978144E-01, .978144E-01,
39714 & .665876E-01, .666556E-01, .666556E-01, .665876E-01, .130457E+01/
39715 DATA (DL(K),K= 936, 1020) /
39716 & .581632E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39717 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39718 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39719 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39720 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39721 & .377668E-01, .377668E-01, .968304E-02, .968304E-02, .968304E-02,
39722 & .968304E-02, .216392E+00,-.130104E-17, .401066E-01, .401066E-01,
39723 & .110266E-01, .110291E-01, .110291E-01, .110266E-01, .284113E+00,
39724 & .164283E-02, .426983E-01, .426983E-01, .126461E-01, .126510E-01,
39725 & .126510E-01, .126461E-01, .350879E+00, .355790E-02, .454940E-01,
39726 & .454940E-01, .144965E-01, .145039E-01, .145039E-01, .144965E-01,
39727 & .414611E+00, .570002E-02, .484493E-01, .484493E-01, .165364E-01,
39728 & .165462E-01, .165462E-01, .165364E-01, .474149E+00, .802739E-02,
39729 & .515153E-01, .515153E-01, .187191E-01, .187313E-01, .187313E-01,
39730 & .187191E-01, .528511E+00, .104932E-01, .546458E-01, .546458E-01,
39731 & .210009E-01, .210154E-01, .210154E-01, .210009E-01, .577107E+00,
39732 & .130535E-01, .577962E-01, .577962E-01, .233395E-01, .233563E-01/
39733 DATA (DL(K),K= 1021, 1105) /
39734 & .233563E-01, .233395E-01, .619574E+00, .156658E-01, .609249E-01,
39735 & .609249E-01, .256954E-01, .257143E-01, .257143E-01, .256954E-01,
39736 & .655725E+00, .182905E-01, .639938E-01, .639938E-01, .280322E-01,
39737 & .280532E-01, .280532E-01, .280322E-01, .685523E+00, .208909E-01,
39738 & .669681E-01, .669681E-01, .303170E-01, .303399E-01, .303399E-01,
39739 & .303170E-01, .709053E+00, .234341E-01, .698172E-01, .698172E-01,
39740 & .325206E-01, .325454E-01, .325454E-01, .325206E-01, .726501E+00,
39741 & .258907E-01, .725141E-01, .725141E-01, .346176E-01, .346442E-01,
39742 & .346442E-01, .346176E-01, .738139E+00, .282352E-01, .750364E-01,
39743 & .750364E-01, .365866E-01, .366148E-01, .366148E-01, .365866E-01,
39744 & .744304E+00, .304461E-01, .773653E-01, .773653E-01, .384099E-01,
39745 & .384396E-01, .384396E-01, .384099E-01, .745388E+00, .325056E-01,
39746 & .794860E-01, .794860E-01, .400736E-01, .401046E-01, .401046E-01,
39747 & .400736E-01, .741819E+00, .343996E-01, .813873E-01, .813873E-01,
39748 & .415670E-01, .415993E-01, .415993E-01, .415670E-01, .734051E+00,
39749 & .361177E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39750 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
39751 DATA (DL(K),K= 1106, 1190) /
39752 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39753 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39754 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39755 & .433773E-01, .433773E-01, .745094E-02, .745094E-02, .745094E-02,
39756 & .745094E-02, .201612E+00,-.130104E-17, .455998E-01, .455998E-01,
39757 & .866239E-02, .866443E-02, .866443E-02, .866239E-02, .255046E+00,
39758 & .149977E-02, .479569E-01, .479569E-01, .100584E-01, .100624E-01,
39759 & .100624E-01, .100584E-01, .305549E+00, .317779E-02, .503976E-01,
39760 & .503976E-01, .115911E-01, .115970E-01, .115970E-01, .115911E-01,
39761 & .351606E+00, .498612E-02, .528804E-01, .528804E-01, .132216E-01,
39762 & .132293E-01, .132293E-01, .132216E-01, .392560E+00, .688553E-02,
39763 & .553621E-01, .553621E-01, .149087E-01, .149181E-01, .149181E-01,
39764 & .149087E-01, .427948E+00, .883486E-02, .578049E-01, .578049E-01,
39765 & .166165E-01, .166276E-01, .166276E-01, .166165E-01, .457612E+00,
39766 & .107980E-01, .601739E-01, .601739E-01, .183120E-01, .183246E-01,
39767 & .183246E-01, .183120E-01, .481565E+00, .127419E-01, .624390E-01,
39768 & .624390E-01, .199661E-01, .199801E-01, .199801E-01, .199661E-01/
39769 DATA (DL(K),K= 1191, 1275) /
39770 & .499943E+00, .146375E-01, .645736E-01, .645736E-01, .215535E-01,
39771 & .215688E-01, .215688E-01, .215535E-01, .512983E+00, .164593E-01,
39772 & .665556E-01, .665556E-01, .230528E-01, .230693E-01, .230693E-01,
39773 & .230528E-01, .520995E+00, .181859E-01, .683669E-01, .683669E-01,
39774 & .244463E-01, .244639E-01, .244639E-01, .244463E-01, .524347E+00,
39775 & .197998E-01, .699932E-01, .699932E-01, .257201E-01, .257387E-01,
39776 & .257387E-01, .257201E-01, .523447E+00, .212869E-01, .714240E-01,
39777 & .714240E-01, .268637E-01, .268832E-01, .268832E-01, .268637E-01,
39778 & .518729E+00, .226367E-01, .726523E-01, .726523E-01, .278697E-01,
39779 & .278900E-01, .278900E-01, .278697E-01, .510641E+00, .238420E-01,
39780 & .736741E-01, .736741E-01, .287338E-01, .287547E-01, .287547E-01,
39781 & .287338E-01, .499630E+00, .248984E-01, .744886E-01, .744886E-01,
39782 & .294542E-01, .294757E-01, .294757E-01, .294542E-01, .486140E+00,
39783 & .258043E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39784 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39785 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39786 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
39787 DATA (DL(K),K= 1276, 1360) /
39788 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39789 & .499162E-01, .499162E-01, .534441E-02, .534441E-02, .534441E-02,
39790 & .534441E-02, .191108E+00,-.151788E-17, .519197E-01, .519197E-01,
39791 & .646285E-02, .646402E-02, .646402E-02, .646285E-02, .232539E+00,
39792 & .137669E-02, .539504E-01, .539504E-01, .769150E-02, .769377E-02,
39793 & .769377E-02, .769150E-02, .269907E+00, .285489E-02, .559598E-01,
39794 & .559598E-01, .898389E-02, .898721E-02, .898721E-02, .898389E-02,
39795 & .302186E+00, .438814E-02, .579130E-01, .579130E-01, .103061E-01,
39796 & .103104E-01, .103104E-01, .103061E-01, .329124E+00, .594258E-02,
39797 & .597754E-01, .597754E-01, .116245E-01, .116297E-01, .116297E-01,
39798 & .116245E-01, .350643E+00, .748452E-02, .615191E-01, .615191E-01,
39799 & .129113E-01, .129174E-01, .129174E-01, .129113E-01, .366890E+00,
39800 & .898645E-02, .631204E-01, .631204E-01, .141428E-01, .141497E-01,
39801 & .141497E-01, .141428E-01, .378134E+00, .104247E-01, .645601E-01,
39802 & .645601E-01, .152995E-01, .153071E-01, .153071E-01, .152995E-01,
39803 & .384719E+00, .117798E-01, .658236E-01, .658236E-01, .163657E-01,
39804 & .163739E-01, .163739E-01, .163657E-01, .387045E+00, .130362E-01/
39805 DATA (DL(K),K= 1361, 1445) /
39806 & .669000E-01, .669000E-01, .173294E-01, .173381E-01, .173381E-01,
39807 & .173294E-01, .385547E+00, .141821E-01, .677824E-01, .677824E-01,
39808 & .181820E-01, .181912E-01, .181912E-01, .181820E-01, .380677E+00,
39809 & .152091E-01, .684672E-01, .684672E-01, .189180E-01, .189277E-01,
39810 & .189277E-01, .189180E-01, .372894E+00, .161119E-01, .689539E-01,
39811 & .689539E-01, .195349E-01, .195449E-01, .195449E-01, .195349E-01,
39812 & .362650E+00, .168880E-01, .692447E-01, .692447E-01, .200324E-01,
39813 & .200427E-01, .200427E-01, .200324E-01, .350383E+00, .175374E-01,
39814 & .693442E-01, .693442E-01, .204123E-01, .204229E-01, .204229E-01,
39815 & .204123E-01, .336505E+00, .180622E-01, .692590E-01, .692590E-01,
39816 & .206783E-01, .206891E-01, .206891E-01, .206783E-01, .321403E+00,
39817 & .184661E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39818 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
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 & .554152E-01, .554152E-01, .386683E-02, .386683E-02, .386683E-02/
39823 DATA (DL(K),K= 1446, 1530) /
39824 & .386683E-02, .185844E+00,-.151788E-17, .571372E-01, .571372E-01,
39825 & .493623E-02, .493704E-02, .493704E-02, .493623E-02, .219342E+00,
39826 & .129037E-02, .588098E-01, .588098E-01, .606768E-02, .606924E-02,
39827 & .606924E-02, .606768E-02, .248288E+00, .263296E-02, .603896E-01,
39828 & .603896E-01, .721747E-02, .721973E-02, .721973E-02, .721747E-02,
39829 & .271974E+00, .398431E-02, .618484E-01, .618484E-01, .835658E-02,
39830 & .835949E-02, .835949E-02, .835658E-02, .290397E+00, .531560E-02,
39831 & .631600E-01, .631600E-01, .945726E-02, .946074E-02, .946074E-02,
39832 & .945726E-02, .303702E+00, .659930E-02, .643051E-01, .643051E-01,
39833 & .104983E-01, .105023E-01, .105023E-01, .104983E-01, .312209E+00,
39834 & .781443E-02, .652691E-01, .652691E-01, .114624E-01, .114669E-01,
39835 & .114669E-01, .114624E-01, .316328E+00, .894407E-02, .660416E-01,
39836 & .660416E-01, .123367E-01, .123416E-01, .123416E-01, .123367E-01,
39837 & .316509E+00, .997546E-02, .666169E-01, .666169E-01, .131119E-01,
39838 & .131171E-01, .131171E-01, .131119E-01, .313229E+00, .108996E-01,
39839 & .669925E-01, .669925E-01, .137818E-01, .137874E-01, .137874E-01,
39840 & .137818E-01, .306974E+00, .117107E-01, .671695E-01, .671695E-01/
39841 DATA (DL(K),K= 1531, 1615) /
39842 & .143437E-01, .143495E-01, .143495E-01, .143437E-01, .298224E+00,
39843 & .124061E-01, .671517E-01, .671517E-01, .147970E-01, .148031E-01,
39844 & .148031E-01, .147970E-01, .287441E+00, .129858E-01, .669454E-01,
39845 & .669454E-01, .151437E-01, .151499E-01, .151499E-01, .151437E-01,
39846 & .275064E+00, .134517E-01, .665590E-01, .665590E-01, .153872E-01,
39847 & .153935E-01, .153935E-01, .153872E-01, .261497E+00, .138078E-01,
39848 & .660023E-01, .660023E-01, .155327E-01, .155391E-01, .155391E-01,
39849 & .155327E-01, .247105E+00, .140595E-01, .652865E-01, .652865E-01,
39850 & .155864E-01, .155929E-01, .155929E-01, .155864E-01, .232218E+00,
39851 & .142131E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39852 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39853 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39854 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39855 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39856 & .601098E-01, .601098E-01, .278641E-02, .278641E-02, .278641E-02,
39857 & .278641E-02, .183460E+00, .130104E-17, .614949E-01, .614949E-01,
39858 & .382710E-02, .382771E-02, .382771E-02, .382710E-02, .211150E+00/
39859 DATA (DL(K),K= 1616, 1700) /
39860 & .122320E-02, .627722E-01, .627722E-01, .489465E-02, .489580E-02,
39861 & .489580E-02, .489465E-02, .234040E+00, .246333E-02, .639042E-01,
39862 & .639042E-01, .594825E-02, .594990E-02, .594990E-02, .594825E-02,
39863 & .251649E+00, .367998E-02, .648697E-01, .648697E-01, .696315E-02,
39864 & .696526E-02, .696526E-02, .696315E-02, .264143E+00, .484875E-02,
39865 & .656502E-01, .656502E-01, .791658E-02, .791907E-02, .791907E-02,
39866 & .791658E-02, .271822E+00, .594722E-02, .662343E-01, .662343E-01,
39867 & .879236E-02, .879520E-02, .879520E-02, .879236E-02, .275124E+00,
39868 & .695957E-02, .666152E-01, .666152E-01, .957846E-02, .958160E-02,
39869 & .958160E-02, .957846E-02, .274549E+00, .787413E-02, .667905E-01,
39870 & .667905E-01, .102668E-01, .102702E-01, .102702E-01, .102668E-01,
39871 & .270615E+00, .868318E-02, .667616E-01, .667616E-01, .108528E-01,
39872 & .108564E-01, .108564E-01, .108528E-01, .263847E+00, .938250E-02,
39873 & .665331E-01, .665331E-01, .113349E-01, .113387E-01, .113387E-01,
39874 & .113349E-01, .254756E+00, .997082E-02, .661123E-01, .661123E-01,
39875 & .117139E-01, .117179E-01, .117179E-01, .117139E-01, .243828E+00,
39876 & .104494E-01, .655090E-01, .655090E-01, .119931E-01, .119971E-01/
39877 DATA (DL(K),K= 1701, 1785) /
39878 & .119971E-01, .119931E-01, .231518E+00, .108217E-01, .647345E-01,
39879 & .647345E-01, .121770E-01, .121811E-01, .121811E-01, .121770E-01,
39880 & .218237E+00, .110927E-01, .638017E-01, .638017E-01, .122717E-01,
39881 & .122759E-01, .122759E-01, .122717E-01, .204353E+00, .112689E-01,
39882 & .627241E-01, .627241E-01, .122842E-01, .122884E-01, .122884E-01,
39883 & .122842E-01, .190187E+00, .113573E-01, .615161E-01, .615161E-01,
39884 & .122221E-01, .122262E-01, .122262E-01, .122221E-01, .176012E+00,
39885 & .113659E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39886 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39887 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39888 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39889 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39890 & .641221E-01, .641221E-01, .198544E-02, .198544E-02, .198544E-02,
39891 & .198544E-02, .183018E+00, .184314E-17, .651208E-01, .651208E-01,
39892 & .300778E-02, .300823E-02, .300823E-02, .300778E-02, .206180E+00,
39893 & .116844E-02, .659664E-01, .659664E-01, .402903E-02, .402989E-02,
39894 & .402989E-02, .402903E-02, .224390E+00, .232648E-02, .666277E-01/
39895 DATA (DL(K),K= 1786, 1870) /
39896 & .666277E-01, .501117E-02, .501238E-02, .501238E-02, .501117E-02,
39897 & .237332E+00, .343657E-02, .670904E-01, .670904E-01, .593321E-02,
39898 & .593473E-02, .593473E-02, .593321E-02, .245310E+00, .447818E-02,
39899 & .673435E-01, .673435E-01, .677663E-02, .677843E-02, .677843E-02,
39900 & .677663E-02, .248743E+00, .543320E-02, .673832E-01, .673832E-01,
39901 & .752958E-02, .753161E-02, .753161E-02, .752958E-02, .248162E+00,
39902 & .629021E-02, .672099E-01, .672099E-01, .818432E-02, .818655E-02,
39903 & .818655E-02, .818432E-02, .244140E+00, .704188E-02, .668281E-01,
39904 & .668281E-01, .873688E-02, .873927E-02, .873927E-02, .873688E-02,
39905 & .237247E+00, .768463E-02, .662457E-01, .662457E-01, .918650E-02,
39906 & .918903E-02, .918903E-02, .918650E-02, .228043E+00, .821808E-02,
39907 & .654734E-01, .654734E-01, .953502E-02, .953766E-02, .953766E-02,
39908 & .953502E-02, .217054E+00, .864446E-02, .645238E-01, .645238E-01,
39909 & .978645E-02, .978915E-02, .978915E-02, .978645E-02, .204766E+00,
39910 & .896811E-02, .634114E-01, .634114E-01, .994639E-02, .994915E-02,
39911 & .994915E-02, .994639E-02, .191614E+00, .919500E-02, .621515E-01,
39912 & .621515E-01, .100217E-01, .100245E-01, .100245E-01, .100217E-01/
39913 DATA (DL(K),K= 1871, 1955) /
39914 & .177983E+00, .933229E-02, .607602E-01, .607602E-01, .100200E-01,
39915 & .100228E-01, .100228E-01, .100200E-01, .164201E+00, .938793E-02,
39916 & .592539E-01, .592539E-01, .994938E-02, .995217E-02, .995217E-02,
39917 & .994938E-02, .150544E+00, .937032E-02, .576488E-01, .576488E-01,
39918 & .981814E-02, .982091E-02, .982091E-02, .981814E-02, .137234E+00,
39919 & .928803E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39920 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39921 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39922 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39923 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39924 & .675167E-01, .675167E-01, .139130E-02, .139130E-02, .139130E-02,
39925 & .139130E-02, .184090E+00, .113841E-17, .680840E-01, .680840E-01,
39926 & .240061E-02, .240097E-02, .240097E-02, .240061E-02, .203559E+00,
39927 & .112278E-02, .684634E-01, .684634E-01, .338513E-02, .338580E-02,
39928 & .338580E-02, .338513E-02, .217944E+00, .221249E-02, .686304E-01,
39929 & .686304E-01, .430938E-02, .431032E-02, .431032E-02, .430938E-02,
39930 & .227068E+00, .323420E-02, .685779E-01, .685779E-01, .515589E-02/
39931 DATA (DL(K),K= 1956, 2040) /
39932 & .515707E-02, .515707E-02, .515589E-02, .231353E+00, .417091E-02,
39933 & .683023E-01, .683023E-01, .591002E-02, .591140E-02, .591140E-02,
39934 & .591002E-02, .231327E+00, .500843E-02, .678068E-01, .678068E-01,
39935 & .656383E-02, .656537E-02, .656537E-02, .656383E-02, .227606E+00,
39936 & .573925E-02, .670989E-01, .670989E-01, .711344E-02, .711513E-02,
39937 & .711513E-02, .711344E-02, .220833E+00, .635992E-02, .661895E-01,
39938 & .661895E-01, .755852E-02, .756031E-02, .756031E-02, .755852E-02,
39939 & .211624E+00, .687048E-02, .650923E-01, .650923E-01, .790162E-02,
39940 & .790350E-02, .790350E-02, .790162E-02, .200567E+00, .727387E-02,
39941 & .638232E-01, .638232E-01, .814753E-02, .814946E-02, .814946E-02,
39942 & .814753E-02, .188197E+00, .757524E-02, .623994E-01, .623994E-01,
39943 & .830271E-02, .830469E-02, .830469E-02, .830271E-02, .174994E+00,
39944 & .778139E-02, .608390E-01, .608390E-01, .837482E-02, .837682E-02,
39945 & .837682E-02, .837482E-02, .161373E+00, .790029E-02, .591605E-01,
39946 & .591605E-01, .837226E-02, .837426E-02, .837426E-02, .837226E-02,
39947 & .147685E+00, .794065E-02, .573824E-01, .573824E-01, .830376E-02,
39948 & .830575E-02, .830575E-02, .830376E-02, .134218E+00, .791148E-02/
39949 DATA (DL(K),K= 2041, 2125) /
39950 & .555224E-01, .555224E-01, .817811E-02, .818008E-02, .818008E-02,
39951 & .817811E-02, .121200E+00, .782185E-02, .535980E-01, .535980E-01,
39952 & .800390E-02, .800584E-02, .800584E-02, .800390E-02, .108803E+00,
39953 & .768059E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39954 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39955 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39956 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39957 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39958 & .703249E-01, .703249E-01, .953926E-03, .953926E-03, .953926E-03,
39959 & .953926E-03, .186497E+00, .108420E-18, .704188E-01, .704188E-01,
39960 & .195267E-02, .195297E-02, .195297E-02, .195267E-02, .202831E+00,
39961 & .108414E-02, .702995E-01, .702995E-01, .290528E-02, .290582E-02,
39962 & .290582E-02, .290528E-02, .213933E+00, .211514E-02, .699499E-01,
39963 & .699499E-01, .377873E-02, .377950E-02, .377950E-02, .377873E-02,
39964 & .219748E+00, .306054E-02, .693699E-01, .693699E-01, .455903E-02,
39965 & .455997E-02, .455997E-02, .455903E-02, .220821E+00, .390679E-02,
39966 & .685634E-01, .685634E-01, .523531E-02, .523640E-02, .523640E-02/
39967 DATA (DL(K),K= 2126, 2210) /
39968 & .523531E-02, .217787E+00, .464347E-02, .675406E-01, .675406E-01,
39969 & .580340E-02, .580462E-02, .580462E-02, .580340E-02, .211353E+00,
39970 & .526681E-02, .663155E-01, .663155E-01, .626315E-02, .626446E-02,
39971 & .626446E-02, .626315E-02, .202230E+00, .577705E-02, .649052E-01,
39972 & .649052E-01, .661759E-02, .661897E-02, .661897E-02, .661759E-02,
39973 & .191081E+00, .617758E-02, .633285E-01, .633285E-01, .687230E-02,
39974 & .687373E-02, .687373E-02, .687230E-02, .178518E+00, .647434E-02,
39975 & .616058E-01, .616058E-01, .703464E-02, .703611E-02, .703611E-02,
39976 & .703464E-02, .165082E+00, .667499E-02, .597580E-01, .597580E-01,
39977 & .711320E-02, .711468E-02, .711468E-02, .711320E-02, .151241E+00,
39978 & .678842E-02, .578059E-01, .578059E-01, .711723E-02, .711872E-02,
39979 & .711872E-02, .711723E-02, .137382E+00, .682417E-02, .557702E-01,
39980 & .557702E-01, .705628E-02, .705776E-02, .705776E-02, .705628E-02,
39981 & .123821E+00, .679205E-02, .536704E-01, .536704E-01, .693979E-02,
39982 & .694125E-02, .694125E-02, .693979E-02, .110798E+00, .670173E-02,
39983 & .515252E-01, .515252E-01, .677689E-02, .677832E-02, .677832E-02,
39984 & .677689E-02, .984933E-01, .656256E-02, .493519E-01, .493519E-01/
39985 DATA (DL(K),K= 2211, 2295) /
39986 & .657614E-02, .657753E-02, .657753E-02, .657614E-02, .870270E-01,
39987 & .638332E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39988 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39989 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39990 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39991 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39992 & .725555E-01, .725555E-01, .636424E-03, .636424E-03, .636424E-03,
39993 & .636424E-03, .190200E+00,-.271051E-17, .721364E-01, .721364E-01,
39994 & .162522E-02, .162546E-02, .162546E-02, .162522E-02, .203770E+00,
39995 & .105090E-02, .714881E-01, .714881E-01, .254763E-02, .254807E-02,
39996 & .254807E-02, .254763E-02, .211914E+00, .202976E-02, .706012E-01,
39997 & .706012E-01, .337323E-02, .337384E-02, .337384E-02, .337323E-02,
39998 & .214704E+00, .290668E-02, .694832E-01, .694832E-01, .409164E-02,
39999 & .409240E-02, .409240E-02, .409164E-02, .212817E+00, .367169E-02,
40000 & .681454E-01, .681454E-01, .469593E-02, .469679E-02, .469679E-02,
40001 & .469593E-02, .207013E+00, .431823E-02, .666048E-01, .666048E-01,
40002 & .518578E-02, .518673E-02, .518673E-02, .518578E-02, .198095E+00/
40003 DATA (DL(K),K= 2296, 2380) /
40004 & .484637E-02, .648819E-01, .648819E-01, .556473E-02, .556575E-02,
40005 & .556575E-02, .556473E-02, .186850E+00, .525997E-02, .629989E-01,
40006 & .629989E-01, .583908E-02, .584014E-02, .584014E-02, .583908E-02,
40007 & .173986E+00, .556566E-02, .609795E-01, .609795E-01, .601725E-02,
40008 & .601834E-02, .601834E-02, .601725E-02, .160140E+00, .577215E-02,
40009 & .588474E-01, .588474E-01, .610889E-02, .611000E-02, .611000E-02,
40010 & .610889E-02, .145850E+00, .588934E-02, .566261E-01, .566261E-01,
40011 & .612435E-02, .612547E-02, .612547E-02, .612435E-02, .131564E+00,
40012 & .592785E-02, .543385E-01, .543385E-01, .607415E-02, .607526E-02,
40013 & .607526E-02, .607415E-02, .117636E+00, .589841E-02, .520060E-01,
40014 & .520060E-01, .596861E-02, .596970E-02, .596970E-02, .596861E-02,
40015 & .104336E+00, .581156E-02, .496485E-01, .496485E-01, .581753E-02,
40016 & .581860E-02, .581860E-02, .581753E-02, .918563E-01, .567728E-02,
40017 & .472842E-01, .472842E-01, .563002E-02, .563105E-02, .563105E-02,
40018 & .563002E-02, .803205E-01, .550487E-02, .449295E-01, .449295E-01,
40019 & .541435E-02, .541535E-02, .541535E-02, .541435E-02, .697975E-01,
40020 & .530276E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40021 DATA (DL(K),K= 2381, 2465) /
40022 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40023 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40024 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40025 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40026 & .742000E-01, .742000E-01, .410482E-03, .410482E-03, .410482E-03,
40027 & .410482E-03, .195273E+00,-.143657E-17, .732296E-01, .732296E-01,
40028 & .138854E-02, .138874E-02, .138874E-02, .138854E-02, .206298E+00,
40029 & .102151E-02, .720241E-01, .720241E-01, .228017E-02, .228054E-02,
40030 & .228054E-02, .228017E-02, .211639E+00, .195225E-02, .705820E-01,
40031 & .705820E-01, .305794E-02, .305844E-02, .305844E-02, .305794E-02,
40032 & .211509E+00, .276522E-02, .689187E-01, .689187E-01, .371549E-02,
40033 & .371609E-02, .371609E-02, .371549E-02, .206745E+00, .345441E-02,
40034 & .670527E-01, .670527E-01, .425016E-02, .425084E-02, .425084E-02,
40035 & .425016E-02, .198254E+00, .401749E-02, .650080E-01, .650080E-01,
40036 & .466572E-02, .466647E-02, .466647E-02, .466572E-02, .186950E+00,
40037 & .445856E-02, .628107E-01, .628107E-01, .496948E-02, .497027E-02,
40038 & .497027E-02, .496948E-02, .173701E+00, .478517E-02, .604878E-01/
40039 DATA (DL(K),K= 2466, 2550) /
40040 & .604878E-01, .517094E-02, .517175E-02, .517175E-02, .517094E-02,
40041 & .159263E+00, .500709E-02, .580665E-01, .580665E-01, .528116E-02,
40042 & .528199E-02, .528199E-02, .528116E-02, .144287E+00, .513562E-02,
40043 & .555730E-01, .555730E-01, .531181E-02, .531265E-02, .531265E-02,
40044 & .531181E-02, .129304E+00, .518264E-02, .530325E-01, .530325E-01,
40045 & .527468E-02, .527550E-02, .527550E-02, .527468E-02, .114731E+00,
40046 & .516012E-02, .504682E-01, .504682E-01, .518116E-02, .518198E-02,
40047 & .518198E-02, .518116E-02, .100877E+00, .507964E-02, .479014E-01,
40048 & .479014E-01, .504198E-02, .504278E-02, .504278E-02, .504198E-02,
40049 & .879578E-01, .495209E-02, .453511E-01, .453511E-01, .486695E-02,
40050 & .486772E-02, .486772E-02, .486695E-02, .761077E-01, .478741E-02,
40051 & .428340E-01, .428340E-01, .466486E-02, .466560E-02, .466560E-02,
40052 & .466486E-02, .653932E-01, .459453E-02, .403645E-01, .403645E-01,
40053 & .444342E-02, .444413E-02, .444413E-02, .444342E-02, .558281E-01,
40054 & .438128E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40055 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40056 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40057 DATA (DL(K),K= 2551, 2635) /
40058 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40059 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40060 & .752337E-01, .752337E-01, .253875E-03, .253875E-03, .253875E-03,
40061 & .253875E-03, .201902E+00,-.159920E-17, .736752E-01, .736752E-01,
40062 & .121909E-02, .121925E-02, .121925E-02, .121909E-02, .210465E+00,
40063 & .994282E-03, .718865E-01, .718865E-01, .207747E-02, .207776E-02,
40064 & .207776E-02, .207747E-02, .212997E+00, .187854E-02, .698746E-01,
40065 & .698746E-01, .280521E-02, .280560E-02, .280560E-02, .280521E-02,
40066 & .209895E+00, .262933E-02, .676629E-01, .676629E-01, .340063E-02,
40067 & .340109E-02, .340109E-02, .340063E-02, .202191E+00, .324527E-02,
40068 & .652775E-01, .652775E-01, .386588E-02, .386641E-02, .386641E-02,
40069 & .386588E-02, .190971E+00, .372876E-02, .627483E-01, .627483E-01,
40070 & .420910E-02, .420967E-02, .420967E-02, .420910E-02, .177278E+00,
40071 & .408818E-02, .601066E-01, .601066E-01, .444148E-02, .444208E-02,
40072 & .444208E-02, .444148E-02, .162071E+00, .433493E-02, .573831E-01,
40073 & .573831E-01, .457564E-02, .457625E-02, .457625E-02, .457564E-02,
40074 & .146148E+00, .448183E-02, .546072E-01, .546072E-01, .462506E-02/
40075 DATA (DL(K),K= 2636, 2720) /
40076 & .462567E-02, .462567E-02, .462506E-02, .130166E+00, .454252E-02,
40077 & .518065E-01, .518065E-01, .460307E-02, .460368E-02, .460368E-02,
40078 & .460307E-02, .114632E+00, .453052E-02, .490062E-01, .490062E-01,
40079 & .452252E-02, .452312E-02, .452312E-02, .452252E-02, .999175E-01,
40080 & .445880E-02, .462287E-01, .462287E-01, .439529E-02, .439588E-02,
40081 & .439588E-02, .439529E-02, .862750E-01, .433936E-02, .434937E-01,
40082 & .434937E-01, .423211E-02, .423268E-02, .423268E-02, .423211E-02,
40083 & .738542E-01, .418306E-02, .408180E-01, .408180E-01, .404245E-02,
40084 & .404299E-02, .404299E-02, .404245E-02, .627228E-01, .399946E-02,
40085 & .382157E-01, .382157E-01, .383446E-02, .383498E-02, .383498E-02,
40086 & .383446E-02, .528847E-01, .379682E-02, .356980E-01, .356980E-01,
40087 & .361508E-02, .361557E-02, .361557E-02, .361508E-02, .442963E-01,
40088 & .358213E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40089 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40090 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40091 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40092 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40093 DATA (DL(K),K= 2721, 2805) /
40094 & .756149E-01, .756149E-01, .148956E-03, .148956E-03, .148956E-03,
40095 & .148956E-03, .210410E+00,-.149078E-18, .734321E-01, .734321E-01,
40096 & .109779E-02, .109791E-02, .109791E-02, .109779E-02, .216444E+00,
40097 & .967243E-03, .710369E-01, .710369E-01, .191860E-02, .191882E-02,
40098 & .191882E-02, .191860E-02, .215992E+00, .180426E-02, .684452E-01,
40099 & .684452E-01, .259230E-02, .259259E-02, .259259E-02, .259230E-02,
40100 & .209697E+00, .249224E-02, .656884E-01, .656884E-01, .312270E-02,
40101 & .312305E-02, .312305E-02, .312270E-02, .198844E+00, .303522E-02,
40102 & .627994E-01, .627994E-01, .351747E-02, .351786E-02, .351786E-02,
40103 & .351747E-02, .184740E+00, .344105E-02, .598138E-01, .598138E-01,
40104 & .378940E-02, .378981E-02, .378981E-02, .378940E-02, .168578E+00,
40105 & .372269E-02, .567666E-01, .567666E-01, .395362E-02, .395405E-02,
40106 & .395405E-02, .395362E-02, .151409E+00, .389544E-02, .536907E-01,
40107 & .536907E-01, .402569E-02, .402613E-02, .402613E-02, .402569E-02,
40108 & .134065E+00, .397499E-02, .506163E-01, .506163E-01, .402117E-02,
40109 & .402161E-02, .402161E-02, .402117E-02, .117191E+00, .397702E-02,
40110 & .475706E-01, .475706E-01, .395467E-02, .395511E-02, .395511E-02/
40111 DATA (DL(K),K= 2806, 2890) /
40112 & .395467E-02, .101250E+00, .391626E-02, .445771E-01, .445771E-01,
40113 & .383961E-02, .384003E-02, .384003E-02, .383961E-02, .865500E-01,
40114 & .380621E-02, .416559E-01, .416559E-01, .368789E-02, .368830E-02,
40115 & .368830E-02, .368789E-02, .732657E-01, .365888E-02, .388235E-01,
40116 & .388235E-01, .350985E-02, .351025E-02, .351025E-02, .350985E-02,
40117 & .614686E-01, .348466E-02, .360931E-01, .360931E-01, .331425E-02,
40118 & .331462E-02, .331462E-02, .331425E-02, .511511E-01, .329240E-02,
40119 & .334751E-01, .334751E-01, .310835E-02, .310870E-02, .310870E-02,
40120 & .310835E-02, .422485E-01, .308941E-02, .309768E-01, .309768E-01,
40121 & .289805E-02, .289838E-02, .289838E-02, .289805E-02, .346590E-01,
40122 & .288164E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40123 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40124 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40125 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40126 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40127 & .752796E-01, .752796E-01, .816906E-04, .816906E-04, .816906E-04,
40128 & .816906E-04, .221322E+00, .298156E-18, .724376E-01, .724376E-01/
40129 DATA (DL(K),K= 2891, 2975) /
40130 & .100884E-02, .100894E-02, .100894E-02, .100884E-02, .224569E+00,
40131 & .938046E-03, .694166E-01, .694166E-01, .178592E-02, .178609E-02,
40132 & .178609E-02, .178592E-02, .220745E+00, .172460E-02, .662414E-01,
40133 & .662414E-01, .240001E-02, .240024E-02, .240024E-02, .240001E-02,
40134 & .210839E+00, .234694E-02, .629511E-01, .629511E-01, .286144E-02,
40135 & .286171E-02, .286171E-02, .286144E-02, .196463E+00, .281556E-02,
40136 & .595849E-01, .595849E-01, .318412E-02, .318441E-02, .318441E-02,
40137 & .318412E-02, .179204E+00, .314448E-02, .561822E-01, .561822E-01,
40138 & .338573E-02, .338605E-02, .338605E-02, .338573E-02, .160420E+00,
40139 & .335151E-02, .527801E-01, .527801E-01, .348530E-02, .348562E-02,
40140 & .348562E-02, .348530E-02, .141254E+00, .345578E-02, .494117E-01,
40141 & .494117E-01, .350098E-02, .350131E-02, .350131E-02, .350098E-02,
40142 & .122547E+00, .347555E-02, .461061E-01, .461061E-01, .344994E-02,
40143 & .345026E-02, .345026E-02, .344994E-02, .104908E+00, .342804E-02,
40144 & .428876E-01, .428876E-01, .334753E-02, .334784E-02, .334784E-02,
40145 & .334753E-02, .887264E-01, .332868E-02, .397764E-01, .397764E-01,
40146 & .320718E-02, .320748E-02, .320748E-02, .320718E-02, .742160E-01/
40147 DATA (DL(K),K= 2976, 3060) /
40148 & .319097E-02, .367882E-01, .367882E-01, .304033E-02, .304062E-02,
40149 & .304062E-02, .304033E-02, .614556E-01, .302641E-02, .339348E-01,
40150 & .339348E-01, .285650E-02, .285677E-02, .285677E-02, .285650E-02,
40151 & .504214E-01, .284454E-02, .312247E-01, .312247E-01, .266337E-02,
40152 & .266363E-02, .266363E-02, .266337E-02, .410205E-01, .265311E-02,
40153 & .286629E-01, .286629E-01, .246705E-02, .246730E-02, .246730E-02,
40154 & .246705E-02, .331166E-01, .245826E-02, .262521E-01, .262521E-01,
40155 & .227226E-02, .227248E-02, .227248E-02, .227226E-02, .265498E-01,
40156 & .226473E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40157 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40158 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40159 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40160 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40161 & .741335E-01, .741335E-01, .409835E-04, .409835E-04, .409835E-04,
40162 & .409835E-04, .235495E+00,-.158395E-17, .705990E-01, .705990E-01,
40163 & .938808E-03, .938883E-03, .938883E-03, .938808E-03, .235413E+00,
40164 & .903728E-03, .669383E-01, .669383E-01, .166382E-02, .166395E-02/
40165 DATA (DL(K),K= 3061, 3145) /
40166 & .166395E-02, .166382E-02, .227523E+00, .163381E-02, .631853E-01,
40167 & .631853E-01, .221128E-02, .221145E-02, .221145E-02, .221128E-02,
40168 & .213316E+00, .218562E-02, .593855E-01, .593855E-01, .259911E-02,
40169 & .259931E-02, .259931E-02, .259911E-02, .194833E+00, .257720E-02,
40170 & .555825E-01, .555825E-01, .284819E-02, .284841E-02, .284841E-02,
40171 & .284819E-02, .174012E+00, .282950E-02, .518174E-01, .518174E-01,
40172 & .298117E-02, .298140E-02, .298140E-02, .298117E-02, .152385E+00,
40173 & .296523E-02, .481268E-01, .481268E-01, .302067E-02, .302090E-02,
40174 & .302090E-02, .302067E-02, .131168E+00, .300708E-02, .445413E-01,
40175 & .445413E-01, .298689E-02, .298712E-02, .298712E-02, .298689E-02,
40176 & .111177E+00, .297532E-02, .410859E-01, .410859E-01, .289793E-02,
40177 & .289815E-02, .289815E-02, .289793E-02, .929352E-01, .288809E-02,
40178 & .377798E-01, .377798E-01, .276920E-02, .276941E-02, .276941E-02,
40179 & .276920E-02, .767178E-01, .276084E-02, .346372E-01, .346372E-01,
40180 & .261353E-02, .261373E-02, .261373E-02, .261353E-02, .626102E-01,
40181 & .260643E-02, .316676E-01, .316676E-01, .244134E-02, .244154E-02,
40182 & .244154E-02, .244134E-02, .505665E-01, .243531E-02, .288765E-01/
40183 DATA (DL(K),K= 3146, 3230) /
40184 & .288765E-01, .226087E-02, .226105E-02, .226105E-02, .226087E-02,
40185 & .404527E-01, .225576E-02, .262660E-01, .262660E-01, .207845E-02,
40186 & .207862E-02, .207862E-02, .207845E-02, .320820E-01, .207412E-02,
40187 & .238351E-01, .238351E-01, .189881E-02, .189897E-02, .189897E-02,
40188 & .189881E-02, .252422E-01, .189514E-02, .215808E-01, .215808E-01,
40189 & .172536E-02, .172551E-02, .172551E-02, .172536E-02, .197186E-01,
40190 & .172225E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40191 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40192 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40193 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40194 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40195 & .720339E-01, .720339E-01, .181946E-04, .181946E-04, .181946E-04,
40196 & .181946E-04, .254393E+00, .469256E-18, .677768E-01, .677768E-01,
40197 & .875835E-03, .875888E-03, .875888E-03, .875835E-03, .249966E+00,
40198 & .860480E-03, .634725E-01, .634725E-01, .153792E-02, .153801E-02,
40199 & .153801E-02, .153792E-02, .236824E+00, .152496E-02, .591619E-01,
40200 & .591619E-01, .201036E-02, .201048E-02, .201048E-02, .201036E-02/
40201 DATA (DL(K),K= 3231, 3315) /
40202 & .217211E+00, .199944E-02, .548948E-01, .548948E-01, .231978E-02,
40203 & .231992E-02, .231992E-02, .231978E-02, .193739E+00, .231058E-02,
40204 & .507162E-01, .507162E-01, .249460E-02, .249475E-02, .249475E-02,
40205 & .249460E-02, .168773E+00, .248686E-02, .466653E-01, .466653E-01,
40206 & .256217E-02, .256232E-02, .256232E-02, .256217E-02, .144012E+00,
40207 & .255566E-02, .427744E-01, .427744E-01, .254804E-02, .254820E-02,
40208 & .254820E-02, .254804E-02, .120695E+00, .254258E-02, .390676E-01,
40209 & .390676E-01, .247365E-02, .247380E-02, .247380E-02, .247365E-02,
40210 & .995452E-01, .246906E-02, .355626E-01, .355626E-01, .235710E-02,
40211 & .235725E-02, .235725E-02, .235710E-02, .809281E-01, .235325E-02,
40212 & .322703E-01, .322703E-01, .221303E-02, .221317E-02, .221317E-02,
40213 & .221303E-02, .649429E-01, .220980E-02, .291963E-01, .291963E-01,
40214 & .205294E-02, .205307E-02, .205307E-02, .205294E-02, .515039E-01,
40215 & .205024E-02, .263419E-01, .263419E-01, .188569E-02, .188581E-02,
40216 & .188581E-02, .188569E-02, .404102E-01, .188343E-02, .237044E-01,
40217 & .237044E-01, .171783E-02, .171795E-02, .171795E-02, .171783E-02,
40218 & .313959E-01, .171594E-02, .212782E-01, .212782E-01, .155409E-02/
40219 DATA (DL(K),K= 3316, 3400) /
40220 & .155419E-02, .155419E-02, .155409E-02, .241750E-01, .155251E-02,
40221 & .190555E-01, .190555E-01, .139767E-02, .139777E-02, .139777E-02,
40222 & .139767E-02, .184646E-01, .139635E-02, .170270E-01, .170270E-01,
40223 & .125065E-02, .125074E-02, .125074E-02, .125065E-02, .139996E-01,
40224 & .124955E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40225 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40226 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40227 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40228 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40229 & .687547E-01, .687547E-01, .676181E-05, .676181E-05, .676181E-05,
40230 & .676181E-05, .280728E+00,-.145838E-17, .637529E-01, .637529E-01,
40231 & .808781E-03, .808818E-03, .808818E-03, .808781E-03, .270033E+00,
40232 & .803169E-03, .588180E-01, .588180E-01, .139388E-02, .139394E-02,
40233 & .139394E-02, .139388E-02, .249568E+00, .138922E-02, .539945E-01,
40234 & .539945E-01, .178168E-02, .178176E-02, .178176E-02, .178168E-02,
40235 & .222743E+00, .177782E-02, .493317E-01, .493317E-01, .200838E-02,
40236 & .200848E-02, .200848E-02, .200838E-02, .192919E+00, .200519E-02/
40237 DATA (DL(K),K= 3401, 3485) /
40238 & .448709E-01, .448709E-01, .211009E-02, .211019E-02, .211019E-02,
40239 & .211009E-02, .162975E+00, .210745E-02, .406433E-01, .406433E-01,
40240 & .211805E-02, .211815E-02, .211815E-02, .211805E-02, .134716E+00,
40241 & .211586E-02, .366716E-01, .366716E-01, .205957E-02, .205968E-02,
40242 & .205968E-02, .205957E-02, .109289E+00, .205776E-02, .329687E-01,
40243 & .329687E-01, .195606E-02, .195616E-02, .195616E-02, .195606E-02,
40244 & .871955E-01, .195457E-02, .295400E-01, .295400E-01, .182447E-02,
40245 & .182456E-02, .182456E-02, .182447E-02, .685399E-01, .182323E-02,
40246 & .263849E-01, .263849E-01, .167765E-02, .167774E-02, .167774E-02,
40247 & .167765E-02, .531615E-01, .167663E-02, .234975E-01, .234975E-01,
40248 & .152505E-02, .152514E-02, .152514E-02, .152505E-02, .407334E-01,
40249 & .152421E-02, .208683E-01, .208683E-01, .137342E-02, .137350E-02,
40250 & .137350E-02, .137342E-02, .308674E-01, .137273E-02, .184852E-01,
40251 & .184852E-01, .122732E-02, .122739E-02, .122739E-02, .122732E-02,
40252 & .231578E-01, .122675E-02, .163340E-01, .163340E-01, .108968E-02,
40253 & .108975E-02, .108975E-02, .108968E-02, .172149E-01, .108921E-02,
40254 & .143996E-01, .143996E-01, .962198E-03, .962260E-03, .962260E-03/
40255 DATA (DL(K),K= 3486, 3570) /
40256 & .962198E-03, .126908E-01, .961815E-03, .126661E-01, .126661E-01,
40257 & .845675E-03, .845732E-03, .845732E-03, .845675E-03, .928555E-02,
40258 & .845361E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40259 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40260 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40261 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40262 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40263 & .639050E-01, .639050E-01, .189600E-05, .189600E-05, .189600E-05,
40264 & .189600E-05, .320203E+00, .545701E-18, .581555E-01, .581555E-01,
40265 & .725861E-03, .725886E-03, .725886E-03, .725861E-03, .299305E+00,
40266 & .724320E-03, .526376E-01, .526376E-01, .121568E-02, .121572E-02,
40267 & .121572E-02, .121568E-02, .267591E+00, .121442E-02, .473911E-01,
40268 & .473911E-01, .150820E-02, .150825E-02, .150825E-02, .150820E-02,
40269 & .230364E+00, .150718E-02, .424558E-01, .424558E-01, .164949E-02,
40270 & .164955E-02, .164955E-02, .164949E-02, .191972E+00, .164867E-02,
40271 & .378600E-01, .378600E-01, .168256E-02, .168262E-02, .168262E-02,
40272 & .168256E-02, .155818E+00, .168189E-02, .336181E-01, .336181E-01/
40273 DATA (DL(K),K= 3571, 3655) /
40274 & .164080E-02, .164086E-02, .164086E-02, .164080E-02, .123609E+00,
40275 & .164026E-02, .297349E-01, .297349E-01, .155136E-02, .155142E-02,
40276 & .155142E-02, .155136E-02, .961680E-01, .155092E-02, .262052E-01,
40277 & .262052E-01, .143382E-02, .143388E-02, .143388E-02, .143382E-02,
40278 & .735522E-01, .143346E-02, .230171E-01, .230171E-01, .130247E-02,
40279 & .130253E-02, .130253E-02, .130247E-02, .553916E-01, .130218E-02,
40280 & .201539E-01, .201539E-01, .116733E-02, .116739E-02, .116739E-02,
40281 & .116733E-02, .411453E-01, .116710E-02, .175955E-01, .175955E-01,
40282 & .103505E-02, .103510E-02, .103510E-02, .103505E-02, .301858E-01,
40283 & .103486E-02, .153199E-01, .153199E-01, .909828E-03, .909880E-03,
40284 & .909880E-03, .909828E-03, .218957E-01, .909677E-03, .133043E-01,
40285 & .133043E-01, .794097E-03, .794146E-03, .794146E-03, .794097E-03,
40286 & .157204E-01, .793976E-03, .115259E-01, .115259E-01, .689012E-03,
40287 & .689057E-03, .689057E-03, .689012E-03, .111816E-01, .688913E-03,
40288 & .996208E-02, .996208E-02, .594880E-03, .594922E-03, .594922E-03,
40289 & .594880E-03, .788559E-02, .594801E-03, .859151E-02, .859151E-02,
40290 & .511455E-03, .511493E-03, .511493E-03, .511455E-03, .551865E-02/
40291 DATA (DL(K),K= 3656, 3740) /
40292 & .511392E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40293 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40294 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40295 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40296 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40297 & .567030E-01, .567030E-01, .317692E-06, .317692E-06, .317692E-06,
40298 & .317692E-06, .387655E+00,-.196551E-18, .502560E-01, .502560E-01,
40299 & .611827E-03, .611838E-03, .611838E-03, .611827E-03, .346975E+00,
40300 & .611576E-03, .442838E-01, .442838E-01, .981907E-03, .981929E-03,
40301 & .981929E-03, .981907E-03, .295290E+00, .981708E-03, .388018E-01,
40302 & .388018E-01, .116826E-02, .116829E-02, .116829E-02, .116826E-02,
40303 & .241157E+00, .116810E-02, .338227E-01, .338227E-01, .122537E-02,
40304 & .122541E-02, .122541E-02, .122537E-02, .190062E+00, .122525E-02,
40305 & .293442E-01, .293442E-01, .120047E-02, .120052E-02, .120052E-02,
40306 & .120047E-02, .145706E+00, .120037E-02, .253494E-01, .253494E-01,
40307 & .112580E-02, .112585E-02, .112585E-02, .112580E-02, .109110E+00,
40308 & .112572E-02, .218132E-01, .218132E-01, .102498E-02, .102503E-02/
40309 DATA (DL(K),K= 3741, 3825) /
40310 & .102503E-02, .102498E-02, .800661E-01, .102492E-02, .187030E-01,
40311 & .187030E-01, .913395E-03, .913450E-03, .913450E-03, .913395E-03,
40312 & .577342E-01, .913348E-03, .159833E-01, .159833E-01, .800935E-03,
40313 & .800990E-03, .800990E-03, .800935E-03, .409782E-01, .800898E-03,
40314 & .136172E-01, .136172E-01, .693698E-03, .693751E-03, .693751E-03,
40315 & .693698E-03, .286780E-01, .693669E-03, .115681E-01, .115681E-01,
40316 & .595013E-03, .595064E-03, .595064E-03, .595013E-03, .198197E-01,
40317 & .594990E-03, .980105E-02, .980105E-02, .506423E-03, .506471E-03,
40318 & .506471E-03, .506423E-03, .135410E-01, .506405E-03, .828286E-02,
40319 & .828286E-02, .428323E-03, .428368E-03, .428368E-03, .428323E-03,
40320 & .915498E-02, .428309E-03, .698303E-02, .698303E-02, .360397E-03,
40321 & .360439E-03, .360439E-03, .360397E-03, .613133E-02, .360386E-03,
40322 & .587373E-02, .587373E-02, .301934E-03, .301973E-03, .301973E-03,
40323 & .301934E-03, .407092E-02, .301925E-03, .492985E-02, .492985E-02,
40324 & .252029E-03, .252064E-03, .252064E-03, .252029E-03, .268179E-02,
40325 & .252022E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40326 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40327 DATA (DL(K),K= 3826, 3910) /
40328 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40329 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40330 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40331 & .450567E-01, .450567E-01, .151200E-07, .151200E-07, .151200E-07,
40332 & .151200E-07, .542258E+00,-.767310E-18, .381624E-01, .381624E-01,
40333 & .438685E-03, .438751E-03, .438751E-03, .438685E-03, .447480E+00,
40334 & .438674E-03, .321250E-01, .321250E-01, .653465E-03, .653574E-03,
40335 & .653574E-03, .653465E-03, .347952E+00, .653456E-03, .268827E-01,
40336 & .268827E-01, .724735E-03, .724868E-03, .724868E-03, .724735E-03,
40337 & .258636E+00, .724728E-03, .223751E-01, .223751E-01, .709421E-03,
40338 & .709567E-03, .709567E-03, .709421E-03, .185088E+00, .709417E-03,
40339 & .185359E-01, .185359E-01, .650478E-03, .650626E-03, .650626E-03,
40340 & .650478E-03, .128686E+00, .650474E-03, .152906E-01, .152906E-01,
40341 & .572423E-03, .572567E-03, .572567E-03, .572423E-03, .873875E-01,
40342 & .572420E-03, .125654E-01, .125654E-01, .490165E-03, .490302E-03,
40343 & .490302E-03, .490165E-03, .581141E-01, .490163E-03, .102901E-01,
40344 & .102901E-01, .411740E-03, .411866E-03, .411866E-03, .411740E-03/
40345 DATA (DL(K),K= 3911, 3995) /
40346 & .379596E-01, .411738E-03, .839975E-02, .839975E-02, .340986E-03,
40347 & .341101E-03, .341101E-03, .340986E-03, .244073E-01, .340985E-03,
40348 & .683634E-02, .683634E-02, .279417E-03, .279520E-03, .279520E-03,
40349 & .279417E-03, .154717E-01, .279416E-03, .554846E-02, .554846E-02,
40350 & .227114E-03, .227204E-03, .227204E-03, .227114E-03, .968450E-02,
40351 & .227113E-03, .449143E-02, .449143E-02, .183425E-03, .183504E-03,
40352 & .183504E-03, .183425E-03, .599306E-02, .183425E-03, .362676E-02,
40353 & .362676E-02, .147387E-03, .147455E-03, .147455E-03, .147387E-03,
40354 & .366977E-02, .147387E-03, .292164E-02, .292164E-02, .117936E-03,
40355 & .117995E-03, .117995E-03, .117936E-03, .222583E-02, .117936E-03,
40356 & .234830E-02, .234830E-02, .940414E-04, .940914E-04, .940914E-04,
40357 & .940414E-04, .133844E-02, .940412E-04, .188339E-02, .188339E-02,
40358 & .747651E-04, .748074E-04, .748074E-04, .747651E-04, .798451E-03,
40359 & .747649E-04, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40360 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40361 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40362 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40363 DATA (DL(K),K= 3996, 4000) /
40364 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40369 IF(X.GT.0.9985) RETURN
40375 IF(I.EQ.3.AND.X.GT.0.95) GOTO 19
40376 IF(I.EQ.8.AND.X.GT.0.95) GOTO 19
40383 A1 = PHO_CKMTFV(X,F1)
40384 A2 = PHO_CKMTFV(X,F2)
40385 QQ(I)=A1*(S2-S)/DELTA+A2*(S-S1)/DELTA
40391 *$ CREATE PHO_CKMTFV.FOR
40393 CDECK ID>, PHO_CKMTFV
40394 REAL FUNCTION PHO_CKMTFV(X,FVL)
40395 C**********************************************************************
40397 C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
40398 C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
40399 C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
40402 C**********************************************************************
40405 DIMENSION FVL(25),XGRID(25)
40407 C input/output channels
40409 COMMON /POINOU/ LI,LO
40411 DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
40412 *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
40416 IF(X.LT.XGRID(I)) GO TO 2
40421 ELSE IF(I.GT.23) THEN
40427 BXI=LOG(1.-XGRID(I))
40429 BXJ=LOG(1.-XGRID(J))
40431 BXK=LOG(1.-XGRID(K))
40432 FI=LOG(ABS(FVL(I)) +1.E-15)
40433 FJ=LOG(ABS(FVL(J)) +1.E-16)
40434 FK=LOG(ABS(FVL(K)) +1.E-17)
40435 DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
40436 ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
40438 ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
40439 BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
40440 IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
40442 C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
40443 C WRITE(LO,2001) X,FVL
40444 C 2001 FORMAT(8E12.4)
40445 C WRITE(LO,2001) ALPHA,BETA,ALOGA,DET
40447 PHO_CKMTFV=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
40451 *$ CREATE PHO_SASGAM.FOR
40453 CDECK ID>, PHO_SASGAM
40454 C***********************************************************************
40455 C...SaSgam version 2 - parton distributions of the photon
40456 C...by Gerhard A. Schuler and Torbjorn Sjostrand
40457 C...For further information see Z. Phys. C68 (1995) 607
40458 C...and Phys. Lett. B376 (1996) 193.
40460 C...18 January 1996: original code.
40461 C...22 July 1996: calculation of BETA moved in SASBEH.
40463 C!!!Note that one further call parameter - IP2 - has been added
40464 C!!!to the SASGAM argument list compared with version 1.
40466 C...The user should only need to call the SASGAM routine,
40467 C...which in turn calls the auxiliary routines SASVMD, SASANO,
40468 C...SASBEH and SASDIR. The package is self-contained.
40470 C...One particular aspect of these parametrizations is that F2 for
40471 C...the photon is not obtained just as the charge-squared-weighted
40472 C...sum of quark distributions, but differ in the treatment of
40473 C...heavy flavours (in F2 the DIS relation W2 = Q2*(1-x)/x restricts
40474 C...the kinematics range of heavy-flavour production, but the same
40475 C...kinematics is not relevant e.g. for jet production) and, for the
40476 C...'MSbar' fits, in the addition of a Cgamma term related to the
40477 C...separation of direct processes. Schematically:
40478 C...PDF = VMD (rho, omega, phi) + anomalous (d, u, s, c, b).
40479 C...F2 = VMD (rho, omega, phi) + anomalous (d, u, s) +
40480 C... Bethe-Heitler (c, b) (+ Cgamma (d, u, s)).
40481 C...The J/psi and Upsilon states have not been included in the VMD sum,
40482 C...but low c and b masses in the other components should compensate
40483 C...for this in a duality sense.
40485 C...The calling sequence is the following:
40486 C CALL SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40487 C...with the following declaration statement:
40488 C DIMENSION XPDFGM(-6:6)
40489 C...and, optionally, further information in:
40490 C COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
40492 C COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
40493 C...Input: ISET = 1 : SaS set 1D ('DIS', Q0 = 0.6 GeV)
40494 C = 2 : SaS set 1M ('MSbar', Q0 = 0.6 GeV)
40495 C = 3 : SaS set 2D ('DIS', Q0 = 2 GeV)
40496 C = 4 : SaS set 2M ('MSbar', Q0 = 2 GeV)
40499 C P2 : P2 value; should be = 0. for an on-shell photon.
40500 C IP2 : scheme used to evaluate off-shell anomalous component.
40501 C = 0 : recommended default, see = 7.
40502 C = 1 : dipole dampening by integration; very time-consuming.
40503 C = 2 : P_0^2 = max( Q_0^2, P^2 )
40504 C = 3 : P_0^2 = Q_0^2 + P^2.
40505 C = 4 : P_{eff} that preserves momentum sum.
40506 C = 5 : P_{int} that preserves momentum and average
40508 C = 6 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
40509 C = 7 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
40510 C...Output: F2GM : F2 value of the photon (including factors of alpha_em).
40511 C XPFDGM : x times parton distribution functions of the photon,
40512 C with elements 0 = g, 1 = d, 2 = u, 3 = s, 4 = c, 5 = b,
40513 C 6 = t (always empty!), - for antiquarks (result is same).
40514 C...The breakdown by component is stored in the commonblock SASCOM,
40515 C with elements as above.
40516 C XPVMD : rho, omega, phi VMD part only of output.
40517 C XPANL : d, u, s anomalous part only of output.
40518 C XPANH : c, b anomalous part only of output.
40519 C XPBEH : c, b Bethe-Heitler part only of output.
40520 C XPDIR : Cgamma (direct contribution) part only of output.
40521 C...The above arrays do not distinguish valence and sea contributions,
40522 C...although this information is available internally. The additional
40523 C...commonblock SASVAL provides the valence part only of the above
40524 C...distributions. Array names VXPVMD, VXPANL and VXPANH correspond
40525 C...to XPVMD, XPANL and XPANH, while XPBEH and XPDIR are valence only
40526 C...and therefore not given doubly. VXPDGM gives the sum of valence
40527 C...parts, and so matches XPDFGM. The difference, i.e. XPVMD-VXPVMD
40528 C...and so on, gives the sea part only.
40529 C***********************************************************************
40531 SUBROUTINE PHO_SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40532 C...Purpose: to construct the F2 and parton distributions of the photon
40533 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
40534 C...For F2, c and b are included by the Bethe-Heitler formula;
40535 C...in the 'MSbar' scheme additionally a Cgamma term is added.
40537 DIMENSION XPDFGM(-6:6)
40539 C input/output channels
40541 COMMON /POINOU/ LI,LO
40543 COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
40545 COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
40546 CPH SAVE /SASCOM/,/SASVAL/
40548 C...Temporary array.
40549 DIMENSION XPGA(-6:6), VXPGA(-6:6)
40550 C...Charm and bottom masses (low to compensate for J/psi etc.).
40551 DATA PMC/1.3/, PMB/4.6/
40552 C...alpha_em and alpha_em/(2*pi).
40553 DATA AEM/0.007297/, AEM2PI/0.0011614/
40554 C...Lambda value for 4 flavours.
40556 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
40558 C...VMD couplings f_V**2/(4*pi).
40559 DATA FRHO/2.20/, FOMEGA/23.6/, FPHI/18.4/
40560 C...Masses for rho (=omega) and phi.
40561 DATA PMRHO/0.770/, PMPHI/1.020/
40562 C...Number of points in integration for IP2=1.
40580 C...Check that input sensible.
40581 IF(ISET.LE.0.OR.ISET.GE.5) THEN
40582 WRITE(LO,*) ' FATAL ERROR: SaSgam called for unknown set'
40583 WRITE(LO,*) ' ISET = ',ISET
40586 IF(X.LE.0..OR.X.GT.1.) THEN
40587 WRITE(LO,*) ' FATAL ERROR: SaSgam called for unphysical x'
40588 WRITE(LO,*) ' X = ',X
40592 C...Set Q0 cut-off parameter as function of set used.
40600 C...Scale choice for off-shell photon; common factors.
40605 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
40606 FACNOR=LOG(Q2/Q02)/NSTEP
40607 ELSEIF(IP2.EQ.2) THEN
40609 ELSEIF(IP2.EQ.3) THEN
40611 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
40612 ELSEIF(IP2.EQ.4) THEN
40613 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40614 & ((Q2+P2)*(Q02+P2)))
40615 ELSEIF(IP2.EQ.5) THEN
40616 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40617 & ((Q2+P2)*(Q02+P2)))
40618 P2MX=Q0*SQRT(P2MXA)
40619 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
40620 ELSEIF(IP2.EQ.6) THEN
40621 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40622 & ((Q2+P2)*(Q02+P2)))
40623 P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
40625 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40626 & ((Q2+P2)*(Q02+P2)))
40627 P2MX=Q0*SQRT(P2MXA)
40629 P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
40630 P2MXB=MAX(0.,1.-P2/Q2)*P2MXB+MIN(1.,P2/Q2)*P2MXA
40631 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
40634 C...Call VMD parametrization for d quark and use to give rho, omega,
40635 C...phi. Note dipole dampening for off-shell photon.
40636 CALL PHO_SASVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40640 FACUD=AEM*(1./FRHO+1./FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
40641 FACS=AEM*(1./FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
40643 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
40645 XPVMD(1)=XPVMD(1)+(1.-FRACU)*FACUD*XFVAL
40646 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
40647 XPVMD(3)=XPVMD(3)+FACS*XFVAL
40648 XPVMD(-1)=XPVMD(-1)+(1.-FRACU)*FACUD*XFVAL
40649 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
40650 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
40651 VXPVMD(1)=(1.-FRACU)*FACUD*XFVAL
40652 VXPVMD(2)=FRACU*FACUD*XFVAL
40653 VXPVMD(3)=FACS*XFVAL
40654 VXPVMD(-1)=(1.-FRACU)*FACUD*XFVAL
40655 VXPVMD(-2)=FRACU*FACUD*XFVAL
40656 VXPVMD(-3)=FACS*XFVAL
40659 C...Anomalous parametrizations for different strategies
40660 C...for off-shell photons; except full integration.
40662 C...Call anomalous parametrization for d + u + s.
40663 CALL PHO_SASANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40665 XPANL(KFL)=FACNOR*XPGA(KFL)
40666 VXPANL(KFL)=FACNOR*VXPGA(KFL)
40669 C...Call anomalous parametrization for c and b.
40670 CALL PHO_SASANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40672 XPANH(KFL)=FACNOR*XPGA(KFL)
40673 VXPANH(KFL)=FACNOR*VXPGA(KFL)
40675 CALL PHO_SASANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40677 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
40678 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
40682 C...Special option: loop over flavours and integrate over k2.
40684 DO 160 ISTEP=1,NSTEP
40685 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5)/NSTEP)
40686 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
40687 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
40688 CALL PHO_SASVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
40689 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
40690 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8./9.)
40691 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2./9.)
40693 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
40694 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
40695 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
40696 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
40702 C...Call Bethe-Heitler term expression for charm and bottom.
40703 CALL PHO_SASBEH(4,X,Q2,P2,PMC**2,XPBH)
40706 CALL PHO_SASBEH(5,X,Q2,P2,PMB**2,XPBH)
40710 C...For MSbar subtraction call C^gamma term expression for d, u, s.
40711 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
40712 CALL PHO_SASDIR(X,Q2,P2,Q02,XPGA)
40714 XPDIR(KFL)=XPGA(KFL)
40718 C...Store result in output array.
40721 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4./9.
40722 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
40723 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
40724 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
40725 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
40731 C*********************************************************************
40733 *$ CREATE PHO_SASVMD.FOR
40735 CDECK ID>, PHO_SASVMD
40736 SUBROUTINE PHO_SASVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40737 C...Purpose: to evaluate the VMD parton distributions of a photon,
40738 C...evolved homogeneously from an initial scale P2 to Q2.
40739 C...Does not include dipole suppression factor.
40740 C...ISET is parton distribution set, see above;
40741 C...additionally ISET=0 is used for the evolution of an anomalous photon
40742 C...which branched at a scale P2 and then evolved homogeneously to Q2.
40743 C...ALAM is the 4-flavour Lambda, which is automatically converted
40744 C...to 3- and 5-flavour equivalents as needed.
40746 DIMENSION XPGA(-6:6), VXPGA(-6:6)
40748 C input/output channels
40750 COMMON /POINOU/ LI,LO
40752 DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
40761 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
40762 ALAM3=ALAM*(PMC/ALAM)**(2./27.)
40763 ALAM5=ALAM*(ALAM/PMB)**(2./23.)
40764 P2EFF=MAX(P2,1.2*ALAM3**2)
40765 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
40766 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
40767 Q2EFF=MAX(Q2,P2EFF)
40769 C...Find number of flavours at lower and upper scale.
40771 IF(P2EFF.LT.PMC**2) NFP=3
40772 IF(P2EFF.GT.PMB**2) NFP=5
40774 IF(Q2EFF.LT.PMC**2) NFQ=3
40775 IF(Q2EFF.GT.PMB**2) NFQ=5
40777 C...Find s as sum of 3-, 4- and 5-flavour parts.
40781 IF(NFQ.EQ.3) Q2DIV=Q2EFF
40782 S=S+(6./27.)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
40784 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
40786 IF(NFP.EQ.3) P2DIV=PMC**2
40788 IF(NFQ.EQ.5) Q2DIV=PMB**2
40789 S=S+(6./25.)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
40793 IF(NFP.EQ.5) P2DIV=P2EFF
40794 S=S+(6./23.)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
40797 C...Calculate frequent combinations of x and s.
40804 C...Evaluate homogeneous anomalous parton distributions below or
40805 C...above threshold.
40807 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40808 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40809 XVAL = X * 1.5 * (X**2+X1**2)
40813 XVAL = (1.5/(1.-0.197*S+4.33*S2)*X**2 + (1.5+2.10*S)/
40814 & (1.+3.29*S)*X1**2 + 5.23*S/(1.+1.17*S+19.9*S3)*X*X1) *
40815 & X**(1./(1.+1.5*S)) * (1.-X**2)**(2.667*S)
40816 XGLU = 4.*S/(1.+4.76*S+15.2*S2+29.3*S4) *
40817 & X**(-2.03*S/(1.+2.44*S)) * (X1*XL)**(1.333*S) *
40818 & ((4.*X**2+7.*X+4.)*X1/3. - 2.*X*(1.+X)*XL)
40819 XSEA = S2/(1.+4.54*S+8.19*S2+8.05*S3) *
40820 & X**(-1.54*S/(1.+1.29*S)) * X1**(2.667*S) *
40821 & ((8.-73.*X+62.*X**2)*X1/9. + (3.-8.*X**2/3.)*X*XL +
40822 & (2.*X-1.)*X*XL**2)
40825 C...Evaluate set 1D parton distributions below or above threshold.
40826 ELSEIF(ISET.EQ.1) THEN
40827 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40828 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40829 XVAL = 1.294 * X**0.80 * X1**0.76
40830 XGLU = 1.273 * X**0.40 * X1**1.76
40831 XSEA = 0.100 * X1**3.76
40833 XVAL = 1.294/(1.+0.252*S+3.079*S2) * X**(0.80-0.13*S) *
40834 & X1**(0.76+0.667*S) * XL**(2.*S)
40835 XGLU = 7.90*S/(1.+5.50*S) * EXP(-5.16*S) *
40836 & X**(-1.90*S/(1.+3.60*S)) * X1**1.30 * XL**(0.50+3.*S) +
40837 & 1.273 * EXP(-10.*S) * X**0.40 * X1**(1.76+3.*S)
40838 XSEA = (0.1-0.397*S2+1.121*S3)/(1.+5.61*S2+5.26*S3) *
40839 & X**(-7.32*S2/(1.+10.3*S2)) *
40840 & X1**((3.76+15.*S+12.*S2)/(1.+4.*S))
40841 XSEA0 = 0.100 * X1**3.76
40844 C...Evaluate set 1M parton distributions below or above threshold.
40845 ELSEIF(ISET.EQ.2) THEN
40846 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40847 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40848 XVAL = 0.8477 * X**0.51 * X1**1.37
40849 XGLU = 3.42 * X**0.255 * X1**2.37
40852 XVAL = 0.8477/(1.+1.37*S+2.18*S2+3.73*S3) * X**(0.51+0.21*S)
40853 & * X1**1.37 * XL**(2.667*S)
40854 XGLU = 24.*S/(1.+9.6*S+0.92*S2+14.34*S3) * EXP(-5.94*S) *
40855 & X**((-0.013-1.80*S)/(1.+3.14*S)) * X1**(2.37+0.4*S) *
40856 & XL**(0.32+3.6*S) + 3.42 * EXP(-12.*S) * X**0.255 *
40858 XSEA = 0.842*S/(1.+21.3*S-33.2*S2+229.*S3) *
40859 & X**((0.13-2.90*S)/(1.+5.44*S)) * X1**(3.45+0.5*S) *
40864 C...Evaluate set 2D parton distributions below or above threshold.
40865 ELSEIF(ISET.EQ.3) THEN
40866 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40867 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40868 XVAL = X**0.46 * X1**0.64 + 0.76 * X
40869 XGLU = 1.925 * X1**2
40870 XSEA = 0.242 * X1**4
40872 XVAL = (1.+0.186*S)/(1.-0.209*S+1.495*S2) * X**(0.46+0.25*S)
40873 & * X1**((0.64+0.14*S+5.*S2)/(1.+S)) * XL**(1.9*S) +
40874 & (0.76+0.4*S) * X * X1**(2.667*S)
40875 XGLU = (1.925+5.55*S+147.*S2)/(1.-3.59*S+3.32*S2) *
40876 & EXP(-18.67*S) * X**((-5.81*S-5.34*S2)/(1.+29.*S-4.26*S2))
40877 & * X1**((2.-5.9*S)/(1.+1.7*S)) * XL**(9.3*S/(1.+1.7*S))
40878 XSEA = (0.242-0.252*S+1.19*S2)/(1.-0.607*S+21.95*S2) *
40879 & X**(-12.1*S2/(1.+2.62*S+16.7*S2)) * X1**4 * XL**S
40880 XSEA0 = 0.242 * X1**4
40883 C...Evaluate set 2M parton distributions below or above threshold.
40884 ELSEIF(ISET.EQ.4) THEN
40885 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40886 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40887 XVAL = 1.168 * X**0.50 * X1**2.60 + 0.965 * X
40888 XGLU = 1.808 * X1**2
40889 XSEA = 0.209 * X1**4
40891 XVAL = (1.168+1.771*S+29.35*S2) * EXP(-5.776*S) *
40892 & X**((0.5+0.208*S)/(1.-0.794*S+1.516*S2)) *
40893 & X1**((2.6+7.6*S)/(1.+5.*S)) * XL**(5.15*S/(1.+2.*S)) +
40894 & (0.965+22.35*S)/(1.+18.4*S) * X * X1**(2.667*S)
40895 XGLU = (1.808+29.9*S)/(1.+26.4*S) * EXP(-5.28*S) *
40896 & X**((-5.35*S-10.11*S2)/(1.+31.71*S)) *
40897 & X1**((2.-7.3*S+4.*S2)/(1.+2.5*S)) *
40898 & XL**(10.9*S/(1.+2.5*S))
40899 XSEA = (0.209+0.644*S2)/(1.+0.319*S+17.6*S2) *
40900 & X**((-0.373*S-7.71*S2)/(1.+0.815*S+11.0*S2)) *
40901 & X1**(4.+S) * XL**(0.45*S)
40902 XSEA0 = 0.209 * X1**4
40906 C...Threshold factors for c and b sea.
40907 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
40909 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
40910 SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40912 XCHM=XSEA*(1.-(SCH/SLL)**2)
40914 XCHM=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SCH/SLL)
40918 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
40919 SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40921 XBOT=XSEA*(1.-(SBT/SLL)**2)
40923 XBOT=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SBT/SLL)
40927 C...Fill parton distributions.
40934 XPGA(KFA)=XPGA(KFA)+XVAL
40936 XPGA(-KFL)=XPGA(KFL)
40944 C*********************************************************************
40946 *$ CREATE PHO_SASANO.FOR
40948 CDECK ID>, PHO_SASANO
40949 SUBROUTINE PHO_SASANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40950 C...Purpose: to evaluate the parton distributions of the anomalous
40951 C...photon, inhomogeneously evolved from a scale P2 (where it vanishes)
40953 C...KF=0 gives the sum over (up to) 5 flavours,
40954 C...KF<0 limits to flavours up to abs(KF),
40955 C...KF>0 is for flavour KF only.
40956 C...ALAM is the 4-flavour Lambda, which is automatically converted
40957 C...to 3- and 5-flavour equivalents as needed.
40960 C input/output channels
40962 COMMON /POINOU/ LI,LO
40964 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
40965 DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
40972 IF(Q2.LE.P2) RETURN
40975 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
40976 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2./27.))**2
40978 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2./23.))**2
40979 P2EFF=MAX(P2,1.2*ALAMSQ(3))
40980 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
40981 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
40982 Q2EFF=MAX(Q2,P2EFF)
40985 C...Find number of flavours at lower and upper scale.
40987 IF(P2EFF.LT.PMC**2) NFP=3
40988 IF(P2EFF.GT.PMB**2) NFP=5
40990 IF(Q2EFF.LT.PMC**2) NFQ=3
40991 IF(Q2EFF.GT.PMB**2) NFQ=5
40993 C...Define range of flavour loop.
40997 ELSEIF(KF.LT.0) THEN
41005 C...Loop over flavours the photon can branch into.
41006 DO 110 KFL=KFLMN,KFLMX
41008 C...Light flavours: calculate t range and (approximate) s range.
41009 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
41010 TDIFF=LOG(Q2EFF/P2EFF)
41011 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41012 & LOG(P2EFF/ALAMSQ(NFQ)))
41013 IF(NFQ.GT.NFP) THEN
41015 IF(NFQ.EQ.4) Q2DIV=PMC**2
41016 SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
41017 & LOG(P2EFF/ALAMSQ(NFQ)))
41018 SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
41019 & LOG(P2EFF/ALAMSQ(NFQ-1)))
41020 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
41022 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
41024 SNF4=(6./(33.-2.*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
41025 & LOG(P2EFF/ALAMSQ(4)))
41026 SNF3=(6./(33.-2.*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
41027 & LOG(P2EFF/ALAMSQ(3)))
41028 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
41031 C...u and s quark do not need a separate treatment when d has been done.
41032 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
41034 C...Charm: as above, but only include range above c threshold.
41035 ELSEIF(KFL.EQ.4) THEN
41036 IF(Q2.LE.PMC**2) GOTO 110
41037 P2EFF=MAX(P2EFF,PMC**2)
41038 Q2EFF=MAX(Q2EFF,P2EFF)
41039 TDIFF=LOG(Q2EFF/P2EFF)
41040 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41041 & LOG(P2EFF/ALAMSQ(NFQ)))
41042 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
41044 SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
41045 & LOG(P2EFF/ALAMSQ(NFQ)))
41046 SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
41047 & LOG(P2EFF/ALAMSQ(NFQ-1)))
41048 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
41051 C...Bottom: as above, but only include range above b threshold.
41052 ELSEIF(KFL.EQ.5) THEN
41053 IF(Q2.LE.PMB**2) GOTO 110
41054 P2EFF=MAX(P2EFF,PMB**2)
41055 Q2EFF=MAX(Q2,P2EFF)
41056 TDIFF=LOG(Q2EFF/P2EFF)
41057 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41058 & LOG(P2EFF/ALAMSQ(NFQ)))
41061 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
41063 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4./9.
41064 FAC=AEM2PI*2.*CHSQ*TDIFF
41066 C...Evaluate parton distributions (normalized to unit momentum sum).
41067 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
41068 XVAL= ((1.5+2.49*S+26.9*S**2)/(1.+32.3*S**2)*X**2 +
41069 & (1.5-0.49*S+7.83*S**2)/(1.+7.68*S**2)*(1.-X)**2 +
41070 & 1.5*S/(1.-3.2*S+7.*S**2)*X*(1.-X)) *
41071 & X**(1./(1.+0.58*S)) * (1.-X**2)**(2.5*S/(1.+10.*S))
41072 XGLU= 2.*S/(1.+4.*S+7.*S**2) *
41073 & X**(-1.67*S/(1.+2.*S)) * (1.-X**2)**(1.2*S) *
41074 & ((4.*X**2+7.*X+4.)*(1.-X)/3. - 2.*X*(1.+X)*XL)
41075 XSEA= 0.333*S**2/(1.+4.90*S+4.69*S**2+21.4*S**3) *
41076 & X**(-1.18*S/(1.+1.22*S)) * (1.-X)**(1.2*S) *
41077 & ((8.-73.*X+62.*X**2)*(1.-X)/9. + (3.-8.*X**2/3.)*X*XL +
41078 & (2.*X-1.)*X*XL**2)
41080 C...Threshold factors for c and b sea.
41081 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
41083 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
41084 SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41085 XCHM=XSEA*(1.-(SCH/SLL)**3)
41088 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
41089 SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41090 XBOT=XSEA*(1.-(SBT/SLL)**3)
41094 C...Add contribution of each valence flavour.
41095 XPGA(0)=XPGA(0)+FAC*XGLU
41096 XPGA(1)=XPGA(1)+FAC*XSEA
41097 XPGA(2)=XPGA(2)+FAC*XSEA
41098 XPGA(3)=XPGA(3)+FAC*XSEA
41099 XPGA(4)=XPGA(4)+FAC*XCHM
41100 XPGA(5)=XPGA(5)+FAC*XBOT
41101 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
41102 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
41105 XPGA(-KFL)=XPGA(KFL)
41106 VXPGA(-KFL)=VXPGA(KFL)
41111 C*********************************************************************
41113 *$ CREATE PHO_SASBEH.FOR
41115 CDECK ID>, PHO_SASBEH
41116 SUBROUTINE PHO_SASBEH(KF,X,Q2,P2,PM2,XPBH)
41117 C...Purpose: to evaluate the Bethe-Heitler cross section for
41118 C...heavy flavour production.
41120 DATA AEM2PI/0.0011614/
41126 C...Check kinematics limits.
41127 IF(X.GE.Q2/(4.*PM2+Q2+P2)) RETURN
41130 IF(BETA2.LT.1E-10) RETURN
41134 C...Simple case: P2 = 0.
41135 IF(P2.LT.1E-4) THEN
41136 IF(BETA.LT.0.99) THEN
41137 XBL=LOG((1.+BETA)/(1.-BETA))
41139 XBL=LOG((1.+BETA)**2*W2/(4.*PM2))
41141 SIGBH=BETA*(8.*X*(1.-X)-1.-RMQ*X*(1.-X))+
41142 & XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)
41144 C...Complicated case: P2 > 0, based on approximation of
41145 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
41147 RPQ=1.-4.*X**2*P2/Q2
41148 IF(RPQ.GT.1E-10) THEN
41149 RPBE=SQRT(RPQ*BETA2)
41150 IF(RPBE.LT.0.99) THEN
41151 XBL=LOG((1.+RPBE)/(1.-RPBE))
41152 XBI=2.*RPBE/(1.-RPBE**2)
41154 RPBESN=4.*PM2/W2+(4.*X**2*P2/Q2)*BETA2
41155 XBL=LOG((1.+RPBE)**2/RPBESN)
41158 SIGBH=BETA*(6.*X*(1.-X)-1.)+
41159 & XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)+
41160 & XBI*(2.*X/Q2)*(PM2*X*(2.-RMQ)-P2*X)
41164 C...Multiply by charge-squared etc. to get parton distribution.
41166 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4./9.
41167 XPBH=3.*CHSQ*AEM2PI*X*SIGBH
41171 C*********************************************************************
41173 *$ CREATE PHO_SASDIR.FOR
41175 CDECK ID>, PHO_SASDIR
41176 SUBROUTINE PHO_SASDIR(X,Q2,P2,Q02,XPGA)
41177 C...Purpose: to evaluate the direct contribution, i.e. the C^gamma term,
41178 C...as needed in MSbar parametrizations.
41180 DIMENSION XPGA(-6:6)
41181 DATA PMC/1.3/, PMB/4.6/, AEM2PI/0.0011614/
41188 C...Evaluate common x-dependent expression.
41189 XTMP = (X**2+(1.-X)**2) * (-LOG(X)) - 1.
41190 CGAM = 3.*AEM2PI*X * (XTMP*(1.+P2/(P2+Q02)) + 6.*X*(1.-X))
41192 C...d, u, s part by simple charge factor.
41193 XPGA(1)=(1./9.)*CGAM
41194 XPGA(2)=(4./9.)*CGAM
41195 XPGA(3)=(1./9.)*CGAM
41197 C...Also fill for antiquarks.
41204 *$ CREATE PHO_PHGAL.FOR
41206 CDECK ID>, PHO_PHGAL
41207 SUBROUTINE PHO_PHGAL(X,Q2,XPDF)
41208 C***********************************************************************
41210 C photon parton densities with built-in momentum sum rule and
41211 C Regge-based low-x behaviour
41213 C H. Abramowicz, E. Gurvich, A. Levy: Phys.Lett.B420:104-108,1998
41214 C e-Print Archive: hep-ph/9711355
41216 C code submitted by E.Gurvich, slightly modified (R.Engel, 09/1998)
41218 C***********************************************************************
41219 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
41222 PARAMETER(IX=100,IQ=7,NARG=2,NFUN=4)
41224 & XT(IX),Q2T(IQ),ARG(NARG),ENT(IX+IQ),
41225 & XPV(IX,IQ,0:NFUN),XPDF(-6:6)
41231 C...100 x values; in (D-4,.77) log spaced (78 points)
41232 C... in (.78,.995) lineary spaced (22 points)
41233 DATA Q2T/4.D0,10.D0,50.D0,1.D2,1.D3,1.D4,1.D5/
41235 &0.1000D-03,0.1123D-03,0.1262D-03,0.1417D-03,0.1592D-03,0.1789D-03,
41236 &0.2009D-03,0.2257D-03,0.2535D-03,0.2848D-03,0.3199D-03,0.3593D-03,
41237 &0.4037D-03,0.4534D-03,0.5093D-03,0.5722D-03,0.6427D-03,0.7220D-03,
41238 &0.8110D-03,0.9110D-03,0.1023D-02,0.1150D-02,0.1291D-02,0.1451D-02,
41239 &0.1629D-02,0.1830D-02,0.2056D-02,0.2310D-02,0.2594D-02,0.2914D-02,
41240 &0.3274D-02,0.3677D-02,0.4131D-02,0.4640D-02,0.5212D-02,0.5855D-02,
41241 &0.6577D-02,0.7388D-02,0.8299D-02,0.9323D-02,0.1047D-01,0.1176D-01,
41242 &0.1321D-01,0.1484D-01,0.1667D-01,0.1873D-01,0.2104D-01,0.2363D-01,
41243 &0.2655D-01,0.2982D-01,0.3350D-01,0.3763D-01,0.4227D-01,0.4748D-01,
41244 &0.5334D-01,0.5992D-01,0.6731D-01,0.7560D-01,0.8493D-01,0.9540D-01,
41245 &0.1072D+00,0.1204D+00,0.1352D+00,0.1519D+00,0.1706D+00,0.1917D+00,
41246 &0.2153D+00,0.2419D+00,0.2717D+00,0.3052D+00,0.3428D+00,0.3851D+00,
41247 &0.4326D+00,0.4859D+00,0.5458D+00,0.6131D+00,0.6887D+00,0.7737D+00,
41248 &0.7837D+00,0.7937D+00,0.8037D+00,0.8137D+00,0.8237D+00,0.8337D+00,
41249 &0.8437D+00,0.8537D+00,0.8637D+00,0.8737D+00,0.8837D+00,0.8937D+00,
41250 &0.9037D+00,0.9137D+00,0.9237D+00,0.9337D+00,0.9437D+00,0.9537D+00,
41251 &0.9637D+00,0.9737D+00,0.9837D+00,0.9937D+00/
41253 C...place for DATA blocks
41254 DATA (XPV(I,1,0),I=1,100)/
41255 &0.6632D-01,0.6536D-01,0.6390D-01,0.6196D-01,0.5952D-01,0.5663D-01,
41256 &0.5339D-01,0.5124D-01,0.5029D-01,0.4893D-01,0.4718D-01,0.4505D-01,
41257 &0.4259D-01,0.4038D-01,0.3966D-01,0.3860D-01,0.3721D-01,0.3551D-01,
41258 &0.3354D-01,0.3206D-01,0.3134D-01,0.3031D-01,0.2902D-01,0.2747D-01,
41259 &0.2608D-01,0.2543D-01,0.2451D-01,0.2335D-01,0.2202D-01,0.2132D-01,
41260 &0.2051D-01,0.1950D-01,0.1851D-01,0.1783D-01,0.1696D-01,0.1609D-01,
41261 &0.1539D-01,0.1454D-01,0.1386D-01,0.1310D-01,0.1242D-01,0.1169D-01,
41262 &0.1104D-01,0.1036D-01,0.9694D-02,0.9046D-02,0.8400D-02,0.7792D-02,
41263 &0.7173D-02,0.6573D-02,0.5978D-02,0.5411D-02,0.4853D-02,0.4307D-02,
41264 &0.3791D-02,0.3292D-02,0.2818D-02,0.2382D-02,0.1976D-02,0.1606D-02,
41265 &0.1275D-02,0.9866D-03,0.7403D-03,0.5351D-03,0.3713D-03,0.2450D-03,
41266 &0.1524D-03,0.8849D-04,0.4730D-04,0.2278D-04,0.9707D-05,0.3518D-05,
41267 &0.1041D-05,0.2356D-06,0.3682D-07,0.3365D-08,0.1333D-09,0.1188D-11,
41268 &0.6095D-12,0.3031D-12,0.1457D-12,0.6733D-13,0.2986D-13,0.1262D-13,
41269 &0.5060D-14,0.1912D-14,0.6734D-15,0.2199D-15,0.6498D-16,0.1729D-16,
41270 &0.4059D-17,0.8091D-18,0.1324D-18,0.1691D-19,0.1518D-20,0.8785D-22,
41271 &0.2519D-23,0.2197D-25,0.2840D-28,0.1908D-33/
41272 DATA (XPV(I,1,1),I=1,100)/
41273 &0.5848D-03,0.5838D-03,0.5793D-03,0.5713D-03,0.5597D-03,0.5447D-03,
41274 &0.5270D-03,0.5167D-03,0.5143D-03,0.5087D-03,0.4998D-03,0.4879D-03,
41275 &0.4731D-03,0.4599D-03,0.4584D-03,0.4538D-03,0.4461D-03,0.4355D-03,
41276 &0.4223D-03,0.4133D-03,0.4109D-03,0.4053D-03,0.3970D-03,0.3859D-03,
41277 &0.3763D-03,0.3739D-03,0.3686D-03,0.3605D-03,0.3504D-03,0.3473D-03,
41278 &0.3426D-03,0.3355D-03,0.3286D-03,0.3253D-03,0.3196D-03,0.3138D-03,
41279 &0.3102D-03,0.3047D-03,0.3014D-03,0.2971D-03,0.2939D-03,0.2901D-03,
41280 &0.2875D-03,0.2849D-03,0.2824D-03,0.2805D-03,0.2787D-03,0.2780D-03,
41281 &0.2772D-03,0.2771D-03,0.2773D-03,0.2784D-03,0.2799D-03,0.2820D-03,
41282 &0.2850D-03,0.2886D-03,0.2930D-03,0.2985D-03,0.3050D-03,0.3126D-03,
41283 &0.3215D-03,0.3316D-03,0.3432D-03,0.3564D-03,0.3714D-03,0.3883D-03,
41284 &0.4073D-03,0.4287D-03,0.4526D-03,0.4794D-03,0.5092D-03,0.5425D-03,
41285 &0.5796D-03,0.6207D-03,0.6664D-03,0.7171D-03,0.7733D-03,0.8356D-03,
41286 &0.8429D-03,0.8502D-03,0.8574D-03,0.8647D-03,0.8719D-03,0.8791D-03,
41287 &0.8863D-03,0.8935D-03,0.9007D-03,0.9079D-03,0.9151D-03,0.9222D-03,
41288 &0.9294D-03,0.9365D-03,0.9436D-03,0.9508D-03,0.9579D-03,0.9650D-03,
41289 &0.9720D-03,0.9791D-03,0.9862D-03,0.9932D-03/
41290 DATA (XPV(I,1,2),I=1,100)/
41291 &0.2339D-02,0.2335D-02,0.2317D-02,0.2285D-02,0.2239D-02,0.2179D-02,
41292 &0.2108D-02,0.2067D-02,0.2057D-02,0.2035D-02,0.1999D-02,0.1951D-02,
41293 &0.1892D-02,0.1840D-02,0.1833D-02,0.1815D-02,0.1784D-02,0.1742D-02,
41294 &0.1689D-02,0.1653D-02,0.1643D-02,0.1621D-02,0.1588D-02,0.1544D-02,
41295 &0.1505D-02,0.1496D-02,0.1474D-02,0.1442D-02,0.1402D-02,0.1389D-02,
41296 &0.1370D-02,0.1342D-02,0.1314D-02,0.1301D-02,0.1278D-02,0.1255D-02,
41297 &0.1241D-02,0.1219D-02,0.1205D-02,0.1188D-02,0.1176D-02,0.1160D-02,
41298 &0.1150D-02,0.1139D-02,0.1130D-02,0.1122D-02,0.1115D-02,0.1112D-02,
41299 &0.1109D-02,0.1108D-02,0.1109D-02,0.1114D-02,0.1120D-02,0.1128D-02,
41300 &0.1140D-02,0.1154D-02,0.1172D-02,0.1194D-02,0.1220D-02,0.1251D-02,
41301 &0.1286D-02,0.1326D-02,0.1373D-02,0.1426D-02,0.1485D-02,0.1553D-02,
41302 &0.1629D-02,0.1715D-02,0.1811D-02,0.1917D-02,0.2037D-02,0.2170D-02,
41303 &0.2318D-02,0.2483D-02,0.2666D-02,0.2868D-02,0.3093D-02,0.3342D-02,
41304 &0.3372D-02,0.3401D-02,0.3430D-02,0.3459D-02,0.3488D-02,0.3517D-02,
41305 &0.3545D-02,0.3574D-02,0.3603D-02,0.3632D-02,0.3660D-02,0.3689D-02,
41306 &0.3717D-02,0.3746D-02,0.3775D-02,0.3803D-02,0.3831D-02,0.3860D-02,
41307 &0.3888D-02,0.3916D-02,0.3945D-02,0.3973D-02/
41308 DATA (XPV(I,1,3),I=1,100)/
41309 &0.1755D-03,0.1751D-03,0.1738D-03,0.1714D-03,0.1679D-03,0.1634D-03,
41310 &0.1581D-03,0.1550D-03,0.1543D-03,0.1526D-03,0.1499D-03,0.1464D-03,
41311 &0.1419D-03,0.1380D-03,0.1375D-03,0.1361D-03,0.1338D-03,0.1306D-03,
41312 &0.1267D-03,0.1240D-03,0.1233D-03,0.1216D-03,0.1191D-03,0.1158D-03,
41313 &0.1129D-03,0.1122D-03,0.1106D-03,0.1082D-03,0.1051D-03,0.1042D-03,
41314 &0.1028D-03,0.1006D-03,0.9857D-04,0.9759D-04,0.9587D-04,0.9414D-04,
41315 &0.9305D-04,0.9140D-04,0.9041D-04,0.8912D-04,0.8817D-04,0.8702D-04,
41316 &0.8626D-04,0.8546D-04,0.8472D-04,0.8415D-04,0.8362D-04,0.8339D-04,
41317 &0.8317D-04,0.8312D-04,0.8318D-04,0.8352D-04,0.8398D-04,0.8459D-04,
41318 &0.8550D-04,0.8658D-04,0.8789D-04,0.8956D-04,0.9151D-04,0.9379D-04,
41319 &0.9644D-04,0.9948D-04,0.1030D-03,0.1069D-03,0.1114D-03,0.1165D-03,
41320 &0.1222D-03,0.1286D-03,0.1358D-03,0.1438D-03,0.1528D-03,0.1628D-03,
41321 &0.1739D-03,0.1862D-03,0.1999D-03,0.2151D-03,0.2320D-03,0.2507D-03,
41322 &0.2529D-03,0.2551D-03,0.2572D-03,0.2594D-03,0.2616D-03,0.2637D-03,
41323 &0.2659D-03,0.2681D-03,0.2702D-03,0.2724D-03,0.2745D-03,0.2767D-03,
41324 &0.2788D-03,0.2810D-03,0.2831D-03,0.2852D-03,0.2874D-03,0.2895D-03,
41325 &0.2916D-03,0.2937D-03,0.2959D-03,0.2980D-03/
41326 DATA (XPV(I,1,4),I=1,100)/
41327 &0.7018D-03,0.7006D-03,0.6951D-03,0.6855D-03,0.6716D-03,0.6537D-03,
41328 &0.6324D-03,0.6200D-03,0.6172D-03,0.6104D-03,0.5998D-03,0.5854D-03,
41329 &0.5677D-03,0.5519D-03,0.5500D-03,0.5445D-03,0.5353D-03,0.5226D-03,
41330 &0.5068D-03,0.4960D-03,0.4930D-03,0.4864D-03,0.4764D-03,0.4631D-03,
41331 &0.4516D-03,0.4487D-03,0.4423D-03,0.4326D-03,0.4205D-03,0.4167D-03,
41332 &0.4111D-03,0.4026D-03,0.3943D-03,0.3903D-03,0.3835D-03,0.3765D-03,
41333 &0.3722D-03,0.3656D-03,0.3616D-03,0.3565D-03,0.3527D-03,0.3481D-03,
41334 &0.3450D-03,0.3418D-03,0.3389D-03,0.3366D-03,0.3345D-03,0.3336D-03,
41335 &0.3327D-03,0.3325D-03,0.3327D-03,0.3341D-03,0.3359D-03,0.3383D-03,
41336 &0.3420D-03,0.3463D-03,0.3516D-03,0.3582D-03,0.3660D-03,0.3752D-03,
41337 &0.3858D-03,0.3979D-03,0.4118D-03,0.4277D-03,0.4456D-03,0.4660D-03,
41338 &0.4887D-03,0.5145D-03,0.5432D-03,0.5752D-03,0.6111D-03,0.6510D-03,
41339 &0.6955D-03,0.7448D-03,0.7997D-03,0.8605D-03,0.9280D-03,0.1003D-02,
41340 &0.1011D-02,0.1020D-02,0.1029D-02,0.1038D-02,0.1046D-02,0.1055D-02,
41341 &0.1064D-02,0.1072D-02,0.1081D-02,0.1089D-02,0.1098D-02,0.1107D-02,
41342 &0.1115D-02,0.1124D-02,0.1132D-02,0.1141D-02,0.1149D-02,0.1158D-02,
41343 &0.1166D-02,0.1175D-02,0.1183D-02,0.1192D-02/
41344 DATA (XPV(I,2,0),I=1,100)/
41345 &0.1024D+00,0.1007D+00,0.9821D-01,0.9497D-01,0.9093D-01,0.8617D-01,
41346 &0.8086D-01,0.7731D-01,0.7566D-01,0.7338D-01,0.7048D-01,0.6700D-01,
41347 &0.6300D-01,0.5939D-01,0.5814D-01,0.5638D-01,0.5410D-01,0.5135D-01,
41348 &0.4819D-01,0.4580D-01,0.4460D-01,0.4293D-01,0.4087D-01,0.3843D-01,
41349 &0.3624D-01,0.3517D-01,0.3372D-01,0.3192D-01,0.2988D-01,0.2879D-01,
41350 &0.2755D-01,0.2602D-01,0.2454D-01,0.2352D-01,0.2224D-01,0.2097D-01,
41351 &0.1995D-01,0.1875D-01,0.1779D-01,0.1673D-01,0.1580D-01,0.1480D-01,
41352 &0.1393D-01,0.1305D-01,0.1218D-01,0.1136D-01,0.1055D-01,0.9801D-02,
41353 &0.9052D-02,0.8337D-02,0.7641D-02,0.6989D-02,0.6357D-02,0.5747D-02,
41354 &0.5179D-02,0.4637D-02,0.4127D-02,0.3663D-02,0.3232D-02,0.2840D-02,
41355 &0.2487D-02,0.2174D-02,0.1901D-02,0.1662D-02,0.1459D-02,0.1285D-02,
41356 &0.1137D-02,0.1010D-02,0.9006D-03,0.8023D-03,0.7126D-03,0.6276D-03,
41357 &0.5458D-03,0.4661D-03,0.3876D-03,0.3101D-03,0.2334D-03,0.1570D-03,
41358 &0.1486D-03,0.1404D-03,0.1322D-03,0.1242D-03,0.1162D-03,0.1084D-03,
41359 &0.1007D-03,0.9304D-04,0.8554D-04,0.7817D-04,0.7086D-04,0.6372D-04,
41360 &0.5670D-04,0.4982D-04,0.4307D-04,0.3647D-04,0.3005D-04,0.2382D-04,
41361 &0.1781D-04,0.1208D-04,0.6720D-05,0.1928D-05/
41362 DATA (XPV(I,2,1),I=1,100)/
41363 &0.1449D-02,0.1433D-02,0.1407D-02,0.1370D-02,0.1324D-02,0.1268D-02,
41364 &0.1204D-02,0.1163D-02,0.1147D-02,0.1123D-02,0.1089D-02,0.1048D-02,
41365 &0.1000D-02,0.9567D-03,0.9446D-03,0.9250D-03,0.8981D-03,0.8642D-03,
41366 &0.8244D-03,0.7951D-03,0.7821D-03,0.7623D-03,0.7362D-03,0.7043D-03,
41367 &0.6759D-03,0.6640D-03,0.6459D-03,0.6223D-03,0.5945D-03,0.5817D-03,
41368 &0.5660D-03,0.5455D-03,0.5256D-03,0.5132D-03,0.4963D-03,0.4794D-03,
41369 &0.4669D-03,0.4510D-03,0.4394D-03,0.4261D-03,0.4151D-03,0.4031D-03,
41370 &0.3934D-03,0.3838D-03,0.3747D-03,0.3666D-03,0.3591D-03,0.3533D-03,
41371 &0.3477D-03,0.3433D-03,0.3397D-03,0.3376D-03,0.3364D-03,0.3361D-03,
41372 &0.3375D-03,0.3399D-03,0.3437D-03,0.3492D-03,0.3562D-03,0.3648D-03,
41373 &0.3751D-03,0.3871D-03,0.4009D-03,0.4167D-03,0.4344D-03,0.4543D-03,
41374 &0.4760D-03,0.5003D-03,0.5268D-03,0.5558D-03,0.5876D-03,0.6226D-03,
41375 &0.6610D-03,0.7035D-03,0.7509D-03,0.8041D-03,0.8638D-03,0.9294D-03,
41376 &0.9367D-03,0.9440D-03,0.9511D-03,0.9581D-03,0.9648D-03,0.9714D-03,
41377 &0.9776D-03,0.9836D-03,0.9891D-03,0.9942D-03,0.9987D-03,0.1003D-02,
41378 &0.1006D-02,0.1008D-02,0.1008D-02,0.1007D-02,0.1004D-02,0.9977D-03,
41379 &0.9868D-03,0.9681D-03,0.9347D-03,0.8678D-03/
41380 DATA (XPV(I,2,2),I=1,100)/
41381 &0.3175D-02,0.3156D-02,0.3117D-02,0.3057D-02,0.2976D-02,0.2876D-02,
41382 &0.2760D-02,0.2689D-02,0.2666D-02,0.2625D-02,0.2566D-02,0.2489D-02,
41383 &0.2398D-02,0.2316D-02,0.2299D-02,0.2266D-02,0.2217D-02,0.2152D-02,
41384 &0.2073D-02,0.2018D-02,0.1998D-02,0.1962D-02,0.1911D-02,0.1847D-02,
41385 &0.1791D-02,0.1773D-02,0.1739D-02,0.1692D-02,0.1636D-02,0.1614D-02,
41386 &0.1586D-02,0.1545D-02,0.1506D-02,0.1485D-02,0.1452D-02,0.1420D-02,
41387 &0.1398D-02,0.1368D-02,0.1348D-02,0.1324D-02,0.1306D-02,0.1285D-02,
41388 &0.1271D-02,0.1256D-02,0.1243D-02,0.1233D-02,0.1224D-02,0.1220D-02,
41389 &0.1217D-02,0.1217D-02,0.1220D-02,0.1227D-02,0.1237D-02,0.1249D-02,
41390 &0.1267D-02,0.1288D-02,0.1313D-02,0.1345D-02,0.1381D-02,0.1422D-02,
41391 &0.1469D-02,0.1522D-02,0.1582D-02,0.1648D-02,0.1722D-02,0.1804D-02,
41392 &0.1893D-02,0.1992D-02,0.2099D-02,0.2216D-02,0.2345D-02,0.2486D-02,
41393 &0.2641D-02,0.2812D-02,0.3002D-02,0.3216D-02,0.3455D-02,0.3718D-02,
41394 &0.3748D-02,0.3777D-02,0.3806D-02,0.3833D-02,0.3861D-02,0.3887D-02,
41395 &0.3912D-02,0.3936D-02,0.3958D-02,0.3978D-02,0.3996D-02,0.4012D-02,
41396 &0.4024D-02,0.4032D-02,0.4035D-02,0.4031D-02,0.4018D-02,0.3993D-02,
41397 &0.3949D-02,0.3875D-02,0.3741D-02,0.3474D-02/
41398 DATA (XPV(I,2,3),I=1,100)/
41399 &0.1046D-02,0.1031D-02,0.1008D-02,0.9768D-03,0.9381D-03,0.8923D-03,
41400 &0.8410D-03,0.8074D-03,0.7928D-03,0.7720D-03,0.7450D-03,0.7121D-03,
41401 &0.6741D-03,0.6398D-03,0.6287D-03,0.6123D-03,0.5906D-03,0.5640D-03,
41402 &0.5332D-03,0.5101D-03,0.4988D-03,0.4827D-03,0.4624D-03,0.4380D-03,
41403 &0.4161D-03,0.4059D-03,0.3914D-03,0.3732D-03,0.3524D-03,0.3416D-03,
41404 &0.3290D-03,0.3133D-03,0.2981D-03,0.2878D-03,0.2747D-03,0.2616D-03,
41405 &0.2515D-03,0.2392D-03,0.2296D-03,0.2191D-03,0.2100D-03,0.2004D-03,
41406 &0.1923D-03,0.1842D-03,0.1764D-03,0.1694D-03,0.1627D-03,0.1571D-03,
41407 &0.1517D-03,0.1469D-03,0.1427D-03,0.1394D-03,0.1367D-03,0.1345D-03,
41408 &0.1333D-03,0.1327D-03,0.1329D-03,0.1340D-03,0.1360D-03,0.1387D-03,
41409 &0.1424D-03,0.1469D-03,0.1522D-03,0.1584D-03,0.1654D-03,0.1733D-03,
41410 &0.1819D-03,0.1915D-03,0.2019D-03,0.2132D-03,0.2257D-03,0.2396D-03,
41411 &0.2553D-03,0.2737D-03,0.2956D-03,0.3227D-03,0.3570D-03,0.4009D-03,
41412 &0.4064D-03,0.4119D-03,0.4175D-03,0.4231D-03,0.4287D-03,0.4344D-03,
41413 &0.4400D-03,0.4457D-03,0.4512D-03,0.4567D-03,0.4621D-03,0.4673D-03,
41414 &0.4723D-03,0.4769D-03,0.4811D-03,0.4848D-03,0.4875D-03,0.4891D-03,
41415 &0.4888D-03,0.4853D-03,0.4756D-03,0.4518D-03/
41416 DATA (XPV(I,2,4),I=1,100)/
41417 &0.1564D-02,0.1548D-02,0.1521D-02,0.1483D-02,0.1434D-02,0.1375D-02,
41418 &0.1308D-02,0.1265D-02,0.1249D-02,0.1223D-02,0.1188D-02,0.1145D-02,
41419 &0.1094D-02,0.1048D-02,0.1035D-02,0.1015D-02,0.9868D-03,0.9509D-03,
41420 &0.9086D-03,0.8776D-03,0.8644D-03,0.8436D-03,0.8161D-03,0.7822D-03,
41421 &0.7521D-03,0.7400D-03,0.7212D-03,0.6963D-03,0.6669D-03,0.6538D-03,
41422 &0.6377D-03,0.6163D-03,0.5956D-03,0.5832D-03,0.5658D-03,0.5486D-03,
41423 &0.5363D-03,0.5203D-03,0.5091D-03,0.4962D-03,0.4859D-03,0.4746D-03,
41424 &0.4661D-03,0.4578D-03,0.4502D-03,0.4441D-03,0.4387D-03,0.4355D-03,
41425 &0.4329D-03,0.4318D-03,0.4320D-03,0.4342D-03,0.4379D-03,0.4429D-03,
41426 &0.4503D-03,0.4594D-03,0.4704D-03,0.4839D-03,0.4996D-03,0.5177D-03,
41427 &0.5383D-03,0.5613D-03,0.5869D-03,0.6152D-03,0.6462D-03,0.6802D-03,
41428 &0.7167D-03,0.7565D-03,0.7995D-03,0.8461D-03,0.8972D-03,0.9538D-03,
41429 &0.1018D-02,0.1092D-02,0.1181D-02,0.1290D-02,0.1428D-02,0.1604D-02,
41430 &0.1626D-02,0.1649D-02,0.1671D-02,0.1694D-02,0.1716D-02,0.1739D-02,
41431 &0.1762D-02,0.1784D-02,0.1806D-02,0.1828D-02,0.1850D-02,0.1871D-02,
41432 &0.1891D-02,0.1909D-02,0.1926D-02,0.1941D-02,0.1952D-02,0.1958D-02,
41433 &0.1957D-02,0.1943D-02,0.1905D-02,0.1811D-02/
41434 DATA (XPV(I,3,0),I=1,100)/
41435 &0.1761D+00,0.1728D+00,0.1680D+00,0.1619D+00,0.1544D+00,0.1456D+00,
41436 &0.1358D+00,0.1292D+00,0.1260D+00,0.1218D+00,0.1165D+00,0.1101D+00,
41437 &0.1029D+00,0.9643D-01,0.9409D-01,0.9087D-01,0.8680D-01,0.8192D-01,
41438 &0.7638D-01,0.7217D-01,0.7000D-01,0.6708D-01,0.6352D-01,0.5934D-01,
41439 &0.5561D-01,0.5375D-01,0.5129D-01,0.4829D-01,0.4491D-01,0.4309D-01,
41440 &0.4104D-01,0.3857D-01,0.3618D-01,0.3454D-01,0.3252D-01,0.3053D-01,
41441 &0.2896D-01,0.2712D-01,0.2565D-01,0.2407D-01,0.2268D-01,0.2123D-01,
41442 &0.1997D-01,0.1870D-01,0.1748D-01,0.1634D-01,0.1523D-01,0.1422D-01,
41443 &0.1321D-01,0.1227D-01,0.1137D-01,0.1053D-01,0.9723D-02,0.8952D-02,
41444 &0.8241D-02,0.7563D-02,0.6926D-02,0.6345D-02,0.5801D-02,0.5298D-02,
41445 &0.4833D-02,0.4407D-02,0.4017D-02,0.3657D-02,0.3327D-02,0.3021D-02,
41446 &0.2735D-02,0.2469D-02,0.2217D-02,0.1976D-02,0.1746D-02,0.1522D-02,
41447 &0.1307D-02,0.1098D-02,0.8959D-03,0.7002D-03,0.5112D-03,0.3292D-03,
41448 &0.3097D-03,0.2906D-03,0.2718D-03,0.2534D-03,0.2354D-03,0.2178D-03,
41449 &0.2005D-03,0.1836D-03,0.1672D-03,0.1511D-03,0.1354D-03,0.1203D-03,
41450 &0.1055D-03,0.9128D-04,0.7756D-04,0.6440D-04,0.5185D-04,0.3998D-04,
41451 &0.2891D-04,0.1876D-04,0.9776D-05,0.2464D-05/
41452 DATA (XPV(I,3,1),I=1,100)/
41453 &0.3351D-02,0.3297D-02,0.3217D-02,0.3112D-02,0.2981D-02,0.2828D-02,
41454 &0.2656D-02,0.2543D-02,0.2493D-02,0.2422D-02,0.2332D-02,0.2223D-02,
41455 &0.2097D-02,0.1984D-02,0.1946D-02,0.1892D-02,0.1821D-02,0.1734D-02,
41456 &0.1635D-02,0.1560D-02,0.1523D-02,0.1471D-02,0.1406D-02,0.1329D-02,
41457 &0.1260D-02,0.1228D-02,0.1182D-02,0.1126D-02,0.1061D-02,0.1028D-02,
41458 &0.9902D-03,0.9426D-03,0.8967D-03,0.8664D-03,0.8274D-03,0.7890D-03,
41459 &0.7596D-03,0.7240D-03,0.6969D-03,0.6671D-03,0.6417D-03,0.6149D-03,
41460 &0.5928D-03,0.5708D-03,0.5502D-03,0.5317D-03,0.5144D-03,0.5002D-03,
41461 &0.4867D-03,0.4753D-03,0.4655D-03,0.4582D-03,0.4526D-03,0.4487D-03,
41462 &0.4475D-03,0.4480D-03,0.4506D-03,0.4559D-03,0.4632D-03,0.4729D-03,
41463 &0.4849D-03,0.4991D-03,0.5155D-03,0.5343D-03,0.5552D-03,0.5783D-03,
41464 &0.6033D-03,0.6307D-03,0.6600D-03,0.6915D-03,0.7256D-03,0.7626D-03,
41465 &0.8031D-03,0.8482D-03,0.8993D-03,0.9582D-03,0.1026D-02,0.1099D-02,
41466 &0.1107D-02,0.1115D-02,0.1122D-02,0.1129D-02,0.1136D-02,0.1142D-02,
41467 &0.1148D-02,0.1152D-02,0.1156D-02,0.1159D-02,0.1161D-02,0.1161D-02,
41468 &0.1160D-02,0.1156D-02,0.1150D-02,0.1141D-02,0.1127D-02,0.1107D-02,
41469 &0.1078D-02,0.1036D-02,0.9685D-03,0.8413D-03/
41470 DATA (XPV(I,3,2),I=1,100)/
41471 &0.5039D-02,0.4982D-02,0.4889D-02,0.4761D-02,0.4597D-02,0.4401D-02,
41472 &0.4179D-02,0.4036D-02,0.3979D-02,0.3893D-02,0.3777D-02,0.3634D-02,
41473 &0.3466D-02,0.3315D-02,0.3273D-02,0.3206D-02,0.3114D-02,0.2997D-02,
41474 &0.2860D-02,0.2760D-02,0.2717D-02,0.2650D-02,0.2562D-02,0.2454D-02,
41475 &0.2359D-02,0.2321D-02,0.2262D-02,0.2184D-02,0.2092D-02,0.2052D-02,
41476 &0.2003D-02,0.1938D-02,0.1875D-02,0.1839D-02,0.1787D-02,0.1736D-02,
41477 &0.1700D-02,0.1653D-02,0.1622D-02,0.1585D-02,0.1557D-02,0.1526D-02,
41478 &0.1504D-02,0.1483D-02,0.1464D-02,0.1450D-02,0.1438D-02,0.1433D-02,
41479 &0.1430D-02,0.1432D-02,0.1438D-02,0.1450D-02,0.1466D-02,0.1487D-02,
41480 &0.1515D-02,0.1547D-02,0.1585D-02,0.1631D-02,0.1683D-02,0.1742D-02,
41481 &0.1808D-02,0.1880D-02,0.1960D-02,0.2048D-02,0.2142D-02,0.2245D-02,
41482 &0.2354D-02,0.2471D-02,0.2596D-02,0.2729D-02,0.2872D-02,0.3025D-02,
41483 &0.3193D-02,0.3378D-02,0.3587D-02,0.3827D-02,0.4100D-02,0.4397D-02,
41484 &0.4429D-02,0.4461D-02,0.4490D-02,0.4519D-02,0.4545D-02,0.4570D-02,
41485 &0.4592D-02,0.4611D-02,0.4627D-02,0.4639D-02,0.4646D-02,0.4647D-02,
41486 &0.4642D-02,0.4628D-02,0.4604D-02,0.4566D-02,0.4510D-02,0.4431D-02,
41487 &0.4317D-02,0.4147D-02,0.3877D-02,0.3370D-02/
41488 DATA (XPV(I,3,3),I=1,100)/
41489 &0.2958D-02,0.2904D-02,0.2827D-02,0.2727D-02,0.2604D-02,0.2461D-02,
41490 &0.2301D-02,0.2195D-02,0.2146D-02,0.2079D-02,0.1995D-02,0.1894D-02,
41491 &0.1778D-02,0.1674D-02,0.1637D-02,0.1586D-02,0.1520D-02,0.1440D-02,
41492 &0.1349D-02,0.1280D-02,0.1245D-02,0.1197D-02,0.1138D-02,0.1068D-02,
41493 &0.1005D-02,0.9742D-03,0.9325D-03,0.8812D-03,0.8233D-03,0.7922D-03,
41494 &0.7568D-03,0.7138D-03,0.6722D-03,0.6438D-03,0.6084D-03,0.5735D-03,
41495 &0.5460D-03,0.5138D-03,0.4883D-03,0.4609D-03,0.4371D-03,0.4123D-03,
41496 &0.3912D-03,0.3704D-03,0.3507D-03,0.3327D-03,0.3158D-03,0.3012D-03,
41497 &0.2873D-03,0.2751D-03,0.2641D-03,0.2551D-03,0.2474D-03,0.2410D-03,
41498 &0.2365D-03,0.2334D-03,0.2318D-03,0.2321D-03,0.2339D-03,0.2372D-03,
41499 &0.2421D-03,0.2485D-03,0.2562D-03,0.2652D-03,0.2755D-03,0.2870D-03,
41500 &0.2995D-03,0.3131D-03,0.3278D-03,0.3438D-03,0.3615D-03,0.3814D-03,
41501 &0.4046D-03,0.4328D-03,0.4682D-03,0.5142D-03,0.5747D-03,0.6529D-03,
41502 &0.6625D-03,0.6722D-03,0.6819D-03,0.6916D-03,0.7012D-03,0.7107D-03,
41503 &0.7200D-03,0.7292D-03,0.7380D-03,0.7464D-03,0.7544D-03,0.7617D-03,
41504 &0.7681D-03,0.7735D-03,0.7776D-03,0.7798D-03,0.7796D-03,0.7761D-03,
41505 &0.7676D-03,0.7510D-03,0.7195D-03,0.6522D-03/
41506 DATA (XPV(I,3,4),I=1,100)/
41507 &0.3464D-02,0.3410D-02,0.3329D-02,0.3222D-02,0.3090D-02,0.2933D-02,
41508 &0.2758D-02,0.2643D-02,0.2593D-02,0.2521D-02,0.2430D-02,0.2318D-02,
41509 &0.2190D-02,0.2075D-02,0.2037D-02,0.1982D-02,0.1910D-02,0.1821D-02,
41510 &0.1720D-02,0.1643D-02,0.1607D-02,0.1554D-02,0.1489D-02,0.1410D-02,
41511 &0.1340D-02,0.1308D-02,0.1262D-02,0.1205D-02,0.1140D-02,0.1108D-02,
41512 &0.1070D-02,0.1023D-02,0.9772D-03,0.9482D-03,0.9103D-03,0.8732D-03,
41513 &0.8458D-03,0.8121D-03,0.7877D-03,0.7607D-03,0.7388D-03,0.7157D-03,
41514 &0.6981D-03,0.6812D-03,0.6662D-03,0.6540D-03,0.6438D-03,0.6377D-03,
41515 &0.6331D-03,0.6316D-03,0.6326D-03,0.6376D-03,0.6453D-03,0.6560D-03,
41516 &0.6708D-03,0.6887D-03,0.7102D-03,0.7361D-03,0.7656D-03,0.7991D-03,
41517 &0.8365D-03,0.8777D-03,0.9226D-03,0.9714D-03,0.1024D-02,0.1080D-02,
41518 &0.1138D-02,0.1201D-02,0.1267D-02,0.1338D-02,0.1415D-02,0.1501D-02,
41519 &0.1599D-02,0.1717D-02,0.1863D-02,0.2051D-02,0.2296D-02,0.2612D-02,
41520 &0.2650D-02,0.2689D-02,0.2729D-02,0.2767D-02,0.2806D-02,0.2844D-02,
41521 &0.2882D-02,0.2919D-02,0.2954D-02,0.2988D-02,0.3020D-02,0.3049D-02,
41522 &0.3075D-02,0.3097D-02,0.3114D-02,0.3123D-02,0.3122D-02,0.3108D-02,
41523 &0.3074D-02,0.3008D-02,0.2881D-02,0.2614D-02/
41524 DATA (XPV(I,4,0),I=1,100)/
41525 &0.2113D+00,0.2071D+00,0.2012D+00,0.1936D+00,0.1844D+00,0.1736D+00,
41526 &0.1616D+00,0.1536D+00,0.1497D+00,0.1445D+00,0.1380D+00,0.1303D+00,
41527 &0.1215D+00,0.1136D+00,0.1108D+00,0.1069D+00,0.1019D+00,0.9605D-01,
41528 &0.8939D-01,0.8432D-01,0.8171D-01,0.7821D-01,0.7395D-01,0.6897D-01,
41529 &0.6452D-01,0.6231D-01,0.5938D-01,0.5583D-01,0.5185D-01,0.4969D-01,
41530 &0.4728D-01,0.4438D-01,0.4158D-01,0.3967D-01,0.3731D-01,0.3500D-01,
41531 &0.3318D-01,0.3105D-01,0.2936D-01,0.2754D-01,0.2595D-01,0.2429D-01,
41532 &0.2285D-01,0.2141D-01,0.2003D-01,0.1874D-01,0.1749D-01,0.1635D-01,
41533 &0.1523D-01,0.1418D-01,0.1317D-01,0.1223D-01,0.1134D-01,0.1048D-01,
41534 &0.9692D-02,0.8938D-02,0.8227D-02,0.7578D-02,0.6967D-02,0.6398D-02,
41535 &0.5867D-02,0.5377D-02,0.4922D-02,0.4497D-02,0.4101D-02,0.3730D-02,
41536 &0.3379D-02,0.3048D-02,0.2732D-02,0.2429D-02,0.2139D-02,0.1858D-02,
41537 &0.1588D-02,0.1328D-02,0.1077D-02,0.8361D-03,0.6052D-03,0.3850D-03,
41538 &0.3616D-03,0.3387D-03,0.3162D-03,0.2943D-03,0.2728D-03,0.2518D-03,
41539 &0.2314D-03,0.2114D-03,0.1919D-03,0.1731D-03,0.1546D-03,0.1369D-03,
41540 &0.1197D-03,0.1032D-03,0.8729D-04,0.7214D-04,0.5778D-04,0.4429D-04,
41541 &0.3179D-04,0.2044D-04,0.1053D-04,0.2601D-05/
41542 DATA (XPV(I,4,1),I=1,100)/
41543 &0.4299D-02,0.4223D-02,0.4115D-02,0.3974D-02,0.3799D-02,0.3595D-02,
41544 &0.3367D-02,0.3216D-02,0.3148D-02,0.3054D-02,0.2934D-02,0.2790D-02,
41545 &0.2625D-02,0.2476D-02,0.2426D-02,0.2353D-02,0.2260D-02,0.2147D-02,
41546 &0.2018D-02,0.1920D-02,0.1871D-02,0.1804D-02,0.1720D-02,0.1620D-02,
41547 &0.1532D-02,0.1489D-02,0.1431D-02,0.1359D-02,0.1277D-02,0.1234D-02,
41548 &0.1185D-02,0.1125D-02,0.1067D-02,0.1028D-02,0.9791D-03,0.9308D-03,
41549 &0.8936D-03,0.8491D-03,0.8150D-03,0.7777D-03,0.7459D-03,0.7125D-03,
41550 &0.6849D-03,0.6575D-03,0.6318D-03,0.6088D-03,0.5872D-03,0.5693D-03,
41551 &0.5524D-03,0.5380D-03,0.5254D-03,0.5159D-03,0.5084D-03,0.5028D-03,
41552 &0.5003D-03,0.4998D-03,0.5017D-03,0.5066D-03,0.5139D-03,0.5237D-03,
41553 &0.5360D-03,0.5508D-03,0.5679D-03,0.5875D-03,0.6093D-03,0.6334D-03,
41554 &0.6593D-03,0.6876D-03,0.7177D-03,0.7500D-03,0.7848D-03,0.8225D-03,
41555 &0.8639D-03,0.9103D-03,0.9634D-03,0.1025D-02,0.1097D-02,0.1174D-02,
41556 &0.1183D-02,0.1191D-02,0.1199D-02,0.1206D-02,0.1212D-02,0.1219D-02,
41557 &0.1224D-02,0.1229D-02,0.1232D-02,0.1235D-02,0.1236D-02,0.1235D-02,
41558 &0.1232D-02,0.1227D-02,0.1219D-02,0.1207D-02,0.1190D-02,0.1167D-02,
41559 &0.1133D-02,0.1085D-02,0.1009D-02,0.8680D-03/
41560 DATA (XPV(I,4,2),I=1,100)/
41561 &0.5972D-02,0.5895D-02,0.5773D-02,0.5610D-02,0.5402D-02,0.5156D-02,
41562 &0.4878D-02,0.4698D-02,0.4623D-02,0.4513D-02,0.4369D-02,0.4191D-02,
41563 &0.3984D-02,0.3798D-02,0.3743D-02,0.3659D-02,0.3544D-02,0.3402D-02,
41564 &0.3235D-02,0.3113D-02,0.3058D-02,0.2976D-02,0.2870D-02,0.2740D-02,
41565 &0.2626D-02,0.2578D-02,0.2507D-02,0.2414D-02,0.2305D-02,0.2257D-02,
41566 &0.2198D-02,0.2121D-02,0.2046D-02,0.2003D-02,0.1942D-02,0.1882D-02,
41567 &0.1840D-02,0.1786D-02,0.1749D-02,0.1707D-02,0.1674D-02,0.1639D-02,
41568 &0.1613D-02,0.1589D-02,0.1567D-02,0.1551D-02,0.1538D-02,0.1533D-02,
41569 &0.1530D-02,0.1533D-02,0.1540D-02,0.1554D-02,0.1573D-02,0.1597D-02,
41570 &0.1628D-02,0.1665D-02,0.1709D-02,0.1760D-02,0.1818D-02,0.1884D-02,
41571 &0.1957D-02,0.2038D-02,0.2125D-02,0.2221D-02,0.2324D-02,0.2434D-02,
41572 &0.2551D-02,0.2676D-02,0.2807D-02,0.2946D-02,0.3095D-02,0.3254D-02,
41573 &0.3428D-02,0.3621D-02,0.3839D-02,0.4092D-02,0.4382D-02,0.4698D-02,
41574 &0.4731D-02,0.4764D-02,0.4795D-02,0.4824D-02,0.4851D-02,0.4876D-02,
41575 &0.4898D-02,0.4917D-02,0.4931D-02,0.4941D-02,0.4945D-02,0.4943D-02,
41576 &0.4933D-02,0.4913D-02,0.4881D-02,0.4833D-02,0.4766D-02,0.4671D-02,
41577 &0.4538D-02,0.4344D-02,0.4039D-02,0.3475D-02/
41578 DATA (XPV(I,4,3),I=1,100)/
41579 &0.3908D-02,0.3834D-02,0.3728D-02,0.3592D-02,0.3425D-02,0.3231D-02,
41580 &0.3015D-02,0.2871D-02,0.2804D-02,0.2714D-02,0.2600D-02,0.2464D-02,
41581 &0.2309D-02,0.2169D-02,0.2119D-02,0.2050D-02,0.1962D-02,0.1855D-02,
41582 &0.1735D-02,0.1643D-02,0.1596D-02,0.1532D-02,0.1453D-02,0.1361D-02,
41583 &0.1278D-02,0.1237D-02,0.1183D-02,0.1116D-02,0.1040D-02,0.9992D-03,
41584 &0.9531D-03,0.8972D-03,0.8434D-03,0.8065D-03,0.7608D-03,0.7159D-03,
41585 &0.6806D-03,0.6392D-03,0.6067D-03,0.5717D-03,0.5414D-03,0.5098D-03,
41586 &0.4831D-03,0.4567D-03,0.4317D-03,0.4090D-03,0.3877D-03,0.3693D-03,
41587 &0.3517D-03,0.3363D-03,0.3224D-03,0.3109D-03,0.3010D-03,0.2928D-03,
41588 &0.2869D-03,0.2826D-03,0.2801D-03,0.2799D-03,0.2814D-03,0.2848D-03,
41589 &0.2899D-03,0.2967D-03,0.3051D-03,0.3151D-03,0.3263D-03,0.3390D-03,
41590 &0.3528D-03,0.3678D-03,0.3841D-03,0.4018D-03,0.4214D-03,0.4437D-03,
41591 &0.4700D-03,0.5022D-03,0.5431D-03,0.5965D-03,0.6670D-03,0.7574D-03,
41592 &0.7684D-03,0.7795D-03,0.7905D-03,0.8015D-03,0.8124D-03,0.8230D-03,
41593 &0.8335D-03,0.8436D-03,0.8533D-03,0.8624D-03,0.8708D-03,0.8784D-03,
41594 &0.8849D-03,0.8901D-03,0.8934D-03,0.8945D-03,0.8925D-03,0.8863D-03,
41595 &0.8739D-03,0.8517D-03,0.8113D-03,0.7282D-03/
41596 DATA (XPV(I,4,4),I=1,100)/
41597 &0.4411D-02,0.4336D-02,0.4226D-02,0.4084D-02,0.3907D-02,0.3700D-02,
41598 &0.3469D-02,0.3316D-02,0.3248D-02,0.3153D-02,0.3032D-02,0.2886D-02,
41599 &0.2718D-02,0.2567D-02,0.2516D-02,0.2444D-02,0.2349D-02,0.2235D-02,
41600 &0.2103D-02,0.2004D-02,0.1956D-02,0.1888D-02,0.1804D-02,0.1703D-02,
41601 &0.1613D-02,0.1571D-02,0.1514D-02,0.1441D-02,0.1359D-02,0.1317D-02,
41602 &0.1269D-02,0.1210D-02,0.1153D-02,0.1116D-02,0.1069D-02,0.1022D-02,
41603 &0.9882D-03,0.9465D-03,0.9161D-03,0.8828D-03,0.8558D-03,0.8276D-03,
41604 &0.8060D-03,0.7854D-03,0.7672D-03,0.7526D-03,0.7404D-03,0.7330D-03,
41605 &0.7277D-03,0.7261D-03,0.7277D-03,0.7338D-03,0.7434D-03,0.7565D-03,
41606 &0.7745D-03,0.7963D-03,0.8222D-03,0.8532D-03,0.8886D-03,0.9283D-03,
41607 &0.9728D-03,0.1021D-02,0.1074D-02,0.1131D-02,0.1192D-02,0.1257D-02,
41608 &0.1325D-02,0.1397D-02,0.1473D-02,0.1554D-02,0.1642D-02,0.1739D-02,
41609 &0.1852D-02,0.1988D-02,0.2158D-02,0.2377D-02,0.2664D-02,0.3029D-02,
41610 &0.3074D-02,0.3119D-02,0.3163D-02,0.3207D-02,0.3251D-02,0.3294D-02,
41611 &0.3336D-02,0.3377D-02,0.3416D-02,0.3452D-02,0.3486D-02,0.3517D-02,
41612 &0.3543D-02,0.3564D-02,0.3578D-02,0.3582D-02,0.3574D-02,0.3549D-02,
41613 &0.3500D-02,0.3411D-02,0.3249D-02,0.2916D-02/
41614 DATA (XPV(I,5,0),I=1,100)/
41615 &0.3395D+00,0.3321D+00,0.3219D+00,0.3090D+00,0.2933D+00,0.2751D+00,
41616 &0.2550D+00,0.2414D+00,0.2348D+00,0.2261D+00,0.2153D+00,0.2025D+00,
41617 &0.1881D+00,0.1751D+00,0.1704D+00,0.1640D+00,0.1559D+00,0.1464D+00,
41618 &0.1357D+00,0.1276D+00,0.1233D+00,0.1178D+00,0.1110D+00,0.1032D+00,
41619 &0.9616D-01,0.9268D-01,0.8813D-01,0.8262D-01,0.7648D-01,0.7317D-01,
41620 &0.6948D-01,0.6506D-01,0.6083D-01,0.5795D-01,0.5442D-01,0.5097D-01,
41621 &0.4827D-01,0.4513D-01,0.4265D-01,0.4000D-01,0.3769D-01,0.3529D-01,
41622 &0.3322D-01,0.3117D-01,0.2920D-01,0.2737D-01,0.2561D-01,0.2402D-01,
41623 &0.2245D-01,0.2098D-01,0.1958D-01,0.1829D-01,0.1704D-01,0.1585D-01,
41624 &0.1476D-01,0.1370D-01,0.1270D-01,0.1178D-01,0.1090D-01,0.1007D-01,
41625 &0.9286D-02,0.8547D-02,0.7848D-02,0.7182D-02,0.6551D-02,0.5949D-02,
41626 &0.5372D-02,0.4823D-02,0.4298D-02,0.3794D-02,0.3314D-02,0.2852D-02,
41627 &0.2413D-02,0.1995D-02,0.1599D-02,0.1223D-02,0.8693D-03,0.5397D-03,
41628 &0.5052D-03,0.4716D-03,0.4388D-03,0.4068D-03,0.3757D-03,0.3454D-03,
41629 &0.3160D-03,0.2875D-03,0.2599D-03,0.2332D-03,0.2073D-03,0.1825D-03,
41630 &0.1587D-03,0.1359D-03,0.1142D-03,0.9370D-04,0.7445D-04,0.5655D-04,
41631 &0.4018D-04,0.2553D-04,0.1296D-04,0.3149D-05/
41632 DATA (XPV(I,5,1),I=1,100)/
41633 &0.7886D-02,0.7728D-02,0.7505D-02,0.7221D-02,0.6873D-02,0.6469D-02,
41634 &0.6022D-02,0.5723D-02,0.5585D-02,0.5398D-02,0.5164D-02,0.4885D-02,
41635 &0.4568D-02,0.4283D-02,0.4181D-02,0.4041D-02,0.3864D-02,0.3650D-02,
41636 &0.3408D-02,0.3225D-02,0.3131D-02,0.3005D-02,0.2850D-02,0.2668D-02,
41637 &0.2506D-02,0.2427D-02,0.2321D-02,0.2191D-02,0.2045D-02,0.1968D-02,
41638 &0.1880D-02,0.1774D-02,0.1672D-02,0.1604D-02,0.1519D-02,0.1435D-02,
41639 &0.1371D-02,0.1295D-02,0.1236D-02,0.1172D-02,0.1118D-02,0.1062D-02,
41640 &0.1015D-02,0.9690D-03,0.9257D-03,0.8867D-03,0.8503D-03,0.8197D-03,
41641 &0.7906D-03,0.7655D-03,0.7432D-03,0.7255D-03,0.7107D-03,0.6987D-03,
41642 &0.6911D-03,0.6864D-03,0.6850D-03,0.6876D-03,0.6934D-03,0.7025D-03,
41643 &0.7147D-03,0.7300D-03,0.7482D-03,0.7692D-03,0.7926D-03,0.8187D-03,
41644 &0.8465D-03,0.8768D-03,0.9089D-03,0.9431D-03,0.9801D-03,0.1020D-02,
41645 &0.1065D-02,0.1116D-02,0.1177D-02,0.1250D-02,0.1336D-02,0.1431D-02,
41646 &0.1441D-02,0.1451D-02,0.1460D-02,0.1468D-02,0.1476D-02,0.1483D-02,
41647 &0.1489D-02,0.1494D-02,0.1497D-02,0.1499D-02,0.1499D-02,0.1497D-02,
41648 &0.1492D-02,0.1483D-02,0.1471D-02,0.1454D-02,0.1430D-02,0.1398D-02,
41649 &0.1354D-02,0.1291D-02,0.1195D-02,0.1022D-02/
41650 DATA (XPV(I,5,2),I=1,100)/
41651 &0.9523D-02,0.9362D-02,0.9127D-02,0.8821D-02,0.8442D-02,0.7997D-02,
41652 &0.7501D-02,0.7174D-02,0.7029D-02,0.6828D-02,0.6569D-02,0.6258D-02,
41653 &0.5901D-02,0.5579D-02,0.5475D-02,0.5323D-02,0.5125D-02,0.4884D-02,
41654 &0.4606D-02,0.4399D-02,0.4301D-02,0.4162D-02,0.3986D-02,0.3776D-02,
41655 &0.3590D-02,0.3508D-02,0.3391D-02,0.3242D-02,0.3073D-02,0.2992D-02,
41656 &0.2897D-02,0.2777D-02,0.2663D-02,0.2592D-02,0.2499D-02,0.2408D-02,
41657 &0.2344D-02,0.2263D-02,0.2207D-02,0.2144D-02,0.2095D-02,0.2043D-02,
41658 &0.2005D-02,0.1970D-02,0.1939D-02,0.1917D-02,0.1898D-02,0.1891D-02,
41659 &0.1887D-02,0.1891D-02,0.1901D-02,0.1921D-02,0.1948D-02,0.1981D-02,
41660 &0.2025D-02,0.2076D-02,0.2134D-02,0.2204D-02,0.2281D-02,0.2367D-02,
41661 &0.2463D-02,0.2566D-02,0.2678D-02,0.2798D-02,0.2925D-02,0.3060D-02,
41662 &0.3199D-02,0.3347D-02,0.3500D-02,0.3659D-02,0.3827D-02,0.4007D-02,
41663 &0.4203D-02,0.4424D-02,0.4679D-02,0.4981D-02,0.5336D-02,0.5723D-02,
41664 &0.5764D-02,0.5803D-02,0.5840D-02,0.5875D-02,0.5906D-02,0.5934D-02,
41665 &0.5959D-02,0.5978D-02,0.5992D-02,0.6000D-02,0.6000D-02,0.5991D-02,
41666 &0.5971D-02,0.5938D-02,0.5890D-02,0.5821D-02,0.5726D-02,0.5597D-02,
41667 &0.5419D-02,0.5166D-02,0.4781D-02,0.4089D-02/
41668 DATA (XPV(I,5,3),I=1,100)/
41669 &0.7505D-02,0.7347D-02,0.7127D-02,0.6848D-02,0.6508D-02,0.6113D-02,
41670 &0.5677D-02,0.5385D-02,0.5248D-02,0.5065D-02,0.4837D-02,0.4566D-02,
41671 &0.4259D-02,0.3982D-02,0.3881D-02,0.3744D-02,0.3571D-02,0.3365D-02,
41672 &0.3131D-02,0.2953D-02,0.2861D-02,0.2738D-02,0.2589D-02,0.2414D-02,
41673 &0.2257D-02,0.2179D-02,0.2077D-02,0.1952D-02,0.1812D-02,0.1736D-02,
41674 &0.1651D-02,0.1549D-02,0.1451D-02,0.1384D-02,0.1302D-02,0.1222D-02,
41675 &0.1159D-02,0.1086D-02,0.1028D-02,0.9666D-03,0.9136D-03,0.8587D-03,
41676 &0.8123D-03,0.7666D-03,0.7236D-03,0.6846D-03,0.6479D-03,0.6163D-03,
41677 &0.5861D-03,0.5595D-03,0.5354D-03,0.5152D-03,0.4975D-03,0.4824D-03,
41678 &0.4710D-03,0.4620D-03,0.4558D-03,0.4530D-03,0.4527D-03,0.4552D-03,
41679 &0.4601D-03,0.4675D-03,0.4771D-03,0.4889D-03,0.5026D-03,0.5181D-03,
41680 &0.5351D-03,0.5540D-03,0.5746D-03,0.5972D-03,0.6228D-03,0.6525D-03,
41681 &0.6882D-03,0.7329D-03,0.7908D-03,0.8669D-03,0.9668D-03,0.1092D-02,
41682 &0.1106D-02,0.1121D-02,0.1136D-02,0.1150D-02,0.1164D-02,0.1178D-02,
41683 &0.1191D-02,0.1203D-02,0.1214D-02,0.1225D-02,0.1234D-02,0.1242D-02,
41684 &0.1247D-02,0.1250D-02,0.1251D-02,0.1247D-02,0.1239D-02,0.1224D-02,
41685 &0.1199D-02,0.1159D-02,0.1093D-02,0.9633D-03/
41686 DATA (XPV(I,5,4),I=1,100)/
41687 &0.7997D-02,0.7838D-02,0.7615D-02,0.7329D-02,0.6980D-02,0.6573D-02,
41688 &0.6123D-02,0.5823D-02,0.5684D-02,0.5497D-02,0.5261D-02,0.4981D-02,
41689 &0.4662D-02,0.4375D-02,0.4274D-02,0.4134D-02,0.3955D-02,0.3741D-02,
41690 &0.3497D-02,0.3313D-02,0.3221D-02,0.3095D-02,0.2940D-02,0.2758D-02,
41691 &0.2596D-02,0.2518D-02,0.2414D-02,0.2285D-02,0.2140D-02,0.2065D-02,
41692 &0.1981D-02,0.1877D-02,0.1779D-02,0.1715D-02,0.1634D-02,0.1555D-02,
41693 &0.1497D-02,0.1427D-02,0.1376D-02,0.1320D-02,0.1276D-02,0.1229D-02,
41694 &0.1194D-02,0.1161D-02,0.1131D-02,0.1108D-02,0.1089D-02,0.1077D-02,
41695 &0.1069D-02,0.1067D-02,0.1070D-02,0.1080D-02,0.1095D-02,0.1116D-02,
41696 &0.1144D-02,0.1178D-02,0.1218D-02,0.1265D-02,0.1318D-02,0.1378D-02,
41697 &0.1444D-02,0.1516D-02,0.1594D-02,0.1677D-02,0.1764D-02,0.1858D-02,
41698 &0.1954D-02,0.2056D-02,0.2162D-02,0.2275D-02,0.2398D-02,0.2536D-02,
41699 &0.2696D-02,0.2890D-02,0.3134D-02,0.3450D-02,0.3859D-02,0.4365D-02,
41700 &0.4425D-02,0.4485D-02,0.4544D-02,0.4602D-02,0.4658D-02,0.4713D-02,
41701 &0.4765D-02,0.4815D-02,0.4861D-02,0.4903D-02,0.4940D-02,0.4970D-02,
41702 &0.4993D-02,0.5007D-02,0.5008D-02,0.4994D-02,0.4961D-02,0.4900D-02,
41703 &0.4801D-02,0.4642D-02,0.4373D-02,0.3853D-02/
41704 DATA (XPV(I,6,0),I=1,100)/
41705 &0.4823D+00,0.4713D+00,0.4562D+00,0.4371D+00,0.4141D+00,0.3874D+00,
41706 &0.3580D+00,0.3381D+00,0.3284D+00,0.3157D+00,0.3000D+00,0.2816D+00,
41707 &0.2609D+00,0.2422D+00,0.2354D+00,0.2262D+00,0.2147D+00,0.2012D+00,
41708 &0.1860D+00,0.1744D+00,0.1685D+00,0.1606D+00,0.1511D+00,0.1401D+00,
41709 &0.1304D+00,0.1255D+00,0.1192D+00,0.1116D+00,0.1031D+00,0.9852D-01,
41710 &0.9345D-01,0.8740D-01,0.8162D-01,0.7769D-01,0.7289D-01,0.6822D-01,
41711 &0.6457D-01,0.6033D-01,0.5700D-01,0.5343D-01,0.5035D-01,0.4714D-01,
41712 &0.4439D-01,0.4166D-01,0.3905D-01,0.3663D-01,0.3429D-01,0.3219D-01,
41713 &0.3012D-01,0.2819D-01,0.2634D-01,0.2464D-01,0.2300D-01,0.2142D-01,
41714 &0.1997D-01,0.1857D-01,0.1723D-01,0.1600D-01,0.1482D-01,0.1370D-01,
41715 &0.1263D-01,0.1162D-01,0.1065D-01,0.9734D-02,0.8858D-02,0.8020D-02,
41716 &0.7218D-02,0.6455D-02,0.5727D-02,0.5031D-02,0.4372D-02,0.3743D-02,
41717 &0.3148D-02,0.2587D-02,0.2059D-02,0.1563D-02,0.1101D-02,0.6756D-03,
41718 &0.6315D-03,0.5886D-03,0.5468D-03,0.5062D-03,0.4667D-03,0.4284D-03,
41719 &0.3913D-03,0.3553D-03,0.3206D-03,0.2871D-03,0.2547D-03,0.2238D-03,
41720 &0.1942D-03,0.1660D-03,0.1392D-03,0.1139D-03,0.9030D-04,0.6843D-04,
41721 &0.4849D-04,0.3074D-04,0.1557D-04,0.3784D-05/
41722 DATA (XPV(I,6,1),I=1,100)/
41723 &0.1205D-01,0.1178D-01,0.1142D-01,0.1096D-01,0.1041D-01,0.9763D-02,
41724 &0.9053D-02,0.8577D-02,0.8354D-02,0.8057D-02,0.7688D-02,0.7251D-02,
41725 &0.6756D-02,0.6310D-02,0.6149D-02,0.5929D-02,0.5654D-02,0.5325D-02,
41726 &0.4953D-02,0.4670D-02,0.4526D-02,0.4332D-02,0.4097D-02,0.3822D-02,
41727 &0.3577D-02,0.3456D-02,0.3297D-02,0.3102D-02,0.2885D-02,0.2769D-02,
41728 &0.2639D-02,0.2483D-02,0.2333D-02,0.2232D-02,0.2107D-02,0.1985D-02,
41729 &0.1891D-02,0.1781D-02,0.1696D-02,0.1604D-02,0.1526D-02,0.1445D-02,
41730 &0.1377D-02,0.1310D-02,0.1248D-02,0.1192D-02,0.1139D-02,0.1094D-02,
41731 &0.1052D-02,0.1015D-02,0.9816D-03,0.9544D-03,0.9311D-03,0.9114D-03,
41732 &0.8975D-03,0.8872D-03,0.8810D-03,0.8801D-03,0.8830D-03,0.8899D-03,
41733 &0.9007D-03,0.9151D-03,0.9330D-03,0.9541D-03,0.9781D-03,0.1005D-02,
41734 &0.1034D-02,0.1065D-02,0.1099D-02,0.1135D-02,0.1174D-02,0.1217D-02,
41735 &0.1266D-02,0.1323D-02,0.1392D-02,0.1478D-02,0.1581D-02,0.1696D-02,
41736 &0.1708D-02,0.1720D-02,0.1731D-02,0.1741D-02,0.1751D-02,0.1759D-02,
41737 &0.1766D-02,0.1772D-02,0.1776D-02,0.1778D-02,0.1778D-02,0.1775D-02,
41738 &0.1769D-02,0.1759D-02,0.1744D-02,0.1723D-02,0.1695D-02,0.1657D-02,
41739 &0.1604D-02,0.1530D-02,0.1417D-02,0.1218D-02/
41740 DATA (XPV(I,6,2),I=1,100)/
41741 &0.1365D-01,0.1339D-01,0.1302D-01,0.1254D-01,0.1195D-01,0.1127D-01,
41742 &0.1051D-01,0.1001D-01,0.9777D-02,0.9465D-02,0.9073D-02,0.8604D-02,
41743 &0.8069D-02,0.7589D-02,0.7425D-02,0.7195D-02,0.6900D-02,0.6544D-02,
41744 &0.6138D-02,0.5834D-02,0.5686D-02,0.5481D-02,0.5226D-02,0.4925D-02,
41745 &0.4658D-02,0.4536D-02,0.4367D-02,0.4157D-02,0.3918D-02,0.3801D-02,
41746 &0.3667D-02,0.3499D-02,0.3340D-02,0.3241D-02,0.3112D-02,0.2987D-02,
41747 &0.2897D-02,0.2787D-02,0.2709D-02,0.2624D-02,0.2557D-02,0.2487D-02,
41748 &0.2436D-02,0.2387D-02,0.2346D-02,0.2315D-02,0.2290D-02,0.2279D-02,
41749 &0.2273D-02,0.2277D-02,0.2289D-02,0.2313D-02,0.2346D-02,0.2387D-02,
41750 &0.2441D-02,0.2503D-02,0.2575D-02,0.2660D-02,0.2755D-02,0.2859D-02,
41751 &0.2974D-02,0.3099D-02,0.3232D-02,0.3374D-02,0.3523D-02,0.3680D-02,
41752 &0.3841D-02,0.4010D-02,0.4183D-02,0.4363D-02,0.4552D-02,0.4754D-02,
41753 &0.4976D-02,0.5229D-02,0.5526D-02,0.5885D-02,0.6313D-02,0.6782D-02,
41754 &0.6832D-02,0.6879D-02,0.6924D-02,0.6966D-02,0.7004D-02,0.7038D-02,
41755 &0.7067D-02,0.7091D-02,0.7108D-02,0.7117D-02,0.7116D-02,0.7105D-02,
41756 &0.7081D-02,0.7041D-02,0.6982D-02,0.6899D-02,0.6786D-02,0.6631D-02,
41757 &0.6421D-02,0.6123D-02,0.5672D-02,0.4871D-02/
41758 DATA (XPV(I,6,3),I=1,100)/
41759 &0.1167D-01,0.1141D-01,0.1105D-01,0.1060D-01,0.1005D-01,0.9414D-02,
41760 &0.8715D-02,0.8245D-02,0.8024D-02,0.7730D-02,0.7367D-02,0.6937D-02,
41761 &0.6451D-02,0.6013D-02,0.5853D-02,0.5637D-02,0.5366D-02,0.5044D-02,
41762 &0.4680D-02,0.4403D-02,0.4259D-02,0.4069D-02,0.3839D-02,0.3571D-02,
41763 &0.3331D-02,0.3212D-02,0.3055D-02,0.2866D-02,0.2654D-02,0.2540D-02,
41764 &0.2413D-02,0.2260D-02,0.2114D-02,0.2014D-02,0.1892D-02,0.1773D-02,
41765 &0.1680D-02,0.1572D-02,0.1488D-02,0.1398D-02,0.1320D-02,0.1240D-02,
41766 &0.1173D-02,0.1106D-02,0.1044D-02,0.9874D-03,0.9342D-03,0.8881D-03,
41767 &0.8442D-03,0.8052D-03,0.7698D-03,0.7399D-03,0.7134D-03,0.6903D-03,
41768 &0.6722D-03,0.6574D-03,0.6463D-03,0.6397D-03,0.6365D-03,0.6368D-03,
41769 &0.6405D-03,0.6473D-03,0.6570D-03,0.6695D-03,0.6844D-03,0.7019D-03,
41770 &0.7213D-03,0.7431D-03,0.7673D-03,0.7943D-03,0.8253D-03,0.8617D-03,
41771 &0.9063D-03,0.9627D-03,0.1036D-02,0.1133D-02,0.1259D-02,0.1412D-02,
41772 &0.1430D-02,0.1448D-02,0.1465D-02,0.1482D-02,0.1499D-02,0.1514D-02,
41773 &0.1529D-02,0.1543D-02,0.1556D-02,0.1567D-02,0.1576D-02,0.1583D-02,
41774 &0.1587D-02,0.1588D-02,0.1586D-02,0.1578D-02,0.1563D-02,0.1539D-02,
41775 &0.1504D-02,0.1448D-02,0.1358D-02,0.1189D-02/
41776 DATA (XPV(I,6,4),I=1,100)/
41777 &0.1216D-01,0.1189D-01,0.1153D-01,0.1107D-01,0.1051D-01,0.9868D-02,
41778 &0.9154D-02,0.8677D-02,0.8454D-02,0.8157D-02,0.7787D-02,0.7349D-02,
41779 &0.6851D-02,0.6404D-02,0.6244D-02,0.6025D-02,0.5749D-02,0.5420D-02,
41780 &0.5047D-02,0.4764D-02,0.4621D-02,0.4429D-02,0.4195D-02,0.3920D-02,
41781 &0.3677D-02,0.3559D-02,0.3402D-02,0.3211D-02,0.2996D-02,0.2884D-02,
41782 &0.2759D-02,0.2608D-02,0.2463D-02,0.2369D-02,0.2251D-02,0.2138D-02,
41783 &0.2053D-02,0.1952D-02,0.1879D-02,0.1800D-02,0.1736D-02,0.1670D-02,
41784 &0.1619D-02,0.1572D-02,0.1531D-02,0.1498D-02,0.1470D-02,0.1454D-02,
41785 &0.1442D-02,0.1439D-02,0.1442D-02,0.1455D-02,0.1475D-02,0.1502D-02,
41786 &0.1539D-02,0.1584D-02,0.1637D-02,0.1699D-02,0.1769D-02,0.1847D-02,
41787 &0.1934D-02,0.2027D-02,0.2128D-02,0.2235D-02,0.2348D-02,0.2468D-02,
41788 &0.2591D-02,0.2721D-02,0.2857D-02,0.3001D-02,0.3158D-02,0.3333D-02,
41789 &0.3538D-02,0.3788D-02,0.4102D-02,0.4506D-02,0.5022D-02,0.5648D-02,
41790 &0.5720D-02,0.5792D-02,0.5862D-02,0.5931D-02,0.5997D-02,0.6060D-02,
41791 &0.6120D-02,0.6176D-02,0.6226D-02,0.6271D-02,0.6308D-02,0.6337D-02,
41792 &0.6354D-02,0.6359D-02,0.6348D-02,0.6316D-02,0.6257D-02,0.6163D-02,
41793 &0.6019D-02,0.5797D-02,0.5436D-02,0.4755D-02/
41794 DATA (XPV(I,7,0),I=1,100)/
41795 &0.6367D+00,0.6216D+00,0.6010D+00,0.5752D+00,0.5440D+00,0.5081D+00,
41796 &0.4686D+00,0.4418D+00,0.4287D+00,0.4116D+00,0.3907D+00,0.3662D+00,
41797 &0.3385D+00,0.3137D+00,0.3045D+00,0.2923D+00,0.2772D+00,0.2594D+00,
41798 &0.2393D+00,0.2241D+00,0.2163D+00,0.2060D+00,0.1936D+00,0.1792D+00,
41799 &0.1665D+00,0.1602D+00,0.1520D+00,0.1421D+00,0.1311D+00,0.1252D+00,
41800 &0.1187D+00,0.1109D+00,0.1035D+00,0.9842D-01,0.9228D-01,0.8630D-01,
41801 &0.8164D-01,0.7624D-01,0.7200D-01,0.6747D-01,0.6355D-01,0.5948D-01,
41802 &0.5601D-01,0.5255D-01,0.4926D-01,0.4620D-01,0.4326D-01,0.4061D-01,
41803 &0.3801D-01,0.3557D-01,0.3324D-01,0.3109D-01,0.2903D-01,0.2705D-01,
41804 &0.2521D-01,0.2344D-01,0.2175D-01,0.2018D-01,0.1868D-01,0.1725D-01,
41805 &0.1589D-01,0.1460D-01,0.1337D-01,0.1219D-01,0.1107D-01,0.9999D-02,
41806 &0.8975D-02,0.8003D-02,0.7079D-02,0.6199D-02,0.5369D-02,0.4581D-02,
41807 &0.3839D-02,0.3144D-02,0.2492D-02,0.1883D-02,0.1320D-02,0.8054D-03,
41808 &0.7523D-03,0.7006D-03,0.6504D-03,0.6016D-03,0.5543D-03,0.5084D-03,
41809 &0.4640D-03,0.4210D-03,0.3796D-03,0.3397D-03,0.3011D-03,0.2644D-03,
41810 &0.2292D-03,0.1957D-03,0.1640D-03,0.1342D-03,0.1063D-03,0.8046D-04,
41811 &0.5699D-04,0.3611D-04,0.1829D-04,0.4453D-05/
41812 DATA (XPV(I,7,1),I=1,100)/
41813 &0.1667D-01,0.1629D-01,0.1577D-01,0.1511D-01,0.1431D-01,0.1340D-01,
41814 &0.1239D-01,0.1171D-01,0.1139D-01,0.1097D-01,0.1045D-01,0.9835D-02,
41815 &0.9139D-02,0.8514D-02,0.8286D-02,0.7979D-02,0.7594D-02,0.7137D-02,
41816 &0.6621D-02,0.6230D-02,0.6029D-02,0.5762D-02,0.5438D-02,0.5061D-02,
41817 &0.4726D-02,0.4560D-02,0.4342D-02,0.4078D-02,0.3784D-02,0.3626D-02,
41818 &0.3451D-02,0.3240D-02,0.3038D-02,0.2902D-02,0.2735D-02,0.2572D-02,
41819 &0.2446D-02,0.2299D-02,0.2185D-02,0.2064D-02,0.1960D-02,0.1852D-02,
41820 &0.1762D-02,0.1673D-02,0.1591D-02,0.1516D-02,0.1446D-02,0.1386D-02,
41821 &0.1329D-02,0.1278D-02,0.1233D-02,0.1195D-02,0.1162D-02,0.1134D-02,
41822 &0.1113D-02,0.1096D-02,0.1084D-02,0.1078D-02,0.1077D-02,0.1081D-02,
41823 &0.1090D-02,0.1103D-02,0.1119D-02,0.1140D-02,0.1164D-02,0.1191D-02,
41824 &0.1220D-02,0.1253D-02,0.1288D-02,0.1325D-02,0.1367D-02,0.1413D-02,
41825 &0.1466D-02,0.1530D-02,0.1609D-02,0.1708D-02,0.1830D-02,0.1967D-02,
41826 &0.1981D-02,0.1995D-02,0.2008D-02,0.2021D-02,0.2032D-02,0.2042D-02,
41827 &0.2051D-02,0.2058D-02,0.2063D-02,0.2066D-02,0.2066D-02,0.2063D-02,
41828 &0.2057D-02,0.2045D-02,0.2029D-02,0.2005D-02,0.1973D-02,0.1929D-02,
41829 &0.1869D-02,0.1784D-02,0.1655D-02,0.1427D-02/
41830 DATA (XPV(I,7,2),I=1,100)/
41831 &0.1825D-01,0.1787D-01,0.1734D-01,0.1666D-01,0.1584D-01,0.1488D-01,
41832 &0.1382D-01,0.1312D-01,0.1280D-01,0.1236D-01,0.1182D-01,0.1117D-01,
41833 &0.1044D-01,0.9780D-02,0.9550D-02,0.9233D-02,0.8830D-02,0.8348D-02,
41834 &0.7799D-02,0.7387D-02,0.7184D-02,0.6906D-02,0.6565D-02,0.6163D-02,
41835 &0.5808D-02,0.5642D-02,0.5418D-02,0.5140D-02,0.4827D-02,0.4670D-02,
41836 &0.4493D-02,0.4274D-02,0.4067D-02,0.3936D-02,0.3769D-02,0.3607D-02,
41837 &0.3489D-02,0.3347D-02,0.3246D-02,0.3136D-02,0.3050D-02,0.2959D-02,
41838 &0.2893D-02,0.2830D-02,0.2777D-02,0.2736D-02,0.2703D-02,0.2687D-02,
41839 &0.2678D-02,0.2680D-02,0.2693D-02,0.2720D-02,0.2757D-02,0.2805D-02,
41840 &0.2867D-02,0.2940D-02,0.3024D-02,0.3123D-02,0.3233D-02,0.3355D-02,
41841 &0.3489D-02,0.3632D-02,0.3785D-02,0.3948D-02,0.4118D-02,0.4297D-02,
41842 &0.4479D-02,0.4668D-02,0.4863D-02,0.5063D-02,0.5274D-02,0.5499D-02,
41843 &0.5750D-02,0.6038D-02,0.6381D-02,0.6800D-02,0.7306D-02,0.7864D-02,
41844 &0.7924D-02,0.7980D-02,0.8034D-02,0.8085D-02,0.8131D-02,0.8172D-02,
41845 &0.8208D-02,0.8236D-02,0.8258D-02,0.8270D-02,0.8271D-02,0.8259D-02,
41846 &0.8233D-02,0.8188D-02,0.8122D-02,0.8027D-02,0.7897D-02,0.7721D-02,
41847 &0.7480D-02,0.7139D-02,0.6624D-02,0.5709D-02/
41848 DATA (XPV(I,7,3),I=1,100)/
41849 &0.1630D-01,0.1592D-01,0.1540D-01,0.1475D-01,0.1396D-01,0.1305D-01,
41850 &0.1205D-01,0.1138D-01,0.1107D-01,0.1065D-01,0.1013D-01,0.9526D-02,
41851 &0.8839D-02,0.8222D-02,0.7995D-02,0.7690D-02,0.7310D-02,0.6860D-02,
41852 &0.6352D-02,0.5966D-02,0.5766D-02,0.5502D-02,0.5183D-02,0.4813D-02,
41853 &0.4483D-02,0.4318D-02,0.4103D-02,0.3844D-02,0.3555D-02,0.3399D-02,
41854 &0.3225D-02,0.3018D-02,0.2820D-02,0.2685D-02,0.2521D-02,0.2360D-02,
41855 &0.2235D-02,0.2091D-02,0.1978D-02,0.1857D-02,0.1754D-02,0.1647D-02,
41856 &0.1557D-02,0.1468D-02,0.1385D-02,0.1310D-02,0.1239D-02,0.1177D-02,
41857 &0.1118D-02,0.1066D-02,0.1018D-02,0.9774D-03,0.9411D-03,0.9091D-03,
41858 &0.8835D-03,0.8619D-03,0.8450D-03,0.8338D-03,0.8268D-03,0.8242D-03,
41859 &0.8257D-03,0.8312D-03,0.8403D-03,0.8529D-03,0.8686D-03,0.8875D-03,
41860 &0.9087D-03,0.9331D-03,0.9605D-03,0.9915D-03,0.1028D-02,0.1070D-02,
41861 &0.1124D-02,0.1191D-02,0.1279D-02,0.1395D-02,0.1545D-02,0.1725D-02,
41862 &0.1746D-02,0.1766D-02,0.1786D-02,0.1805D-02,0.1823D-02,0.1841D-02,
41863 &0.1857D-02,0.1872D-02,0.1886D-02,0.1897D-02,0.1907D-02,0.1913D-02,
41864 &0.1916D-02,0.1915D-02,0.1909D-02,0.1897D-02,0.1877D-02,0.1846D-02,
41865 &0.1799D-02,0.1729D-02,0.1618D-02,0.1411D-02/
41866 DATA (XPV(I,7,4),I=1,100)/
41867 &0.1678D-01,0.1640D-01,0.1587D-01,0.1522D-01,0.1442D-01,0.1350D-01,
41868 &0.1249D-01,0.1181D-01,0.1149D-01,0.1107D-01,0.1055D-01,0.9935D-02,
41869 &0.9238D-02,0.8611D-02,0.8385D-02,0.8078D-02,0.7694D-02,0.7237D-02,
41870 &0.6721D-02,0.6331D-02,0.6132D-02,0.5867D-02,0.5545D-02,0.5170D-02,
41871 &0.4837D-02,0.4676D-02,0.4462D-02,0.4202D-02,0.3912D-02,0.3761D-02,
41872 &0.3592D-02,0.3388D-02,0.3194D-02,0.3068D-02,0.2911D-02,0.2759D-02,
41873 &0.2646D-02,0.2513D-02,0.2415D-02,0.2310D-02,0.2226D-02,0.2139D-02,
41874 &0.2072D-02,0.2010D-02,0.1955D-02,0.1911D-02,0.1875D-02,0.1852D-02,
41875 &0.1836D-02,0.1830D-02,0.1833D-02,0.1848D-02,0.1872D-02,0.1905D-02,
41876 &0.1950D-02,0.2004D-02,0.2069D-02,0.2145D-02,0.2231D-02,0.2327D-02,
41877 &0.2432D-02,0.2547D-02,0.2669D-02,0.2800D-02,0.2937D-02,0.3082D-02,
41878 &0.3232D-02,0.3389D-02,0.3553D-02,0.3727D-02,0.3917D-02,0.4130D-02,
41879 &0.4378D-02,0.4681D-02,0.5061D-02,0.5547D-02,0.6163D-02,0.6897D-02,
41880 &0.6981D-02,0.7063D-02,0.7144D-02,0.7221D-02,0.7296D-02,0.7367D-02,
41881 &0.7433D-02,0.7494D-02,0.7548D-02,0.7595D-02,0.7632D-02,0.7658D-02,
41882 &0.7671D-02,0.7667D-02,0.7644D-02,0.7595D-02,0.7513D-02,0.7388D-02,
41883 &0.7203D-02,0.6923D-02,0.6476D-02,0.5646D-02/
41890 ENT(I)=LOG10(XT(I))
41895 ENT(IX+I)=LOG10(Q2T(I))
41899 C..various flavours (u-->2,d-->1)
41900 XPDF(0)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,0))
41901 XPDF(1)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,1))
41902 XPDF(2)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,2))
41903 XPDF(3)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,3))
41904 XPDF(4)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,4))
41911 *$ CREATE PHO_DBFINT.FOR
41913 CDECK ID>, PHO_DBFINT
41914 DOUBLE PRECISION FUNCTION PHO_DBFINT(NARG,ARG,NA,ENT,TABLE)
41915 C***********************************************************************
41917 C routine based on CERN library E104
41919 C multi-dimensional interpolation routine, needed for PHOJET
41920 C internal cross section tables and several PDF sets (GRV98 and AGL)
41922 C changed to avoid recursive function calls (R.Engel, 09/98)
41924 C***********************************************************************
41925 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
41928 INTEGER NA(NARG), INDEX(32)
41929 DOUBLE PRECISION ARG(NARG),ENT(NARG),TABLE(*),WEIGHT(32)
41936 IF(NARG .LT. 1 .OR. NARG .GT. 5) RETURN
41949 IF(NDIM .GT. 2) GOTO 10
41950 IF(NDIM .EQ. 1) GOTO 100
41952 IF(H .EQ. ZEROD) GOTO 90
41954 IF(X-ENT(LMIN+1) .EQ. ZEROD) GOTO 21
41956 ETA = H / (ENT(LMIN+1) - ENT(LMIN))
41959 11 LOCC = (LOCA+LOCB) / 2
41960 IF(X-ENT(LOCC)) 12, 20, 13
41964 14 IF(LOCB-LOCA .GT. 1) GOTO 11
41965 LOCA = MIN ( MAX (LOCA,LMIN), LMAX-1 )
41966 ISHIFT = (LOCA - LMIN) * ISTEP
41967 ETA = (X - ENT(LOCA)) / (ENT(LOCA+1) - ENT(LOCA))
41969 20 ISHIFT = (LOCC - LMIN) * ISTEP
41970 21 DO 22 K = 1, KNOTS
41971 INDEX(K) = INDEX(K) + ISHIFT
41974 30 DO 31 K = 1, KNOTS
41975 INDEX(K) = INDEX(K) + ISHIFT
41976 INDEX(K+KNOTS) = INDEX(K) + ISTEP
41977 WEIGHT(K+KNOTS) = WEIGHT(K) * ETA
41978 WEIGHT(K) = WEIGHT(K) - WEIGHT(K+KNOTS)
41981 90 ISTEP = ISTEP * NDIM
41983 DO 200 K = 1, KNOTS
41985 DBFINT = DBFINT + WEIGHT(K) * TABLE(I)
41988 PHO_DBFINT = DBFINT
41992 *$ CREATE PHVAL.FOR
41995 SUBROUTINE PHVAL(IGRP,ISET,XI,SCALE2,PD,IRET)
41996 C**********************************************************************
41998 C dummy subroutine, remove to link PHOLIB
42000 C**********************************************************************
42001 IMPLICIT DOUBLE PRECISION (A-H,O-Z)