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),
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 C model switches and parameters
11841 INTEGER ISWMDL,IPAMDL
11842 DOUBLE PRECISION PARMDL
11843 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11844 C table of particle indices for recursive PHOJET calls
11846 PARAMETER ( MAXIPX = 100 )
11847 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
11848 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
11849 & IPOIX1,IPOIX2,IPOIX3
11850 C general process information
11851 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
11852 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
11853 C global event kinematics and particle IDs
11854 INTEGER IFPAP,IFPAB
11855 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
11856 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
11858 INTEGER IPFIL,IFAFIL,IFBFIL
11859 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
11860 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
11861 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
11862 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
11863 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
11864 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
11865 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
11866 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
11867 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
11868 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
11869 & IPFIL,IFAFIL,IFBFIL
11870 C event weights and generated cross section
11871 INTEGER IPOWGC,ISWCUT,IVWGHT
11872 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
11873 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
11874 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
11875 C internal rejection counters
11877 PARAMETER (NMXJ=60)
11878 CHARACTER*10 REJTIT
11880 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
11883 C clear event statistics
11897 C-------------------------------------------------------------------
11898 C nondiffractive resolved processes
11900 IF(IPROC.EQ.1) THEN
11901 C sample number of interactions
11905 C generate only hard events
11906 IF(ISWMDL(2).EQ.0) THEN
11913 C minimum bias events
11916 CALL PHO_SAMPRB(ECM,IP,IINT,JINT,KINT)
11917 IPOWGC(1) = IPOWGC(1)+1
11923 C resolved soft processes: pomeron and reggeon
11926 C resolved hard process: hard pomeron
11928 C resolved absorptive corrections
11931 C restrictions given by user
11932 IF(MSPOM.LT.ISWCUT(1)) GOTO 10
11933 IF(MSREG.LT.ISWCUT(2)) GOTO 10
11934 IF(MHPOM.LT.ISWCUT(3)) GOTO 10
11935 HSWGHT(1) = 1.D0/DBLE(IPOWGC(1))
11936 C ----------------------------
11937 IF(ISWMDL(15).EQ.0) THEN
11939 IF(MSREG.GT.0) THEN
11946 ELSE IF(ISWMDL(15).EQ.1) THEN
11947 IF(MHPOM.GT.0) THEN
11951 ELSE IF(MSPOM.GT.0) THEN
11957 ELSE IF(ISWMDL(15).EQ.2) THEN
11958 MHPOM = MIN(1,MHPOM)
11959 ELSE IF(ISWMDL(15).EQ.3) THEN
11960 MSPOM = MIN(1,MSPOM)
11963 C ----------------------------
11972 IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,I7,6I4)')
11973 & 'PHO_PARTON: EV,SP,SR,HP,HD,ET,EL',
11974 & KEVENT,MSPOM,MSREG,MHPOM,MHDIR,MPTRI,MPLOO
11979 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
11987 CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
11989 IF(IREJ.EQ.50) RETURN
11990 IF(IDEB(3).GE.2) THEN
11991 WRITE(LO,'(/1X,A,I5)')
11992 & 'PHO_PARTON: rejection by PHO_STDPAR ',ITRY2
11993 CALL PHO_PREVNT(-1)
11997 IF(MHPOM.GT.0) THEN
11999 ELSE IF(MSPOM.GT.0) THEN
12004 C check of quantum numbers of parton configurations
12005 IF(IDEB(3).GE.0) THEN
12006 CALL PHO_CHECK(1,IREJ)
12007 IF(IREJ.NE.0) GOTO 50
12009 C sample strings to prepare fragmentation
12010 CALL PHO_STRING(1,IREJ)
12012 IF(IREJ.EQ.50) RETURN
12013 IFAIL(30) = IFAIL(30)+1
12014 IF(IDEB(3).GE.2) THEN
12015 WRITE(LO,'(/1X,A,I5)')
12016 & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
12017 CALL PHO_PREVNT(-1)
12019 IF(ITRY2.LT.20) GOTO 50
12020 IF(IDEB(3).GE.1) THEN
12021 WRITE(LO,'(/1X,A,I5)')
12022 & 'PHO_PARTON: rejection',ITRY2
12023 CALL PHO_PREVNT(-1)
12035 C-------------------------------------------------------------------
12036 C elastic scattering / quasi-elastic rho/omega/phi production
12038 ELSE IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
12039 IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,I4)')
12040 & 'PHO_PARTON: ela./q-ela.sca:(EV,IPROC)',KEVENT,IPROC
12042 C DPMJET call with special projectile / target: transform into CMS
12043 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12044 & CALL PHO_DFWRAP(1,JM1,JM2)
12046 CALL PHO_QELAST(IPROC,JM1,JM2,IREJ)
12049 C DPMJET call with special projectile / target: clean up
12050 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12051 & CALL PHO_DFWRAP(-2,JM1,JM2)
12052 IF(IDEB(3).GE.2) THEN
12053 WRITE(LO,'(/1X,A,I5)')
12054 & 'PHO_PARTON: rejection by PHO_QELAST',IREJ
12055 CALL PHO_PREVNT(-1)
12060 C DPMJET call with special projectile / target: transform back
12061 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12062 & CALL PHO_DFWRAP(2,JM1,JM2)
12064 C prepare possible decays
12065 CALL PHO_STRING(1,IREJ)
12067 IF(IREJ.EQ.50) RETURN
12068 IFAIL(30) = IFAIL(30)+1
12072 C---------------------------------------------------------------------
12073 C double Pomeron scattering
12075 ELSE IF(IPROC.EQ.4) THEN
12078 IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10)')
12079 & 'PHO_PARTON: EV,double-pomeron scattering',KEVENT
12084 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12086 CALL PHO_CDIFF(JM1,JM2,MSOFT,MHARD,1,IREJ)
12088 IF(IDEB(3).GE.2) THEN
12089 WRITE(LO,'(/1X,A,I5)')
12090 & 'PHO_PARTON: rejection by PHO_CDIFF',IREJ
12091 CALL PHO_PREVNT(-1)
12095 C check of quantum numbers of parton configurations
12096 IF(IDEB(3).GE.0) THEN
12097 CALL PHO_CHECK(1,IREJ)
12098 IF(IREJ.NE.0) GOTO 60
12100 C sample strings to prepare fragmentation
12101 CALL PHO_STRING(1,IREJ)
12103 IF(IREJ.EQ.50) RETURN
12104 IFAIL(30) = IFAIL(30)+1
12105 IF(IDEB(3).GE.2) THEN
12106 WRITE(LO,'(/1X,A,I5)')
12107 & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
12108 CALL PHO_PREVNT(-1)
12110 IF(ITRY2.LT.10) GOTO 60
12111 WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
12112 CALL PHO_PREVNT(-1)
12117 C-----------------------------------------------------------------------
12118 C single / double diffraction dissociation
12120 ELSE IF((IPROC.GE.5).AND.(IPROC.LE.7)) THEN
12123 IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,2I4)')
12124 & 'PHO_PARTON: EV,diffraction',KEVENT,IPAR1,IPAR2
12125 IF(IPROC.EQ.5) ID1S = ID1S+1
12126 IF(IPROC.EQ.6) ID2S = ID2S+1
12127 IF(IPROC.EQ.7) ID3S = ID3S+1
12131 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12134 IF(IPROC.EQ.5) IPAR2 = 0
12135 IF(IPROC.EQ.6) IPAR1 = 0
12136 C calculate rapidity gap survival probability
12138 IF(ECM.GT.10.D0) THEN
12139 IF((IPAR1.GE.1).AND.(IPAR2.EQ.0)) THEN
12140 IF(SIGTR1(1).LT.1.D-10) THEN
12143 SPROB = SIGHSD(1)/(SIGTR1(1)-2.D0*(SIGDPO(1)+SIGDPO(2)))
12145 ELSE IF((IPAR1.EQ.0).AND.(IPAR2.GE.1)) THEN
12146 IF(SIGTR2(1).LT.1.D-10) THEN
12149 SPROB = SIGHSD(2)/(SIGTR2(1)-2.D0*(SIGDPO(1)+SIGDPO(3)))
12151 ELSE IF((IPAR1.GE.1).AND.(IPAR2.GE.1)) THEN
12152 IF(SIGLOO.LT.1.D-10) THEN
12155 SPROB = SIGHDD/SIGLOO
12160 * temporary patch, r.e. 8.6.99
12164 C DPMJET call with special projectile / target: transform into CMS
12165 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12166 & CALL PHO_DFWRAP(1,JM1,JM2)
12168 CALL PHO_DIFDIS(IPAR1,IPAR2,JM1,JM2,SPROB,0,MSOFT,MHARD,IREJ)
12171 C DPMJET call with special projectile / target: clean up
12172 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12173 & CALL PHO_DFWRAP(-2,JM1,JM2)
12174 IF(IDEB(3).GE.2) THEN
12175 WRITE(LO,'(/1X,A,I5)')
12176 & 'PHO_PARTON: rejection by PHO_DIFDIS',IREJ
12177 CALL PHO_PREVNT(-1)
12182 C DPMJET call with special projectile / target: transform back
12183 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12184 & CALL PHO_DFWRAP(2,JM1,JM2)
12186 C check of quantum numbers of parton configurations
12187 IF(IDEB(3).GE.0) THEN
12188 CALL PHO_CHECK(1,IREJ)
12189 IF(IREJ.NE.0) GOTO 70
12191 C sample strings to prepare fragmentation
12192 CALL PHO_STRING(1,IREJ)
12194 IF(IREJ.EQ.50) RETURN
12195 IFAIL(30) = IFAIL(30)+1
12196 IF(IDEB(3).GE.2) THEN
12197 WRITE(LO,'(/1X,A,I5)')
12198 & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
12199 CALL PHO_PREVNT(-1)
12201 IF(ITRY2.LT.10) GOTO 70
12202 WRITE(LO,'(/1X,A,I5)')
12203 & 'PHO_PARTON: rejection',ITRY2
12204 CALL PHO_PREVNT(-1)
12207 IF(IPROC.EQ.5) ID1A = ID1A+1
12208 IF(IPROC.EQ.6) ID2A = ID2A+1
12209 IF(IPROC.EQ.7) ID3A = ID3A+1
12211 C-----------------------------------------------------------------------
12212 C single / double direct processes
12214 ELSE IF(IPROC.EQ.8) THEN
12219 IF(IDEB(3).GE.5) THEN
12220 WRITE(LO,'(1X,A,I10)') 'PHO_PARTON: EV,direct proc',KEVENT
12226 IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12232 CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
12234 IF(IREJ.EQ.50) RETURN
12235 IF(IDEB(3).GE.2) THEN
12236 WRITE(LO,'(/1X,A,I5)')
12237 & 'PHO_PARTON: rejection by PHO_STDPAR',ITRY2
12238 CALL PHO_PREVNT(-1)
12243 C check of quantum numbers of parton configurations
12244 IF(IDEB(3).GE.0) THEN
12245 CALL PHO_CHECK(1,IREJ)
12246 IF(IREJ.NE.0) GOTO 80
12248 C sample strings to prepare fragmentation
12249 CALL PHO_STRING(1,IREJ)
12251 IF(IREJ.EQ.50) RETURN
12252 IFAIL(30) = IFAIL(30)+1
12253 IF(IDEB(3).GE.2) THEN
12254 WRITE(LO,'(/1X,A,I5)')
12255 & 'PHO_PARTON: rejection by PHO_STRING',ITRY2
12256 CALL PHO_PREVNT(-1)
12258 IF(ITRY2.LT.10) GOTO 80
12259 WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
12260 CALL PHO_PREVNT(-1)
12263 IF(IPROC.EQ.5) ID1A = ID1A+1
12264 IF(IPROC.EQ.6) ID2A = ID2A+1
12265 IF(IPROC.EQ.7) ID3A = ID3A+1
12268 C-----------------------------------------------------------------------
12269 C initialize control statistics
12271 ELSE IF(IPROC.EQ.-1) THEN
12272 CALL PHO_SAMPRB(ECM,-1,0,0,0)
12273 CALL PHO_STDPAR(-1,0,0,0,0,0,0,IREJ)
12274 CALL PHO_SEAFLA(-1,0,0,DUM)
12275 IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
12276 & CALL PHO_QELAST(-1,1,2,0)
12297 CALL PHO_STRING(-1,IREJ)
12298 CALL PHO_DIFDIS(0,0,0,0,0.D0,-1,0,0,IREJ)
12301 C-----------------------------------------------------------------------
12302 C produce statistics summary
12304 ELSE IF(IPROC.EQ.-2) THEN
12305 IF(ISWMDL(2).NE.0) CALL PHO_SAMPRB(ECM,-2,0,0,0)
12306 IF(IDEB(3).GE.0) THEN
12307 WRITE(LO,'(/1X,A,/1X,A)')
12308 & 'PHO_PARTON: internal statistics on parton configurations',
12309 & '--------------------------------------------------------'
12310 WRITE(LO,'(5X,A)') 'process sampled accepted'
12311 WRITE(LO,'(5X,A,2I12)') 'soft pom.',ISPS,ISPA
12312 WRITE(LO,'(5X,A,2I12)') 'hard pom.',IHPS,IHPA
12313 WRITE(LO,'(5X,A,2I12)') 'soft reg.',ISRS,ISRA
12314 WRITE(LO,'(5X,A,2I12)') 'enh. tri.',ISTS,ISTA
12315 WRITE(LO,'(5X,A,2I12)') 'enh. loo.',ISLS,ISLA
12316 WRITE(LO,'(5X,A,2I12)') 'diff.pa1.',ID1S,ID1A
12317 WRITE(LO,'(5X,A,2I12)') 'diff.pa2.',ID2S,ID2A
12318 WRITE(LO,'(5X,A,2I12)') 'doub.dif.',ID3S,ID3A
12319 WRITE(LO,'(5X,A,2I12)') 'doub.pom.',IDPS,IDPA
12320 WRITE(LO,'(5X,A,2I12/)') 'dir.phot.',IDIS,IDIA
12322 CALL PHO_STDPAR(-2,0,0,0,0,0,0,IREJ)
12323 IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
12324 & CALL PHO_QELAST(-2,1,2,0)
12325 CALL PHO_STRING(-2,IREJ)
12326 CALL PHO_DIFDIS(0,0,0,0,0.D0,-2,0,0,IREJ)
12327 CALL PHO_SEAFLA(-2,0,0,DUM)
12330 WRITE(LO,'(1X,A,I2)')
12331 & 'PARTON:ERROR: unknown process ID ',IPROC
12337 *$ CREATE PHO_MCINI.FOR
12339 CDECK ID>, PHO_MCINI
12340 SUBROUTINE PHO_MCINI
12341 C********************************************************************
12343 C initialization of MC event generation
12345 C********************************************************************
12346 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12349 PARAMETER ( PIMASS = 0.13D0,
12352 C input/output channels
12354 COMMON /POINOU/ LI,LO
12355 C event debugging information
12357 PARAMETER (NMAXD=100)
12358 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12359 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12360 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12361 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12362 C model switches and parameters
12364 INTEGER ISWMDL,IPAMDL
12365 DOUBLE PRECISION PARMDL
12366 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
12367 C general process information
12368 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
12369 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
12371 INTEGER IPFIL,IFAFIL,IFBFIL
12372 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
12373 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
12374 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
12375 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
12376 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
12377 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
12378 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
12379 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
12380 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
12381 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
12382 & IPFIL,IFAFIL,IFBFIL
12383 C hard cross sections and MC selection weights
12385 PARAMETER ( Max_pro_2 = 16 )
12386 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
12387 & MH_acc_1,MH_acc_2
12388 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
12389 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
12390 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
12391 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
12392 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
12393 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
12394 C interpolation tables for hard cross section and MC selection weights
12395 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
12396 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
12397 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
12398 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
12399 & HQ2a_tab,HQ2b_tab,HEcm_tab
12401 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12402 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12403 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12404 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12405 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
12406 & HEcm_tab(1:Max_tab_E,0:4),
12407 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
12408 C global event kinematics and particle IDs
12409 INTEGER IFPAP,IFPAB
12410 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
12411 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
12412 C obsolete cut-off information
12413 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
12414 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
12415 C event weights and generated cross section
12416 INTEGER IPOWGC,ISWCUT,IVWGHT
12417 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
12418 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
12419 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
12420 C cut probability distribution
12421 INTEGER IEETA1,IIMAX,KKMAX
12422 PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
12423 INTEGER IEEMAX,IMAX,KMAX
12425 DOUBLE PRECISION EPTAB
12426 COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
12428 C energy-interpolation table
12430 PARAMETER ( IEETA2 = 20 )
12432 DOUBLE PRECISION SIGTAB,SIGECM
12433 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
12435 CHARACTER*15 PHO_PNAME
12438 DATA XMPOM / 0.766D0 /
12440 C initialize fragmentation
12441 CALL PHO_FRAINI(ISWMDL(6))
12443 C reset interpolation tables
12447 SIGTAB(I,K,J) = 0.D0
12453 C max. number of allowed colors (large N expansion)
12456 CALL PHO_SELCOL(IC1,IC2,0,0,0,0,-1)
12458 C lower energy limit of initialization
12459 ETABLO = PARMDL(19)
12460 IF(ECM.LE.5.D0) ETABLO = MIN(2.5D0,ETABLO)
12462 WRITE(LO,'(/,1X,A,2F12.1)')
12463 & 'PHO_MCINI: selected energy range (SQRT(S))',ETABLO,ECM
12464 WRITE(LO,'(5X,A,A,F7.3,E15.4)')
12465 & 'particle 1 (name,mass,virtuality): ',PHO_PNAME(IFPAP(1),1),
12466 & PMASS(1),PVIRT(1)
12467 WRITE(LO,'(5X,A,A,F7.3,E15.4)')
12468 & 'particle 2 (name,mass,virtuality): ',PHO_PNAME(IFPAP(2),1),
12469 & PMASS(2),PVIRT(2)
12471 C cuts on probabilities of multiple interactions
12472 IMAX = MIN(IPAMDL(32),IIMAX)
12473 KMAX = MIN(IPAMDL(33),KKMAX)
12474 AH = 2.D0*PTCUT(1)/ECM
12475 IMAX = MAX(5,MIN(IMAX,INT(ECM/2.0D0)))
12476 KMAX = MIN(KMAX,1+INT(0.9*1.D0/AH))
12478 C hard interpolation table
12480 ECMF(2) = 0.9D0*ECMF(1)
12484 IH_Ecm_up(k) = MIN(IPAMDL(30),Max_tab_E)
12485 IF(ECMF(k).LT.100.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),15)
12486 IF(ECMF(k).LT.50.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),10)
12487 IF(ECMF(k).LT.10.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),5)
12490 C initialization of hard scattering for all channels and cutoffs
12491 IF(HSWCUT(5).GT.PARMDL(36)) CALL PHO_HARMCI(-1,ECMF(1))
12493 IF(ISWMDL(2).EQ.0) I0 = 1
12495 CALL PHO_HARMCI(I,ECMF(I))
12498 C dimension of interpolation table of cut probabilities
12499 IEEMAX = MIN(IPAMDL(31),IEETA1)
12500 IF(ECM.LT.100.D0) IEEMAX = MIN(IEEMAX,15)
12501 IF(ECM.LT.50.D0) IEEMAX = MIN(IEEMAX,10)
12502 IF(ECM.LT.10.D0) IEEMAX = MIN(IEEMAX,5)
12505 C calculate probability distribution
12513 IF(ISWMDL(2).EQ.0) I0 = 1
12515 ECMPRO = ECMF(IP)*1.001D0
12523 ELSE IF(IP.EQ.3) THEN
12530 ELSE IF(IP.EQ.2) THEN
12545 IF(IEEMAX.GT.1) THEN
12547 ELMIN = LOG(ETABLO)
12551 EDELTA = (LOG(ECMPRO)-ELMIN)/DBLE(MAX(1,IEEMAX-1))
12553 ECMPRO = EXP(ELMIN+DBLE(I-1)*EDELTA)
12554 CALL PHO_PRBDIS(IP,ECMPRO,I)
12557 CALL PHO_PRBDIS(IP,ECMPRO,1)
12560 C debug output of cross section tables
12561 IF(((IDEB(62).GE.0).AND.(IP.EQ.1)).OR.(IDEB(62).GE.3)) THEN
12562 IF((PVIRT(1)+PVIRT(2).GT.0.01D0).AND.(IDEB(62).EQ.0)) GOTO 201
12563 WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12564 &'Table of total cross sections (mb) for particle combination',IP,
12565 &' Ecm SIGtot SIGela SIGine SIGqel SIGsd1 SIGsd2 SIGdd',
12566 &'-------------------------------------------------------------'
12568 WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,1,I),
12569 & SIGTAB(IP,2,I),SIGTAB(IP,28,I),SIGTAB(IP,3,I),
12570 & SIGTAB(IP,30,I)+SIGTAB(IP,32,I),
12571 & SIGTAB(IP,31,I)+SIGTAB(IP,33,I),
12572 & SIGTAB(IP,34,I)+SIGTAB(IP,35,I)
12575 IF(IDEB(62).GE.2) THEN
12576 WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12577 &'Table of partial x-sections (mb) for particle combination',IP,
12578 &' Ecm SIGSD1L SIGSD1H SIGSD2L SIGSD2H SIGDDL SIGDDH SIGCDF',
12579 &'--------------------------------------------------------------'
12581 WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,30,I),
12582 & SIGTAB(IP,32,I),SIGTAB(IP,31,I),SIGTAB(IP,33,I),
12583 & SIGTAB(IP,34,I),SIGTAB(IP,35,I),SIGTAB(IP,36,I)
12586 IF(IDEB(62).GE.2) THEN
12587 WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12588 &'Table of born graph x-sections (mb) for particle combination',IP,
12589 &' Ecm SIGSVDM SIGHRES SIGHDIR SIGTR1 SIGTR2 SIGLOO SIGDPO',
12590 &'-------------------------------------------------------------'
12592 WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),
12593 & SIGTAB(IP,56,I)+SIGTAB(IP,57,I),SIGTAB(IP,58,I),
12594 & SIGTAB(IP,59,I),SIGTAB(IP,60,I)+SIGTAB(IP,61,I),
12595 & SIGTAB(IP,62,I)+SIGTAB(IP,63,I),SIGTAB(IP,64,I),
12596 & SIGTAB(IP,65,I)+SIGTAB(IP,66,I)+SIGTAB(IP,67,I)
12599 WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12600 &'Table of unitarized x-sections (mb) for particle combination',IP,
12601 &' Ecm SIGSVDM SIGHVDM SIGTR1 SIGTR2 SIGLOO SIGDPO SLOPE',
12602 &'-------------------------------------------------------------'
12604 WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,79,I),
12605 & SIGTAB(IP,80,I),SIGTAB(IP,32,I),SIGTAB(IP,33,I),
12606 & SIGTAB(IP,35,I),SIGTAB(IP,36,I),SIGTAB(IP,39,I)
12609 IF(IDEB(62).GE.1) THEN
12610 WRITE(LO,'(/1X,A,/1X,A,2I4,/1X,A,/1X,A)')
12611 &'Table of expected average number of cuts in non-diff events:',
12612 &' for max. number of cuts soft/hard:',IMAX,KMAX,
12613 &' Ecm PTCUT SIGNDF POM-S POM-H REG-S',
12614 &'---------------------------------------------'
12616 WRITE(LO,'(1X,1P,6E10.3)') SIGECM(IP,I),SIGTAB(IP,77,I),
12617 & SIGTAB(IP,78,I),SIGTAB(IP,74,I),SIGTAB(IP,75,I),
12621 WRITE(LO,'(/1X,A,/1X,A,/1X,A)')
12622 & 'Table of rapidity gap survival probability (high-mass diff.):',
12623 & ' Ecm Spro-sd1 Spro-sd2 Spro-dd Spro-cd',
12624 & '---------------------------------------------------'
12626 IF(SIGECM(IP,I).GT.10.D0) THEN
12627 SPRSD1 = SIGTAB(IP,32,I)/(SIGTAB(IP,60,I)
12628 & -2.D0*(SIGTAB(IP,65,I)+SIGTAB(IP,66,I)))
12629 SPRSD2 = SIGTAB(IP,33,I)/(SIGTAB(IP,62,I)
12630 & -2.D0*(SIGTAB(IP,65,I)+SIGTAB(IP,67,I)))
12631 SPRDD = SIGTAB(IP,35,I)/(SIGTAB(IP,64,I)+SIGTAB(IP,61,I)
12632 & +SIGTAB(IP,63,I)-2.D0*(SIGTAB(IP,66,I)
12633 & +SIGTAB(IP,67,I)+2.D0*SIGTAB(IP,68,I)))
12634 SPRCDF = SIGTAB(IP,36,I)/(SIGTAB(IP,65,I)+SIGTAB(IP,66,I)
12635 & +SIGTAB(IP,67,I)+SIGTAB(IP,68,I))
12636 WRITE(LO,'(1X,1P,5E10.3)') SIGECM(IP,I),
12637 & SPRSD1,SPRSD2,SPRDD,SPRCDF
12645 C simulate only hard scatterings
12646 IF(ISWMDL(2).EQ.0) THEN
12647 WRITE(LO,'(2(/1X,A))')
12648 & 'WARNING: generation of hard scatterings only!',
12649 & '============================================='
12661 IF(IPRON(1,1).EQ.1) SIGMAX = SIGTAB(1,58,I)
12662 IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGTAB(1,59,I)
12663 IF(SIGMAX.GT.SIGGEN(4)) THEN
12669 WRITE(LO,'(2(/1X,A))')
12670 & 'activated processes, cross section',
12671 & '----------------------------------'
12672 WRITE(LO,'(5X,A,I3,2X,3I3)')
12673 & ' nondiffr. resolved processes',(IPRON(1,K),K=1,4)
12674 WRITE(LO,'(5X,A,I3,2X,3I3)')
12675 & ' elastic scattering',(IPRON(2,K),K=1,4)
12676 WRITE(LO,'(5X,A,I3,2X,3I3)')
12677 & 'qelast. vectormeson production',(IPRON(3,K),K=1,4)
12678 WRITE(LO,'(5X,A,I3,2X,3I3)')
12679 & ' double pomeron processes',(IPRON(4,K),K=1,4)
12680 WRITE(LO,'(5X,A,I3,2X,3I3)')
12681 & ' single diffract. particle (1)',(IPRON(5,K),K=1,4)
12682 WRITE(LO,'(5X,A,I3,2X,3I3)')
12683 & ' single diffract. particle (2)',(IPRON(6,K),K=1,4)
12684 WRITE(LO,'(5X,A,I3,2X,3I3)')
12685 & ' double diffract. processes',(IPRON(7,K),K=1,4)
12686 WRITE(LO,'(5X,A,I3,2X,3I3)')
12687 & ' direct photon processes',(IPRON(8,K),K=1,4)
12689 C calculate effective cross section
12692 CALL PHO_CSINT(1,IFPAP(1),IFPAP(2),-1,-1,SIGECM(1,I),
12693 & PVIRT(1),PVIRT(2))
12695 if(iswmdl(2).ge.1) then
12696 IF(IPRON(1,1).EQ.1) SIGMAX = SIGTOT-SIGELA-SIGVM(0,0)
12697 & -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
12698 & -SIGLDD-SIGHDD-SIGDIR
12699 IF(IPRON(2,1).EQ.1) SIGMAX = SIGMAX+SIGELA
12700 IF(IPRON(3,1).EQ.1) SIGMAX = SIGMAX+SIGVM(0,0)
12701 IF(IPRON(4,1).EQ.1) SIGMAX = SIGMAX+SIGCDF(0)
12702 IF(IPRON(5,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(1)+SIGHSD(1)
12703 IF(IPRON(6,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(2)+SIGHSD(2)
12704 IF(IPRON(7,1).EQ.1) SIGMAX = SIGMAX+SIGLDD+SIGHDD
12705 IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
12707 IF(IPRON(1,1).EQ.1) SIGMAX = SIGHAR
12708 IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
12710 IF(SIGMAX.GT.SIGGEN(4)) THEN
12718 IF(SIGGEN(4).LT.1.D-20) THEN
12719 WRITE(LO,'(//1X,A)')
12720 & 'PHO_MCINI:ERROR: selected processes have vanishing x-section'
12723 WRITE(LO,'(3X,A,1P3E11.4)') 'maximum search (Elow/Eup/Epeak)',
12724 & SIGECM(1,1),SIGECM(1,IEEMAX),SIGECM(1,ISIGM)
12725 WRITE(LO,'(11X,A,1PE12.4,/)') 'max. cross section (mb)',SIGGEN(4)
12729 *$ CREATE PHO_REJSTA.FOR
12731 CDECK ID>, PHO_REJSTA
12732 SUBROUTINE PHO_REJSTA(IMODE)
12733 C********************************************************************
12735 C MC rejection counting
12737 C input IMODE -1 initialization
12738 C -2 output of statistics
12740 C********************************************************************
12744 C input/output channels
12746 COMMON /POINOU/ LI,LO
12747 C event debugging information
12749 PARAMETER (NMAXD=100)
12750 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12751 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12752 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12753 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12754 C internal rejection counters
12756 PARAMETER (NMXJ=60)
12757 CHARACTER*10 REJTIT
12759 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
12766 IF(IMODE.EQ.-1) THEN
12771 REJTIT(1) = 'PARTON ALL'
12772 REJTIT(2) = 'STDPAR ALL'
12773 REJTIT(3) = 'STDPAR DPO'
12774 REJTIT(4) = 'POMSCA ALL'
12775 REJTIT(5) = 'POMSCA INT'
12776 REJTIT(6) = 'POMSCA KIN'
12777 REJTIT(7) = 'DIFDIS ALL'
12778 REJTIT(8) = 'POSPOM ALL'
12779 REJTIT(9) = 'HRES.DIF.1'
12780 REJTIT(10) = 'HDIR.DIF.1'
12781 REJTIT(11) = 'HRES.DIF.2'
12782 REJTIT(12) = 'HDIR.DIF.2'
12783 REJTIT(13) = 'DIFDIS INT'
12784 REJTIT(14) = 'HADRON SP2'
12785 REJTIT(15) = 'HADRON SP3'
12786 REJTIT(16) = 'HARDIR ALL'
12787 REJTIT(17) = 'HARDIR INT'
12788 REJTIT(18) = 'HARDIR KIN'
12789 REJTIT(19) = 'MCHECK BAR'
12790 REJTIT(20) = 'MCHECK MES'
12791 REJTIT(21) = 'DIF.DISS.1'
12792 REJTIT(22) = 'DIF.DISS.2'
12793 REJTIT(23) = 'STRFRA ALL'
12794 REJTIT(24) = 'MSHELL CHA'
12795 REJTIT(25) = 'PARTPT SOF'
12796 REJTIT(26) = 'PARTPT HAR'
12797 REJTIT(27) = 'INTRINS KT'
12798 REJTIT(28) = 'HACHEK DIR'
12799 REJTIT(29) = 'HACHEK RES'
12800 REJTIT(30) = 'STRING ALL'
12801 REJTIT(31) = 'POMSCA INT'
12802 REJTIT(32) = 'DIFF SLOPE'
12803 REJTIT(33) = 'GLU2QU ALL'
12804 REJTIT(34) = 'MASCOR ALL'
12805 REJTIT(35) = 'PARCOR ALL'
12806 REJTIT(36) = 'MSHELL PAR'
12807 REJTIT(37) = 'MSHELL ALL'
12808 REJTIT(38) = 'POMCOR ALL'
12809 REJTIT(39) = 'DB-POM KIN'
12810 REJTIT(40) = 'DB-POM ALL'
12811 REJTIT(41) = 'SOFTXX ALL'
12812 REJTIT(42) = 'SOFTXX PSP'
12815 ELSE IF(IMODE.EQ.-2) THEN
12816 WRITE(LO,'(/,1X,A,/,1X,A)') 'PHO_REJSTA: rejection statistics',
12817 & '--------------------------------'
12820 & WRITE(LO,'(1X,I3,1X,A,5X,I15)') I,REJTIT(I),IFAIL(I)
12823 WRITE(LO,'(1X,A,I3)') 'PHO_REJSTA: invalid mode ',IMODE
12828 *$ CREATE PHO_POSPOM.FOR
12830 CDECK ID>, PHO_POSPOM
12831 SUBROUTINE PHO_POSPOM(IP,IND1,IND2,IGEN,IPOM,KCUT,ISWAP,IREJ)
12832 C***********************************************************************
12834 C registration of one cut pomeron (soft/semihard)
12836 C input: IP particle combination the pomeron belongs to
12837 C IND1,2 position of X values in /POSOFT/
12838 C 1 corresponds to a valence-pomeron
12839 C IGEN production process of mother particles
12840 C IPOM pomeron number
12841 C KCUT total number of cut pomerons and reggeons
12843 C output: ISWAP exchange of x values
12844 C IND1,2 increased by the number of partons belonging
12845 C to the generated pomeron cut
12846 C IREJ success/failure
12848 C**********************************************************************
12849 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12852 PARAMETER ( DEPS = 1.D-8 )
12854 C input/output channels
12856 COMMON /POINOU/ LI,LO
12857 C event debugging information
12859 PARAMETER (NMAXD=100)
12860 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12861 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12862 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12863 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12864 C internal rejection counters
12866 PARAMETER (NMXJ=60)
12867 CHARACTER*10 REJTIT
12869 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
12870 C model switches and parameters
12872 INTEGER ISWMDL,IPAMDL
12873 DOUBLE PRECISION PARMDL
12874 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
12875 C general process information
12876 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
12877 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
12878 C global event kinematics and particle IDs
12879 INTEGER IFPAP,IFPAB
12880 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
12881 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
12882 C data of c.m. system of Pomeron / Reggeon exchange
12883 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
12884 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
12885 & SIDP,CODP,SIFP,COFP
12886 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
12887 & SIDP,CODP,SIFP,COFP,NPOSP(2),
12888 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
12889 C obsolete cut-off information
12890 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
12891 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
12892 C energy-interpolation table
12894 PARAMETER ( IEETA2 = 20 )
12896 DOUBLE PRECISION SIGTAB,SIGECM
12897 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
12898 C light-cone x fractions and c.m. momenta of soft cut string ends
12900 PARAMETER ( MAXSOF = 50 )
12901 INTEGER IJSI2,IJSI1
12902 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
12903 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
12904 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
12905 & IJSI1(MAXSOF),IJSI2(MAXSOF)
12906 C standard particle data interface
12908 PARAMETER (NMXHEP=4000)
12909 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
12910 DOUBLE PRECISION PHEP,VHEP
12911 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
12912 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
12914 C extension to standard particle data interface (PHOJET specific)
12915 INTEGER IMPART,IPHIST,ICOLOR
12916 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
12917 C table of particle indices for recursive PHOJET calls
12919 PARAMETER ( MAXIPX = 100 )
12920 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
12921 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
12922 & IPOIX1,IPOIX2,IPOIX3
12924 DIMENSION P1(4),P2(4),WGXHSD(2),WGX(6)
12932 EA1 = XS1(IND1)*ECMP/2.D0
12933 EA2 = XS1(IND1+1)*ECMP/2.D0
12934 EB1 = XS2(IND2)*ECMP/2.D0
12935 EB2 = XS2(IND2+1)*ECMP/2.D0
12936 CMASS1 = MIN(EA1,EA2)
12937 CMASS2 = MIN(EB1,EB2)
12940 IF(IDEB(9).GE.20) THEN
12941 WRITE(LO,'(1X,2A,5I4)') 'PHO_POSPOM: ',
12942 & 'IP,IND1,IND2,KCUT,IPOIX1',IP,IND1,IND2,KCUT,IPOIX1
12943 WRITE(LO,'(1X,A,2I4,1P2E12.4)') 'MOTHER1/2,MASS1/2',JM1,JM2,
12949 CALL PHO_VALFLA(JM1,IFLA1,IFLA2,EA1,EA2)
12951 CALL PHO_SEAFLA(JM1,IFLA1,IFLA2,CMASS1)
12954 CALL PHO_VALFLA(JM2,IFLB1,IFLB2,EB1,EB2)
12956 CALL PHO_SEAFLA(JM2,IFLB1,IFLB2,CMASS2)
12959 P1(I) = PSOFT1(I,IND1)+PSOFT1(I,IND1+1)
12960 P2(I) = PSOFT2(I,IND2)+PSOFT2(I,IND2+1)
12963 C pomeron resolved?
12964 IF((ISWMDL(14).GT.0).AND.(IPOIX1.GT.0)) THEN
12965 C find energy for cross section calculation
12966 IF(IPAMDL(16).EQ.2) THEN
12968 ELSE IF(IPAMDL(16).EQ.3) THEN
12969 IF(IPROCE.EQ.1) THEN
12975 ESUB = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2
12976 & -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2)
12978 C load cross sections from interpolation table
12979 IF(ESUB.LE.SIGECM(IP,1)) THEN
12982 ELSE IF(ESUB.LT.SIGECM(IP,ISIMAX)) THEN
12984 IF(ESUB.LE.SIGECM(IP,I)) GOTO 200
12990 WRITE(LO,'(/1X,A,2E12.3)')
12991 & 'PHO_POSPOM: energy too high',ESUB,SIGECM(IP,ISIMAX)
12992 CALL PHO_PREVNT(-1)
12997 IF(I1.NE.I2) FAC2=LOG(ESUB/SIGECM(IP,I1))
12998 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
13000 C calculate weights
13001 * WGXHSD(1) = FAC2*SIGTAB(IP,32,I2)+FAC1*SIGTAB(IP,32,I1)
13002 * WGXHSD(2) = FAC2*SIGTAB(IP,33,I2)+FAC1*SIGTAB(IP,33,I1)
13003 * WGXHDD = FAC2*SIGTAB(IP,35,I2)+FAC1*SIGTAB(IP,35,I1)
13004 * WGXCDF = FAC2*SIGTAB(IP,36,I2)+FAC1*SIGTAB(IP,36,I1)
13005 * WGXPOM = FAC2*SIGTAB(IP,37,I2)+FAC1*SIGTAB(IP,37,I1)
13006 * WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
13008 WGXPOM = FAC2*(SIGTAB(IP,56,I2)+SIGTAB(IP,57,I2))
13009 & +FAC1*(SIGTAB(IP,56,I1)+SIGTAB(IP,57,I1))
13010 WGXHSD(1) = FAC2*SIGTAB(IP,60,I2)+FAC1*SIGTAB(IP,60,I1)
13011 WGXHSD(2) = FAC2*SIGTAB(IP,62,I2)+FAC1*SIGTAB(IP,62,I1)
13012 WGXHDD = FAC2*(SIGTAB(IP,61,I2)+SIGTAB(IP,63,I2)
13013 & +SIGTAB(IP,64,I2))
13014 & +FAC1*(SIGTAB(IP,61,I1)+SIGTAB(IP,63,I1)
13015 & +SIGTAB(IP,64,I1))
13016 WGXCDF = FAC2*(SIGTAB(IP,65,I2)+SIGTAB(IP,66,I2)
13017 & +SIGTAB(IP,67,I2)+SIGTAB(IP,68,I2))
13018 & +FAC1*(SIGTAB(IP,65,I1)+SIGTAB(IP,66,I1)
13019 & +SIGTAB(IP,67,I1)+SIGTAB(IP,68,I1))
13022 WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
13023 C central diff. cut
13025 C diff. diss. of particle 1
13027 C diff. diss. of particle 2
13029 C double diff. dissociation
13032 WGX(6) = 2.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)
13034 * IF((WGX(1).LT.0.D0).AND.((IP.EQ.1).OR.(IDEB(9).GE.1))) THEN
13035 * WRITE(LO,'(1X,A,/1X,A,I3,1P,2E11.3)') ' PHO_POSPOM: ',
13036 * & ' unitarity bound reached for ',IP,ESUB,WGX(1)
13037 * WRITE(LO,'(5X,A)') 'WGXHSD(1),WGXHSD(2),WGXHDD,WGXCDF,WGXPOM:'
13038 * WRITE(LO,'(5X,1P5E11.3)') WGXHSD,WGXHDD,WGXCDF,WGXPOM
13039 * WRITE(LO,'(5X,A,/,5X,1P,6E11.3)') 'weight factors WG(1-6)',WGX
13042 SUM = WGX(1)+WGX(2)+WGX(3)+WGX(4)+WGX(5)+WGX(6)
13046 XI = DT_RNDM(SUM)*SUM
13052 IF((XI.GT.SUM).AND.(I.LT.6)) GOTO 210
13053 C phase space correction
13056 IF(I.EQ.6) ISAM = 8
13057 PACC = EXP(-PARMDL(8)*DBLE(ISAM*PARMDL(160+IP))/ESUB)
13058 * IF(DT_RNDM(SUM).GT.PACC) I=1
13059 IF(DT_RNDM(SUM).GT.PACC) GOTO 205
13062 C do not generate diffraction for events with only one cut pomeron
13063 IF((KCUT.EQ.1).AND.(I.LT.6)) I = 1
13065 C do not generate recursive calls for remants with
13066 C diquark-anti-diquark flavour contents
13067 if((abs(IFLA1).gt.1000).and.(IFLA1+IFLA2.eq.0)) I = 1
13068 if((abs(IFLB1).gt.1000).and.(IFLB1+IFLB2.eq.0)) I = 1
13071 IF(IDEB(9).GE.20) WRITE(LO,'(1X,A,/1X,I2,1P7E11.3)')
13072 & 'PHO_POSPOM: IPRO,ESUB,WGX(1-6)',I,ESUB,WGX
13075 C second scattering needed
13076 CALL PHO_HACODE(IFLA1,IFLA2,IDHA1,IDUM)
13077 CALL PHO_HACODE(IFLB1,IFLB2,IDHA2,IDUM)
13078 IDPD1 = IPHO_ID2PDG(IDHA1)
13079 IDPD2 = IPHO_ID2PDG(IDHA2)
13081 if(INDX1.eq.1) then
13082 if((IPHIST(2,JM1).GE.0).and.(IDHEP(JM1).NE.990))
13087 CALL PHO_REGPAR(1,IDPD1,IDHA1,JM1,JM2,P1(1),P1(2),P1(3),P1(4),
13088 & IPOM,IGEN_had,0,0,IPOS1,1)
13090 if(INDX2.eq.1) then
13091 if((IPHIST(2,JM2).GE.0).and.(IDHEP(JM2).NE.990))
13096 CALL PHO_REGPAR(1,IDPD2,IDHA2,JM2,JM1,P2(1),P2(2),P2(3),P2(4),
13097 & IPOM,IGEN_had,0,0,IPOS1,1)
13103 IF(IPOIX2.GT.MAXIPX) THEN
13104 WRITE(LO,'(1X,2A,2I5)') 'PHO_POSPOM: no space left in ',
13105 & '/PORECU/ (IPOIX2,MAXIPX):',IPOIX2,MAXIPX
13109 IPORES(IPOIX2) = I+2
13110 IPOPOS(1,IPOIX2) = IPOS1-1
13111 IPOPOS(2,IPOIX2) = IPOS1
13117 IF(ISWMDL(12).EQ.0) THEN
13119 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
13120 CALL PHO_SELCOL(0,0,ICC1,ICC2,ICD1,ICD2,1)
13122 C purely gluonic pomeron or sea strings formed by gluons
13124 IF( ((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0))
13125 & .OR.((IPAMDL(19).EQ.1).AND.(IND1.NE.1))) THEN
13129 IF( ((IDHEP(JM2).EQ.990).AND.(IPAMDL(20).GT.0))
13130 & .OR.((IPAMDL(19).EQ.1).AND.(IND2.NE.1))) THEN
13136 IF(IFLA1.NE.21) THEN
13137 IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
13138 & .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
13139 & CALL PHO_SWAPI(ICA1,ICD1)
13141 IF(IFLB1.NE.21) THEN
13142 IF(((ABS(IFLB1).GT.6).AND.(IFLB1.LT.0))
13143 & .OR.((ABS(IFLB1).LE.6).AND.(IFLB1.GT.0)))
13144 & CALL PHO_SWAPI(ICB1,ICC1)
13147 IF(ICA1*ICB1.GT.0) THEN
13148 IF((IND1.NE.1).AND.(IND2.NE.1)) THEN
13149 IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
13150 CALL PHO_SWAPI(IFLA1,IFLA2)
13151 CALL PHO_SWAPI(ICA1,ICD1)
13153 CALL PHO_SWAPI(IFLB1,IFLB2)
13154 CALL PHO_SWAPI(ICB1,ICC1)
13156 ELSE IF(IND1.NE.1) THEN
13157 CALL PHO_SWAPI(IFLA1,IFLA2)
13158 CALL PHO_SWAPI(ICA1,ICD1)
13159 ELSE IF(IND2.NE.1) THEN
13160 CALL PHO_SWAPI(IFLB1,IFLB2)
13161 CALL PHO_SWAPI(ICB1,ICC1)
13162 ELSE IF((IFLA1.EQ.-IFLA2).AND.(IFLB1.EQ.-IFLB2)) THEN
13163 IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
13164 CALL PHO_SWAPI(IFLA1,IFLA2)
13165 CALL PHO_SWAPI(ICA1,ICD1)
13167 CALL PHO_SWAPI(IFLB1,IFLB2)
13168 CALL PHO_SWAPI(ICB1,ICC1)
13170 ELSE IF(IFLA1.EQ.-IFLA2) THEN
13171 CALL PHO_SWAPI(IFLA1,IFLA2)
13172 CALL PHO_SWAPI(ICA1,ICD1)
13173 ELSE IF(IFLB1.EQ.-IFLB2) THEN
13174 CALL PHO_SWAPI(IFLB1,IFLB2)
13175 CALL PHO_SWAPI(ICB1,ICC1)
13178 IF(IDEB(9).GE.5) THEN
13179 WRITE(LO,'(1X,A,I12)')
13180 & 'PHO_POSPOM: string end swap (KEVENT)',KEVENT
13181 WRITE(LO,'(5X,A,4I7)')
13182 & 'flavors:',IFLA1,IFLA2,IFLB1,IFLB2
13183 WRITE(LO,'(5X,A,4I7)') 'colors :',ICA1,ICD1,ICB1,ICC1
13190 C purely gluonic pomeron or sea strings formed by gluons
13191 IF(IFLA1.EQ.21) THEN
13192 CALL PHO_REGPAR(-1,21,0,JM1,JM2,P1(1),P1(2),P1(3),P1(4),
13193 & IPOM,IGEN,ICA1,ICD1,IPOS1,1)
13196 C strings formed by quarks
13198 C valence quark labels
13199 IF((INDX1.EQ.1).and.(IPHIST(2,JM1).GE.0)
13200 & .and.(IDHEP(JM1).NE.990)) THEN
13205 CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
13206 & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICA1,
13209 CALL PHO_REGPAR(-1,IFLA2,0,JM1,JM2,PSOFT1(1,IND1),
13210 & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICD1,
13215 C purely gluonic pomeron or sea strings formed by gluons
13216 IF(IFLB1.EQ.21) THEN
13217 CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,P2(1),P2(2),P2(3),P2(4),
13218 & IPOM,IGEN,ICB1,ICC1,IPOS2,1)
13221 C strings formed by quarks
13223 C valence quark labels
13224 IF((INDX2.EQ.1).and.(IPHIST(2,JM2).GE.0)
13225 & .and.(IDHEP(JM2).NE.990)) THEN
13230 CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
13231 & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICB1,
13234 CALL PHO_REGPAR(-1,IFLB2,0,JM2,JM1,PSOFT2(1,IND2),
13235 & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICC1,
13240 C soft pt assignment
13241 IF(ISWMDL(18).EQ.0) THEN
13242 CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(IP),IREJ)
13244 IFAIL(25) = IFAIL(25)+1
13249 * CALL PHO_BFKL(P1,P2,IPART,IREJ)
13250 * IF(IREJ.NE.0) RETURN
13255 *$ CREATE PHO_HADSP2.FOR
13257 CDECK ID>, PHO_HADSP2
13258 SUBROUTINE PHO_HADSP2(IFLB,XS1,XMAX,XSOFT1,IREJ)
13259 C***********************************************************************
13261 C split hadron momentum XMAX into two partons using
13262 C lower cut-off: AS
13264 C input: IFLB compressed particle code of particle to split
13265 C XS1 sum of x values already selected
13266 C XMAX maximal x possible
13268 C output: XS1 new sum of x values (without first one)
13269 C XSOFT1 field of selected x values
13271 C**********************************************************************
13272 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13275 PARAMETER ( DEPS = 1.D-8 )
13277 DIMENSION XSOFT1(50)
13279 C input/output channels
13281 COMMON /POINOU/ LI,LO
13282 C event debugging information
13284 PARAMETER (NMAXD=100)
13285 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13286 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13287 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13288 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13289 C internal rejection counters
13291 PARAMETER (NMXJ=60)
13292 CHARACTER*10 REJTIT
13294 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13295 C data on most recent hard scattering
13296 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13297 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13298 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13299 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13300 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13301 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13302 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13303 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13304 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13307 DATA PVMES1 /-0.5D0/
13308 DATA PVMES2 /-0.5D0/
13309 DATA PVBAR1 / 1.5D0/
13310 DATA PVBAR2 /-0.5D0/
13316 IF(ipho_bar3(IFLB,0).EQ.0) THEN
13317 XPOT1 = PVMES1+1.D0
13318 XPOT2 = PVMES2+1.D0
13319 C baryonic particle
13321 XPOT1 = PVBAR1+1.D0
13322 XPOT2 = PVBAR2+1.D0
13329 IF(ITER.GE.ITMAX) THEN
13330 IF(IDEB(39).GE.3) THEN
13331 WRITE(LO,'(1X,A,I8)')
13332 & 'PHO_HADSP2: REJECTION (ITER)',ITER
13333 WRITE(LO,'(5X,A,3E12.3)') 'XS1,XMAX,AS:',XS1,XMAX,AS
13335 IFAIL(14) = IFAIL(14)+1
13339 ZZ = XREST*PHO_RNDBET(XPOT2,XPOT1)
13340 IF((ZZ.GT.XMAX).OR.(ZZ.LT.AS)) GOTO 100
13342 IF((1.D0-XSS1).LT.AS) GOTO 100
13345 XSOFT1(1) = 1.D0-XSS1
13348 IF(IDEB(39).GE.10) THEN
13349 WRITE(LO,'(1X,A,2I8)') 'PHO_HADSP2: ITMAX,ITER',ITMAX,ITER
13350 WRITE(LO,'(5X,A,3E10.3,5X,2E11.4)') 'XS1,XMAX,AS X1,X2:',
13351 & XS1,XMAX,AS,XSOFT1(1),XSOFT1(2)
13355 *$ CREATE PHO_HADSP3.FOR
13357 CDECK ID>, PHO_HADSP3
13358 SUBROUTINE PHO_HADSP3(IFLB,XS1,XMAX,XSOFT1,IREJ)
13359 C***********************************************************************
13361 C split hadron momentum XMAX into diquark & quark pair
13362 C using lower cut-off: AS
13364 C input: IFLB compressed particle code of particle to split
13365 C XS1 sum of x values already selected
13366 C XMAX maximal x possible
13368 C output: XS1 new sum of x values
13369 C XSOFT1 field of selected x values
13372 C**********************************************************************
13373 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13375 PARAMETER ( DEPS = 1.D-8 )
13377 DIMENSION XSOFT1(50),XSOFT2(50)
13379 C input/output channels
13381 COMMON /POINOU/ LI,LO
13382 C event debugging information
13384 PARAMETER (NMAXD=100)
13385 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13386 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13387 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13388 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13389 C internal rejection counters
13391 PARAMETER (NMXJ=60)
13392 CHARACTER*10 REJTIT
13394 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13395 C data of c.m. system of Pomeron / Reggeon exchange
13396 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
13397 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
13398 & SIDP,CODP,SIFP,COFP
13399 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
13400 & SIDP,CODP,SIFP,COFP,NPOSP(2),
13401 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
13403 DIMENSION XPOT1(3),XPOT2(3),XMIN(2,3)
13406 DATA PVMES1 /-0.5D0/
13407 DATA PVMES2 /-0.5D0/
13408 DATA PSMES /-0.99D0/
13409 DATA PVBAR1 / 1.5D0/
13410 DATA PVBAR2 /-0.5D0/
13411 DATA PSBAR /-0.99D0/
13415 C determine exponents
13421 IF(ipho_bar3(IFLB,0).EQ.0) THEN
13428 C baryonic particle
13448 CALL PHO_SELSXS(3,3,XPOT1,XPOT2,XMIN,XS1,XDUM1,XMAX,XDUM2,
13449 & XSOFT1,XSOFT2,IREJ)
13452 IF(IDEB(74).GE.3) WRITE(LO,'(1X,A,I6,2E12.4)')
13453 & 'PHO_HADSP3: rejection (IFLB,XS1,XMAX)',IFLB,XS1,XMAX
13454 IFAIL(15) = IFAIL(15)+1
13459 IF(IDEB(74).GE.10) THEN
13460 WRITE(LO,'(1X,A,I6,2E12.4)')
13461 & 'PHO_HADSP3: IFLB,XS1,XMAX',IFLB,XS1,XMAX
13463 WRITE(LO,'(10X,I4,2E12.4)') I,XSOFT1(I),XSOFT2(I)
13469 *$ CREATE PHO_SOFTXX.FOR
13471 CDECK ID>, PHO_SOFTXX
13472 SUBROUTINE PHO_SOFTXX(JM1,JM2,MSPAR1,MSPAR2,IVAL1,IVAL2,MSM1,MSM2,
13473 & XSUM1,XSUM2,XMAX1,XMAX2,XS1,XS2,IREJ)
13474 C***********************************************************************
13476 C select soft x values
13478 C input: JM1,JM2 mother particle index in POEVT1
13479 C (0 flavour not known before)
13480 C MSPAR1,2 number of x values to select
13481 C IVAL1,2 number valence quarks involved in hard
13482 C scattering (0,1,2)
13483 C MSM1,2 minimum number of soft x to get sampled
13484 C XSUM1,2 sum of all x values samples up this call
13485 C XMAX1,2 max. x value
13487 C output XSUM1,2 new sum of x-values sampled
13488 C XS1,2 field containing sampled x values
13490 C x values of valence partons are first given
13492 C***********************************************************************
13493 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13496 C input/output channels
13498 COMMON /POINOU/ LI,LO
13499 C event debugging information
13501 PARAMETER (NMAXD=100)
13502 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13503 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13504 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13505 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13506 C internal rejection counters
13508 PARAMETER (NMXJ=60)
13509 CHARACTER*10 REJTIT
13511 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13512 C model switches and parameters
13514 INTEGER ISWMDL,IPAMDL
13515 DOUBLE PRECISION PARMDL
13516 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
13517 C data of c.m. system of Pomeron / Reggeon exchange
13518 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
13519 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
13520 & SIDP,CODP,SIFP,COFP
13521 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
13522 & SIDP,CODP,SIFP,COFP,NPOSP(2),
13523 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
13524 C standard particle data interface
13526 PARAMETER (NMXHEP=4000)
13527 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
13528 DOUBLE PRECISION PHEP,VHEP
13529 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
13530 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
13532 C extension to standard particle data interface (PHOJET specific)
13533 INTEGER IMPART,IPHIST,ICOLOR
13534 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
13535 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
13536 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
13537 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
13538 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
13539 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
13540 C obsolete cut-off information
13541 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
13542 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
13543 C data on most recent hard scattering
13544 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13545 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13546 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13547 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13548 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13549 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13550 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13551 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13552 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13554 DIMENSION XS1(*),XS2(*)
13557 PARAMETER ( MAXPOT = 50 )
13558 DIMENSION XPOT1(MAXPOT),XPOT2(MAXPOT),XMIN(2,MAXPOT)
13562 MSMAX = MAX(MSPAR1,MSPAR2)
13563 MSMIN = MAX(MSM1,MSM2)
13564 IF(MSMAX.GT.MAXPOT) THEN
13565 WRITE(LO,'(1X,2A,2I4)') 'PHO_SOFTXX: no space left in ',
13566 & 'local fields XPOT1/2 (MSMAX,MAXPOT):',MSMAX,MAXPOT
13570 C determine exponents
13571 IBAR1 = ipho_bar3(JM1,2)
13572 IBAR2 = ipho_bar3(JM2,2)
13574 IF((IBAR1*IBAR2).LT.0) ISWAP = 1
13575 C meson-baryon scattering (asymmetric sea)
13576 IF((ABS(IBAR1)+ABS(IBAR2)).EQ.1) THEN
13584 C lower limits for x sampling
13585 XMMINA = 2.D0*PARMDL(157)/ECMP
13586 XBMINA = 2.D0*PARMDL(158)/ECMP
13587 XSMINA = 2.D0*PARMDL(159)/ECMP
13588 XMIN1 = MAX(XSOMIN,AS/XMAX2)
13589 XMIN2 = MAX(XSOMIN,AS/XMAX1)
13590 XMAXP1 = MIN(1.D0-XMIN1*MSMAX,XMAX1)
13591 XMAXP2 = MIN(1.D0-XMIN2*MSMAX,XMAX2)
13592 XMIN1 = MAX(AS/XMAX2,XMIN1)
13593 XMIN2 = MAX(AS/XMAX1,XMIN2)
13596 XMMIN1 = MAX(XMIN1,XMMINA)
13597 XBMIN1 = MAX(XMIN1,XBMINA)
13598 XSMIN1 = MAX(XMIN1,XSMINA)
13600 IF(IBAR1.EQ.0) THEN
13601 IF(IHFLS(1).EQ.0) THEN
13602 XPOT1(1) = PARMDL(62)
13604 XPOT1(2) = PARMDL(63)
13607 XPOT1(1) = PARMDL(54)
13609 XPOT1(2) = PARMDL(55)
13612 DO 100 I=3-IVAL1,MSMAX
13616 C baryonic particle
13618 IF(IHFLS(1).EQ.0) THEN
13619 XPOT1(1) = PARMDL(62)
13621 XPOT1(2) = PARMDL(63)
13624 XPOT1(1) = PARMDL(50)
13626 XPOT1(2) = PARMDL(51)
13629 DO 200 I=3-IVAL1,MSMAX
13636 XMMIN2 = MAX(XMIN2,XMMINA)
13637 XBMIN2 = MAX(XMIN2,XBMINA)
13638 XSMIN2 = MAX(XMIN2,XSMINA)
13640 IF(IBAR2.EQ.0) THEN
13641 IF(IHFLS(2).EQ.0) THEN
13642 XPOT2(1) = PARMDL(62)
13644 XPOT2(2) = PARMDL(63)
13647 XPOT2(1) = PARMDL(54)
13649 XPOT2(2) = PARMDL(55)
13652 DO 300 I=3-IVAL2,MSMAX
13656 C baryonic particle
13658 IF(IHFLS(2).EQ.0) THEN
13659 XPOT2(1) = PARMDL(62)
13661 XPOT2(2) = PARMDL(63)
13664 XPOT2(1) = PARMDL(50)
13666 XPOT2(2) = PARMDL(51)
13669 DO 400 I=3-IVAL2,MSMAX
13679 C check limits (important for valences)
13680 IF((XMIN(1,1).GE.XMAXP1).OR.(XMIN(1,2).GE.XMAXP1)) GOTO 1000
13681 IF((XMIN(2,1).GE.XMAXP2).OR.(XMIN(2,2).GE.XMAXP2)) GOTO 1000
13684 IF(IHFLS(1).NE.0) XMINS1 = XMINS1+(PARMDL(166)/ECMP)**2
13686 IF(IHFLS(2).NE.0) XMINS2 = XMINS2+(PARMDL(166)/ECMP)**2
13688 XMINS1 = XMINS1+XMIN(1,I)
13689 XMINS2 = XMINS2+XMIN(2,I)
13691 IF((XMINS1.GE.1.D0).OR.(XMINS2.GE.1.D0)) GOTO 1000
13693 C try to sample x values
13694 IF(IPAMDL(14).EQ.0) THEN
13695 IF(MSOFT.EQ.2) THEN
13696 CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13698 ELSE IF(MSOFT.LT.5) THEN
13699 CALL PHO_SELSXR(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13700 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13702 CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13703 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13705 ELSE IF(IPAMDL(14).EQ.1) THEN
13706 IF(MSOFT.EQ.2) THEN
13707 CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13710 CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13711 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13713 ELSE IF(IPAMDL(14).EQ.2) THEN
13714 CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13715 & XMAXP1,XMAXP2,XS1,XS2,IREJ)
13716 ELSE IF(IPAMDL(14).EQ.3) THEN
13717 IF(MSOFT.EQ.2) THEN
13718 CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13720 ELSE IF(IVAL1+IVAL2.EQ.0) THEN
13721 CALL PHO_SELSXI(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)
13728 WRITE(LO,'(/,1X,A,I3)')
13729 & 'PHO_SOFTXX:ERROR: unsupported IPAMDL(14)',IPAMDL(14)
13733 IFAIL(41) = IFAIL(41)+1
13734 IF(IDEB(60).GE.2) THEN
13735 WRITE(LO,'(1X,A,I12,4I3)')
13736 & 'PHO_SOFTXX: rejection: EVE,MSP1/2,MSM1/2',
13737 & KEVENT,MSPAR1,MSPAR2,MSM1,MSM2
13738 WRITE(LO,'(1X,A,1P4E11.3)') 'XSUM1/2,XMAX1/2',
13739 & XSUM1,XSUM2,XMAX1,XMAX2
13743 IF(MSOFT.NE.MSMAX) THEN
13744 MSDIFF = MSMAX-MSOFT
13745 MSPAR1 = MSPAR1-MSDIFF
13746 MSPAR2 = MSPAR2-MSDIFF
13749 C correct for different MSPAR numbers
13750 IF(MSOFT.NE.MSPAR1) THEN
13751 IF(MSPAR1.GT.1) THEN
13753 DO 500 I=MSPAR1+1,MSOFT
13756 XFAC = (1.D0-XSUM1)/(1.D0-XDEL-XSUM1)
13758 XS1(I) = XS1(I)*XFAC
13760 XSS1 = (XSS1-XDEL-XSUM1)*XFAC+XSUM1
13765 IF(MSOFT.NE.MSPAR2) THEN
13766 IF(MSPAR2.GT.1) THEN
13768 DO 600 I=MSPAR2+1,MSOFT
13771 XFAC = (1.D0-XSUM2)/(1.D0-XDEL-XSUM2)
13773 XS2(I) = XS2(I)*XFAC
13775 XSS2 = (XSS2-XDEL-XSUM2)*XFAC+XSUM2
13782 XS1(1) = 1.D0 - XSS1
13783 XS2(1) = 1.D0 - XSS2
13788 IF(IDEB(60).GE.10) THEN
13789 WRITE(LO,'(1X,A,I8,2I4,2E12.4)')
13790 & 'PHO_SOFTXX: EVE,MSPAR1/2,XSUM1/2:',
13791 & KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
13792 WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I XS1/2 XPOT1/2 XMIN1/2'
13794 WRITE(LO,'(5X,I3,6E12.4)') I,XS1(I),XS2(I),XPOT1(I),XPOT2(I),
13795 & XMIN(1,I),XMIN(2,I)
13801 C not enough phase space
13804 IFAIL(42) = IFAIL(42)+1
13808 IF(IDEB(60).GE.1) THEN
13809 WRITE (6,'(1X,A,1P,2E11.3,/1X,A,/5X,6E11.3)')
13810 & 'PHO_SOFTXX: Xmin>Xmax or sum(Xmin)>1 (ECM,AS)',
13811 & ECMP,AS,'PHO_SOFTXX: Xmin1/2,Xmaxp1/2,sum(Xmin1/2)',
13812 & XMIN1,XMIN2,XMAXP1,XMAXP2,XMINS1,XMINS2
13813 WRITE(LO,'(1X,A,1P,3E11.3)')
13814 & 'PHO_SOFTXX: Xmmina,Xbmina,Xsmina:',XMMINA,XBMINA,XSMINA
13815 WRITE(LO,'(1X,A,1P,3E11.3)')
13816 & 'PHO_SOFTXX: Xmmin1,Xbmin1,Xsmin1:',XMMIN1,XBMIN1,XSMIN1
13817 WRITE(LO,'(1X,A,1P,3E11.3)')
13818 & 'PHO_SOFTXX: Xmmin2,Xbmin2,Xsmin2:',XMMIN2,XBMIN2,XSMIN2
13820 & 'PHO_SOFTXX: Table of lower x limits (I,Xmin(1,I),Xmin(2,I))'
13822 WRITE(LO,'(5X,I3,1P,2E11.3)') I,XMIN(1,I),XMIN(2,I)
13824 WRITE(LO,'(1X,A,I10,2I4,2E11.3)')
13825 & 'PHO_SOFTXX: KEVENT,MSPAR1/2,XSUM1/2:',
13826 & KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
13827 WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I XPOT1/2 XMIN1/2'
13829 WRITE(LO,'(5X,I3,4E12.4)') I,XPOT1(I),XPOT2(I),
13830 & XMIN(1,I),XMIN(2,I)
13836 *$ CREATE PHO_SELSXR.FOR
13838 CDECK ID>, PHO_SELSXR
13839 SUBROUTINE PHO_SELSXR(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
13840 & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
13841 C***********************************************************************
13843 C select x values of soft string ends (rejection method)
13845 C***********************************************************************
13846 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13849 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
13851 C input/output channels
13853 COMMON /POINOU/ LI,LO
13854 C event debugging information
13856 PARAMETER (NMAXD=100)
13857 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13858 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13859 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13860 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13861 C model switches and parameters
13863 INTEGER ISWMDL,IPAMDL
13864 DOUBLE PRECISION PARMDL
13865 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
13866 C data on most recent hard scattering
13867 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13868 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13869 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13870 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13871 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13872 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13873 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13874 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13875 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13876 C global event kinematics and particle IDs
13877 INTEGER IFPAP,IFPAB
13878 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
13879 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
13880 C obsolete cut-off information
13881 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
13882 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
13884 DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
13886 IF(IDEB(13).GE.10) THEN
13887 WRITE(LO,'(1X,A)') 'PHO_SELSXR:'
13888 WRITE(LO,'(5X,A,I4,5E11.3)') 'MSOFT,XS1,XS2,XMAX1,2',
13889 & MSOFT,XS1,XS2,XMAX1,XMAX2
13891 WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
13897 XMINK = MAX(PSOMIN/ECM*2.D0,XSOMIN)
13898 XMIN1 = MAX(AS/XMAX1,XMINK)
13899 XMIN2 = MAX(AS/XMAX2,XMINK)
13901 IF(MSOFT.EQ.1) THEN
13906 XWMAX = MAX(XMAX1**XPOT1(1),XMIN1**XPOT1(1))
13907 & *MAX(XMAX2**XPOT2(1),XMIN2**XPOT2(1))
13912 POT(1,I) = XPOT1(I)+1.D0
13913 POT(2,I) = XPOT2(I)+1.D0
13914 REVP(1,I) = 1.D0/POT(1,I)
13915 REVP(2,I) = 1.D0/POT(2,I)
13916 XLMIN(1,I) = XMIN(1,I)**POT(1,I)
13917 XLMAX = XMAX1**POT(1,I)
13918 XLDIF(1,I) = XLMAX-XLMIN(1,I)
13919 XLMIN(2,I) = XMIN(2,I)**POT(2,I)
13920 XLMAX = XMAX2**POT(2,I)
13921 XLDIF(2,I) = XLMAX-XLMIN(2,I)
13927 IF(ITRY0.GE.IPAMDL(181)) THEN
13928 IF(MSOFT-MSMIN.GE.2) THEN
13940 Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
13941 Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
13942 XSOFT1(I) = Z1**REVP(1,I)
13943 XSOFT2(I) = Z2**REVP(2,I)
13945 IF(ITRY1.GE.50) GOTO 1000
13946 IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
13948 XREST1 = XREST1-XSOFT1(I)
13949 IF(XREST1.LT.XMIN1) GOTO 5
13950 IF(XREST1.LT.XMIN(1,1)) GOTO 5
13951 XREST2 = XREST2-XSOFT2(I)
13952 IF(XREST2.LT.XMIN2) GOTO 5
13953 IF(XREST2.LT.XMIN(2,1)) GOTO 5
13954 IF(XREST1*XREST2.LT.AS) GOTO 5
13962 * XX = XX*XSOFT1(I)**XPOT1(I)*XSOFT2(I)**XPOT2(I)
13964 XX = XSOFT1(1)**XPOT1(1)*XSOFT2(1)**XPOT2(1)
13965 IF((XX-DT_RNDM(XX)*XWMAX).LT.0.D0) GOTO 5
13973 IF(IDEB(13).GE.2) THEN
13974 WRITE(LO,'(1X,A,2I4)')
13975 & 'PHO_SELSXR: REJECTION(ITRY0/1)',ITRY0,ITRY1
13976 WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
13981 *$ CREATE PHO_SELSX2.FOR
13983 CDECK ID>, PHO_SELSX2
13984 SUBROUTINE PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
13986 C***********************************************************************
13988 C select x values of soft string ends using PHO_RNDBET
13990 C***********************************************************************
13991 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13994 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XS1(*),XS2(*)
13996 C input/output channels
13998 COMMON /POINOU/ LI,LO
13999 C event debugging information
14001 PARAMETER (NMAXD=100)
14002 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14003 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14004 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14005 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14006 C model switches and parameters
14008 INTEGER ISWMDL,IPAMDL
14009 DOUBLE PRECISION PARMDL
14010 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14011 C data on most recent hard scattering
14012 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14013 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14014 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14015 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14016 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14017 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14018 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14019 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14020 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14021 C obsolete cut-off information
14022 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14023 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14027 IF(IDEB(32).GE.10) THEN
14028 WRITE(LO,'(1X,A)') 'PHO_SELSX2:'
14029 WRITE(LO,'(5X,A,5E11.3)') 'AS,XSUM1,2,XMAX1,2',
14030 & AS,XSUM1,XSUM2,XMAX1,XMAX2
14032 WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
14039 GAM1 = XPOT1(1)+1.D0
14040 GAM2 = XPOT2(1)+1.D0
14041 BET1 = XPOT1(2)+1.D0
14042 BET2 = XPOT2(2)+1.D0
14045 DO 100 I=1,IPAMDL(182)
14049 X1 = PHO_RNDBET(GAM1,BET1)
14051 IF(ITRY1.GE.50) GOTO 1000
14052 IF((X1.LE.XMIN(1,1)).OR.((1.D0-X1).LE.XMIN(1,2))) GOTO 10
14056 X2 = PHO_RNDBET(GAM2,BET2)
14058 IF(ITRY2.GE.50) GOTO 1000
14059 IF((X2.LE.XMIN(2,1)).OR.((1.D0-X2).LE.XMIN(2,2))) GOTO 11
14063 IF(X1*X2*FAC.GT.AS) THEN
14064 IF(X3*X4*FAC.GT.AS) THEN
14069 IF(XS1(1).GT.XMIN(1,1)) THEN
14070 IF(XS2(1).GT.XMIN(2,1)) THEN
14071 IF(XS1(2).GT.XMIN(1,2)) THEN
14072 IF(XS2(2).GT.XMIN(2,2)) THEN
14073 XSUM1 = XSUM1+XS1(2)
14074 XSUM2 = XSUM2+XS2(2)
14088 IF(IDEB(32).GE.2) THEN
14089 WRITE(LO,'(1X,A,3I4)')
14090 & 'PHO_SELSX2: REJECTION(ITRY0/1/2)',ITRY0,ITRY1,ITRY2
14091 WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
14098 *$ CREATE PHO_SELSXS.FOR
14100 CDECK ID>, PHO_SELSXS
14101 SUBROUTINE PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
14102 & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
14103 C***********************************************************************
14105 C select x values of soft string ends (rescaling method)
14107 C***********************************************************************
14108 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14111 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
14113 C input/output channels
14115 COMMON /POINOU/ LI,LO
14116 C event debugging information
14118 PARAMETER (NMAXD=100)
14119 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14120 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14121 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14122 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14123 C model switches and parameters
14125 INTEGER ISWMDL,IPAMDL
14126 DOUBLE PRECISION PARMDL
14127 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14128 C data on most recent hard scattering
14129 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14130 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14131 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14132 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14133 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14134 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14135 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14136 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14137 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14138 C obsolete cut-off information
14139 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14140 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14142 DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
14148 IF(MSOFT.EQ.1) THEN
14149 XSOFT1(1) = 1.D0-XS1
14151 XSOFT2(1) = 1.D0-XS2
14157 POT(1,I) = XPOT1(I)+1.D0
14158 POT(2,I) = XPOT2(I)+1.D0
14159 REVP(1,I) = 1.D0/POT(1,I)
14160 REVP(2,I) = 1.D0/POT(2,I)
14161 XLMIN(1,I) = XMIN(1,I)**POT(1,I)
14162 XLMAX = XMAX1**POT(1,I)
14163 XLDIF(1,I) = XLMAX-XLMIN(1,I)
14164 XLMIN(2,I) = XMIN(2,I)**POT(2,I)
14165 XLMAX = XMAX2**POT(2,I)
14166 XLDIF(2,I) = XLMAX-XLMIN(2,I)
14172 IF(ITRY0.GE.IPAMDL(180)) THEN
14173 IF(MSOFT-MSMIN.GE.2) THEN
14184 Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
14185 Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
14186 XSOFT1(I) = Z1**REVP(1,I)
14187 XSOFT2(I) = Z2**REVP(2,I)
14189 IF(ITRY1.GE.50) GOTO 1000
14190 IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
14191 XSUM1 = XSUM1+XSOFT1(I)
14192 XSUM2 = XSUM2+XSOFT2(I)
14194 FAC1 = (1.D0-XS1)/XSUM1
14195 FAC2 = (1.D0-XS2)/XSUM2
14197 XSOFT1(I) = XSOFT1(I)*FAC1
14198 XSOFT2(I) = XSOFT2(I)*FAC2
14199 IF(XSOFT1(I).LT.XMIN(1,I)) GOTO 5
14200 IF(XSOFT2(I).LT.XMIN(2,I)) GOTO 5
14201 IF(XSOFT1(I)*XSOFT2(I).LT.AS) GOTO 5
14204 XS1 = 1.D0-XSOFT1(1)
14205 XS2 = 1.D0-XSOFT2(1)
14210 IF(IDEB(14).GE.2) THEN
14211 WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXS: ',
14212 & 'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
14214 WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
14220 *$ CREATE PHO_SELSXI.FOR
14222 CDECK ID>, PHO_SELSXI
14223 SUBROUTINE PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
14224 & XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
14225 C***********************************************************************
14227 C select x values of soft string ends (sea independent from valence)
14229 C***********************************************************************
14230 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14233 DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
14235 C input/output channels
14237 COMMON /POINOU/ LI,LO
14238 C event debugging information
14240 PARAMETER (NMAXD=100)
14241 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14242 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14243 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14244 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14245 C model switches and parameters
14247 INTEGER ISWMDL,IPAMDL
14248 DOUBLE PRECISION PARMDL
14249 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14250 C data on most recent hard scattering
14251 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14252 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14253 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14254 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14255 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14256 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14257 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14258 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14259 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14260 C obsolete cut-off information
14261 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14262 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14264 DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
14271 POT(1,I) = XPOT1(I)+1.D0
14272 POT(2,I) = XPOT2(I)+1.D0
14273 REVP(1,I) = 1.D0/POT(1,I)
14274 REVP(2,I) = 1.D0/POT(2,I)
14275 XLMIN(1,I) = XMIN(1,I)**POT(1,I)
14276 XLMAX = XMAX1**POT(1,I)
14277 XLDIF(1,I) = XLMAX-XLMIN(1,I)
14278 XLMIN(2,I) = XMIN(2,I)**POT(2,I)
14279 XLMAX = XMAX2**POT(2,I)
14280 XLDIF(2,I) = XLMAX-XLMIN(2,I)
14288 IF(ITRY0.GE.IPAMDL(183)) THEN
14289 IF(MSOFT-MSMIN.GE.2) THEN
14300 Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
14301 Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
14302 XSOFT1(I) = Z1**REVP(1,I)
14303 XSOFT2(I) = Z2**REVP(2,I)
14305 IF(ITRY1.GE.50) GOTO 1000
14306 IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
14307 XSUM1 = XSUM1+XSOFT1(I)
14308 XSUM2 = XSUM2+XSOFT2(I)
14311 IF(XSUM1.GT.1.D0-XMIN(1,1)-XMIN(1,2)) GOTO 5
14312 IF(XSUM2.GT.1.D0-XMIN(2,1)-XMIN(2,2)) GOTO 5
14314 C selection of valence
14315 CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
14316 & XSOFT1,XSOFT2,IREJ)
14318 IF(MSOFT-MSMIN.GE.2) THEN
14322 IF(IDEB(31).GE.2) WRITE(LO,'(1X,A,1P,4E11.4)')
14323 & 'PHO_SELSXI: rejection by PHO_SELSX2 (XSUM1/2,XMAX1/2)',
14324 & XSUM1,XSUM2,XMAX1,XMAX2
14328 XS1 = 1.D0-XSOFT1(1)
14329 XS2 = 1.D0-XSOFT2(1)
14334 IF(IDEB(14).GE.2) THEN
14335 WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXI: ',
14336 & 'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
14338 WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
14344 *$ CREATE PHO_SELCOL.FOR
14346 CDECK ID>, PHO_SELCOL
14347 SUBROUTINE PHO_SELCOL(ICO1,ICO2,ICOA1,ICOA2,ICOB1,ICOB2,IMODE)
14348 C********************************************************************
14350 C color combinatorics
14352 C input: ICO1,2 colors of incoming particle
14353 C IMODE -2 output of initialization status
14354 C -1 initialization
14355 C ICINP(1) selection mode
14357 C 1 large N_c expansion
14358 C ICINP(2) max. allowed color
14359 C 0 clear internal color counter
14360 C 1 hadron into two colored objects
14361 C 2 quark into quark gluon
14362 C 3 gluon into gluon gluon
14363 C 4 gluon into quark antiquark
14365 C output: ICOA1,2 colors of first outgoing particle
14366 C ICOB1,2 colors of second outgoing particle
14368 C********************************************************************
14369 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14372 C input/output channels
14374 COMMON /POINOU/ LI,LO
14375 C event debugging information
14377 PARAMETER (NMAXD=100)
14378 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14379 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14380 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14381 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14383 DATA METHOD /0/, II /0/
14387 IF(METHOD.EQ.0) THEN
14389 IF(IMODE.EQ.1) THEN
14392 & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14397 ELSE IF(IMODE.EQ.2) THEN
14400 & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14411 ELSE IF(IMODE.EQ.3) THEN
14414 & II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14415 IF(DT_RNDM(DUM).GT.0.5D0) THEN
14426 ELSE IF(IMODE.EQ.4) THEN
14431 ELSE IF(IMODE.EQ.0) THEN
14433 ELSE IF(IMODE.EQ.-1) THEN
14436 ELSE IF(IMODE.EQ.-2) THEN
14437 WRITE(LO,'(1X,A,2I5)') 'PHO_SELCOL: METHOD,MAXCOL',
14440 WRITE(LO,'(1X,A,I5)')
14441 & 'PHO_SELCOL:ERROR: unsupported mode',IMODE
14446 WRITE(LO,'(1X,A,I5)')
14447 & 'PHO_SELCOL:ERROR:unsupported method selected',METHOD
14452 IF(IDEB(75).GE.10) THEN
14453 WRITE(LO,'(1X,A,I5,I12,I5)') 'PHO_SELCOL: IMODE,MAXCOL,II',
14455 WRITE(LO,'(10X,A,2I5)') 'input colors',ICI1,ICI2
14456 WRITE(LO,'(10X,A,4I5)') 'output colors',ICOA1,ICOA2,ICOB1,ICOB2
14461 *$ CREATE ipho_diqu.FOR
14463 CDECK ID>, ipho_diqu
14464 INTEGER FUNCTION ipho_diqu(iq1,iq2)
14465 C***********************************************************************
14467 C selection of diquark number (PDG convention)
14469 C***********************************************************************
14475 C input/output channels
14477 COMMON /POINOU/ LI,LO
14478 C event debugging information
14480 PARAMETER (NMAXD=100)
14481 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14482 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14483 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14484 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14485 C model switches and parameters
14487 INTEGER ISWMDL,IPAMDL
14488 DOUBLE PRECISION PARMDL
14489 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14491 C external functions
14492 double precision DT_RNDM
14496 double precision dum
14504 i0 = max(i1,i2)*1000+min(i1,i2)*100
14505 if(DT_RNDM(dum).gt.PARMDL(135)) then
14512 ipho_diqu = sign(i0,iq1)
14516 *$ CREATE PHO_PARREM.FOR
14518 CDECK ID>, PHO_PARREM
14519 SUBROUTINE PHO_PARREM(INDX,IOUT,IREM,IREJ)
14520 C**********************************************************************
14522 C selection of particle remnant flavour(s) (quark or diquark)
14524 C input: INDX index of particle in /POEVT1/
14525 C IOUT parton which was taken out
14527 C output: IREM remnant according to valence flavours
14528 C IREJ 0 flavour combination possible
14529 C 1 flavour combination impossible
14531 C all particle ID are given according to PDG conventions
14533 C**********************************************************************
14537 integer INDX,IOUT,IREM,IREJ
14539 C input/output channels
14541 COMMON /POINOU/ LI,LO
14542 C event debugging information
14544 PARAMETER (NMAXD=100)
14545 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14546 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14547 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14548 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14549 C standard particle data interface
14551 PARAMETER (NMXHEP=4000)
14552 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14553 DOUBLE PRECISION PHEP,VHEP
14554 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14555 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14557 C extension to standard particle data interface (PHOJET specific)
14558 INTEGER IMPART,IPHIST,ICOLOR
14559 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14560 C general particle data
14561 double precision xm_list,tau_list,gam_list,
14562 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
14563 & xm_bb82_list,xm_bb102_list
14564 integer ich3_list,iba3_list,iq_list,
14565 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
14566 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
14567 & xm_psm2_list(6,6),xm_vem2_list(6,6),
14568 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
14569 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
14570 & ich3_list(300),iba3_list(300),iq_list(3,300),
14571 & id_psm_list(6,6),id_vem_list(6,6),
14572 & id_b8_list(6,6,6),id_b10_list(6,6,6)
14574 C external functions
14578 integer ID,IS,ID1,ID2,i,k,K1,K2,IQUA,IDQ
14579 dimension IQUA(3),IDQ(2)
14586 WRITE(LO,'(1X,A,I6)') 'PHO_PARREM: no CPC ID available for',INDX
14590 C particle with flavour mixing
14595 else if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
14596 C pi0, rho0, and omega
14597 IF(ABS(IOUT).LE.2) THEN
14603 else if((abs(ID1).eq.311).or.(ID1.eq.310).or.(ID1.eq.130)) then
14604 C neutral kaons (K0,K0-bar)
14605 if(abs(IOUT).eq.1) then
14606 IREM = sign(3,-IOUT)
14608 else if(abs(IOUT).eq.3) then
14609 IREM = sign(1,-IOUT)
14614 else if((ID1.eq.990).or.(ID1.eq.110)) then
14615 C pomeron and reggeon
14623 IQUA(1) = iq_list(1,ID)*IS
14624 IQUA(2) = iq_list(2,ID)*IS
14625 IQUA(3) = iq_list(3,ID)*IS
14627 C compare to flavour content
14628 IF(ABS(IOUT).LT.1000) THEN
14629 C single quark requested
14630 IF(IQUA(1).EQ.IOUT) THEN
14633 ELSE IF(IQUA(2).EQ.IOUT) THEN
14636 ELSE IF(IQUA(3).EQ.IOUT) THEN
14642 IF(IQUA(3).EQ.0) THEN
14645 IREM = ipho_diqu(IQUA(K1),IQUA(K2))
14647 ELSE IF(IQUA(3).NE.0) THEN
14648 C diquark requested from baryon
14650 IDQ(2) = (IOUT-IDQ(1)*1000)/100
14653 if(IDQ(i).eq.IQUA(k)) then
14661 IREM = IQUA(1)+IQUA(2)+IQUA(3)
14666 IF(IDEB(72).GE.10) WRITE(LO,'(1X,A,5I6)')
14667 & 'PHO_PARREM: INDX,ID-PDG,ID-BAM,IOUT,IREM',
14668 & INDX,ID1,ID2,IOUT,IREM
14674 IF(IDEB(72).GE.2) WRITE(LO,'(1X,A,5I7)')
14675 & 'PHO_PARREM: rejection IDPDG,Q1-3,IOUT',IDHEP(INDX),IQUA,IOUT
14679 *$ CREATE PHO_VALFLA.FOR
14681 CDECK ID>, PHO_VALFLA
14682 SUBROUTINE PHO_VALFLA(IPAR,IFL1,IFL2,E1,E2)
14683 C***********************************************************************
14685 C selection of valence flavour decomposition of particle IPAR
14687 C input: IPAR particle index in /POEVT1/
14688 C -1 initialization
14689 C -2 output of statistics
14690 C XMASS mass of particle
14691 C (important for pomeron:
14692 C mass dependent flavour sampling)
14694 C output: IFL1,IFL2
14695 C baryon: IFL1 diquark flavour
14696 C (valence flavours according to PDG conventions)
14698 C***********************************************************************
14699 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14702 PARAMETER ( EPS = 0.1D0,
14705 C input/output channels
14707 COMMON /POINOU/ LI,LO
14708 C event debugging information
14710 PARAMETER (NMAXD=100)
14711 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14712 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14713 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14714 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14715 C model switches and parameters
14717 INTEGER ISWMDL,IPAMDL
14718 DOUBLE PRECISION PARMDL
14719 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14720 C standard particle data interface
14722 PARAMETER (NMXHEP=4000)
14723 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14724 DOUBLE PRECISION PHEP,VHEP
14725 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14726 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14728 C extension to standard particle data interface (PHOJET specific)
14729 INTEGER IMPART,IPHIST,ICOLOR
14730 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14731 C general particle data
14732 double precision xm_list,tau_list,gam_list,
14733 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
14734 & xm_bb82_list,xm_bb102_list
14735 integer ich3_list,iba3_list,iq_list,
14736 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
14737 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
14738 & xm_psm2_list(6,6),xm_vem2_list(6,6),
14739 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
14740 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
14741 & ich3_list(300),iba3_list(300),iq_list(3,300),
14742 & id_psm_list(6,6),id_vem_list(6,6),
14743 & id_b8_list(6,6,6),id_b10_list(6,6,6)
14749 C select particle code
14751 ID = abs(IMPART(K))
14752 IBAR = IPHO_BAR3(K,2)
14760 if(ITER.GT.ITMX) then
14761 WRITE(LO,'(1x,2a,i10,1p,2e11.3)') 'PHO_VALFLA: ',
14762 & 'no valences found for (IPAR,E1,E2)',IPAR,E1,E2
14771 C charge dependent flavour sampling
14773 K = INT(DT_RNDM(E1)*6.D0)+1
14777 ELSE IF(K.EQ.5) THEN
14784 C optional strangeness suppression
14785 IF((IFL1.EQ.3).AND.(DT_RNDM(E2).GT.PARMDL(160))) GOTO 15
14786 IF(DT_RNDM(DUM).LT.0.5D0) THEN
14793 ELSE IF((ID1.EQ.990).or.(ID1.eq.110)) THEN
14794 IF(ISWMDL(19).EQ.0) THEN
14795 C SU(3) symmetric valences
14796 K = INT(DT_RNDM(E1)*3.D0)+1
14797 IF(DT_RNDM(DUM).LT.0.5D0) THEN
14803 ELSE IF(ISWMDL(19).EQ.1) THEN
14804 C mass dependent flavour sampling
14806 CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
14808 WRITE(LO,'(/1X,2A,I5)') 'PHO_VALFLA: ',
14809 & 'invalid flavour selection mode ISWMDL(19)',ISWMDL(19)
14813 C meson with flavour mixing
14814 ELSE if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
14815 K = INT(2.D0*DT_RNDM(E1))+1
14820 K = INT(2.D0*DT_RNDM(E1))+1
14821 IFL1 = iq_list(K,ID)
14823 IFL2 = iq_list(K,ID)
14826 CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
14832 K = INT(2.999999D0*DT_RNDM(E2))+1
14835 IFL1 = ipho_diqu(iq_list(K1,ID),iq_list(K2,ID))
14836 IFL2 = iq_list(K,ID)
14839 C change sign for antiparticles
14845 ************************************************************************
14846 C check kinematic constraints
14847 * IF((PHO_PMASS(IFL1,3).GT.E1)
14848 * & .OR.(PHO_PMASS(IFL2,3).GT.E2)) GOTO 10
14849 ************************************************************************
14852 IF(IDEB(46).GE.10) WRITE(LO,'(1X,A,I5,2E12.4,2I7)')
14853 & 'PHO_VALFLA: IPAR,MASS1/2,FL1/2',IPAR,E1,E2,IFL1,IFL2
14855 ELSE IF(IPAR.EQ.-1) THEN
14858 ELSE IF(IPAR.EQ.-2) THEN
14859 C output of final statistics
14862 WRITE(LO,'(1X,A,I10)')
14863 & 'PHO_VALFLA:ERROR: invalid input particle (IPAR)',IPAR
14869 *$ CREATE PHO_REGFLA.FOR
14871 CDECK ID>, PHO_REGFLA
14872 SUBROUTINE PHO_REGFLA(JM1,JM2,IFLR1,IFLR2,IREJ)
14873 C**********************************************************************
14875 C selection of reggeon flavours
14877 C input: JM1,JM2 position index of mother hadrons
14879 C output: IFLR1,IFLR2 valence flavours according to
14880 C PDG conventions and JM1,JM2
14881 C IREJ 0 reggeon possible
14882 C 1 reggeon impossible
14884 C**********************************************************************
14885 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14888 PARAMETER ( EPS = 0.1D0,
14891 C input/output channels
14893 COMMON /POINOU/ LI,LO
14894 C event debugging information
14896 PARAMETER (NMAXD=100)
14897 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14898 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14899 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14900 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14901 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
14902 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
14903 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
14904 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
14905 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
14906 C standard particle data interface
14908 PARAMETER (NMXHEP=4000)
14909 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14910 DOUBLE PRECISION PHEP,VHEP
14911 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14912 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14914 C extension to standard particle data interface (PHOJET specific)
14915 INTEGER IMPART,IPHIST,ICOLOR
14916 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14922 E1 = SQRT((PHEP(4,JM1)+PHEP(4,JM2))**2
14923 & -(PHEP(1,JM1)+PHEP(1,JM2))**2
14924 & -(PHEP(2,JM1)+PHEP(2,JM2))**2
14925 & -(PHEP(3,JM1)+PHEP(3,JM2))**2)/2.D0
14928 IF(ITER.GT.50) THEN
14931 IF(IDEB(41).GE.2) WRITE(LO,'(/1X,A,2I7,1P,E12.4)')
14932 & 'PHO_REGFLA: rejection, no reggeon found for',
14933 & IDHEP(JM1),IDHEP(JM2),E1
14937 CALL PHO_VALFLA(JM1,IFLA1,IFLA2,E1,E1)
14938 CALL PHO_VALFLA(JM2,IFLB1,IFLB2,E1,E1)
14939 IF(IFLA1.EQ.-IFLB1) THEN
14942 ELSE IF(IFLA1.EQ.-IFLB2) THEN
14945 ELSE IF(IFLA2.EQ.-IFLB1) THEN
14948 ELSE IF(IFLA2.EQ.-IFLB2) THEN
14953 IF(IDEB(41).GE.25) WRITE(LO,'(/1X,A,3I4)')
14954 & 'PHO_REGFLA: int.rejection JM1,JM2,ITRY',JM1,JM2,ITER
14958 IF(IDEB(41).GE.10) WRITE(LO,'(1X,A,/5X,2I4,2I6,2I5,1PE10.3)')
14959 & 'PHO_REGFLA: JM1/2,PDG-ID1/2,IFLR1/2,MASS',
14960 & JM1,JM2,IDHEP(JM1),IDHEP(JM2),IFLR1,IFLR2,E1
14961 ELSE IF(JM1.EQ.-1) THEN
14963 ELSE IF(JM1.EQ.-2) THEN
14964 C output of statistics
14966 WRITE(LO,'(1X,A,I10)')
14967 & 'PHO_REGFLA: invalid mother particle (JM1)',JM1
14973 *$ CREATE PHO_SEAFLA.FOR
14975 CDECK ID>, PHO_SEAFLA
14976 SUBROUTINE PHO_SEAFLA(IPAR,IFL1,IFL2,CHMASS)
14977 C**********************************************************************
14979 C selection of sea flavour content of particle IPAR
14981 C input: IPAR particle index in /POEVT1/
14982 C CHMASS available invariant string mass
14983 C positive mass --> use BAMJET method
14984 C negative mass --> SU(3) symmetric sea according
14985 C to values given in PARMDL(1-6)
14986 C IPAR -1 initialization
14987 C -2 output of statistics
14989 C output: sea flavours according to PDG conventions
14991 C**********************************************************************
14992 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14995 PARAMETER ( EPS = 0.1D0,
14998 C input/output channels
15000 COMMON /POINOU/ LI,LO
15001 C event debugging information
15003 PARAMETER (NMAXD=100)
15004 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15005 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15006 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15007 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15008 C model switches and parameters
15010 INTEGER ISWMDL,IPAMDL
15011 DOUBLE PRECISION PARMDL
15012 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15013 C some hadron information, will be deleted in future versions
15015 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
15016 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
15019 IF((ISWMDL(20).EQ.1).OR.(CHMASS.LT.0.D0)) THEN
15020 C constant weights for sea
15024 SUM = SUM + PARMDL(K)
15026 XI = DT_RNDM(SUM)*SUM
15029 SUM = SUM + PARMDL(K)
15030 IF(XI.LE.SUM) GOTO 55
15033 IF(K.GT.NFSEA) GOTO 15
15035 C mass dependent flavour sampling
15037 CALL PHO_FLAUX(CHMASS,K)
15038 IF(K.GT.NFSEA) GOTO 10
15040 IF(DT_RNDM(CHMASS).GT.0.5D0) K = -K
15043 IF(IDEB(46).GE.10) THEN
15044 WRITE(LO,'(1X,A,3I5,E12.4)') 'PHO_SEAFLA:IPAR,IFL1,IFL2,MASS',
15045 & IPAR,IFL1,IFL2,CHMASS
15047 ELSE IF(IPAR.EQ.-1) THEN
15050 ELSE IF(IPAR.EQ.-2) THEN
15051 C output of statistics
15053 WRITE(LO,'(1X,A,I10)') 'PHO_SEAFLA:ERROR:INVALID IPAR',IPAR
15059 *$ CREATE PHO_FLAUX.FOR
15061 CDECK ID>, PHO_FLAUX
15062 SUBROUTINE PHO_FLAUX(EQUARK,K)
15063 C***********************************************************************
15065 C auxiliary subroutine to select flavours
15067 C********************************************************************
15068 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15071 PARAMETER ( DEPS = 1.D-14 )
15073 C input/output channels
15075 COMMON /POINOU/ LI,LO
15076 C event debugging information
15078 PARAMETER (NMAXD=100)
15079 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15080 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15081 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15082 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15083 C some hadron information, will be deleted in future versions
15085 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
15086 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
15090 C calculate weights for given energy
15091 IF(EQUARK.LT.QMASS(1)) THEN
15093 & WRITE(LO,'(1X,A,E12.3)') 'PHO_FLAUX: VERY SMALL MASS',
15103 IF(EQUARK.GT.QMASS(K)) THEN
15104 WGHT(K) = PHO_BETAF(EQUARK,QMASS(K),BET)
15108 SUM = SUM + WGHT(K)
15112 XI = SUM*(DT_RNDM(SUM)-DEPS)
15117 SUM = SUM + WGHT(K)
15118 IF(XI.GT.SUM) GOTO 400
15120 IF(IDEB(16).GE.20) THEN
15121 WRITE(LO,'(1X,A,I5)') 'PHO_FLAUX: selected flavour',K
15125 *$ CREATE PHO_BETAF.FOR
15127 CDECK ID>, PHO_BETAF
15128 DOUBLE PRECISION FUNCTION PHO_BETAF(X1,X2,BET)
15129 C********************************************************************
15131 C weights of different quark flavours
15133 C********************************************************************
15134 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15139 IF(BETX1.LT.70.D0) AX=-1.D0/BET**2*(BETX1+1.D0)*EXP(-BETX1)
15140 AY=1.D0/BET**2*(BET*X2+1.D0)*EXP(-BET*X2)
15146 *$ CREATE PHO_MCHECK.FOR
15148 CDECK ID>, PHO_MCHECK
15149 SUBROUTINE PHO_MCHECK(J1,IREJ)
15150 C********************************************************************
15152 C check parton momenta for fragmentation
15154 C input: J1 first string number
15160 C IREJ 0 successful
15163 C in case of very small string mass:
15164 C NNCH mass label of string
15166 C -1 octett baryon / pseudo scalar meson
15167 C 1 decuplett baryon / vector meson
15168 C IBHAD hadron number according to CPC,
15169 C string will be treated as resonance
15170 C (sometimes far off mass shell)
15172 C constant WIDTH ( 0.01GeV ) determines range of acceptance
15174 C********************************************************************
15175 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15178 PARAMETER ( WIDTH = 0.01D0,
15181 C input/output channels
15183 COMMON /POINOU/ LI,LO
15184 C event debugging information
15186 PARAMETER (NMAXD=100)
15187 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15188 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15189 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15190 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15191 C model switches and parameters
15193 INTEGER ISWMDL,IPAMDL
15194 DOUBLE PRECISION PARMDL
15195 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15196 C standard particle data interface
15198 PARAMETER (NMXHEP=4000)
15199 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15200 DOUBLE PRECISION PHEP,VHEP
15201 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15202 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15204 C extension to standard particle data interface (PHOJET specific)
15205 INTEGER IMPART,IPHIST,ICOLOR
15206 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15207 C color string configurations including collapsed strings and hadrons
15209 PARAMETER (MSTR=500)
15210 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15211 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15212 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15213 & NNCH(MSTR),IBHAD(MSTR),ISTR
15214 C internal rejection counters
15216 PARAMETER (NMXJ=60)
15217 CHARACTER*10 REJTIT
15219 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
15222 C quark antiquark jet
15223 STRM = PHEP(5,NPOS(1,J1))
15224 IF(NCODE(J1).EQ.3) THEN
15225 CALL PHO_MEMASS(IPAR1(J1),IPAR2(J1),
15226 & AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
15228 & WRITE(LO,'(1X,A,/3X,I3,5E12.3)')
15229 & 'PHO_MCHECK:1.STRING NO, CHMASS,AMPS,AMPS2,AMVE,AMVE2 ',
15230 & J1,STRM,AMPS,AMPS2,AMVE,AMVE2
15231 IF(STRM.LT.AMPS) THEN
15233 IFAIL(20) = IFAIL(20) + 1
15235 ELSE IF(STRM.LT.AMPS2) THEN
15236 IF(STRM.LT.(AMVE-WIDTH)) THEN
15247 C quark diquark or v.s. jet
15248 ELSE IF((NCODE(J1).EQ.4).OR.(NCODE(J1).EQ.6)) THEN
15249 CALL PHO_BAMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),
15250 & AM8,AM82,AM10,AM102,I8,I10)
15252 & WRITE(LO,'(1X,A,/5X,I3,5E12.3)')
15253 & 'PHO_MCHECK:1.STRING NO, CHMASS,AM8,AM82,AM10,AM102 ',
15254 & J1,STRM,AM8,AM82,AM10,AM102
15255 IF(STRM.LT.AM8) THEN
15257 IFAIL(19) = IFAIL(19) + 1
15259 ELSE IF(STRM.LT.AM82) THEN
15260 IF(STRM.LT.(AM10-WIDTH)) THEN
15271 C diquark a-diquark string
15272 ELSE IF(NCODE(J1).EQ.5) THEN
15273 CALL PHO_DQMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),IPAR4(J1),
15276 & WRITE(LO,'(1X,A,/5X,I3,3E12.3)')
15277 & 'PHO_MCHECK:1.STRING NO, CHMASS,AM82,AM102 ',
15278 & J1,STRM,AM82,AM102
15279 IF(STRM.LT.AM82) THEN
15281 IFAIL(19) = IFAIL(19) + 1
15287 ELSE IF(NCODE(J1).LT.0) THEN
15290 WRITE(LO,'(/,1X,2A,2I8)') 'PHO_MCHECK: ',
15291 & 'inconsistent flavours for string (NO,NCODE)',J1,NCODE(J1)
15296 *$ CREATE PHO_POMCOR.FOR
15298 CDECK ID>, PHO_POMCOR
15299 SUBROUTINE PHO_POMCOR(IREJ)
15300 C********************************************************************
15302 C join quarks to gluons in case of too small masses
15306 C IREJ -1 initialization
15307 C -2 output of statistics
15311 C IREJ 0 successful
15315 C********************************************************************
15316 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15319 PARAMETER ( EPS = 1.D-10 )
15321 C input/output channels
15323 COMMON /POINOU/ LI,LO
15324 C event debugging information
15326 PARAMETER (NMAXD=100)
15327 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15328 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15329 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15330 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15331 C model switches and parameters
15333 INTEGER ISWMDL,IPAMDL
15334 DOUBLE PRECISION PARMDL
15335 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15336 C standard particle data interface
15338 PARAMETER (NMXHEP=4000)
15339 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15340 DOUBLE PRECISION PHEP,VHEP
15341 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15342 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15344 C extension to standard particle data interface (PHOJET specific)
15345 INTEGER IMPART,IPHIST,ICOLOR
15346 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15347 C color string configurations including collapsed strings and hadrons
15349 PARAMETER (MSTR=500)
15350 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15351 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15352 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15353 & NNCH(MSTR),IBHAD(MSTR),ISTR
15357 IF(IREJ.EQ.-1) THEN
15361 ELSE IF(IREJ.EQ.-2) THEN
15362 WRITE(LO,'(/1X,A,2I8)')
15363 & 'PHO_POMCOR: total/joined strings',ICTOT,ICCOR
15372 IF(ISWMDL(25).LE.0) RETURN
15373 C debug string entries
15374 IF(IDEB(83).GE.25) CALL PHO_PRSTRG
15378 IF(ITER.GE.NITER) THEN
15380 IF(IDEB(83).GE.2) THEN
15381 WRITE(LO,'(1X,A,2I5)') 'PHO_POMCOR: rejection',ITER,NITER
15382 IF(IDEB(83).GE.10) CALL PHO_PREVNT(0)
15387 C check mass limits
15390 IF(NCODE(I).LT.0) GOTO 99
15392 NRPOM = IPHIST(2,J1)
15393 IF(NRPOM.GE.100) GOTO 99
15394 CMASS0 = PHEP(5,J1)
15396 IF(NCODE(I).EQ.3) THEN
15397 CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
15398 ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
15399 CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
15400 & AM1,AM2,AM3,AM4,IP1,IP2)
15401 ELSE IF(NCODE(I).EQ.5) THEN
15402 CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
15408 ELSE IF(NCODE(I).EQ.7) THEN
15410 ELSE IF(NCODE(I).LT.0) THEN
15413 WRITE(LO,'(/,1X,A,2I5)') 'ERROR:PHO_POMCOR:STRING NO,NCODE ',
15418 & WRITE(LO,'(1X,A,/3X,2I4,5E11.3,2I5)')
15419 & 'PHO_POMCOR: STRING,POM,CHMASS,AM1,AM2,AM3,AM4,IP1,IP2',
15420 & I,NRPOM,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
15421 C select masses to correct
15422 IF(CMASS0.LT.MAX(AM2,AM4)) THEN
15424 IF((K.NE.I).AND.(NCODE(K).GE.0)) THEN
15426 C join quarks to gluon
15427 IF(NRPOM.EQ.IPHIST(2,J2)) THEN
15435 IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
15436 CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
15437 & -(PHEP(1,KK1)+PHEP(1,KK2))**2
15438 & -(PHEP(2,KK1)+PHEP(2,KK2))**2
15439 & -(PHEP(2,KK1)+PHEP(2,KK2))**2
15440 IFL1 = ABS(IDHEP(KK1))
15442 PROB1 = 0.1D0/MAX(CMASS,EPS)
15444 PROB1 = 0.9D0/MAX(CMASS,EPS)
15447 KK1 = ABS(NPOS(3,I))
15448 KK2 = ABS(NPOS(3,K))
15449 IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
15450 CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
15451 & -(PHEP(1,KK1)+PHEP(1,KK2))**2
15452 & -(PHEP(2,KK1)+PHEP(2,KK2))**2
15453 & -(PHEP(2,KK1)+PHEP(2,KK2))**2
15454 IFL2 = ABS(IDHEP(KK1))
15456 PROB2 = 0.1D0/MAX(CMASS,EPS)
15458 PROB2 = 0.9D0/MAX(CMASS,EPS)
15461 IF(IFL1+IFL2.EQ.0) GOTO 99
15464 IF((DT_RNDM(CMASS)*(PROB1+PROB2)).LT.PROB1) THEN
15471 KK1 = ABS(NPOS(JJ,I))
15472 KK2 = ABS(NPOS(JJ,K))
15473 I1 = ABS(NPOS(JE,I))
15478 K2 = ABS(NPOS(JE,K))
15482 C copy mother partons of string I
15484 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
15485 & PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
15486 & ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
15490 PJ(II) = PHEP(II,KK1)+PHEP(II,KK2)
15492 CALL PHO_REGPAR(-1,21,0,J1,J2,PJ(1),PJ(2),PJ(3),PJ(4),
15493 & I,IPHIST(2,KK2),ICOLOR(1,KK1),ICOLOR(1,KK2),IPOS,1)
15494 C copy mother partons of string K
15496 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
15497 & PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
15498 & ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
15500 C create new string entry
15502 PJ(II) = PHEP(II,J1)+PHEP(II,J2)
15505 CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PJ(1),PJ(2),PJ(3),
15506 & PJ(4),I,IPHIST(2,J1),ICOLOR(1,J1)+ICOLOR(1,J2),
15507 & ICOLOR(2,J1)+ICOLOR(2,J2),IPOS,1)
15508 C delete string K in /POSTRG/
15510 C update string I in /POSTRG/
15514 C calculate new CPC string codes
15515 CALL PHO_ID2STR(IDHEP(IP1),IDHEP(IP2),NCODE(I),IPAR1(I),
15516 & IPAR2(I),IPAR3(I),IPAR4(I))
15524 IF(IDEB(83).GE.20) THEN
15525 WRITE(LO,'(1X,A)') 'PHO_POMCOR: after string recombination'
15526 IF(IDEB(83).GE.22) THEN
15534 *$ CREATE PHO_MASCOR.FOR
15536 CDECK ID>, PHO_MASCOR
15537 SUBROUTINE PHO_MASCOR(IREJ)
15538 C********************************************************************
15540 C check and adjust parton momenta for fragmentation
15544 C IREJ -1 initialization
15545 C -2 output of statistics
15549 C IREJ 0 successful
15552 C in case of very small string mass:
15553 C - direct manipulation of /POEVT1/ and /POEVT2/
15554 C - string will be deleted from /POSTRG/ (label -99)
15556 C********************************************************************
15557 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15560 PARAMETER ( EPS = 1.D-10,
15564 C input/output channels
15566 COMMON /POINOU/ LI,LO
15567 C event debugging information
15569 PARAMETER (NMAXD=100)
15570 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15571 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15572 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15573 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15574 C internal rejection counters
15576 PARAMETER (NMXJ=60)
15577 CHARACTER*10 REJTIT
15579 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
15580 C model switches and parameters
15582 INTEGER ISWMDL,IPAMDL
15583 DOUBLE PRECISION PARMDL
15584 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15585 C standard particle data interface
15587 PARAMETER (NMXHEP=4000)
15588 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15589 DOUBLE PRECISION PHEP,VHEP
15590 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15591 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15593 C extension to standard particle data interface (PHOJET specific)
15594 INTEGER IMPART,IPHIST,ICOLOR
15595 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15596 C color string configurations including collapsed strings and hadrons
15598 PARAMETER (MSTR=500)
15599 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15600 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15601 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15602 & NNCH(MSTR),IBHAD(MSTR),ISTR
15604 DIMENSION PC1(4),PC2(4),P1(4),PTR(4),GAM(3),GAMB(3)
15606 IF(IREJ.EQ.-1) THEN
15610 ELSE IF(IREJ.EQ.-2) THEN
15611 WRITE(LO,'(/1X,A,2I8/)')
15612 & 'PHO_MASCOR: total/converted strings',ICTOT,ICCOR
15620 IF(ISWMDL(7).EQ.-1) RETURN
15622 IF(IDEB(42).GE.25) CALL PHO_PRSTRG
15627 IF(ITER.GE.NITER) THEN
15629 IF(IDEB(42).GE.2) THEN
15630 WRITE(LO,'(1X,A,2I5)') 'PHO_MASCOR: rejection',ITER,NITER
15631 IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
15636 C check mass limits
15637 IF(DT_RNDM(CMASS0).LT.0.5D0) THEN
15646 DO 100 I=IM1,IM2,IST
15648 CMASS0 = PHEP(5,J1)
15650 IF(NCODE(I).EQ.3) THEN
15651 CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
15652 ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
15653 CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
15654 & AM1,AM2,AM3,AM4,IP1,IP2)
15655 ELSE IF(NCODE(I).EQ.5) THEN
15656 CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
15662 ELSE IF(NCODE(I).EQ.7) THEN
15667 *??????????????????????????????????
15670 *??????????????????????????????????
15671 ELSE IF(NCODE(I).LT.0) THEN
15674 WRITE(LO,'(/,1X,A,2I5)') 'PHO_MASCOR:ERROR: string no,NCODE ',
15678 IF(IDEB(42).GE.20) WRITE(LO,'(1X,A,/3X,I3,5E11.3,2I5)')
15679 & 'PHO_MASCOR: string no CHMASS,AM1,AM2,AM3,AM4,IP1,IP2:',
15680 & I,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
15681 C select masses to correct
15684 C correction needed?
15685 C no resonances for diquark-antidiquark and gluon-gluon strings
15686 IF(NCODE(I).EQ.5) THEN
15687 IF(CMASS0.LT.1.3D0*AM1) THEN
15688 IF(ISWMDL(7).LE.2) THEN
15699 C resonances possible
15700 IF(ISWMDL(7).EQ.0) THEN
15701 IF(CMASS0.LT.AM1*0.99D0) THEN
15706 ELSE IF(CMASS0.LT.MIN(AM2,AM4)*1.2D0) THEN
15707 DELM1 = 1.D0/((CMASS0-AM1)**2+EPS)
15708 DELM2 = 1.D0/((CMASS0-AM3)**2+EPS)
15709 IF(DT_RNDM(DELM1).LT.DELM1/(DELM1+DELM2)) THEN
15719 ELSE IF((ISWMDL(7).EQ.1).OR.(ISWMDL(7).EQ.2)) THEN
15720 IF(CMASS0.LT.AM1*0.99) THEN
15726 ELSE IF(ISWMDL(7).EQ.3) THEN
15727 IF(CMASS0.LT.AM1) THEN
15732 WRITE(LO,'(/1X,A,I5)')
15733 & 'PHO_MASCOR:ERROR:UNSUPPORTED ISWMDL(7)',ISWMDL(7)
15738 C correction necessary?
15739 IF(IBHAD(I).NE.0) THEN
15740 C find largest invar. mass
15743 DO 200 J2=NHEP,3,-1
15744 IF(ABS(ISTHEP(J2)).EQ.1) THEN
15745 IF((IPHIST(1,J2).LE.0).OR.(IPHIST(1,J2).GT.ISTR)) THEN
15746 WRITE(LO,'(1X,2A,I7,I12)') 'PHO_MASCOR: ',
15747 & 'inconsistent IPHIST(1,J2) entry (J2,KEV):',J2,KEVENT
15749 ELSE IF(NCODE(IPHIST(1,J2)).GT.0) THEN
15750 CMASS2= (PHEP(4,J1)+PHEP(4,J2))**2
15751 & -(PHEP(1,J1)+PHEP(1,J2))**2
15752 & -(PHEP(2,J1)+PHEP(2,J2))**2
15753 & -(PHEP(3,J1)+PHEP(3,J2))**2
15754 IF(CMASS2.GT.CMASS1) THEN
15762 IF((J1.EQ.J2).OR.(CMASS1.LE.EMIN)) THEN
15763 IF(INEED.EQ.1) THEN
15774 CMASS1 = SQRT(CMASS1)
15775 CMASS2 = PHEP(5,J2)
15776 IF(CMASS1.LT.(CMASS2+CHMASS)) CMASS2 = CMASS1-1.1D0*CHMASS
15778 IF(CMASS2.GT.0.D0) CALL PHO_MSHELL(PHEP(1,J1),PHEP(1,J2),
15779 & CHMASS,CMASS2,PC1,PC2,IREJ)
15781 IFAIL(24) = IFAIL(24)+1
15782 IF(IDEB(42).GE.2) THEN
15783 WRITE(LO,'(1X,A,2I4)')
15784 & 'PHO_MASCOR: rejection by PHO_MSHELL (J1,J2):',J1,J2
15785 IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
15790 C momentum transfer
15792 PTR(II) = PHEP(II,J2)-PC2(II)
15794 IF(IDEB(42).GE.10) WRITE(LO,'(1X,A,/5X,2I3,4E12.3)')
15795 & 'PHO_MASCOR: J1,J2,transfer',J1,J2,PTR
15796 C copy parents of strings
15797 C register partons belonging to first string
15798 IF(IDHEP(J1).EQ.90) THEN
15800 K2 = MAX(JMOHEP(1,J1),-JMOHEP(2,J1))
15803 ESUM = ESUM+PHEP(4,II)
15805 IF(JMOHEP(2,J1).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J1))
15807 FAC = PHEP(4,II)/ESUM
15809 P1(K) = PHEP(K,II)+FAC*PTR(K)
15811 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15812 & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15813 & ICOLOR(2,II),IPOS,1)
15816 IF(JMOHEP(2,J1).GT.0) THEN
15818 FAC = PHEP(4,II)/ESUM
15820 P1(K) = PHEP(K,II)+FAC*PTR(K)
15822 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15823 & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15824 & ICOLOR(2,II),IPOS,1)
15831 C register partons belonging to second string
15832 IF(IDHEP(J2).EQ.90) THEN
15833 CALL PHO_GETLTR(PHEP(1,J2),PC2,GAM,GAMB,DELE,IREJL)
15835 K2 = MAX(JMOHEP(1,J2),-JMOHEP(2,J2))
15838 ESUM = ESUM+PHEP(4,II)
15840 IF(JMOHEP(2,J2).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J2))
15842 **sr 28.12.2006 fix adopted from FLUKA
15843 C FAC = PHEP(4,II)/ESUM
15844 IF (ABS(ESUM).GT.0.D0) THEN
15845 FAC = PHEP(4,II)/ESUM
15850 IF(IREJL.EQ.0) THEN
15851 CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
15852 P1(4) = P1(4)+FAC*DELE
15855 P1(K) = PHEP(K,II)-FAC*PTR(K)
15858 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15859 & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15860 & ICOLOR(2,II),IPOS,1)
15863 IF(JMOHEP(2,J2).GT.0) THEN
15865 FAC = PHEP(4,II)/ESUM
15866 IF(IREJL.EQ.0) THEN
15867 CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
15868 P1(4) = P1(4)+FAC*DELE
15871 P1(K) = PHEP(K,II)-FAC*PTR(K)
15874 CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15875 & P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15876 & ICOLOR(2,II),IPOS,1)
15883 C register first string/collapsed to hadron
15884 IF((ISWMDL(7).EQ.0).OR.(ISWMDL(7).EQ.1)) THEN
15885 IF(NCODE(I).NE.5) THEN
15886 CALL PHO_REGPAR(1,0,IBHAD(I),K1A,K2A,PC1(1),PC1(2),PC1(3),
15887 & PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
15888 C label string as collapsed to hadron/resonance
15892 CALL PHO_REGPAR(-1,90,0,K1A,K2A,PC1(1),PC1(2),PC1(3),
15893 & PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
15900 CALL PHO_REGPAR(ISTA,IDHEP(J1),IMPART(J1),K1A,K2A,PC1(1),
15901 & PC1(2),PC1(3),PC1(4),IPHIST(1,J1),IPHIST(2,J1),
15902 & ICOLOR(1,J1),ICOLOR(2,J1),IPOS,1)
15903 IF(IDHEP(J1).EQ.90) THEN
15904 NPOS(1,IPHIST(1,J1)) = IPOS
15905 NPOS(2,IPHIST(1,J1)) = K1A
15906 NPOS(3,IPHIST(1,J1)) = K2A
15907 C label string as collapsed to resonance-string
15909 ELSE IF((IPHIST(1,J1).GE.1).AND.(IPHIST(1,J1).LE.ISTR)) THEN
15910 IF(NPOS(1,IPHIST(1,J1)).EQ.J1) NPOS(1,IPHIST(1,J1))=IPOS
15913 C register second string/hadron/parton
15914 CALL PHO_REGPAR(ISTB,IDHEP(J2),IMPART(J2),K1B,K2B,PC2(1),
15915 & PC2(2),PC2(3),PC2(4),IPHIST(1,J2),IPHIST(2,J2),ICOLOR(1,J2),
15916 & ICOLOR(2,J2),IPOS,1)
15917 IF(IDHEP(J2).EQ.90) THEN
15918 NPOS(1,IPHIST(1,J2))=IPOS
15919 NPOS(2,IPHIST(1,J2))=K1B
15920 NPOS(3,IPHIST(1,J2))=K2B
15921 C label string touched by momentum transfer
15923 ELSE IF((IPHIST(1,J2).GE.1).AND.(IPHIST(1,J2).LE.ISTR)) THEN
15924 IF(NPOS(1,IPHIST(1,J2)).EQ.J2) NPOS(1,IPHIST(1,J2))=IPOS
15928 C consistency checks
15929 IF(IDEB(42).GE.5) THEN
15930 CALL PHO_CHECK(-1,IDEV)
15931 IF(IDEB(42).GE.25) CALL PHO_PREVNT(0)
15933 C jump to next iteration
15939 IF(IDEB(42).GE.15) THEN
15940 IF((ITOUCH.GT.0).OR.(IDEB(42).GE.25)) THEN
15941 WRITE(LO,'(1X,A,I5)') 'PHO_MASCOR: iterations:',ITER
15947 *$ CREATE PHO_PARCOR.FOR
15949 CDECK ID>, PHO_PARCOR
15950 SUBROUTINE PHO_PARCOR(MODE,IREJ)
15951 C********************************************************************
15953 C conversion of string partons (using JETSET masses)
15955 C input: MODE >0 position index of corresponding string
15956 C -1 initialization
15957 C -2 output of statistics
15960 C IREJ 1 combination of strings impossible
15961 C 0 successful combination
15963 C********************************************************************
15964 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15967 PARAMETER ( DELM = 0.005D0,
15971 C input/output channels
15973 COMMON /POINOU/ LI,LO
15974 C event debugging information
15976 PARAMETER (NMAXD=100)
15977 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15978 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15979 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15980 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15981 C internal rejection counters
15983 PARAMETER (NMXJ=60)
15984 CHARACTER*10 REJTIT
15986 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
15987 C model switches and parameters
15989 INTEGER ISWMDL,IPAMDL
15990 DOUBLE PRECISION PARMDL
15991 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15992 C standard particle data interface
15994 PARAMETER (NMXHEP=4000)
15995 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15996 DOUBLE PRECISION PHEP,VHEP
15997 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15998 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16000 C extension to standard particle data interface (PHOJET specific)
16001 INTEGER IMPART,IPHIST,ICOLOR
16002 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16003 C color string configurations including collapsed strings and hadrons
16005 PARAMETER (MSTR=500)
16006 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16007 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16008 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16009 & NNCH(MSTR),IBHAD(MSTR),ISTR
16011 DIMENSION PP1(4),PP2(4),PB1(4),PB2(4),GAM(3),GAMB(3),
16012 & PL(4,100),XMP(100),XML(100)
16014 DOUBLE PRECISION PYMASS
16019 IF(IMODE.GT.0) THEN
16021 I1 = JMOHEP(1,IMODE)
16022 I2 = ABS(JMOHEP(2,IMODE))
16023 C copy to local field
16028 PL(K,L) = PHEP(K,I)
16031 XML(L) = PYMASS(IDHEP(I))
16034 XMC = PHEP(5,IMODE)
16035 IF(IDEB(82).GE.20) THEN
16036 WRITE(LO,'(1X,A,I7,2I4)')
16037 & 'PHO_PARCOR: ini.momenta,masses(C/L),EV,ICH,L',
16040 WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16045 C two parton configurations
16046 C -----------------------------------------
16050 IF((XM1+XM2).GE.XMC) THEN
16051 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,/,5X,I3,3E12.4)')
16052 & 'PHO_PARCOR: REJECTION I,XM1,XM2,XMC',
16053 & IMODE,XM1,XM2,XMC
16056 C conversion possible
16057 CALL PHO_MSHELL(PL(1,1),PL(1,2),XM1,XM2,PP1,PP2,IREJ)
16059 IFAIL(36) = IFAIL(36)+1
16060 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,I4,E12.4)')
16061 & 'PHO_PARCOR: rejection by PHO_MSHELL EV,STRING,MASS',
16073 C multi parton configurations
16074 C ---------------------------------
16077 C random selection of string side to start with
16078 IF(DT_RNDM(XMC).LT.0.5D0) THEN
16100 IF(ITER.GT.2) GOTO 230
16102 C conversion according to color flow method
16104 DO 210 II=K1,K2-KS,KS
16105 DO 215 IK=II+KS,K2,KS
16108 * IF(IDEB(82).GE.10) WRITE(LO,'(1X,A,2I3,4E12.4)')
16109 * & 'PHO_PARCOR:I,K,XM(1-4)',II,IK,XM1,XMP(II),XM2,XMP(IK)
16110 IF((ABS(XM1-XMP(II)).GT.DELM)
16111 & .OR.(ABS(XM2-XMP(IK)).GT.DELM)) THEN
16112 CALL PHO_MSHELL(PL(1,II),PL(1,IK),XM1,XM2,PP1,PP2,IREJ)
16114 IFAIL(36) = IFAIL(36)+1
16115 IF(IDEB(82).GE.6) WRITE(LO,'(1X,2A,I8,3I4)')
16117 & 'int.rej. by PHO_MSHELL EV,IC,I1,I2',
16118 & KEVENT,IMODE,II,IK
16123 PL(KK,II) = PP1(KK)
16124 PL(KK,IK) = PP2(KK)
16137 IF(IFAI.NE.0) GOTO 300
16142 C conversion according to remainder method
16145 IF(ABS(XM1-XMP(I)).GT.DELM) THEN
16148 C conversion necessary
16151 PB2(K) = PHEP(K,IMODE)-PB1(K)
16153 XM2 = PB2(4)**2-PB2(1)**2-PB2(2)**2-PB2(3)**2
16154 IF(XM2.LT.0.D0) THEN
16155 IF(IDEB(82).GE.10) WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
16157 & 'int.rej. I,IPA,ICH,XML,XMP,XM2**2,MCHAIN',
16158 & I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
16162 IF((XM1+XM2).GE.XMC) THEN
16163 IF(IDEB(82).GE.10) WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
16165 & 'int.rej. I,IPA,ICH,XML,XMP,XM2,XMC',
16166 & I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
16169 C conversion possible
16170 CALL PHO_MSHELL(PB1,PB2,XM1,XM2,PP1,PP2,IREJ)
16172 IFAIL(36) = IFAIL(36)+1
16173 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,3I4)')
16174 & 'PHO_PARCOR: PHO_MSHELL rej. ITER,STRING,PARTON',
16178 C calculate Lorentz transformation
16179 CALL PHO_GETLTR(PB2,PP2,GAM,GAMB,DELE,IREJ)
16181 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,3I4)')
16182 & 'PHO_PARCOR: PHO_GETLTR rej. ITER,STRING,PARTON',
16187 C transform remaining partons
16190 CALL PHO_MKSLTR(PL(1,L),PP2,GAM,GAMB)
16205 C register transformed partons
16213 CALL PHO_REGPAR(-1,IDHEP(I),0,IMODE,0,PL(1,L),PL(2,L),
16214 & PL(3,L),PL(4,L),IPHIST(1,I),IPHIST(2,I),ICOLOR(1,I),
16215 & ICOLOR(2,I),IPOS,1)
16219 CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PHEP(1,IMODE),
16220 & PHEP(2,IMODE),PHEP(3,IMODE),PHEP(4,IMODE),IPHIST(1,IMODE),
16221 & IPHIST(2,IMODE),ICOLOR(1,IMODE),ICOLOR(2,IMODE),IPOS,1)
16223 I = IPHIST(1,IMODE)
16229 IF(IDEB(82).GE.20) THEN
16230 WRITE(LO,'(1X,A,I7,2I4)')
16231 & 'PHO_PARCOR: fin.momenta,masses(C/L),(EV,ICH,L)',
16234 WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16237 WRITE(LO,'(1X,A,2I5)')
16238 & 'PHO_PARCOR: conversion done (old/new ICH)',IMODE,IPOS
16244 IF(IDEB(82).GE.3) THEN
16245 WRITE(LO,'(/1X,A,/,5X,3I5,E12.4)')
16246 & 'PHO_PARCOR: rejection I,IPAR,ICHAIN,MCHAIN',
16247 & IFAI,IPAR,IMODE,XMC
16248 IF(IDEB(82).GE.5) THEN
16249 WRITE(LO,'(1X,A,I7,2I4)')
16250 & 'PHO_PARCOR: momenta,masses(C/L),(EV,ICH,L)',
16251 & KEVENT,IMODE,IPAR
16253 WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16260 ELSE IF(IMODE.EQ.-1) THEN
16264 ELSE IF(IMODE.EQ.-2) THEN
16270 *$ CREATE PHO_STRING.FOR
16272 CDECK ID>, PHO_STRING
16273 SUBROUTINE PHO_STRING(IMODE,IREJ)
16274 C********************************************************************
16276 C calculation of string combinatorics, Lorentz boosts and
16279 C - splitting of gluons
16280 C - strings will be built up from pairs of partons
16281 C according to their color labels
16282 C with IDHEP(..) = -1
16283 C - there can be other particles between to string partons
16284 C (these will be unchanged by string construction)
16285 C - string mass fine correction
16287 C input: IMODE 1 complete string processing
16288 C -1 initialization
16289 C -2 output of statistics
16292 C IREJ 1 combination of strings impossible
16293 C 0 successful combination
16294 C 50 rejection due to user cutoffs
16296 C********************************************************************
16297 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16300 PARAMETER ( DEPS = 1.D-15,
16303 C input/output channels
16305 COMMON /POINOU/ LI,LO
16306 C event debugging information
16308 PARAMETER (NMAXD=100)
16309 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16310 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16311 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16312 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16313 C general process information
16314 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
16315 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
16316 C internal rejection counters
16318 PARAMETER (NMXJ=60)
16319 CHARACTER*10 REJTIT
16321 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
16322 C model switches and parameters
16324 INTEGER ISWMDL,IPAMDL
16325 DOUBLE PRECISION PARMDL
16326 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16327 C hard cross sections and MC selection weights
16329 PARAMETER ( Max_pro_2 = 16 )
16330 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
16331 & MH_acc_1,MH_acc_2
16332 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
16333 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
16334 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
16335 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
16336 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
16337 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
16338 C standard particle data interface
16340 PARAMETER (NMXHEP=4000)
16341 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16342 DOUBLE PRECISION PHEP,VHEP
16343 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16344 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16346 C extension to standard particle data interface (PHOJET specific)
16347 INTEGER IMPART,IPHIST,ICOLOR
16348 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16349 C color string configurations including collapsed strings and hadrons
16351 PARAMETER (MSTR=500)
16352 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16353 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16354 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16355 & NNCH(MSTR),IBHAD(MSTR),ISTR
16356 C table of particle indices for recursive PHOJET calls
16358 PARAMETER ( MAXIPX = 100 )
16359 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
16360 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
16361 & IPOIX1,IPOIX2,IPOIX3
16363 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
16364 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
16365 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
16368 IF(IMODE.EQ.-1) THEN
16369 CALL PHO_POMCOR(-1)
16370 CALL PHO_MASCOR(-1)
16371 CALL PHO_PARCOR(-1,IREJ)
16373 ELSE IF(IMODE.EQ.-2) THEN
16374 CALL PHO_POMCOR(-2)
16375 CALL PHO_MASCOR(-2)
16376 CALL PHO_PARCOR(-2,IREJ)
16380 C generate enhanced graphs
16381 IF(IPOIX2.GT.0) THEN
16385 IF(ISWMDL(14).EQ.1) IPOIX1 = 0
16399 IF(IPORES(I).EQ.8) THEN
16405 IGEN = abs(IPHIST(2,IPOPOS(1,I)))
16406 CALL PHO_STDPAR(IPOPOS(1,I),IPOPOS(2,I),IGEN,
16407 & LSPOM,LSREG,LHPOM,LHDIR,IREJ)
16409 IF(IDEB(4).GE.2) THEN
16410 WRITE(LO,'(/1X,A,I5)')
16411 & 'PHO_STRING: sec.rejection by PHO_STDPAR',IREJ
16412 CALL PHO_PREVNT(-1)
16416 KSPOM = KSPOMS+LSPOM
16417 KSREG = KSREGS+LSREG
16418 KHPOM = KHPOMS+LHPOM
16419 KHDIR = KHDIRS+LHDIR
16420 ELSE IF(IPORES(I).EQ.4) THEN
16423 CALL PHO_CDIFF(IPOPOS(1,I),IPOPOS(2,I),MSOFT,MHARD,1,IREJ)
16426 IF(IDEB(4).GE.2) THEN
16427 WRITE(LO,'(/1X,A,I5)')
16428 & 'PHO_STRING: sec.rejection by PHO_CDIFF',IREJ
16429 CALL PHO_PREVNT(-1)
16434 KSPOM = KSPOMS+KSPOM
16435 KSREG = KSREGS+KSREG
16436 KHPOM = KHPOMS+KHPOM
16437 KHDIR = KHDIRS+KHDIR
16441 IF(IPORES(I).EQ.5) THEN
16444 ELSE IF(IPORES(I).EQ.6) THEN
16453 CALL PHO_DIFDIS(IDIF1,IDIF2,IPOPOS(1,I),IPOPOS(2,I),SPROB,
16454 & 0,MSOFT,MHARD,IREJ)
16457 IF(IDEB(4).GE.2) THEN
16458 WRITE(LO,'(/1X,A,I5)')
16459 & 'PHO_STRING: sec.rejection by PHO_DIFDIS',IREJ
16460 CALL PHO_PREVNT(-1)
16464 KSPOM = KSPOMS+KSPOM
16465 KSREG = KSREGS+KSREG
16466 KHPOM = KHPOMS+KHPOM
16467 KHDIR = KHDIRS+KHDIR
16473 IF(IPOIX2.GT.I2) THEN
16479 C optional: split gluons to q-qbar pairs
16480 IF(ISWMDL(9).GT.0) THEN
16483 IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).EQ.21)) THEN
16489 IF(ICOLOR(1,K).EQ.-ICG1) THEN
16491 IF(IQ1*IQ2.NE.0) GOTO 45
16492 ELSE IF(ICOLOR(1,K).EQ.-ICG2) THEN
16494 IF(IQ1*IQ2.NE.0) GOTO 45
16497 WRITE(LO,'(/1X,2A,3I6)') 'PHO_STRING:ERROR:(1) ',
16498 & 'no matching color found (IG,ICG1,ICG2)',I,ICG1,ICG2
16501 CALL PHO_GLU2QU(I,IQ1,IQ2,IREJ)
16503 IF(IDEB(19).GE.5) THEN
16504 WRITE(LO,'(/,1X,A)')
16505 & 'PHO_STRING: no gluon splitting possible'
16514 C construct strings and write entries sorted by strings
16519 IF(ISTR.GT.MSTR) THEN
16520 WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
16521 & 'event has too many strings (ISTR,MSTR):',ISTR,MSTR
16526 IF(ISTHEP(I).EQ.1) THEN
16527 C hadrons / resonances / clusters
16531 NPOS(4,ISTR) = abs(IPHIST(2,I))
16535 ELSE IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).NE.21)) THEN
16536 C quark /diquark terminated strings
16537 ICOL1 = -ICOLOR(1,I)
16542 ICH1 = IPHO_CHR3(I,2)
16543 IBA1 = IPHO_BAR3(I,2)
16544 CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
16545 & P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
16546 & ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
16552 IF(ISTHEP(K).EQ.-1)THEN
16553 IF(IDHEP(K).EQ.21) THEN
16554 IF(ICOLOR(1,K).EQ.ICOL1) THEN
16555 ICOL1 = -ICOLOR(2,K)
16557 ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
16558 ICOL1 = -ICOLOR(1,K)
16561 ELSE IF(ICOLOR(1,K).EQ.ICOL1) THEN
16567 WRITE(LO,'(/1X,A,I5)')
16568 & 'PHO_STRING:ERROR:(2) no matching color found for',-ICOL1
16575 NRPOM = MAX(NRPOM,IPHIST(1,K))
16576 ICH1 = ICH1+IPHO_CHR3(K,2)
16577 IBA1 = IBA1+IPHO_BAR3(K,2)
16578 CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
16579 & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
16580 & IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
16581 C further parton involved?
16582 IF(ICOL1.NE.0) GOTO 65
16586 CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
16587 & ISTR,IGEN,ICH1,IBA1,IPOS,1)
16588 C store additional string information
16589 NPOS(1,ISTR) = IPOS
16591 NPOS(3,ISTR) = -JM2
16592 NPOS(4,ISTR) = abs(IPHIST(2,K))
16593 C calculate CPC string codes
16594 CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
16595 & IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
16601 IF(ISTR.GT.MSTR) THEN
16602 WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
16603 & 'event has too many strings (ISTR,MSTR):',ISTR,MSTR
16608 IF(ISTHEP(I).EQ.-1) THEN
16609 C gluon loop-strings
16610 ICOL1 = -ICOLOR(1,I)
16617 CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
16618 & P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
16619 & ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
16624 IF(ICOLOR(2,I).EQ.ICOL1) GOTO 170
16626 IF(ISTHEP(K).EQ.-1)THEN
16627 IF(ICOLOR(1,K).EQ.ICOL1) THEN
16628 ICOL1 = -ICOLOR(2,K)
16630 ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
16631 ICOL1 = -ICOLOR(1,K)
16636 WRITE(LO,'(/1X,A,I5)')
16637 & 'PHO_STRING:ERROR:(3) no matching color found for',-ICOL1
16644 NRPOM = MAX(NRPOM,IPHIST(1,K))
16645 CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
16646 & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
16647 & IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
16648 C further parton involved?
16649 IF(ICOL1.NE.0) GOTO 165
16654 CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
16655 & ISTR,IGEN,ICH1,IBA1,IPOS,1)
16656 C store additional string information
16657 NPOS(1,ISTR) = IPOS
16659 NPOS(3,ISTR) = -JM2
16660 NPOS(4,ISTR) = abs(IPHIST(2,K))
16661 C calculate CPC string codes
16662 CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
16663 & IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
16670 IF(IDEB(19).GE.17) THEN
16671 WRITE(LO,'(1X,A)') 'PHO_STRING: after string construction'
16675 C pomeron corrections
16676 CALL PHO_POMCOR(IREJ)
16678 IFAIL(38) = IFAIL(38)+1
16679 IF(IDEB(19).GE.3) THEN
16680 WRITE(LO,'(1X,A,I6)')
16681 & 'PHO_STRING: rejection by PHO_POMCOR (IREJ)',IREJ
16682 CALL PHO_PREVNT(-1)
16687 C string mass corrections
16688 CALL PHO_MASCOR(IREJ)
16690 IFAIL(34) = IFAIL(34)+1
16691 IF(IDEB(19).GE.3) THEN
16692 WRITE(LO,'(1X,A,I6)')
16693 & 'PHO_STRING: rejection by PHO_MASCOR (IREJ)',IREJ
16694 CALL PHO_PREVNT(-1)
16699 C parton mass corrections
16701 IF(NCODE(I).GE.0) THEN
16702 CALL PHO_PARCOR(NPOS(1,I),IREJ)
16704 IFAIL(35) = IFAIL(35)+1
16705 IF(IDEB(19).GE.3) THEN
16706 WRITE(LO,'(1X,A,I6)')
16707 & 'PHO_STRING: rejection by PHO_PARCOR (IREJ)',IREJ
16708 CALL PHO_PREVNT(-1)
16715 C statistics of hard processes
16717 IF(ISTHEP(I).EQ.25) THEN
16720 MH_acc_2(K,II) = MH_acc_2(K,II)+1
16724 C debug: write out strings
16725 IF(IDEB(19).GE.5) THEN
16727 & CALL PHO_CHECK(1,IDEV)
16728 IF(IDEB(19).GE.15) THEN
16737 *$ CREATE PHO_STRFRA.FOR
16739 CDECK ID>, PHO_STRFRA
16740 SUBROUTINE PHO_STRFRA(IREJ)
16741 C********************************************************************
16743 C do all fragmentation of strings
16745 C output: IREJ 0 successful
16747 C 50 rejection due to user cutoffs
16749 C********************************************************************
16753 C input/output channels
16755 COMMON /POINOU/ LI,LO
16757 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
16758 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
16759 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
16760 C event debugging information
16762 PARAMETER (NMAXD=100)
16763 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16764 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16765 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16766 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16767 C general process information
16768 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
16769 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
16770 C model switches and parameters
16772 INTEGER ISWMDL,IPAMDL
16773 DOUBLE PRECISION PARMDL
16774 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16775 C global event kinematics and particle IDs
16776 INTEGER IFPAP,IFPAB
16777 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
16778 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
16779 C standard particle data interface
16781 PARAMETER (NMXHEP=4000)
16782 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16783 DOUBLE PRECISION PHEP,VHEP
16784 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16785 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16787 C extension to standard particle data interface (PHOJET specific)
16788 INTEGER IMPART,IPHIST,ICOLOR
16789 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16790 C color string configurations including collapsed strings and hadrons
16792 PARAMETER (MSTR=500)
16793 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16794 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16795 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16796 & NNCH(MSTR),IBHAD(MSTR),ISTR
16800 DOUBLE PRECISION PX,PY,PZ,HE,XMB,PT1,PT2,DUM
16801 INTEGER I,II,IJ,IFOUND,IP,IP_old,IPMOTH,IPOS,IBAM,IJOIN,
16802 & IGEN,IS,ISH,ISTR,J,K1,K2,NHEP1,NLINES
16804 integer indx(500),indx_max
16806 DOUBLE PRECISION DT_RNDM
16807 INTEGER ipho_pdg2id
16808 EXTERNAL DT_RNDM,ipho_pdg2id
16810 DOUBLE PRECISION PYP,RQLUN
16814 DOUBLE PRECISION PARU,PARJ
16815 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16817 DOUBLE PRECISION P,V
16818 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16820 DIMENSION IJOIN(100)
16823 IF(ABS(ISWMDL(6)).GT.3) THEN
16824 WRITE(LO,'(/1X,2A,I3)') 'PHO_STRFRA:ERROR: ',
16825 & 'invalid value of ISWMDL(6)',ISWMDL(6)
16829 C popcorn suppression
16830 IF(PARMDL(134).GT.0.D0) THEN
16831 IF(DT_RNDM(DUM).LT.PARMDL(134)) THEN
16838 C copy partons to fragmentation code JETSET
16844 C select partons with common production process
16846 if(IGEN.lt.0) goto 299
16850 if((IGEN.eq.NPOS(4,I)).or.(IPAMDL(17).eq.0)) then
16852 C write final particles/resonances to JETSET
16853 IF(NCODE(I).EQ.-99) THEN
16856 P(IP,1) = PHEP(1,II)
16857 P(IP,2) = PHEP(2,II)
16858 P(IP,3) = PHEP(3,II)
16859 P(IP,4) = PHEP(4,II)
16860 P(IP,5) = PHEP(5,II)
16862 K(IP,2) = IDHEP(II)
16867 if(indx_max.eq.500) then
16868 WRITE(LO,'(1x,2a,i8,I12)') 'PHO_STRFRA: ',
16869 & 'no space left in index vector (indx,Kevent)',
16874 indx_max = indx_max+1
16875 indx(indx_max) = II
16876 C write partons to JETSET
16877 ELSE IF(NCODE(I).GE.0) THEN
16878 K1 = JMOHEP(1,NPOS(1,I))
16879 K2 = MAX(JMOHEP(1,NPOS(1,I)),-JMOHEP(2,NPOS(1,I)))
16883 P(IP,1) = PHEP(1,II)
16884 P(IP,2) = PHEP(2,II)
16885 P(IP,3) = PHEP(3,II)
16886 P(IP,4) = PHEP(4,II)
16887 P(IP,5) = PHEP(5,II)
16889 K(IP,2) = IDHEP(II)
16896 indx_max = indx_max+1
16897 indx(indx_max) = II
16899 II = JMOHEP(2,NPOS(1,I))
16900 IF((II.GT.0).AND.(II.NE.K1)) THEN
16902 P(IP,1) = PHEP(1,II)
16903 P(IP,2) = PHEP(2,II)
16904 P(IP,3) = PHEP(3,II)
16905 P(IP,4) = PHEP(4,II)
16906 P(IP,5) = PHEP(5,II)
16908 K(IP,2) = IDHEP(II)
16915 indx_max = indx_max+1
16916 indx(indx_max) = II
16919 C connect partons to strings
16920 CALL PYJOIN(IJ,IJOIN)
16923 NPOS(4,I) = -NPOS(4,I)
16929 if(IP.eq.0) goto 299
16931 C hard final state evolution
16932 IF((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
16934 do 125 k1=1,indx_max
16936 IF(IPHIST(1,I).LE.-100) THEN
16943 IF(IJOIN(K1).EQ.0) GOTO 130
16945 IF((IPAMDL(102).EQ.1)
16946 & .AND.(IPHIST(1,I).NE.-100)) GOTO 130
16948 IF(IJOIN(K2).EQ.0) GOTO 135
16950 IF(IPHIST(1,I).EQ.IPHIST(1,II)) THEN
16951 PT1 = SQRT(PHEP(1,II)**2+PHEP(2,II)**2)
16952 PT2 = SQRT(PHEP(1,I)**2+PHEP(2,I)**2)
16953 RQLUN = MIN(PT1,PT2)
16954 IF(IDEB(22).GE.10) WRITE(LO,'(1X,A,2I5,E12.4)')
16955 & 'PHO_STRFRA: PYSHOW called',I,II,RQLUN
16956 CALL PYSHOW(IPHIST(2,I),IPHIST(2,II),RQLUN)
16966 C fragment parton / hadron configuration (hadronization & decay)
16968 IF(ISWMDL(6).NE.0) THEN
16974 if(MSTU(28).ne.0) then
16975 IF(IDEB(22).GE.10) THEN
16976 WRITE(LO,'(1X,A,I12,I3)')
16977 & 'PHO_STRFRA:(1) Lund code warning (EV/code)',
16983 IF(MSTU(24).NE.0) THEN
16984 IF(IDEB(22).GE.2) THEN
16985 WRITE(LO,'(1X,A,I12,I3)')
16986 & 'PHO_STRFRA:(1) rejection by Lund code (EV/code)',
16996 C change particle status in JETSET to avoid internal adjustments
16998 K(k1,1) = K(k1,1)+1000
17005 C restore original JETSET particle status codes
17007 K(i,1) = K(i,1)-1000
17010 * IF(IDEB(22).GE.25) THEN
17011 * WRITE(LO,'(//1X,2A)') 'PHO_STRFRA: ',
17012 * & 'particle/string system before fragmentation'
17013 * CALL PHO_PREVNT(2)
17016 C copy hadrons back to POEVT1 / POEVT2
17021 C copy hadrons back with full history information
17022 IF(IPAMDL(178).EQ.1) THEN
17024 IF(NCODE(II).GE.0) THEN
17025 K1 = IPHIST(2,NPOS(2,II))
17026 K2 = IPHIST(2,-NPOS(3,II))
17027 ELSE IF(NCODE(II).EQ.-99) THEN
17028 K1 = IPHIST(2,NPOS(1,II))
17035 IF(PYK(J,7).EQ.1) THEN
17037 IF((IPMOTH.GE.K1).AND.(IPMOTH.LE.K2)) THEN
17038 IBAM = ipho_pdg2id(PYK(J,8))
17039 IF((IBAM.EQ.0).AND.(ISWMDL(6).NE.0)) THEN
17040 IF(IDEB(22).GE.2) THEN
17041 WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
17042 & 'LUND interface (1) rejection'
17054 C register parton/hadron
17057 IF(ISWMDL(6).EQ.0) THEN
17060 IF(IDEB(22).GE.2) THEN
17061 WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
17062 & 'LUND interface (2) rejection'
17069 CALL PHO_REGPAR(IS,PYK(J,8),IBAM,NPOS(1,II),0,
17070 & PX,PY,PZ,HE,J,0,0,0,IPOS,1)
17075 IF(IFOUND.EQ.0) THEN
17076 IF(IDEB(2).GE.2) THEN
17077 WRITE(LO,'(2A,I12,I3)') 'PHO_STRFRA: ',
17078 & 'no particles found for string (EVE,ISTR):',KEVENT,II
17080 ISTHEP(NPOS(1,II)) = 2
17085 C copy hadrons back without history information
17086 JDAHEP(1,1) = NHEP1
17087 JDAHEP(1,2) = NHEP1
17089 IF(PYK(J,7).EQ.1) THEN
17090 IBAM = ipho_pdg2id(PYK(J,8))
17091 IF((IBAM.EQ.99999).AND.(ISWMDL(6).NE.0)) THEN
17092 IF(IDEB(22).GE.2) THEN
17093 WRITE(LO,'(/1X,A)')
17094 & 'PHO_STRFRA: LUND interface (3) rejection'
17105 C register parton/hadron
17108 IF(ISWMDL(6).EQ.0) THEN
17111 IF(IDEB(22).GE.2) THEN
17112 WRITE(LO,'(/1X,A)')
17113 & 'PHO_STRFRA: LUND interface (4) rejection'
17120 CALL PHO_REGPAR(IS,PYK(J,8),IBAM,1,2,PX,PY,PZ,
17121 & HE,J,0,0,0,IPOS,1)
17126 IF((NCODE(II).GE.0).OR.(NCODE(II).EQ.-99))
17127 & ISTHEP(NPOS(1,II)) = 2
17132 C debug event status
17133 IF(IDEB(22).GE.15) THEN
17134 WRITE(LO,'(//1X,A)')
17135 & 'PHO_STRFRA: particle system after fragmentation'
17141 *$ CREATE PHO_EVEINI.FOR
17143 CDECK ID>, PHO_EVEINI
17144 SUBROUTINE PHO_EVEINI(IMODE,P1,P2,IP1,IP2)
17145 C********************************************************************
17147 C prepare /POEVT1/ for new event
17149 C first subroutine called for each event
17151 C input: P1(4) particle 1
17153 C IMODE 0 general initialization
17154 C 1 initialization of particles and kinematics
17155 C 2 initialization after internal rejection
17157 C output: IP1,IP2 index of interacting particles
17159 C********************************************************************
17160 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17163 DIMENSION P1(4),P2(4)
17165 PARAMETER ( EPS = 1.D-5,
17168 C input/output channels
17170 COMMON /POINOU/ LI,LO
17171 C event debugging information
17173 PARAMETER (NMAXD=100)
17174 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17175 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17176 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17177 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17178 C model switches and parameters
17180 INTEGER ISWMDL,IPAMDL
17181 DOUBLE PRECISION PARMDL
17182 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17183 C general process information
17184 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
17185 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
17186 C gamma-lepton or gamma-hadron vertex information
17187 INTEGER IGHEL,IDPSRC,IDBSRC
17188 DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
17189 & RADSRC,AMSRC,GAMSRC
17190 COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
17191 & GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
17192 & IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
17193 C global event kinematics and particle IDs
17194 INTEGER IFPAP,IFPAB
17195 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
17196 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
17197 C energy-interpolation table
17199 PARAMETER ( IEETA2 = 20 )
17201 DOUBLE PRECISION SIGTAB,SIGECM
17202 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
17204 INTEGER IPFIL,IFAFIL,IFBFIL
17205 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
17206 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
17207 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
17208 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
17209 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
17210 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
17211 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
17212 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
17213 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
17214 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
17215 & IPFIL,IFAFIL,IFBFIL
17216 C color string configurations including collapsed strings and hadrons
17218 PARAMETER (MSTR=500)
17219 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
17220 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
17221 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
17222 & NNCH(MSTR),IBHAD(MSTR),ISTR
17223 C standard particle data interface
17225 PARAMETER (NMXHEP=4000)
17226 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
17227 DOUBLE PRECISION PHEP,VHEP
17228 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
17229 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
17231 C extension to standard particle data interface (PHOJET specific)
17232 INTEGER IMPART,IPHIST,ICOLOR
17233 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
17234 C table of particle indices for recursive PHOJET calls
17236 PARAMETER ( MAXIPX = 100 )
17237 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
17238 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
17239 & IPOIX1,IPOIX2,IPOIX3
17240 C event weights and generated cross section
17241 INTEGER IPOWGC,ISWCUT,IVWGHT
17242 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
17243 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
17244 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
17248 C reset debug variables
17267 IF(ISWMDL(14).GT.0) IPOIX1 = 1
17270 C reset /POEVT1/ and /POEVT2/
17271 CALL PHO_REGPAR(0,0,0,0,0,0.D0,0.D0,0.D0,0.D0,
17273 CALL PHO_SELCOL(0,0,0,0,0,0,0)
17278 C initialization of particle kinematics
17280 C lepton-photon/hadron-photon vertex and initial particles
17283 IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
17284 CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),0,0,PINI(1,1),PINI(2,1),
17285 & PINI(3,1),PINI(4,1),0,0,0,0,IM(1),1)
17287 CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
17288 & P1(4),0,0,0,0,IP1,1)
17290 IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
17291 CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),0,0,PINI(1,2),PINI(2,2),
17292 & PINI(3,2),PINI(4,2),0,0,0,0,IM(2),1)
17294 CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
17295 & P2(4),0,0,0,0,IP2,1)
17297 IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
17298 CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),IM(1),0,PFIN(1,1),
17299 & PFIN(2,1),PFIN(3,1),PFIN(4,1),0,10,0,0,IPOS,1)
17300 CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
17301 & P1(4),0,0,0,0,IP1,1)
17303 IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
17304 CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),IM(2),0,PFIN(1,2),
17305 & PFIN(2,2),PFIN(3,2),PFIN(4,2),0,10,0,0,IPOS,1)
17306 CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
17307 & P2(4),0,0,0,0,IP2,1)
17311 IF(IMODE.LE.1) THEN
17313 ECM = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
17314 & -(P1(3)+P2(3))**2)
17315 * CALL PHO_PECMS(1,PMASS(1),PMASS(2),ECM,PCM,EE)
17316 PMASS(1) = PHEP(5,IP1)
17318 IF(IFPAP(1).EQ.22) PVIRT(1) = PMASS(1)**2
17319 PMASS(2) = PHEP(5,IP2)
17321 IF(IFPAP(2).EQ.22) PVIRT(2) = PMASS(2)**2
17324 C cross section calculations
17326 IF(IMODE.NE.1) THEN
17328 CALL PHO_CSINT(IP,IFPAP(1),IFPAP(2),IGHEL(1),IGHEL(2),
17329 & ECM,PVIRT(1),PVIRT(2))
17332 IF(IMODE.LE.0) THEN
17333 C effective cross section
17335 IF(ISWMDL(2).ge.1) THEN
17336 IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGTOT-SIGELA-SIGVM(0,0)
17337 & -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)-SIGLDD
17339 IF(IPRON(2,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGELA
17340 IF(IPRON(3,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGVM(0,0)
17341 IF(IPRON(4,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGCDF(0)
17342 IF(IPRON(5,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(1)+SIGHSD(1)
17343 IF(IPRON(6,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(2)+SIGHSD(2)
17344 IF(IPRON(7,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLDD+SIGHDD
17345 IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
17346 C simulate only hard scatterings
17348 IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGHAR
17349 IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
17354 C reset of mother/daughter relations only (IMODE = 2)
17357 IF(IDEB(63).GE.15) THEN
17358 WRITE(LO,'(/1X,2A,I12,I3)') 'PHO_EVEINI: ',
17359 & '/POEVT1/ initialized (event/mode)',KEVENT,IMODE
17360 IF(IMODE.LE.0) THEN
17361 WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)') 'PHO_EVEINI: ',
17362 & 'current suppression factors total-1/2 hard-1/2 diff-1/2:',
17366 IDEB(57) = MAX(5,ITMP)
17367 CALL PHO_XSECT(1,0,ONEM)
17375 *$ CREATE PHO_CSINT.FOR
17377 CDECK ID>, PHO_CSINT
17378 SUBROUTINE PHO_CSINT(IP,IFPA,IFPB,IHLA,IHLB,ECM,PVIR2A,PVIR2B)
17379 C********************************************************************
17381 C calculate cross sections by interpolation
17383 C input: IP particle combination
17384 C IFPA/B particle PDG number
17385 C IHLA/B particle helicity (photons only)
17386 C ECM c.m. energy (GeV)
17387 C PVIR2A virtuality of particle A (GeV**2, positive)
17388 C PVIR2B virtuality of particle B (GeV**2, positive)
17390 C output: cross sections stored in /POCSEC/
17392 C********************************************************************
17393 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17396 PARAMETER ( EPS = 1.D-5,
17399 C input/output channels
17401 COMMON /POINOU/ LI,LO
17403 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
17404 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
17405 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
17406 C event debugging information
17408 PARAMETER (NMAXD=100)
17409 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17410 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17411 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17412 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17413 C model switches and parameters
17415 INTEGER ISWMDL,IPAMDL
17416 DOUBLE PRECISION PARMDL
17417 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17418 C energy-interpolation table
17420 PARAMETER ( IEETA2 = 20 )
17422 DOUBLE PRECISION SIGTAB,SIGECM
17423 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
17425 INTEGER IPFIL,IFAFIL,IFBFIL
17426 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
17427 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
17428 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
17429 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
17430 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
17431 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
17432 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
17433 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
17434 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
17435 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
17436 & IPFIL,IFAFIL,IFBFIL
17437 C hard cross sections and MC selection weights
17439 PARAMETER ( Max_pro_2 = 16 )
17440 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
17441 & MH_acc_1,MH_acc_2
17442 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
17443 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
17444 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
17445 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
17446 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
17447 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
17449 DIMENSION PVIRT(2),SIGSRH(2),FSUT(2),FSUL(2),IFPAP(2),IHEL(2)
17451 dimension PD(-6:6),FH_T(2),FH_L(2)
17454 IF(IDEB(15).GE.10) WRITE(LO,'(1X,A,/10X,I3,2I6,1P3E12.4)')
17455 & 'PHO_CSINT: called with IP, IFP1, IFP2, ECM, PVIR1, PVIR2',
17456 & IP,IFPA,IFPB,ECM,PVIR2A,PVIR2B
17458 C check currently stored cross sections
17459 IF((IP.EQ.IPFIL).AND.(ECM.EQ.ECMFIL)
17460 & .AND.(PVIR2A.EQ.P2AFIL).AND.(PVIR2B.EQ.P2BFIL)
17461 & .AND.(IFPA.EQ.IFAFIL).AND.(IFPB.EQ.IFBFIL)) THEN
17462 C nothing to calculate
17464 & WRITE(LO,'(1X,A)') 'PHO_CSINT: nothing done'
17468 C copy to local fields
17476 C load cross sections from interpolation table
17477 IF(ECM.LE.SIGECM(IP,1)) THEN
17480 ELSE IF(ECM.LE.SIGECM(IP,ISIMAX)) THEN
17482 IF(ECM.LE.SIGECM(IP,I)) GOTO 200
17488 WRITE(LO,'(/1X,A,2E12.3)')
17489 & 'PHO_CSINT: too high energy',ECM,SIGECM(IP,ISIMAX)
17490 CALL PHO_PREVNT(-1)
17495 IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
17496 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
17499 C cross section dependence on photon virtualities
17504 IF(IFPAP(K).EQ.22) THEN
17505 IF(ISWMDL(10).GE.1) THEN
17510 C GVDM factors for transverse/longitudinal photons
17512 FSUT(K) = FSUT(K)+PARMDL(26+I)
17513 & /(1.D0+PVIRT(K)/PARMDL(30+I))**2
17515 & +PARMDL(26+I)*PVIRT(K)/(4.D0*PARMDL(30+I))
17516 & /(1.D0+PVIRT(K)/PARMDL(30+I))**2
17518 FSUT(K) = FSUT(K)+PARMDL(30)/(1.D0+PVIRT(K)/PARMDL(34))
17520 IF((ABS(IHEL(K)).EQ.1).OR.(ISWMDL(10).EQ.1)) THEN
17522 FSUH(K) = FSUT(K)/(FSUT(K)+FSUL(K))
17523 C diffraction of trans. photons corresponds mainly to leading twist
17526 C longitudinal (scalar) part
17527 IF((IHEL(K).LE.0).OR.(ISWMDL(10).EQ.1)) THEN
17528 FSUP(K) = FSUP(K)+FSUL(K)
17529 FSUH(K) = FSUH(K)+FSUL(K)/(FSUT(K)+FSUL(K))
17530 C diffraction of long. photons corresponds mainly to higher twist
17531 FSUD(K) = 0.5D0*LOG(((ECM*PARMDL(45))**2+PVIRT(K))
17532 & /((0.765D0+PARMDL(46))**2+PVIRT(K)))
17533 & /LOG(ECM*PARMDL(45)/(0.765D0+PARMDL(46)))
17536 if(ideb(15).ge.10) then
17537 WRITE(LO,'(1x,2a,2i3,/,5x,1p5e12.4)') 'PHO_CSINT: ',
17538 & 'side,helicity,F_tran,F_long,F_eff,F_hard,F_diff',
17539 & K,IHEL(K),FSUT(K),FSUL(K),FSUP(K),FSUH(K),FSUD(K)
17545 FACP = FSUP(1)*FSUP(2)
17546 FACH = FSUH(1)*FSUH(2)
17547 FACD = FSUD(1)*FSUD(2)
17549 C matching of model cross section to F2(x,Q2,P2) in limit of Q2 >> P2
17551 if((IFPAP(1).eq.22).and.(IFPAP(2).eq.22)
17552 & .and.(IPAMDL(117).gt.0)) then
17553 C check kinematic limit
17554 Q2_max = max(PVIRT(1),PVIRT(2))
17555 Q2_min = min(PVIRT(1),PVIRT(2))
17556 if((Q2_max.gt.1.D0).and.(Q2_min.lt.1.D0)) then
17558 C calculate F2 from current parton density
17559 if(PVIRT(1).gt.PVIRT(2)) then
17566 X = Q2/(ECM**2+Q2+P2)
17567 call pho_actpdf(IFPAP(K),K)
17568 call pho_pdf(K,X,Q2,P2,PD)
17569 C light quark contribution
17572 F2_light = F2_light+Q_ch2(j)*(PD(j)+PD(-j))
17574 C heavy quark contribution
17575 call pho_qpmpdf(4,X,Q2,0.D0,P2,xpdf_c)
17576 F2_c = 2.D0*4.D0/9.D0*xpdf_c
17577 F2 = (F2_light+F2_c)
17579 C calculate model prediction
17580 SIGTOT = FAC2*SIGTAB(IP,1,I2)+FAC1*SIGTAB(IP,1,I1)
17581 SIGINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
17582 CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17584 if(ISWMDL(10).ge.2) then
17586 C calculate all helicity combinations
17587 if(IPAMDL(115).eq.0) then
17589 SIGSRH(1) = HSig(10)+HSig(11)
17590 SIGSRH(2) = HSig(12)+HSig(13)
17591 SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
17592 C photon helicity factors
17593 FH_T(1) = FSUT(1)/(FSUT(1)+FSUL(1))
17594 FH_L(1) = 1.D0-FH_T(1)
17595 FH_T(2) = FSUT(2)/(FSUT(2)+FSUL(2))
17596 FH_L(2) = 1.D0-FH_T(2)
17597 SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
17598 & + SIGDIH*FH_T(1)*FH_T(2)
17599 & + SIGSRH(1)*FH_T(1)*FSUT(2)
17600 & + SIGSRH(2)*FSUT(1)*FH_T(2)
17601 SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
17602 & + SIGDIH*FH_T(1)*FH_L(2)
17603 & + SIGSRH(1)*FH_T(1)*FSUL(2)
17604 & + SIGSRH(2)*FSUT(1)*FH_L(2)
17605 SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
17606 & + SIGDIH*FH_L(1)*FH_T(2)
17607 & + SIGSRH(1)*FH_L(1)*FSUT(2)
17608 & + SIGSRH(2)*FSUL(1)*FH_T(2)
17609 SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
17610 & + SIGDIH*FH_L(1)*FH_L(2)
17611 & + SIGSRH(1)*FH_L(1)*FSUL(2)
17612 & + SIGSRH(2)*FSUL(1)*FH_L(2)
17614 C use explicit PDF virtuality dependence (pre-tabulated)
17616 SIGSRH(1) = HSig(10)+HSig(11)
17617 SIGSRH(2) = HSig(12)+HSig(13)
17618 SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
17619 WRITE(LO,*) ' PHO_CSINT: invalid option for F2 matching'
17621 * CALL PHO_HARINT(IP,ECM,PVIRT(1),PVIRT(2),0,
17622 * & Max_pro_2,3,4,1)
17623 * SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
17624 * & + HSig(10)+HSig(12)+HSig(14)+HSig(16)+HSig(18)
17625 * SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
17626 * & + HSig(10)+HSig(12)+HSig(14)+HSig(16)+HSig(19)
17627 * SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
17628 * & + HSig(11)+HSig(13)+HSig(15)+HSig(17)+HSig(20)
17629 * SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
17630 * & + HSig(11)+HSig(13)+HSig(15)+HSig(17)+HSig(21)
17632 Xnu = Ecm*Ecm+Q2+P2
17633 F2_fac = Q2*Xnu/sqrt(Xnu*Xnu-Q2*P2)/(4.D0*Pi*Pi)
17636 F2m = F2_fac*(SIG_TT+SIG_LT-0.5D0*SIG_TL-0.5D0*SIG_LL)
17637 F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUL(1)*FSUT(2)
17638 & -0.5D0*FSUT(1)*FSUL(2)-0.5D0*FSUL(1)*FSUL(2))
17640 F2m = F2_fac*(SIG_TT+SIG_TL-0.5D0*SIG_LT-0.5D0*SIG_LL)
17641 F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUT(1)*FSUL(2)
17642 & -0.5D0*FSUL(1)*FSUT(2)-0.5D0*FSUL(1)*FSUL(2))
17647 C assume sig_eff = sigtot
17649 SIGSRH(1) = HSig(10)+HSig(11)
17650 SIGSRH(2) = HSig(12)+HSig(13)
17651 SIGtmp = SIGTOT-SIGSRH(1)-SIGSRH(2)-SIGDIH
17652 SIGeff = SIGtmp*FSUP(1)*FSUP(2)
17653 & +SIGSRH(1)*FSUP(2)+SIGSRH(2)*FSUP(1)+SIGDIH
17654 Xnu = Ecm*Ecm+Q2+P2
17655 F2_fac = Q2*Xnu/sqrt(Xnu*Xnu-Q2*P2)/(4.D0*Pi*Pi)
17657 F2m = F2_fac*SIGeff
17658 F2s = F2_fac*SIGtmp*FSUP(1)*FSUP(2)
17660 * WRITE(LO,*) ' PHO_CSINT: Q2_1,Q2_2,W ',PVIRT(1),PVIRT(2),Ecm
17661 * WRITE(LO,*) ' PHO_CSINT: F2_mod,F2_pdf,mod/pdf ',F2m,F2,F2m/F2
17663 C global factor to re-scale suppression of soft contributions
17664 Fcorr = (F2-F2m+F2s)/F2s
17665 * WRITE(LO,*) ' PHO_CSINT: re-scaling factor: ',Fcorr,FACP*Fcorr
17671 SIGTOT = (FAC2*SIGTAB(IP,1,I2)+FAC1*SIGTAB(IP,1,I1))*FACP
17672 SIGINE = (FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1))*FACP
17673 SIGELA = (FAC2*SIGTAB(IP,2,I2)+FAC1*SIGTAB(IP,2,I1))*FACP
17678 SIGVM(I,K) = (FAC2*SIGTAB(IP,J,I2)+FAC1*SIGTAB(IP,J,I1))
17683 SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
17684 SIGHAR = FAC2*SIGTAB(IP,58,I2)+FAC1*SIGTAB(IP,58,I1)
17685 C suppression of multi-pomeron graphs (diffraction)
17686 SIGLSD(1) = (FAC2*SIGTAB(IP,30,I2)+FAC1*SIGTAB(IP,30,I1))
17687 & *FACP*FSUP(2)*FSUD(1)
17688 SIGLSD(2) = (FAC2*SIGTAB(IP,31,I2)+FAC1*SIGTAB(IP,31,I1))
17689 & *FACP*FSUP(1)*FSUD(2)
17690 SIGHSD(1) = (FAC2*SIGTAB(IP,32,I2)+FAC1*SIGTAB(IP,32,I1))
17691 & *FACP*FSUP(2)*FSUD(1)
17692 SIGHSD(2) = (FAC2*SIGTAB(IP,33,I2)+FAC1*SIGTAB(IP,33,I1))
17693 & *FACP*FSUP(1)*FSUD(2)
17694 SIGLDD = (FAC2*SIGTAB(IP,34,I2)+FAC1*SIGTAB(IP,34,I1))
17696 SIGHDD = (FAC2*SIGTAB(IP,35,I2)+FAC1*SIGTAB(IP,35,I1))*FACP
17697 SIGCDF(0) = (FAC2*SIGTAB(IP,36,I2)+FAC1*SIGTAB(IP,36,I1))
17699 SIGTR1(1) = (FAC2*SIGTAB(IP,60,I2)+FAC1*SIGTAB(IP,60,I1))
17700 & *FACP*FSUP(2)*FSUD(1)
17701 SIGTR1(2) = (FAC2*SIGTAB(IP,61,I2)+FAC1*SIGTAB(IP,61,I1))
17702 & *FACP*FSUP(2)*FSUD(1)
17703 SIGTR2(1) = (FAC2*SIGTAB(IP,62,I2)+FAC1*SIGTAB(IP,62,I1))
17704 & *FACP*FSUP(1)*FSUD(2)
17705 SIGTR2(2) = (FAC2*SIGTAB(IP,63,I2)+FAC1*SIGTAB(IP,63,I1))
17706 & *FACP*FSUP(1)*FSUD(2)
17707 SIGLOO = (FAC2*SIGTAB(IP,64,I2)+FAC1*SIGTAB(IP,64,I1))*FACP
17708 SIGDPO(1) = (FAC2*SIGTAB(IP,65,I2)+FAC1*SIGTAB(IP,65,I1))
17710 SIGDPO(2) = (FAC2*SIGTAB(IP,66,I2)+FAC1*SIGTAB(IP,66,I1))
17712 SIGDPO(3) = (FAC2*SIGTAB(IP,67,I2)+FAC1*SIGTAB(IP,67,I1))
17714 SIGDPO(4) = (FAC2*SIGTAB(IP,68,I2)+FAC1*SIGTAB(IP,68,I1))
17717 C corrections due to photon virtuality dependence of PDFs
17718 if(iswmdl(2).eq.1) then
17719 CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17720 C minimum bias event generation
17721 IF(IPAMDL(115).GE.1) THEN
17722 C all the virtuality dependence is given by PDF parametrization
17723 SIGHIN = FAC2*SIGTAB(IP,80,I2)+FAC1*SIGTAB(IP,80,I1)
17724 IF(IPAMDL(116).GE.2) THEN
17725 C direct interaction according to full QPM calculation
17727 SIGSRH(1) = HSig(10)+HSig(11)
17728 SIGSRH(2) = HSig(12)+HSig(13)
17730 C direct interaction suppressed according to helicity factor
17731 SIGDIH = HSig(14)*FACH
17732 SIGSRH(1) = (HSig(10)+HSig(11))*FSUH(1)
17733 SIGSRH(2) = (HSig(12)+HSig(13))*FSUH(2)
17735 WRITE(LO,*) ' PHO_CSINT: option not supported yet'
17738 C rescale relevant hard processes
17740 SIGSRH(1) = HSig(10)+HSig(11)
17741 SIGSRH(2) = HSig(12)+HSig(13)
17742 SIGtmp = SIGINE-(SIGDIH+SIGSRH(1)+SIGSRH(2))*FACP
17743 SIGDIR = HSig(14)*FACH+SIGSRH(1)*FSUH(1)*FSUP(2)
17744 & +SIGSRH(2)*FSUP(1)*FSUH(2)
17745 SIGINE = SIGtmp+SIGDIR
17746 SIGTOT = SIGINE+SIGELA
17749 C only hard interactions
17750 CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17751 SIGSRH(1) = (HSig(10)+HSig(11))*FSUH(1)
17752 SIGSRH(2) = (HSig(12)+HSig(13))*FSUH(2)
17753 SIGDIR = HSig(14)+SIGSRH(1)+SIGSRH(2)
17754 SIGHAR = HSig(9)*FACH
17757 SIG1SO = (FAC2*SIGTAB(IP,37,I2)+FAC1*SIGTAB(IP,37,I1))*FACP
17758 SIG1HA = (FAC2*SIGTAB(IP,38,I2)+FAC1*SIGTAB(IP,38,I1))*FACH
17759 SLOEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
17764 SLOVM(I,K) = FAC2*SIGTAB(IP,J,I2)+FAC1*SIGTAB(IP,J,I1)
17767 SIGPOM = (FAC2*SIGTAB(IP,56,I2)+FAC1*SIGTAB(IP,56,I1))*FACP
17768 SIGREG = (FAC2*SIGTAB(IP,57,I2)+FAC1*SIGTAB(IP,57,I1))*FACP
17778 & WRITE(LO,'(1X,A)') 'PHO_CSINT: cross sections calculated'
17784 *$ CREATE PHO_PRIMKT.FOR
17786 CDECK ID>, PHO_PRIMKT
17787 SUBROUTINE PHO_PRIMKT(IMODE,IF,IL,PTCUT,IREJ)
17788 C***********************************************************************
17790 C give primordial kt to partons entering hard scatterings and
17791 C remants connected to hard parton-parton interactions by color flow
17793 C input: IMODE -2 output of statistics
17794 C -1 initialization
17795 C 1 sampling of primordial kt
17796 C IF first entry in /POEVT1/ to check
17797 C IL last entry in /POEVT1/ to check
17798 C PTCUT current value of PTCUT to distinguish
17799 C between soft and hard
17801 C output: IREJ 0 success
17804 C***********************************************************************
17808 DOUBLE PRECISION DEPS
17809 PARAMETER ( DEPS = 1.D-15 )
17811 INTEGER IMODE,IF,IL,IREJ
17812 DOUBLE PRECISION PTCUT
17814 C input/output channels
17816 COMMON /POINOU/ LI,LO
17817 C event debugging information
17819 PARAMETER (NMAXD=100)
17820 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17821 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17822 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17823 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17824 C model switches and parameters
17826 INTEGER ISWMDL,IPAMDL
17827 DOUBLE PRECISION PARMDL
17828 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17830 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
17831 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
17832 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
17833 C data of c.m. system of Pomeron / Reggeon exchange
17834 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
17835 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
17836 & SIDP,CODP,SIFP,COFP
17837 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
17838 & SIDP,CODP,SIFP,COFP,NPOSP(2),
17839 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
17840 C hard scattering data
17842 PARAMETER ( MSCAHD = 50 )
17843 INTEGER LSCAHD,LSC1HD,LSIDX,
17844 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
17845 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
17846 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
17847 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
17848 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
17849 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
17850 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
17851 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
17852 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
17853 C standard particle data interface
17855 PARAMETER (NMXHEP=4000)
17856 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
17857 DOUBLE PRECISION PHEP,VHEP
17858 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
17859 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
17861 C extension to standard particle data interface (PHOJET specific)
17862 INTEGER IMPART,IPHIST,ICOLOR
17863 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
17865 DOUBLE PRECISION PTS,XP,XP2,POLD,PNEW,GA,PP
17866 DIMENSION PTS(0:2,5),XP(5),
17867 & XP2(5,2),POLD(2,2),PNEW(4,2),GA(4),PP(4)
17869 INTEGER IROTT,IBALT,IBAL,IV,IV2,IRMAX
17871 PARAMETER (IRMAX=200)
17872 DIMENSION IROTT(IRMAX),IBALT(5,2),IBAL(2),IV(5),IV2(5,2)
17874 DOUBLE PRECISION SI,EI,SF,EF,PTOT,EE,XX,YY,ZZ,ANORF,FAC,DEL,PT2,
17875 & DEL2,GAE,GAZ,SID,COD,SIF,COF,ESUM
17876 INTEGER IROT,I,J,K,NHD,ISTART,INEXT,ICOM
17879 IF(IDEB(10).GE.10) WRITE(LO,'(1X,A,3I4,1P,E11.3)')
17880 & 'PHO_PRIMKT: called with IMODE,IF,IL,PTCUT',
17881 & IMODE,IF,IL,PTCUT
17883 C give primordial kt to partons engaged in a hard scattering
17885 IF(IMODE.EQ.1) THEN
17897 IF(ISTHEP(I).EQ.25) THEN
17898 C hard scattering number
17899 NHD = IPHIST(1,I+1)
17902 C calculate momenta of incoming partons
17903 POLD(1,1) = XHD(K,1)*ECMP/2.D0
17904 POLD(2,1) = POLD(1,1)
17905 POLD(1,2) = -XHD(K,2)*ECMP/2.D0
17906 POLD(2,2) = -POLD(1,2)
17915 C search for partons involved in hard interaction
17919 IF(ABS(ISTHEP(I)).EQ.1) THEN
17920 C hard scatterd partons (including ISR)
17921 IF((IPHIST(1,I).EQ.-NHD)
17922 & .OR.(IPHIST(1,I).EQ.NHD+1)
17923 & .OR.(IPHIST(1,I).EQ.NHD+2)) THEN
17925 IF(IROT.GT.IRMAX) THEN
17926 WRITE(LO,'(1X,/,2A,2I5)') 'PHO_PRIMKT: ',
17927 & 'no memory left in IROTT, event rejected (max/IROT)',
17935 ELSE IF(IPHIST(1,I).EQ.NHD) THEN
17936 IF(PHEP(3,I).GT.0.D0) THEN
17941 IBAL(J) = IBAL(J)+1
17942 IBALT(IBAL(J),J) = I
17943 XP2(IBAL(J),J) = PHEP(3,I)/ECMP
17944 IF(ISWMDL(24).EQ.0) THEN
17946 IF(IDHEP(I).NE.21) IV2(IBAL(J),J) = ICOLOR(2,I)
17947 ELSE IF(ISWMDL(24).EQ.1) THEN
17948 IV2(IBAL(J),J) = -1
17953 C possibly further hard scattering
17954 ELSE IF(ISTHEP(I).EQ.25) THEN
17963 if(IDEB(10).ge.15) then
17964 WRITE(LO,'(1X,2A,I4)') 'PHO_PRIMKT: ',
17965 & 'hard scattering number: ',NHD/100
17966 WRITE(LO,'(1X,2A,I5)') 'PHO_PRIMKT: ',
17967 & 'number of entries to rotate: ',IROT
17969 WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
17970 & 'entries to rotate: ',I,IROTT(I)
17972 WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
17973 & 'number of entries to balance: ',IBAL
17976 WRITE(LO,'(1X,2A,I2,2I5)')
17977 & 'PHO_PRIMKT: entries to balance (side,no,line)',
17983 C incoming partons (comment lines), skip direct interacting particles
17985 IF((IDHEP(ICOM+K).NE.22).AND.(IDHEP(ICOM+K).NE.990)) THEN
17986 IF(PHEP(3,ICOM+K).GT.0.D0) THEN
17991 IBAL(J) = IBAL(J)+1
17992 IBALT(IBAL(J),J) = -ICOM-K
17993 XP2(IBAL(J),J) = POLD(1,J)/ECMP
17994 IV2(IBAL(J),J) = -1
17998 C check consistency
17999 IF((IBAL(1).GT.4).OR.(IBAL(2).GT.4)) THEN
18000 WRITE(LO,'(1X,2A,I10)') 'PHO_PRIMKT: ',
18001 & 'inconsistent hard scattering remnant for event: ',KEVENT
18002 WRITE(LO,'(1X,A,3I4,1P,E11.3)')
18003 & 'PHO_PRIMKT called with IMODE,IF,IL,PTCUT',
18004 & IMODE,IF,IL,PTCUT
18005 WRITE(LO,'(1X,A,I4)') 'hard scattering number: ',NHD/100
18007 WRITE(LO,'(1X,A,2I5)') 'entries to rotate',I,IROTT(I)
18011 WRITE(LO,'(1X,A,I2,2I5)')
18012 & 'entries to balance (side,no,line)',J,I,IBALT(I,J)
18015 IF(IBAL(1)+IBAL(2).GT.0) CALL PHO_PREVNT(0)
18018 C calculate primordial kt
18021 IF((IBAL(1).GT.1).OR.(IBAL(2).GT.1)) THEN
18023 C add transverse momentum (overwrite /POEVT1/ entries)
18025 IF(IBAL(J).GT.1) THEN
18026 C sample from truncated distribution
18033 CALL PHO_SOFTPT(K,PTCUT,PTCUT,XP,IV,PTS)
18034 IF(PTS(0,K).GE.PARMDL(100)) GOTO 190
18035 C transform incoming partons of hard scattering
18036 DEL = ABS(POLD(1,J))+POLD(2,J)
18039 PNEW(1,J) = PTS(1,K)
18040 PNEW(2,J) = PTS(2,K)
18041 PNEW(3,J) = (-1)**J*(PT2 - DEL2)/(2.D0*DEL)
18042 PNEW(4,J) = (DEL2 + PT2)/(2.D0*DEL)
18043 C spectator partons
18045 DO 220 I=1,IBAL(J)-1
18047 PHEP(1,K) = PHEP(1,K)+PTS(1,I)
18048 PHEP(2,K) = PHEP(2,K)+PTS(2,I)
18049 ESUM = ESUM+PHEP(4,K)
18051 C long. momentum transfer
18052 PP(3) = PNEW(3,J) - POLD(1,J)
18053 PP(4) = PNEW(4,J) - POLD(2,J)
18054 DO 230 I=1,IBAL(J)-1
18056 FAC = PHEP(4,K)/ESUM
18057 PHEP(3,K) = PHEP(3,K) - FAC*PP(3)
18058 PHEP(4,K) = PHEP(4,K) - FAC*PP(4)
18062 IF(IDEB(10).GE.15) THEN
18063 WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
18064 & 'old incoming:',J,0.D0,0.D0,(POLD(I,J),I=1,2)
18065 WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
18066 & 'new incoming:',J,(PNEW(I,J),I=1,4)
18072 PNEW(3,J) = POLD(1,J)
18073 PNEW(4,J) = POLD(2,J)
18077 C transformation of hard scattering final states (including ISR)
18079 C old parton c.m. energy
18080 SI = (POLD(2,1)+POLD(2,2))**2-(POLD(1,1)+POLD(1,2))**2
18082 C new parton c.m. energy
18083 SF = (PNEW(4,1)+PNEW(4,2))**2-(PNEW(1,1)+PNEW(1,2))**2
18084 & -(PNEW(2,1)+PNEW(2,2))**2-(PNEW(3,1)+PNEW(3,2))**2
18088 IF(IDEB(10).GE.25) WRITE(LO,'(1X,A,1P,E12.4)')
18089 & 'PHO_PRIMKT: scaling factor (E-final/E-initial): ',FAC
18091 C calculate Lorentz transformation
18092 GAZ = -(POLD(1,1)+POLD(1,2))/EI
18093 GAE = (POLD(2,1)+POLD(2,2))/EI
18095 GA(I) = (PNEW(I,1)+PNEW(I,2))/EF
18097 CALL PHO_ALTRA(GA(4),-GA(1),-GA(2),-GA(3),PNEW(1,1),PNEW(2,1),
18098 & PNEW(3,1),PNEW(4,1),PTOT,PP(1),PP(2),PP(3),PP(4))
18099 PTOT = MAX(DEPS,PTOT)
18101 SID= SQRT(PP(1)**2+PP(2)**2)/PTOT
18104 IF(PTOT*SID.GT.1.D-5) THEN
18105 COF=PP(1)/(SID*PTOT)
18106 SIF=PP(2)/(SID*PTOT)
18107 ANORF=SQRT(COF*COF+SIF*SIF)
18113 C check consistency initial/final configuration before rotation
18114 IF(IDEB(10).GE.25) THEN
18115 WRITE(LO,'(1X,A,1P,4E11.3)') 'PHO_PRIMKT: ini. momentum (1):',
18116 & 0.D0,0.D0,(POLD(I,1)+POLD(I,2),I=1,2)
18123 PP(J) = PP(J)+PHEP(J,K)
18126 WRITE(LO,'(1X,A,1P,4E11.3)')
18127 & 'PHO_PRIMKT: fin. momentum (1):',PP
18130 C apply rotation/boost to scattered particles
18134 PP(J) = FAC*PHEP(J,K)
18136 CALL PHO_ALTRA(GAE,0.D0,0.D0,GAZ,PP(1),PP(2),PP(3),
18137 & PP(4),PTOT,PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
18138 CALL PHO_TRANS(PHEP(1,K),PHEP(2,K),PHEP(3,K),
18139 & COD,SID,COF,SIF,XX,YY,ZZ)
18141 CALL PHO_ALTRA(GA(4),GA(1),GA(2),GA(3),XX,YY,ZZ,EE,PTOT,
18142 & PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
18146 C check consistency initial/final configuration after rotation
18147 IF(IDEB(10).GE.25) THEN
18149 PP(I) = PNEW(I,1)+PNEW(I,2)
18151 WRITE(LO,'(1X,A,1P,4E11.3)')
18152 & 'PHO_PRIMKT: ini. momentum (2):',PP
18159 PP(J) = PP(J)+PHEP(J,K)
18162 WRITE(LO,'(1X,A,1P,4E11.3)')
18163 & 'PHO_PRIMKT: fin. momentum (2):',PP
18168 IF(INEXT.EQ.1) GOTO 100
18172 ELSE IF(IMODE.EQ.-1) THEN
18174 C output of statistics etc.
18176 ELSE IF(IMODE.EQ.-2) THEN
18181 WRITE(LO,'(/1X,A,I4)')
18182 & 'PHO_PRIMKT:ERROR: invalid value of IMODE:',IMODE
18188 *$ CREATE PHO_PARTPT.FOR
18190 CDECK ID>, PHO_PARTPT
18191 SUBROUTINE PHO_PARTPT(IMODE,IF,IL,PTCUT,IREJ)
18192 C********************************************************************
18194 C assign to soft partons
18196 C input: IMODE -2 output of statistics
18197 C -1 initialization
18198 C 0 sampling of pt for soft partons belonging to
18200 C 1 sampling of pt for soft partons belonging to
18202 C IF first entry in /POEVT1/ to check
18203 C IL last entry in /POEVT1/ to check
18204 C PTCUT current value of PTCUT to distinguish
18205 C between soft and hard
18207 C output: IREJ 0 success
18210 C (soft pt is sampled by call to PHO_SOFTPT)
18212 C********************************************************************
18213 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18216 PARAMETER ( DEPS = 1.D-15 )
18218 INTEGER IMODE,IF,IL,IREJ
18219 DOUBLE PRECISION PTCUT
18221 C input/output channels
18223 COMMON /POINOU/ LI,LO
18224 C event debugging information
18226 PARAMETER (NMAXD=100)
18227 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18228 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18229 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18230 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18231 C model switches and parameters
18233 INTEGER ISWMDL,IPAMDL
18234 DOUBLE PRECISION PARMDL
18235 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18237 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
18238 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
18239 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
18240 C data of c.m. system of Pomeron / Reggeon exchange
18241 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18242 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18243 & SIDP,CODP,SIFP,COFP
18244 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18245 & SIDP,CODP,SIFP,COFP,NPOSP(2),
18246 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
18247 C standard particle data interface
18249 PARAMETER (NMXHEP=4000)
18250 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
18251 DOUBLE PRECISION PHEP,VHEP
18252 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
18253 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
18255 C extension to standard particle data interface (PHOJET specific)
18256 INTEGER IMPART,IPHIST,ICOLOR
18257 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
18259 DOUBLE PRECISION PTS,PB,XP,XPB,PC
18260 DIMENSION PTS(0:2,50),PB(0:2,2),XP(50),XPB(2),PC(4)
18262 INTEGER MODIFY,IV,IVB
18263 DIMENSION MODIFY(50),IV(50),IVB(2)
18266 IF(IDEB(6).GE.10) WRITE(LO,'(1X,A,3I4,1P,E11.3)')
18267 & 'PHO_PARTPT: called with IMODE,IF,IL,PTCUT',
18268 & IMODE,IF,IL,PTCUT
18270 IF(IMODE.LT.0) GOTO 1000
18273 IF((ISWMDL(3).EQ.10).AND.(ISWMDL(4).EQ.10)) RETURN
18275 C count entries to modify
18284 IF(IMODE.EQ.0) THEN
18286 IF((ISTHEP(I).EQ.-1).AND.(ABS(IPHIST(1,I)).LT.100)) THEN
18289 XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
18291 IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
18292 IF(PHEP(4,I).LT.EMIN) THEN
18299 C hard Pomeron associated remnants (IPHIST(1,)=100,200,...)
18301 ELSE IF(IMODE.EQ.1) THEN
18304 IF((ISTHEP(I).EQ.-1).AND.(IPHIST(1,I).GE.100)) THEN
18305 IF(MOD(IPHIST(1,I),100).EQ.0) THEN
18308 XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
18309 IF(ISWMDL(24).EQ.0) THEN
18311 IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
18312 ELSE IF(ISWMDL(24).EQ.1) THEN
18317 IF(PHEP(4,I).LT.EMIN) THEN
18328 WRITE(LO,'(/1X,A,I5)') 'PHO_PARTPT:ERROR: invalid mode',IMODE
18333 IF(IDEB(6).GE.5) THEN
18334 WRITE(LO,'(1X,2A,3I4)') 'PHO_PARTPT: ',
18335 & 'number of partons, IPEAK,MODE',IENTRY,IPEAK,IMODE
18336 IF(IDEB(6).GE.20) CALL PHO_PREVNT(0)
18340 IF(IENTRY.LE.1) RETURN
18342 C sample pt of soft partons
18344 IF(ISWMDL(5).LE.1) THEN
18346 IPEAK = DT_RNDM(DUM)*IENTRY+1
18347 CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
18348 CALL PHO_SWAPD(XP(IPEAK),XP(1))
18349 CALL PHO_SWAPI(IV(IPEAK),IV(1))
18351 C energy limited sampling
18355 IF(ITER.GE.1000) THEN
18356 IF(IDEB(6).GE.3) THEN
18357 WRITE(LO,'(1X,A,3I5)')
18358 & 'PHO_PARTPT: rejection for MODE,ENTRY,ITER',
18359 & IMODE,IENTRY,ITER
18360 WRITE(LO,'(8X,A,I5)') 'I II IV XP EP',
18364 WRITE(LO,'(5X,3I5,1P,2E13.4)')
18365 & I,II,IV(I),XP(I),PHEP(4,II)
18367 IF(IDEB(6).GE.5) CALL PHO_PREVNT(0)
18374 PTMX = MIN(PHEP(4,II),PTCUT)
18377 IF(ISWMDL(5).EQ.0) THEN
18378 CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
18380 CALL PHO_SOFTPT(1,PTMX,PTMX,XPB,IVB,PB)
18385 PSUMX = PSUMX+PB(1,1)
18386 PSUMY = PSUMY+PB(2,1)
18388 PTREM = SQRT(PSUMX**2+PSUMY**2)
18389 IF(PTREM.GT.MIN(PHEP(4,MODIFY(1)),PTCUT)) GOTO 400
18392 ELSE IF((ISWMDL(5).EQ.2)
18393 & .OR.((IMODE.EQ.1).AND.(ISWMDL(5).EQ.3))) THEN
18394 C unlimited sampling
18395 IPEAK = DT_RNDM(PSUMX)*IENTRY+1
18396 CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
18397 CALL PHO_SWAPD(XP(IPEAK),XP(1))
18398 CALL PHO_SWAPI(IV(IPEAK),IV(1))
18399 CALL PHO_SOFTPT(IENTRY,PTCUT,PTCUT,XP,IV,PTS)
18400 ELSE IF(ISWMDL(5).EQ.3) THEN
18401 C each string has balanced pt
18403 IF(IV(K).LE.-90) GOTO 499
18405 IC1 = -ICOLOR(1,I1)
18406 DO 510 L=K+1,IENTRY
18407 IF(ICOLOR(1,MODIFY(L)).EQ.IC1) GOTO 511
18409 WRITE(LO,'(//1X,A,I5)')
18410 & 'PHO_PARTPT:ERROR: no color found for (line,color)',I1,-IC1
18414 AMSQR = (PHEP(4,I1)+PHEP(4,I2))**2-(PHEP(1,I1)+PHEP(1,I2))**2
18415 & -(PHEP(2,I1)+PHEP(2,I2))**2-(PHEP(3,I1)+PHEP(3,I2))**2
18418 IVB(1) = MAX(IV(K),IV(L))
18420 CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
18423 PTS(1,L) = -PB(1,1)
18424 PTS(2,L) = -PB(2,1)
18425 GAM = (PHEP(4,I1)+PHEP(4,I2))/AM
18426 GAMBEZ = (PHEP(3,I1)+PHEP(3,I2))/AM
18429 PLONG = SQRT(PTMX**2-PB(0,1)**2+1.D-12)
18430 PC(3) = SIGN(PLONG,PHEP(3,I1))
18432 CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
18433 & PTOT,PHEP(1,I1),PHEP(2,I1),PHEP(3,I1),PHEP(4,I1))
18437 CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
18438 & PTOT,PHEP(1,I2),PHEP(2,I2),PHEP(3,I2),PHEP(4,I2))
18444 WRITE(LO,'(/1X,A,I4)')
18445 & 'PHO_PARTPT:ERROR: invalid value of ISWMDL(5):',ISWMDL(5)
18449 C change partons in /POEVT1/
18451 IF(IV(II).GT.-90) THEN
18453 PHEP(1,I) = PHEP(1,I)+PTS(1,II)
18454 PHEP(2,I) = PHEP(2,I)+PTS(2,II)
18455 AMSQR = PHEP(4,I)**2
18456 & -PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
18457 PHEP(5,I) = SIGN(SQRT(ABS(AMSQR)),AMSQR)
18462 IF(IDEB(6).GE.15) THEN
18463 WRITE(LO,'(1X,A,/,8X,A,I5)') 'PHO_PARTPT: table of momenta',
18464 & 'I II IV XP EP PTS PTX PTY',IPEAK
18467 WRITE(LO,'(2X,3I5,1P,5E12.4)')
18468 & I,II,IV(I),XP(I),PHEP(4,II),PTS(0,I),PTS(1,I),PTS(2,I)
18474 C initialization / output of statistics
18476 CALL PHO_SOFTPT(IMODE,PTM,PTM,XP,IV,PTS)
18480 *$ CREATE PHO_SOFTPT.FOR
18482 CDECK ID>, PHO_SOFTPT
18483 SUBROUTINE PHO_SOFTPT(ISOFT,PTCUT,PTMAX,XV,IV,PTSOF)
18484 C***********************************************************************
18486 C select pt of soft string ends
18488 C input: ISOFT number of soft partons
18489 C -1 initialization
18490 C >=0 sampling of p_t
18491 C -2 output of statistics
18492 C PTCUT cutoff for soft strings
18493 C PTMAX maximal allowed PT
18494 C XV field of x values
18498 C output: /POINT3/ containing parameters AAS,BETAS
18499 C PTSOF filed with soft pt values
18501 C note: ISWMDL(3/4) = 0 dNs/dP_t = P_t ASS * exp(-BETA*P_t**2)
18502 C ISWMDL(3/4) = 1 dNs/dP_t = P_t ASS * exp(-BETA*P_t)
18503 C ISWMDL(3/4) = 2 photon wave function
18504 C ISWMDL(3/4) = 10 no soft P_t assignment
18506 C***********************************************************************
18507 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18510 PARAMETER ( DEPS = 1.D-15)
18512 DIMENSION PTSOF(0:2,*),XV(*)
18515 C input/output channels
18517 COMMON /POINOU/ LI,LO
18518 C event debugging information
18520 PARAMETER (NMAXD=100)
18521 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18522 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18523 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18524 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18525 C model switches and parameters
18527 INTEGER ISWMDL,IPAMDL
18528 DOUBLE PRECISION PARMDL
18529 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18530 C data of c.m. system of Pomeron / Reggeon exchange
18531 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18532 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18533 & SIDP,CODP,SIFP,COFP
18534 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18535 & SIDP,CODP,SIFP,COFP,NPOSP(2),
18536 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
18537 C data on most recent hard scattering
18538 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
18539 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
18540 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
18541 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
18542 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
18543 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
18544 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
18545 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
18546 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
18547 C data needed for soft-pt calculation
18548 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18549 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18551 DIMENSION BETAB(100)
18554 IF(ISOFT.GE.0) THEN
18555 CALLS = CALLS + 1.D0
18556 C sample according to model ISWMDL(3-6)
18557 IF(ISOFT.GT.1) THEN
18564 IF(IV(I).EQ.1) THEN
18566 C photon/pomeron valence part
18567 IF(IPAMDL(5).EQ.1) THEN
18568 IF(XV(I).GE.0.D0) THEN
18569 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
18574 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
18579 ELSE IF(IPAMDL(5).EQ.2) THEN
18581 ELSE IF(IPAMDL(5).EQ.3) THEN
18585 ELSE IF(IV(I).EQ.0) THEN
18587 C hard scattering remnant
18589 IF(IPAMDL(6).EQ.0) THEN
18591 ELSE IF(IPAMDL(6).EQ.1) THEN
18597 BETA = MAX(BETA,0.01D0)
18598 CALL PHO_SELPT(XV(I),0.D0,PTCUT,PTS,BETA,IMODE)
18599 PTS = MIN(PTMAX,PTS)
18600 CALL PHO_SFECFE(SIG,COG)
18602 PTSOF(1,I) = COG*PTS
18603 PTSOF(2,I) = SIG*PTS
18604 PTXS = PTXS+PTSOF(1,I)
18605 PTYS = PTYS+PTSOF(2,I)
18608 C balancing of momenta
18609 PTS = SQRT(PTXS**2+PTYS**2)
18610 IF(PTS.GE.PTMAX) GOTO 210
18618 C single parton only
18622 IF(IV(1).EQ.1) THEN
18624 C photon/Pomeron valence part
18625 IF(IPAMDL(5).EQ.1) THEN
18626 IF(XV(1).GE.0.D0) THEN
18627 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
18632 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
18637 ELSE IF(IPAMDL(5).EQ.2) THEN
18639 ELSE IF(IPAMDL(5).EQ.3) THEN
18643 ELSE IF(IV(1).EQ.0) THEN
18645 C hard scattering remnant
18647 IF(IPAMDL(6).EQ.1) THEN
18653 BETA = MAX(BETA,0.01D0)
18654 CALL PHO_SELPT(XV(1),0.D0,PTCUT,PTS,BETA,IMODE)
18655 PTS = MIN(PTMAX,PTS)
18656 CALL PHO_SFECFE(SIG,COG)
18658 PTSOF(1,1) = COG*PTS
18659 PTSOF(2,1) = SIG*PTS
18663 IF(IDEB(29).GE.10) THEN
18664 WRITE(LO,'(1X,A,I4)') 'PHO_SOFTPT: ISOFT',ISOFT
18665 WRITE(LO,'(6X,A)') 'TABLE OF I, IV, XV, PT, PT-X, PT-Y, BETA'
18667 WRITE(LO,'(10X,2I3,1P,5E12.3)') I,IV(I),XV(I),PTSOF(0,I),
18668 & PTSOF(1,I),PTSOF(2,I),BETAB(I)
18672 C initialization of statistics and parameters
18674 ELSE IF(ISOFT.EQ.-1) THEN
18677 IMODE = -100+ISWMDL(3)
18678 CALL PHO_SELPT(ECMP,PTSMIN,PTSMAX,PTS,BETAS(3),IMODE)
18680 C output of statistics
18682 ELSE IF(ISOFT.EQ.-2) THEN
18684 WRITE(LO,'(1X,2A,I2)') 'PHO_SOFTPT:ERROR: ',
18685 & 'unsupported ISOFT ',ISOFT
18690 *$ CREATE PHO_SELPT.FOR
18692 CDECK ID>, PHO_SELPT
18693 SUBROUTINE PHO_SELPT(EE,PTLOW,PTHIGH,PTS,BETA,IMODE)
18694 C***********************************************************************
18696 C select pt from different distributions
18698 C input: EE energy (for initialization only)
18699 C otherwise x value of corresponding parton
18700 C PTLOW lower pt limit
18701 C PTHIGH upper pt limit
18702 C (PTHIGH > 20 will cause DEXP underflows)
18704 C IMODE = 0 dNs/dP_t = P_t * ASS * exp(-BETA*P_t**2)
18705 C IMODE = 1 dNs/dP_t = P_t * ASS * exp(-BETA*P_t)
18706 C IMODE = 2 dNs/dP_t according photon wave function
18707 C IMODE = 10 no sampling
18709 C IMODE = -100+IMODE initialization according to
18710 C given limitations
18712 C output: PTS sampled pt value
18714 C BETA soft pt slope in central region
18716 C***********************************************************************
18717 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18720 PARAMETER ( PI2 = 6.28318530718D0,
18725 C input/output channels
18727 COMMON /POINOU/ LI,LO
18728 C event debugging information
18730 PARAMETER (NMAXD=100)
18731 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18732 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18733 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18734 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18735 C model switches and parameters
18737 INTEGER ISWMDL,IPAMDL
18738 DOUBLE PRECISION PARMDL
18739 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18740 C data of c.m. system of Pomeron / Reggeon exchange
18741 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18742 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18743 & SIDP,CODP,SIFP,COFP
18744 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18745 & SIDP,CODP,SIFP,COFP,NPOSP(2),
18746 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
18747 C average number of cut soft and hard ladders (obsolete)
18748 DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
18749 COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
18750 C data needed for soft-pt calculation
18751 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18752 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18754 DOUBLE PRECISION PHO_CONN0,PHO_CONN1
18755 EXTERNAL PHO_CONN0,PHO_CONN1
18759 IF(IMODE.LT.0) GOTO 100
18766 IF(PX.LT.AMIN) RETURN
18768 IF((PX-PTLOW).LT.0.01) THEN
18769 IF(IDEB(5).GE.3) WRITE(LO,'(1X,A,2E12.3,I3)')
18770 & 'PHO_SELPT: PTLOW,PTHIGH,IMODE ',PTLOW,PTHIGH,IMODE
18774 C sampling of pt values according to IMODE
18776 IF(IMODE.EQ.0) THEN
18778 FAC1 = EXP(-BETA*PX**2)
18781 XI1 = DT_RNDM(PX)*FAC2 + FAC1
18782 PTS = SQRT(-1.D0/BETA*LOG(XI1))
18783 IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 25
18785 ELSE IF(IMODE.EQ.1) THEN
18787 XIMIN = EXP(-BETA*PTHIGH)
18790 PTS = -LOG((XIDEL*DT_RNDM(XIDEL)+XIMIN)
18791 & *(XIDEL*DT_RNDM(XIMIN)+XIMIN)+DEPS)/BETA
18792 IF(PTS.LT.XMT) GOTO 50
18793 PTS = SQRT(PTS**2-XMT2)
18794 IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 50
18796 ELSE IF(IMODE.EQ.2) THEN
18798 IF(EE.GE.0.D0) THEN
18804 AA = (1.D0-XV)*XV*P2+PARMDL(25)
18806 PTS = SQRT(AA/(DT_RNDM(PX)+EPS)-AA)
18807 IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 75
18811 ELSE IF(IMODE.NE.10) THEN
18812 WRITE(LO,'(/1X,A,I4)') 'PHO_SELPT:ERROR: invalid IMODE',IMODE
18817 IF(IDEB(5).GE.20) THEN
18818 WRITE(LO,'(1X,A,I3,4E10.3)')
18819 & 'PHO_SELPT: MODE,BET,PTMI,PTMA,PT',
18820 & IMODE,BETA,PTLOW,PTHIGH,PTS
18829 C calculation of parameters
18833 C initialization for model 0 (gaussian pt distribution)
18836 BETAS(1) = PARMDL(23)+0.15D0*LOG(EE)*(PARMDL(24)-PARMDL(23))
18839 XTOL = PHO_CONN0(BETLO)*PHO_CONN0(BETUP)
18840 IF(XTOL.LT.0.D0) THEN
18845 BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN0,METHOD)
18846 * IF(BETA.LT.-1.D+10) THEN
18847 * WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
18848 * & '(model 0: Ecm,PTcut)',EE,PTCON
18849 * WRITE(LO,'(1X,A,1P,3E10.3)')
18850 * & 'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
18851 * CALL PHO_PREVNT(-1)
18854 AAS = DSIGHP/PTCON*EXP(-BETA*PTCON**2)
18861 C initialization for model 1 (exponential pt distribution)
18863 ELSE IF(INIT.EQ.1) THEN
18866 BETAS(1) = PARMDL(21)+0.15D0*LOG(EE)*(PARMDL(22)-PARMDL(21))
18869 XTOL = PHO_CONN1(BETLO)*PHO_CONN1(BETUP)
18870 IF(XTOL.LT.0.D0) THEN
18875 BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN1,METHOD)
18876 * IF(BETA.LT.-1.D+10) THEN
18877 * WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
18878 * & '(model 1: Ecm,PTcut)',EE,PTCON
18879 * WRITE(LO,'(1X,A,1P,3E10.3)')
18880 * & 'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
18881 * CALL PHO_PREVNT(-1)
18884 AAS = DSIGHP/PTCON*EXP(-BETA*PTCON)
18890 ELSE IF(INIT.EQ.10) THEN
18892 & WRITE(LO,'(/1X,A)') 'PHO_SELPT: no soft pt sampling'
18895 WRITE(LO,'(1X,A,I4)') 'PHO_SELPT:ERROR: invalid distribution',
18899 BETA = MIN(BETA,BETAS(1))
18901 C hard cross section is too big: neg. beta parameter
18902 IF(BETA.LE.0.D0) THEN
18903 WRITE(LO,'(1X,A,1P,2E12.3)')
18904 & 'PHO_SELPT: parameter BETA negative (BETA,AAS)',BETA,AAS
18905 WRITE(LO,'(1X,A,1P,4E11.3)') 'SIGS,DSIGHP,SIGH,PTCON:',
18906 & SIGS,DSIGHP,SIGH,PTCON
18907 CALL PHO_PREVNT(-1)
18910 C output of initialization parameters
18911 IF(IDEB(5).GE.10) THEN
18912 WRITE(LO,'(1X,A,I3)') 'PHO_SELPT: initialization for model',
18914 WRITE(LO,'(5X,A,1P,2E13.3)')
18915 & 'BETA,AAS ',BETA,AAS
18916 WRITE(LO,'(5X,A,1P,3E13.3)')
18917 & 'ECM,PTMIN,PTMAX ',EE,PTSMIN,PTSMAX
18918 WRITE(LO,'(5X,A,1P,3E13.3)')
18919 & 'SIGS,DSIGHP,SIGH',SIGS,DSIGHP,SIGH
18924 *$ CREATE PHO_CONN0.FOR
18926 CDECK ID>, PHO_CONN0
18927 DOUBLE PRECISION FUNCTION PHO_CONN0(BETA)
18928 C***********************************************************************
18930 C auxiliary function to determine parameters of soft
18931 C pt distribution dNs/dP_t = P_t * AAS * EXP(-BETA*P_t**2)
18933 C internal factors: FS number of soft partons in soft Pomeron
18934 C FH number of soft partons in hard Pomeron
18936 C***********************************************************************
18940 C input/output channels
18942 COMMON /POINOU/ LI,LO
18943 C average number of cut soft and hard ladders (obsolete)
18944 DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
18945 COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
18946 C data needed for soft-pt calculation
18947 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18948 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18950 DOUBLE PRECISION BETA,XX,FF
18953 IF(ABS(XX).LT.1.D-3) THEN
18954 FF = FS*SIGS+FH*SIGH
18955 & - DSIGHP*(PTCON/2.D0+PTCON**3*BETA/4.D0)
18957 FF = FS*SIGS+FH*SIGH
18958 & - DSIGHP/(2.D0*PTCON*BETA)*(EXP(XX)-1.D0)
18962 * WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:BETA,AAS,FF',BETA,AAS,FF
18963 * WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP
18967 *$ CREATE PHO_CONN1.FOR
18969 CDECK ID>, PHO_CONN1
18970 DOUBLE PRECISION FUNCTION PHO_CONN1(BETA)
18971 C***********************************************************************
18973 C auxiliary function to determine parameters of soft
18974 C pt distribution dNs/dP_t = P_t * AAS * EXP(-BETA*P_t)
18976 C internal factors: FS number of soft partons in soft Pomeron
18977 C FH number of soft partons in hard Pomeron
18979 C***********************************************************************
18983 C input/output channels
18985 COMMON /POINOU/ LI,LO
18986 C average number of cut soft and hard ladders (obsolete)
18987 DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
18988 COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
18989 C data needed for soft-pt calculation
18990 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18991 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18993 DOUBLE PRECISION BETA,XX,FF
18996 IF(ABS(XX).LT.1.D-3) THEN
18997 FF = FS*SIGS+FH*SIGH
18998 & - DSIGHP*(PTCON/2.D0+PTCON**2*BETA/6.D0)
19000 FF = FS*SIGS+FH*SIGH
19001 & - DSIGHP/(PTCON*BETA**2)*(EXP(XX)-1.D0-BETA*PTCON)
19005 * WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:BETA,AAS,FF',BETA,AAS,FF
19006 * WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP
19010 *$ CREATE PHO_MSHELL.FOR
19012 CDECK ID>, PHO_MSHELL
19013 SUBROUTINE PHO_MSHELL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
19014 C********************************************************************
19016 C rescaling of momenta of two partons to put both
19019 C input: PA1,PA2 input momentum vectors
19020 C XM1,2 desired masses of particles afterwards
19021 C P1,P2 changed momentum vectors
19023 C********************************************************************
19024 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19027 PARAMETER ( DEPS = 1.D-20 )
19029 DIMENSION PA1(*),PA2(*),P1(*),P2(*)
19031 C input/output channels
19033 COMMON /POINOU/ LI,LO
19034 C event debugging information
19036 PARAMETER (NMAXD=100)
19037 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19038 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19039 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19040 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19041 C internal rejection counters
19043 PARAMETER (NMXJ=60)
19044 CHARACTER*10 REJTIT
19046 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19051 IF(IDEB(40).GE.10) THEN
19052 WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
19053 WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
19054 WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
19055 WRITE(LO,'(5X,A,2E12.3)') 'new masses:',XM1,XM2
19058 C Lorentz transformation into system CMS
19063 XMS = EE**2-PX**2-PY**2-PZ**2
19064 IF(XMS.LT.(XM1+XM2)**2) THEN
19066 IFAIL(37) = IFAIL(37)+1
19068 if((xm1.gt.1.D4).or.(xm2.gt.1.D4)) irej = irej/idev
19070 IF(IDEB(40).GE.3) THEN
19071 WRITE(LO,'(/1X,A,I12)')
19072 & 'PHO_MSHELL:reject: too small string mass (KEVENT)',KEVENT
19073 WRITE(LO,'(5X,A,3E12.4)') 'two-part.mass, part.masses:',
19074 & SIGN(SQRT(ABS(XMS)),XMS),XM1,XM2
19075 WRITE(LO,'(5X,A,4E11.4)') 'PX,PY,PZ,EE:',PX,PY,PZ,EE
19077 IF(IDEB(40).GE.3) GOTO 55
19086 CALL PHO_ALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
19087 & PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
19089 PTOT1 = MAX(DEPS,PTOT1)
19091 SID = SQRT(P1(1)**2+P1(2)**2)/PTOT1
19094 IF(PTOT1*SID.GT.1.D-5) THEN
19095 COF = P1(1)/(SID*PTOT1)
19096 SIF = P1(2)/(SID*PTOT1)
19097 ANORF = SQRT(COF*COF+SIF*SIF)
19102 C new CM momentum and energies (for masses XM1,XM2)
19106 PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*XMS)
19107 EE1 = SQRT(XM12+PCMP**2)
19110 CALL PHO_TRANS(0.D0,0.D0,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
19111 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
19112 & PTOT1,P1(1),P1(2),P1(3),P1(4))
19113 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
19114 & PTOT2,P2(1),P2(2),P2(3),P2(4))
19116 C check consistency
19118 IF(ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
19120 ELSE IF(ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
19122 ELSE IF(ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
19124 ELSE IF(ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
19130 WRITE(LO,'(1X,A,I3)')
19131 & 'PHO_MSHELL: inconsistent transformation (IDEV)',IDEV
19132 WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
19133 WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
19134 WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
19135 WRITE(LO,'(5X,A,3E12.3)') 'ava.mass,masses:',XMS,XM1,XM2
19136 WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
19137 WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
19138 WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
19139 ELSE IF(IDEB(40).GE.10) THEN
19140 WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
19141 WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
19142 WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
19146 *$ CREATE PHO_GLU2QU.FOR
19148 CDECK ID>, PHO_GLU2QU
19149 SUBROUTINE PHO_GLU2QU(IG,IQ1,IQ2,IREJ)
19150 C********************************************************************
19152 C split gluon with index I in POEVT1
19153 C (massless gluon assumed)
19157 C IQ1 first quark index
19158 C IQ2 second quark index
19160 C output: new quarks in /POEVT1/
19161 C IREJ 1 splitting impossible
19162 C 0 splitting successful
19164 C********************************************************************
19165 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19168 PARAMETER ( DEPS = 1.D-15,
19171 C input/output channels
19173 COMMON /POINOU/ LI,LO
19174 C event debugging information
19176 PARAMETER (NMAXD=100)
19177 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19178 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19179 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19180 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19181 C model switches and parameters
19183 INTEGER ISWMDL,IPAMDL
19184 DOUBLE PRECISION PARMDL
19185 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
19186 C standard particle data interface
19188 PARAMETER (NMXHEP=4000)
19189 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
19190 DOUBLE PRECISION PHEP,VHEP
19191 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
19192 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
19194 C extension to standard particle data interface (PHOJET specific)
19195 INTEGER IMPART,IPHIST,ICOLOR
19196 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
19197 C internal rejection counters
19199 PARAMETER (NMXJ=60)
19200 CHARACTER*10 REJTIT
19202 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19204 DIMENSION P1(4),P2(4)
19209 C calculate string masses max possible
19210 IF(ISWMDL(9).EQ.1) THEN
19211 CMASS1=2.D0*(PHEP(4,IG)*PHEP(4,IQ1)-PHEP(1,IG)*PHEP(1,IQ1)
19212 & -PHEP(2,IG)*PHEP(2,IQ1)-PHEP(3,IG)*PHEP(3,IQ1))
19213 IF(CMASS1.LT.CUTM) THEN
19214 IF(IDEB(73).GE.5) THEN
19215 WRITE(LO,'(1X,A,3I4,4E10.3)')
19216 & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS1',IG,IQ1,IQ2,CMASS1
19218 IFAIL(33) = IFAIL(33) + 1
19222 CMASS2=2.D0*(PHEP(4,IG)*PHEP(4,IQ2)-PHEP(1,IG)*PHEP(1,IQ2)
19223 & -PHEP(2,IG)*PHEP(2,IQ2)-PHEP(3,IG)*PHEP(3,IQ2))
19224 IF(CMASS2.LT.CUTM) THEN
19225 IF(IDEB(73).GE.5) THEN
19226 WRITE(LO,'(1X,A,3I4,4E10.3)')
19227 & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS2',IG,IQ1,IQ2,CMASS2
19229 IFAIL(33) = IFAIL(33) + 1
19234 C calculate minimal z
19235 ZMIN1 = (CUTM-SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))/CMASS1+EPS
19236 ZMIN2 = (CUTM-SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))/CMASS2+EPS
19237 ZMIN = MIN(ZMIN1,ZMIN2)
19238 IF(MAX(ZMIN1,ZMIN2).GE.0.45D0) THEN
19239 IF(IDEB(73).GE.5) THEN
19240 WRITE(LO,'(1X,A,3I3,4E10.3)')
19241 & 'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,ZMIN1,ZMIN2,P1*PG,P2*PG',
19242 & IG,IQ1,IQ2,ZMIN1,ZMIN2,CMASS1,CMASS2
19244 IFAIL(33) = IFAIL(33) + 1
19249 ZMIN = MIN(0.1D0,0.5D0/PHEP(4,IG))
19252 ZFRAC = PHO_GLUSPL(ZMIN)
19253 IF((ZFRAC.LT.ZMIN1).OR.((1.D0-ZFRAC).LT.ZMIN2)) THEN
19257 P1(I) = PHEP(I,IG)*ZFRAC
19258 P2(I) = PHEP(I,IG)*(1.D0-ZFRAC)
19261 CMASS1 = SQRT(ZFRAC*CMASS1+SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))
19262 CMASS2 = SQRT((1.D0-ZFRAC)*CMASS2
19263 & +SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))
19264 CALL PHO_SEAFLA(IG,K,I,MIN(CMASS1,CMASS2))
19265 IF(ABS(IDHEP(IQ1)).GT.6) THEN
19266 K = SIGN(ABS(K),IDHEP(IQ1))
19268 K = -SIGN(ABS(K),IDHEP(IQ1))
19272 IC1 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
19273 IC2 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
19275 IC1 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
19276 IC2 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
19278 C register new partons
19279 CALL PHO_REGPAR(-1,K,0,IG,0,P1(1),P1(2),P1(3),P1(4),
19280 & IPHIST(1,IG),0,IC1,0,IPOS,1)
19281 CALL PHO_REGPAR(-1,-K,0,IG,0,P2(1),P2(2),P2(3),P2(4),
19282 & IPHIST(1,IG),0,IC2,0,IPOS,1)
19284 IF(IDEB(73).GE.20) THEN
19285 WRITE(LO,'(1X,A,/1X,A,3I3,5E10.3)')
19286 & 'PHO_GLU2QU:',' IG,IQ1,IQ2,ZMIN1,2,Z,P1*PG,P2*PG',
19287 & IG,IQ1,IQ2,ZMIN1,ZMIN2,ZFRAC,CMASS1,CMASS2
19288 WRITE(LO,'(1X,A,4I5)') ' flavours, colors ',
19293 *$ CREATE PHO_GLUSPL.FOR
19295 CDECK ID>, PHO_GLUSPL
19296 DOUBLE PRECISION FUNCTION PHO_GLUSPL(ZMIN)
19297 C*********************************************************************
19299 C calculate quark - antiquark light cone momentum fractions
19300 C according to Altarelli-Parisi g->q aq splitting function
19301 C (symmetric z interval assumed)
19303 C input: ZMIN minimal Z value allowed,
19304 C 1-ZMIN maximal Z value allowed
19306 C********************************************************************
19307 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19310 PARAMETER ( ALEXP= 0.3333333333D0,
19313 C input/output channels
19315 COMMON /POINOU/ LI,LO
19316 C event debugging information
19318 PARAMETER (NMAXD=100)
19319 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19320 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19321 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19322 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19324 IF(ZMIN.GE.0.5D0) THEN
19325 IF(IDEB(69).GT.2) THEN
19326 WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN>=0.5',ZMIN
19330 ELSE IF(ZMIN.LE.0.D0) THEN
19331 IF(IDEB(69).GT.2) THEN
19332 WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN<=0',ZMIN
19341 ZZ = ((1.D0-XI)*ZMINL**3+XI*ZMAX**3)**ALEXP
19342 IF(DT_RNDM(ZZ).LT.0.5D0) ZZ = 1.D0-ZZ
19345 IF(IDEB(69).GE.10) THEN
19346 WRITE(LO,'(1X,A,2E12.4)') 'PHO_GLUSPL: ZMIN,Z ',ZMIN,ZZ
19351 *$ CREATE PHO_STDPAR.FOR
19353 CDECK ID>, PHO_STDPAR
19354 SUBROUTINE PHO_STDPAR(IJM1,IJM2,IGEN,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
19355 C***********************************************************************
19357 C select the initial parton x-fractions and flavors and
19358 C the final parton momenta and flavours
19359 C for standard Pomeron/Reggeon cuts
19361 C input: IJM1 index of mother particle 1 in /POEVT1/
19362 C IJM2 index of mother particle 2 in /POEVT1/
19363 C IGEN production process of mother particles
19364 C MSPOM soft cut Pomerons
19365 C MHPOM hard or semihard cut Pomerons
19366 C MSREG soft cut Reggeons
19367 C MHDIR direct hard processes
19369 C IJM1 -1 initialization of statistics
19370 C -2 output of statistics
19372 C output: partons are directly written to /POEVT1/,/POEVT2/
19374 C structure of /POSOFT/
19375 C XS1(I),XS2(I): x-values of initial partons
19376 C IJSI1(I),IJSI2(I): flavor of initial parton
19379 C negative antiquarks
19380 C IJSF1(I),IJSF2(I): flavor of final state partons
19381 C PSOFT1(I,J),PSOFT2(I,J): final part. momentum and energy
19387 C***********************************************************************
19388 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19391 PARAMETER (RHOMAS = 0.766D0,
19395 C input/output channels
19397 COMMON /POINOU/ LI,LO
19398 C event debugging information
19400 PARAMETER (NMAXD=100)
19401 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19402 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19403 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19404 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19405 C model switches and parameters
19407 INTEGER ISWMDL,IPAMDL
19408 DOUBLE PRECISION PARMDL
19409 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
19411 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
19412 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
19413 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
19414 C general process information
19415 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
19416 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
19417 C global event kinematics and particle IDs
19418 INTEGER IFPAP,IFPAB
19419 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
19420 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
19421 C data of c.m. system of Pomeron / Reggeon exchange
19422 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
19423 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
19424 & SIDP,CODP,SIFP,COFP
19425 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
19426 & SIDP,CODP,SIFP,COFP,NPOSP(2),
19427 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
19428 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
19429 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
19430 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
19431 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
19432 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
19433 C obsolete cut-off information
19434 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
19435 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
19436 C currently activated parton density parametrizations
19438 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
19439 DOUBLE PRECISION PDFLAM,PDFQ2M
19440 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
19441 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
19442 C hard scattering parameters used for most recent hard interaction
19444 DOUBLE PRECISION ALQCD2,BQCD
19445 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
19446 C particles created by initial state evolution
19447 INTEGER MXISR1,MXISR2
19448 PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
19449 INTEGER IFLISR,IPOISR,IMXISR
19450 DOUBLE PRECISION PHISR
19451 COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
19452 & IPOISR(2,2,MXISR2),IMXISR(2)
19453 C light-cone x fractions and c.m. momenta of soft cut string ends
19455 PARAMETER ( MAXSOF = 50 )
19456 INTEGER IJSI2,IJSI1
19457 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
19458 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
19459 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
19460 & IJSI1(MAXSOF),IJSI2(MAXSOF)
19461 C table of particle indices for recursive PHOJET calls
19463 PARAMETER ( MAXIPX = 100 )
19464 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
19465 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
19466 & IPOIX1,IPOIX2,IPOIX3
19467 C hard scattering data
19469 PARAMETER ( MSCAHD = 50 )
19470 INTEGER LSCAHD,LSC1HD,LSIDX,
19471 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
19472 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
19473 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
19474 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
19475 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
19476 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
19477 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
19478 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
19479 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
19480 C standard particle data interface
19482 PARAMETER (NMXHEP=4000)
19483 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
19484 DOUBLE PRECISION PHEP,VHEP
19485 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
19486 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
19488 C extension to standard particle data interface (PHOJET specific)
19489 INTEGER IMPART,IPHIST,ICOLOR
19490 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
19491 C internal rejection counters
19493 PARAMETER (NMXJ=60)
19494 CHARACTER*10 REJTIT
19496 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19497 C internal cross check information on hard scattering limits
19498 DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
19499 COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)
19500 C hard cross sections and MC selection weights
19502 PARAMETER ( Max_pro_2 = 16 )
19503 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
19504 & MH_acc_1,MH_acc_2
19505 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
19506 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
19507 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
19508 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
19509 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
19510 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
19512 double precision pho_alphas
19514 DIMENSION PC(4),IFLA(2),ICI(2,2)
19516 IF(IJM1.EQ.-1) THEN
19519 ETAMA(1,I) = -1.D10
19521 ETAMA(2,I) = -1.D10
19527 CALL PHO_HARSCA(IJM1,1)
19528 CALL PHO_HARCOL(IJM1,0.D0,0,0,0,0,0,0,0,0,0,0,0,0)
19532 ELSE IF(IJM1.EQ.-2) THEN
19534 C output internal statistics
19535 IF(IDEB(23).GE.1) THEN
19536 WRITE(LO,'(/1X,A)')
19537 & 'kinematic limits particle c (ETAMIN,ETAMAX,XMIN,XMAX)'
19539 WRITE(LO,'(5X,I3,4E13.5)')
19540 & I,ETAMI(1,I),ETAMA(1,I),XXMI(1,I),XXMA(1,I)
19543 & 'kinematic limits particle d (ETAMIN,ETAMAX,XMIN,XMAX)'
19545 WRITE(LO,'(5X,I3,4E13.5)')
19546 & I,ETAMI(2,I),ETAMA(2,I),XXMI(2,I),XXMA(2,I)
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)
19557 IF(IDEB(23).GT.5) WRITE(LO,221) IJM1,IJM2,MSPOM,MHPOM,MSREG,MHDIR
19558 221 FORMAT (' PHO_STDPAR: JM1/2,MSPOM,MHPOM,MSREG,MHDIR ',6I5)
19560 C get mother data (exchange if first particle is a pomeron)
19561 IF((IDHEP(IJM1).EQ.990).AND.(IFPAP(1).NE.990)) THEN
19571 IDPDG1 = IDHEP(JM1)
19572 IDBAM1 = IMPART(JM1)
19573 IDPDG2 = IDHEP(JM2)
19574 IDBAM2 = IMPART(JM2)
19576 C store current status of /POEVT1/
19585 C get nominal masses (photons: VDM assumption)
19587 IF(IDHEP(JM1).EQ.22) THEN
19588 PMASSP(1) = RHOMAS+DELMAS
19589 PVIRTP(1) = PHEP(5,JM1)**2
19591 PMASSP(1) = PHO_PMASS(IDBAM1,0)+DELMAS
19594 IF(IDHEP(JM2).EQ.22) THEN
19595 PMASSP(2) = RHOMAS+DELMAS
19596 PVIRTP(2) = PHEP(5,JM2)**2
19598 PMASSP(2) = PHO_PMASS(IDBAM2,0)+DELMAS
19602 C calculate c.m. energy and check kinematics
19603 PC(1) = PHEP(1,JM1)+PHEP(1,JM2)
19604 PC(2) = PHEP(2,JM1)+PHEP(2,JM2)
19605 PC(3) = PHEP(3,JM1)+PHEP(3,JM2)
19606 PC(4) = PHEP(4,JM1)+PHEP(4,JM2)
19607 SS = (PC(4)+PC(3))*(PC(4)-PC(3))-PC(1)**2-PC(2)**2
19609 IF(SS.LE.(PMASSP(1)+PMASSP(2)+DEPS)**2) THEN
19610 WRITE(LO,'(/,1X,2A)') 'PHO_STDPAR: ',
19611 & 'energy smaller than two-particle threshold (event rejected)'
19618 IF(IDEB(23).GE.5) THEN
19619 WRITE(LO,'(1X,2A,2I7,E12.4)') 'PHO_STDPAR: ',
19620 & 'particles, available energy:',IDHEP(JM1),IDHEP(JM2),ECMP
19621 IF(IDEB(23).GE.25) CALL PHO_PREVNT(0)
19624 C Lorentz transformation into c.m. system
19626 GAMBEP(I) = PC(I)/ECMP
19628 CALL PHO_ALTRA(GAMBEP(4),-GAMBEP(1),-GAMBEP(2),-GAMBEP(3),
19629 & PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
19630 & PHEP(4,JM1),PTOT1,PC(1),PC(2),PC(3),PC(4))
19631 C rotation angle: particle 1 moves along +z
19633 SIDP = SQRT(PC(1)**2+PC(2)**2)/PTOT1
19636 IF(PTOT1*SIDP.GT.1.D-5) THEN
19637 COFP = PC(1)/(SIDP*PTOT1)
19638 SIFP = PC(2)/(SIDP*PTOT1)
19639 ANORF = SQRT(COFP*COFP+SIFP*SIFP)
19644 XM12 = PMASSP(1)**2
19645 XM22 = PMASSP(2)**2
19646 PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*ECMP)
19648 C find particle combination
19650 IF(IDPDG2.EQ.IFPAP(2)) THEN
19651 IF(IDPDG1.EQ.IFPAP(1)) II = 1
19652 ELSE IF(IDPDG2.EQ.990) THEN
19653 IF(IDPDG1.EQ.IFPAP(1)) THEN
19655 ELSE IF(IDPDG1.EQ.IFPAP(2)) THEN
19657 ELSE IF(IDPDG1.EQ.990) THEN
19662 IF(ISWMDL(14).GT.0) THEN
19665 WRITE(LO,'(/1X,2A,2I8)') 'PHO_STDPAR:ERROR: ',
19666 & 'invalid particle combination:',IDPDG1,IDPDG2
19671 C select parton distribution functions from tables
19672 IF((MHPOM+MHDIR).GT.0) THEN
19673 CALL PHO_ACTPDF(IDPDG1,1)
19674 CALL PHO_ACTPDF(IDPDG2,2)
19675 C initialize alpha_s calculation
19676 DUMMY = PHO_ALPHAS(0.D0,-4)
19679 C interpolate hard cross sections and rejection weights
19680 CALL PHO_HARINT(II,ECMP,PVIRTP(1),PVIRTP(2),
19681 & -1,Max_pro_2,1,4,MSPOM+MHPOM+MHDIR)
19685 C position of first particle added to /POEVT2/
19688 C ---------------- direct processes -----------------
19690 IF(MHDIR.EQ.1) THEN
19691 CALL PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
19692 IF(IREJ.EQ.50) RETURN
19693 IF(IREJ.NE.0) GOTO 150
19694 C write comments to /POEVT1/
19695 CALL PHO_REGPAR(25,II,NPROHD(1),IDPDG1,IDPDG2,X0HD(1,1),
19696 & X0HD(1,2),PTHD(1),VHD(1),N0INHD(1,1),N0INHD(1,2),
19697 & IPHO_CNV1(NOUTHD(1,1)),IPHO_CNV1(NOUTHD(1,2)),IPOS,1)
19698 CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,1)),IPDF1,JM1,JM2,
19699 & PPH(1,1),PPH(2,1),PPH(3,1),Q2SCA(1,1),100,NBRAHD(1,1),
19700 & ICA1,ICA2,IPOS,1)
19701 CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,2)),IPDF2,JM2,JM1,
19702 & PPH(1,2),PPH(2,2),PPH(3,2),Q2SCA(1,2),100,NBRAHD(1,2),
19703 & ICA1,ICA2,IPOS,1)
19704 CALL PHO_REGPAR(21,NOUTHD(1,1),IPDF1,JM1,JM2,PPH(5,1),
19705 & PPH(6,1),PPH(7,1),PPH(8,1),100,NBRAHD(1,1),ICA1,ICA2,
19707 CALL PHO_REGPAR(21,NOUTHD(1,2),IPDF2,JM2,JM1,PPH(5,2),
19708 & PPH(6,2),PPH(7,2),PPH(8,2),100,NBRAHD(1,2),ICA1,ICA2,
19711 C soft spectator partons
19719 C single resolved: QCD compton scattering
19720 C ------------------------------
19721 IF(NPROHD(1).EQ.10) THEN
19722 C register hadron remnant
19723 CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
19724 IPDF2 = 1000*IGRP(2)+ISET(2)
19725 ELSE IF(NPROHD(1).EQ.12) THEN
19726 C register hadron remnant
19727 CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
19728 IPDF1 = 1000*IGRP(1)+ISET(1)
19730 C single resolved: photon gluon fusion
19731 C ---------------------------
19732 ELSE IF(NPROHD(1).EQ.11) THEN
19733 C register hadron remnant
19734 CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
19735 IPDF2 = 1000*IGRP(2)+ISET(2)
19736 ELSE IF(NPROHD(1).EQ.13) THEN
19737 C register hadron remnant
19738 CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
19739 IPDF1 = 1000*IGRP(1)+ISET(1)
19741 C direct process (no remnant)
19742 C ----------------------------
19743 ELSE IF(NPROHD(1).EQ.14) THEN
19747 C write final high-pt partons to POEVT1
19748 IF((ISWMDL(8).GE.2).AND.(NPROHD(1).NE.14)) THEN
19754 IFLA(1) = NINHD(I,1)
19755 IFLA(2) = NINHD(I,2)
19756 C initial state radiation
19758 DO 135 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
19761 IFLB = IFLISR(K,IPA)
19762 IF(ABS(IFLB).LE.6) THEN
19764 IF(ICI(K,1)*ICI(K,2).NE.0) THEN
19766 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19767 & ICI(K,1),ICI(K,2),3)
19768 ELSE IF(IFLB.GT.0) THEN
19769 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19770 & ICI(K,1),ICI(K,2),4)
19772 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
19776 IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
19777 IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
19778 CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
19784 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
19787 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19788 & ICI(K,1),ICI(K,2),2)
19791 IIFL = IPHO_CNV1(IFLB)
19792 IFLA(K) = IFLA(K)-IFLB
19801 CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
19802 & PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),I*100+K,
19803 & IGEN,IC1,IC2,IPOS,1)
19806 ICOLOR(1,IPOS1-2) = ICI(1,1)
19807 ICOLOR(2,IPOS1-2) = ICI(1,2)
19808 ICOLOR(1,IPOS1-1) = ICI(2,1)
19809 ICOLOR(2,IPOS1-1) = ICI(2,2)
19810 CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
19811 & IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
19812 & NOUTHD(I,2),ICI(2,1),ICI(2,2))
19813 ICOLOR(1,IPOS1) = ICI(1,1)
19814 ICOLOR(2,IPOS1) = ICI(1,2)
19815 ICOLOR(1,IPOS2) = ICI(2,1)
19816 ICOLOR(2,IPOS2) = ICI(2,2)
19818 IPA = IPOISR(K,1,I)
19819 CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
19820 & PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
19821 & PHISR(K,4,IPA),-I*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
19824 ICOLOR(1,IPOS1-2) = ICA1
19825 ICOLOR(2,IPOS1-2) = ICA2
19826 ICOLOR(1,IPOS1-1) = ICB1
19827 ICOLOR(2,IPOS1-1) = ICB2
19828 CALL PHO_HARCOL(NPROHD(1),VHD(1),NINHD(1,1),ICA1,ICA2,
19829 & NINHD(1,2),ICB1,ICB2,NOUTHD(1,1),ICA1,ICA2,
19830 & NOUTHD(1,2),ICB1,ICB2)
19831 ICOLOR(1,IPOS1) = ICA1
19832 ICOLOR(2,IPOS1) = ICA2
19833 ICOLOR(1,IPOS2) = ICB1
19834 ICOLOR(2,IPOS2) = ICB2
19836 IF(ABS(NOUTHD(1,1)).GT.12) I = 1
19837 CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,1)),0,JM1,JM2,PPH(5,1),
19838 & PPH(6,1),PPH(7,1),PPH(8,1),-100,IGEN,ICA1,ICA2,IPOS,1)
19839 CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,2)),0,JM1,JM2,PPH(5,2),
19840 & PPH(6,2),PPH(7,2),PPH(8,2),-100,IGEN,ICB1,ICB2,IPOS,1)
19843 C assign soft pt to spectators
19844 IF(ISWMDL(18).EQ.0) THEN
19846 CALL PHO_PARTPT(0,NLOR1,IPOS2,PTCUT(II),IREJ)
19848 IFAIL(26) = IFAIL(26) + 1
19854 C ----------------- resolved processes -------------------
19856 C single Reggeon exchange
19857 C ----------------------------
19858 ELSE IF((MSREG.EQ.1).AND.(MHPOM+MSPOM.EQ.0)) THEN
19860 CALL PHO_REGFLA(JM1,JM2,IFL1,IFL2,IREJ)
19862 IFAIL(24) = IFAIL(24)+1
19866 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
19867 IF(((ABS(IFL1).GT.6).AND.(IFL1.GT.0))
19868 & .OR.((ABS(IFL1).LE.6).AND.(IFL1.LT.0))) THEN
19869 CALL PHO_SWAPI(ICA1,ICB1)
19875 C DPMJET call with special projectile / target
19876 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
19877 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH*XPSUB,
19878 & ECMH*XPSUB,-1,IGEN,ICA1,0,IPOS1,1)
19879 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH*XTSUB,
19880 & ECMH*XTSUB,-1,IGEN,ICB1,0,IPOS2,1)
19881 C default treatment
19883 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH,ECMH,
19884 & -1,IGEN,ICA1,0,IPOS1,1)
19885 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH,ECMH,
19886 & -1,IGEN,ICB1,0,IPOS2,1)
19889 C soft pt assignment
19890 IF(ISWMDL(18).EQ.0) THEN
19891 CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
19893 IFAIL(25) = IFAIL(25) + 1
19898 C multi Reggeon / Pomeron exchange
19899 C----------------------------------------
19901 C parton configuration
19903 CALL PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,MSPAR1,MSPAR2,
19904 & MHPAR1,MHPAR2,IREJ)
19906 IF(IREJ.EQ.50) RETURN
19907 IF(IREJ.NE.0) GOTO 150
19909 C register particles
19910 IF(IDEB(23).GE.15) WRITE(LO,'(1X,A,/15X,7I5)')
19911 & 'PHO_STDPAR: MSPOM,MHPOM,MSREG,MSPAR1/2,IVAL1/2',
19912 & MSPOM,MHPOM,MSREG,MSPAR1,MSPAR2,IVAL1,IVAL2
19914 C register soft partons
19915 IF(IVAL1.NE.0) THEN
19916 IF(IVAL1.LT.0) THEN
19922 ELSE IF(MSPOM.EQ.0) THEN
19927 IF(IVAL2.NE.0) THEN
19928 IF(IVAL2.LT.0) THEN
19934 ELSE IF(MSPOM.EQ.0) THEN
19940 IF(IDEB(23).GE.20) WRITE(LO,'(1X,A,2I3,2X,2I3)')
19941 & 'PHO_STDPAR: IND1/2,IVAL1/2',IND1,IND2,IVAL1,IVAL2
19943 C soft Pomeron final states
19944 C -----------------------------------
19945 K = MSPOM+MHPOM+MSREG
19948 CALL PHO_POSPOM(II,IND1,IND2,IGEN,I,K,ISWAP,IREJ)
19950 IFAIL(8) = IFAIL(8) + 1
19956 C soft Reggeon final states
19957 C -----------------------------------------
19960 CMASS1 = MIN(PSOFT1(4,IND1),PSOFT2(4,IND2))
19961 IF(DT_RNDM(CMASS1).LT.0.5D0) THEN
19962 CALL PHO_SEAFLA(JM1,IFLA1,IFLB1,CMASS1)
19964 CALL PHO_SEAFLA(JM2,IFLA1,IFLB1,CMASS1)
19967 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
19968 IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
19969 & .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
19970 & CALL PHO_SWAPI(ICA1,ICB1)
19972 CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
19973 & PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),
19974 & I,IGEN,ICA1,ICA2,IPOS1,1)
19976 CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
19977 & PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),
19978 & I,IGEN,ICB1,ICB2,IPOS2,1)
19981 IF(IDEB(23).GE.20) WRITE(LO,'(1X,A,/15X,6I4)')
19982 & 'PHO_STDPAR: reg.cut: IND1,IND2,IFLA,IFLB,IPOS1,IPOS2',
19983 & IND1-1,IND2-1,IFLA1,IFLB1,IPOS1,IPOS2
19985 C soft pt assignment
19986 IF(ISWMDL(18).EQ.0) THEN
19987 CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
19989 IFAIL(25) = IFAIL(25) + 1
19996 C hard Pomeron final states
19997 C ------------------------------------
20004 IFLI1 = IPHO_CNV1(N0INHD(I,1))
20005 IFLI2 = IPHO_CNV1(N0INHD(I,2))
20006 IFLO1 = IPHO_CNV1(NOUTHD(I,1))
20007 IFLO2 = IPHO_CNV1(NOUTHD(I,2))
20008 C write comments to /POEVT1/
20009 CALL PHO_REGPAR(25,II,NPROHD(I),IDPDG1,IDPDG2,X0HD(I,1),
20010 & X0HD(I,2),PTHD(I),VHD(I),N0INHD(I,1),N0INHD(I,2),
20011 & IFLO1,IFLO2,IPOS,1)
20013 IPDF = 1000*IGRP(1)+ISET(1)
20014 CALL PHO_REGPAR(20,IFLI1,IPDF,JM1,JM2,PPH(I1,1),
20015 & PPH(I1+1,1),PPH(I1+2,1),Q2SCA(I,1),L*100,NBRAHD(I,1),
20016 & ICA1,ICA2,IPOS,1)
20017 IPDF = 1000*IGRP(2)+ISET(2)
20018 CALL PHO_REGPAR(20,IFLI2,IPDF,JM2,JM1,PPH(I1,2),
20019 & PPH(I1+1,2),PPH(I1+2,2),Q2SCA(I,2),L*100,NBRAHD(I,2),
20020 & ICB1,ICB2,IPOS,1)
20022 IPDF = 1000*IGRP(1)+ISET(1)
20023 CALL PHO_REGPAR(21,IFLO1,IPDF,JM1,JM2,PPH(I1,1),
20024 & PPH(I1+1,1),PPH(I1+2,1),PPH(I,1),L*100,NBRAHD(I,1),
20025 & ICA1,ICA2,IPOS1,1)
20026 IPDF = 1000*IGRP(2)+ISET(2)
20027 CALL PHO_REGPAR(21,IFLO2,IPDF,JM2,JM1,PPH(I1,2),
20028 & PPH(I1+1,2),PPH(I1+2,2),PPH(I,2),L*100,NBRAHD(I,2),
20029 & ICB1,ICB2,IPOS2,1)
20031 C spectator partons belonging to hard interaction
20032 IF(IVAL1.EQ.I) THEN
20035 ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL1.EQ.0)) THEN
20042 CALL PHO_HARREM(JM1,JM2,IGEN,L,IVQ,IND,ICA1,ICA2,IUSED,IREJ)
20043 IF(IVQ.LT.0) IND1 = IND1-IUSED
20044 IF(IVAL2.EQ.I) THEN
20047 ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL2.EQ.0)) THEN
20054 CALL PHO_HARREM(JM2,JM1,IGEN,-L,IVQ,IND,ICB1,ICB2,IUSED,IREJ)
20055 IF(IVQ.LT.0) IND2 = IND2-IUSED
20057 C register hard scattered partons
20058 IF((ISWMDL(8).GE.2)
20059 & .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
20064 IFLA(1) = NINHD(I,1)
20065 IFLA(2) = NINHD(I,2)
20066 C initial state radiation
20068 DO 235 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
20071 IFLB = IFLISR(K,IPA)
20072 IF(ABS(IFLB).LE.6) THEN
20074 IF(ICI(K,1)*ICI(K,2).NE.0) THEN
20076 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20077 & ICI(K,1),ICI(K,2),3)
20078 ELSE IF(IFLB.GT.0) THEN
20079 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20080 & ICI(K,1),ICI(K,2),4)
20082 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
20083 & ICI(K,2),IC1,IC2,4)
20086 IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
20087 IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
20088 CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
20094 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
20095 & ICI(K,2),IC1,IC2,2)
20097 CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20098 & ICI(K,1),ICI(K,2),2)
20101 IIFL = IPHO_CNV1(IFLB)
20102 IFLA(K) = IFLA(K)-IFLB
20111 CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
20112 & PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),
20113 & L*100+K,IGEN,IC1,IC2,IPOS,1)
20116 ICOLOR(1,IPOS1-2) = ICI(1,1)
20117 ICOLOR(2,IPOS1-2) = ICI(1,2)
20118 ICOLOR(1,IPOS1-1) = ICI(2,1)
20119 ICOLOR(2,IPOS1-1) = ICI(2,2)
20120 CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
20121 & IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
20122 & NOUTHD(I,2),ICI(2,1),ICI(2,2))
20123 ICOLOR(1,IPOS1) = ICI(1,1)
20124 ICOLOR(2,IPOS1) = ICI(1,2)
20125 ICOLOR(1,IPOS2) = ICI(2,1)
20126 ICOLOR(2,IPOS2) = ICI(2,2)
20128 IPA = IPOISR(K,1,I)
20129 CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
20130 & PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
20131 & PHISR(K,4,IPA),-L*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
20134 ICOLOR(1,IPOS1-2) = ICA1
20135 ICOLOR(2,IPOS1-2) = ICA2
20136 ICOLOR(1,IPOS1-1) = ICB1
20137 ICOLOR(2,IPOS1-1) = ICB2
20138 CALL PHO_HARCOL(NPROHD(I),VHD(I),NINHD(I,1),ICA1,ICA2,
20139 & NINHD(I,2),ICB1,ICB2,NOUTHD(I,1),ICA1,ICA2,
20140 & NOUTHD(I,2),ICB1,ICB2)
20141 ICOLOR(1,IPOS1) = ICA1
20142 ICOLOR(2,IPOS1) = ICA2
20143 ICOLOR(1,IPOS2) = ICB1
20144 ICOLOR(2,IPOS2) = ICB2
20146 CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,1)),0,JM1,JM2,
20147 & PPH(I1,1),PPH(I1+1,1),PPH(I1+2,1),PPH(I1+3,1),-L*100,IGEN,
20148 & ICA1,ICA2,IPOS,1)
20149 CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,2)),0,JM1,JM2,
20150 & PPH(I1,2),PPH(I1+1,2),PPH(I1+2,2),PPH(I1+3,2),-L*100,IGEN,
20151 & ICB1,ICB2,IPOS,1)
20154 C end of resolved parton registration
20157 IF(MHDIR+MHPOM.GT.0) THEN
20159 IF(ISWMDL(29).GE.1) THEN
20160 C primordial kt of hard scattering
20161 CALL PHO_PRIMKT(1,NLOR1,NHEP,PTCUT(II),IREJ)
20163 IFAIL(27) = IFAIL(27)+1
20166 ELSE IF(ISWMDL(24).GE.0) THEN
20167 C give "soft" pt only to soft (spectator) partons in hard processes
20168 CALL PHO_PARTPT(1,NLOR1,NHEP,PTCUT(II),IREJ)
20170 IFAIL(26) = IFAIL(26)+1
20177 C give "soft" pt to partons in soft Pomerons
20178 IF((MHDIR.EQ.0).AND.(ISWMDL(18).EQ.1)) THEN
20179 CALL PHO_PARTPT(0,NLOR1,NHEP,PTCUT(II),IREJ)
20181 IFAIL(25) = IFAIL(25) + 1
20186 C boost back to lab frame
20187 CALL PHO_LTRHEP(NLOR1,NHEP,CODP,SIDP,COFP,SIFP,GAMBEP(4),
20188 & GAMBEP(1),GAMBEP(2),GAMBEP(3))
20191 C rejection treatment
20193 IFAIL(2) = IFAIL(2)+1
20199 C reset mother-daugther relations
20210 IF(IDEB(23).GT.2) WRITE(LO,'(/1X,A,4I6)')
20211 & 'PHO_STDPAR: rejection (MSPOM,MHPOM,MSREG,MHDIR)',
20212 & MSPOM,MHPOM,MSREG,MHDIR
20217 *$ CREATE PHO_HARCOL.FOR
20219 CDECK ID>, PHO_HARCOL
20220 SUBROUTINE PHO_HARCOL(MSPR,V,IP1,ICA1,ICA2,IP2,ICB1,ICB2,
20221 & IP3,ICC1,ICC2,IP4,ICD1,ICD2)
20222 C*********************************************************************
20224 C calculate color flow for hard resolved process
20226 C input: IP1..4 flavour of partons (PDG convention)
20227 C V parton subprocess Mandelstam variable V = t/s
20228 C (lightcone momenta assumed)
20229 C ICA,ICB color labels
20230 C MSPR process number
20231 C -1 initialization of statistics
20232 C -2 output of statistics
20234 C output: ICC,ICD color label of final partons
20236 C (it is possible to use the same variables for in and output)
20238 C**********************************************************************
20239 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20242 C input/output channels
20244 COMMON /POINOU/ LI,LO
20245 C event debugging information
20247 PARAMETER (NMAXD=100)
20248 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
20249 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20250 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
20251 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20252 C model switches and parameters
20254 INTEGER ISWMDL,IPAMDL
20255 DOUBLE PRECISION PARMDL
20256 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
20257 C names of hard scattering processes
20259 PARAMETER ( Max_pro_1 = 16 )
20261 COMMON /POHPRO/ PROC(0:Max_pro_1)
20263 DIMENSION PC(3),ICONF(8,5),IRECN(8,2)
20266 IF(MSPR.EQ.-1) THEN
20275 C output of statistics
20276 ELSE IF(MSPR.EQ.-2) THEN
20277 IF(IDEB(26).LT.1) RETURN
20278 WRITE(LO,'(/1X,A,/1X,A)')
20279 & 'PHO_HARCOL: sampled color configurations',
20280 & '----------------------------------------'
20281 WRITE(LO,'(6X,A,15X,A)')
20282 & 'diagram color configurations (1-4)','sum'
20285 ICONF(I,5) = ICONF(I,5) + ICONF(I,K)
20287 WRITE(LO,'(2X,A,4I11,I12)') PROC(I),(ICONF(I,K),K=1,5)
20289 IF(ISWMDL(11).GE.2) THEN
20290 WRITE(LO,'(/6X,A)')
20291 & 'diagram with / without color re-connection'
20293 WRITE(LO,'(2X,A,2I11)') PROC(I),IRECN(I,1),IRECN(I,2)
20299 C gluons: first color positive, quarks second color zero
20322 & WRITE(LO,'(1X,A,I4,/,5X,A,3I5,2X,3I5)')
20323 & 'PHO_HARCOL: process',MSPR,
20324 & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
20327 IF(IPAMDL(21).EQ.1) THEN
20329 C soft color re-connection option
20332 C hard g g final state, only g g --> g g
20333 IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
20334 IF(DT_RNDM(V).LT.PARMDL(140)) THEN
20339 IRECN(MSPR,1) = IRECN(MSPR,1)+1
20344 ELSE IF(MSPR.EQ.3) THEN
20345 C hard q g final state
20346 IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
20347 IF(DT_RNDM(V).LT.PARMDL(141)) THEN
20352 IRECN(MSPR,1) = IRECN(MSPR,1)+1
20357 ELSE IF((MSPR.EQ.5).OR.(MSPR.EQ.7).OR.(MSPR.EQ.8)) THEN
20358 C hard q q final state
20359 IF(ICA1.NE.-ICB1) THEN
20360 IF(DT_RNDM(V).LT.PARMDL(142)) THEN
20365 IRECN(MSPR,1) = IRECN(MSPR,1)+1
20371 IRECN(MSPR,2) = IRECN(MSPR,2)+1
20374 IF((ISWMDL(11).EQ.1).AND.(MSPR.LT.10)) THEN
20376 C large Nc limit of all graphs
20380 IF(DT_RNDM(V).GT.0.5D0) THEN
20385 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20391 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20393 ELSE IF(MSPR.EQ.2) THEN
20395 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20401 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20407 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20409 ELSE IF(MSPR.EQ.3) THEN
20411 IF(DT_RNDM(V).LT.0.5D0) THEN
20412 IF(IP1+IP2.GT.0) THEN
20417 ELSE IF(IP1.LT.0) THEN
20426 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20429 CALL PHO_HARCOR(-ICA1,ICB2)
20433 ELSE IF(IP2.GT.0) THEN
20434 CALL PHO_HARCOR(-ICB1,ICA2)
20438 ELSE IF(IP1.LT.0) THEN
20439 CALL PHO_HARCOR(-ICA1,ICB1)
20443 ELSE IF(IP2.LT.0) THEN
20444 CALL PHO_HARCOR(-ICB1,ICA1)
20449 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20451 ELSE IF(MSPR.EQ.4) THEN
20455 CALL PHO_HARCOR(-ICB1,ICA2)
20456 IF(ICB2.EQ.-ICB1) IC3 = ICA2
20457 IF(IP3*IC1.LT.0) THEN
20462 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20463 ELSE IF(MSPR.EQ.5) THEN
20465 IF(DT_RNDM(V).LT.0.5D0) THEN
20466 IF(ICA1*IP3.LT.0) THEN
20473 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20475 IF(ICA1*IP3.LT.0) THEN
20482 CALL PHO_HARCOR(-ICA1,ICB1)
20483 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20485 ELSE IF(MSPR.EQ.6) THEN
20487 IF(ICA1*IP3.LT.0) THEN
20490 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20494 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20496 ELSE IF(MSPR.EQ.7) THEN
20498 IF(DT_RNDM(V).LT.0.5D0) THEN
20501 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20505 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20507 ELSE IF(MSPR.EQ.8) THEN
20509 IF(IP1*IP2.GT.0) THEN
20510 IF(IP3.EQ.IP1) THEN
20517 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20519 IF(ICA1*IP3.LT.0) THEN
20526 CALL PHO_HARCOR(-ICA1,ICB1)
20527 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20531 WRITE(LO,'(/1X,A,I3)')
20532 & 'PHO_HARCOL:ERROR:invalid process number (MSPR)',MSPR
20538 C color flow according to QCD leading order matrix element
20543 PC(1) = 1/V**2 +2.D0/V +3.D0 +2.D0*V +V**2
20544 PC(2) = 1/U**2 +2.D0/U +3.D0 +2.D0*U +U**2
20545 PC(3) = (V/U)**2+2.D0*(V/U)+3.D0 +2.D0*(U/V)+(U/V)**2
20546 XI = (PC(1)+PC(2)+PC(3))*DT_RNDM(U)
20550 IF(XI.LT.PCS) GOTO 120
20554 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20555 IF(DT_RNDM(V).GT.0.5D0) THEN
20560 CALL PHO_HARCOR(-ICB2,ICA1)
20561 IF(ICB1.EQ.-ICB2) IC3 = ICA1
20567 CALL PHO_HARCOR(-ICB1,ICA2)
20568 IF(ICB2.EQ.-ICB1) IC4 = ICA2
20570 ELSE IF(I.EQ.2) THEN
20571 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20572 IF(DT_RNDM(U).GT.0.5D0) THEN
20577 CALL PHO_HARCOR(-ICB2,ICA1)
20578 IF(ICB1.EQ.-ICB2) IC1 = ICA1
20584 CALL PHO_HARCOR(-ICB1,ICA2)
20585 IF(ICB2.EQ.-ICB1) IC2 = ICA2
20588 IF(DT_RNDM(V).GT.0.5D0) THEN
20600 ICONF(MSPR,I) = ICONF(MSPR,I)+1
20601 ELSE IF(MSPR.EQ.2) THEN
20603 PC(1) = U/V-2.D0*U**2
20604 PC(2) = V/U-2.D0*V**2
20605 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20606 XI = (PC(1)+PC(2))*DT_RNDM(U)
20607 IF(XI.LT.PC(1)) THEN
20613 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20619 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20627 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20633 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20636 ELSE IF(MSPR.EQ.3) THEN
20638 PC(1) = 2.D0*(U/V)**2-U
20639 PC(2) = 2.D0/V**2-1.D0/U
20640 XI = (PC(1)+PC(2))*DT_RNDM(V)
20641 IF(XI.LT.PC(1)) THEN
20642 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20647 CALL PHO_HARCOR(-ICA1,ICB2)
20648 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20649 ELSE IF(IP1.LT.0) THEN
20653 CALL PHO_HARCOR(-ICA1,ICB1)
20654 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20655 ELSE IF(IP2.GT.0) THEN
20659 CALL PHO_HARCOR(-ICB1,ICA2)
20660 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20665 CALL PHO_HARCOR(-ICB1,ICA1)
20666 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20673 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20674 ELSE IF(IP1.LT.0) THEN
20678 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20679 ELSE IF(IP2.GT.0) THEN
20683 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20688 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20691 ELSE IF(MSPR.EQ.4) THEN
20693 PC(1) = U/V-2.D0*U**2
20694 PC(2) = V/U-2.D0*V**2
20695 XI = (PC(1)+PC(2))*DT_RNDM(U)
20696 IF(XI.LT.PC(1)) THEN
20700 CALL PHO_HARCOR(-ICB1,ICA2)
20701 IF(ICB2.EQ.-ICB1) IC3 = ICA2
20702 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20706 CALL PHO_HARCOR(-ICB2,ICA1)
20707 IF(ICB1.EQ.-ICB2) IC3 = ICA1
20708 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20714 CALL PHO_HARCOR(-ICB2,ICA1)
20715 IF(ICB1.EQ.-ICB2) IC1 = ICA1
20716 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20720 CALL PHO_HARCOR(-ICB1,ICA2)
20721 IF(ICB2.EQ.-ICB1) IC1 = ICA2
20722 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20725 ELSE IF(MSPR.EQ.5) THEN
20727 PC(1) = (1.D0+U**2)/V**2
20728 PC(2) = (V**2+U**2)
20729 XI = (PC(1)+PC(2))*DT_RNDM(V)
20730 IF(XI.LT.PC(1)) THEN
20731 CALL PHO_HARCOR(-ICB1,ICA1)
20732 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20736 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20740 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20744 IC1 = MAX(ICA1,ICB1)
20745 IC3 = MIN(ICA1,ICB1)
20746 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20748 IC1 = MIN(ICA1,ICB1)
20749 IC3 = MAX(ICA1,ICB1)
20750 ICONF(MSPR,4) = ICONF(MSPR,4)+1
20753 ELSE IF(MSPR.EQ.6) THEN
20756 IC1 = MAX(ICA1,ICB1)
20757 IC3 = MIN(ICA1,ICB1)
20758 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20760 IC1 = MIN(ICA1,ICB1)
20761 IC3 = MAX(ICA1,ICB1)
20762 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20764 ELSE IF(MSPR.EQ.7) THEN
20766 PC(1) = (1.D0+U**2)/V**2
20767 PC(2) = (1.D0+V**2)/U**2
20768 XI = (PC(1)+PC(2))*DT_RNDM(U)
20769 IF(XI.LT.PC(1)) THEN
20772 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20776 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20778 ELSE IF(MSPR.EQ.8) THEN
20780 IF(IP1*IP2.LT.0) THEN
20781 CALL PHO_HARCOR(-ICB1,ICA1)
20782 CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20786 ICONF(MSPR,1) = ICONF(MSPR,1)+1
20790 ICONF(MSPR,2) = ICONF(MSPR,2)+1
20795 ICONF(MSPR,3) = ICONF(MSPR,3)+1
20798 ELSE IF(MSPR.EQ.10) THEN
20800 CALL PHO_SELCOL(ICB1,ICB2,IC1,IC2,IC3,IC4,2)
20802 CALL PHO_SWAPI(IC1,IC3)
20803 CALL PHO_SWAPI(IC2,IC4)
20805 ELSE IF(MSPR.EQ.11) THEN
20809 IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
20810 ELSE IF(MSPR.EQ.12) THEN
20812 CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,2)
20814 CALL PHO_SWAPI(IC1,IC3)
20815 CALL PHO_SWAPI(IC2,IC4)
20817 ELSE IF(MSPR.EQ.13) THEN
20821 IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
20822 ELSE IF(MSPR.EQ.14) THEN
20823 IF(ABS(IP3).GT.12) THEN
20827 CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,1)
20828 IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
20832 WRITE(LO,'(/1X,A,I3)')
20833 & 'PHO_HARCOL:ERROR:invalid process number',MSPR
20840 IF(IDEB(26).GE.10) WRITE(LO,'(5X,A,3I5,2X,3I5)')
20841 & 'final partons and colors',IP3,IC1,IC2,IP4,IC3,IC4
20842 C color connection?
20843 * IF(((IC1.NE.-IC3).AND.(IC1.NE.-IC4)).AND.
20844 * & (((IC2.NE.0).AND.(IC2.NE.-IC3).AND.(IC2.NE.-IC4))
20845 * & .OR.(IC2.EQ.0))) THEN
20847 * IF(((IP1.EQ.IP3).AND.(ICA1.EQ.IC1).AND.(ICA2.EQ.IC2))
20848 * & .OR.((IP1.EQ.IP4).AND.(ICA1.EQ.IC3).AND.(ICA2.EQ.IC4))) THEN
20849 * IF(IRC.NE.1) THEN
20850 * WRITE(LO,'(1X,A,I10,I3)')
20851 * & 'PHO_HARCOL:unexp. re-connection (event/MSPR):',KEVENT,MSPR
20852 * WRITE(LO,'(5X,A,3I5,2X,3I5)')
20853 * & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
20854 * WRITE(LO,'(5X,A,3I5,2X,3I5)')
20855 * & 'final partons and colors ',IP3,IC1,IC2,IP4,IC3,IC4
20860 * IF(IRC.EQ.1) THEN
20861 * WRITE(LO,'(1X,A,I10,I3)')
20862 * & 'PHO_HARCOL:re-conn. failed (event/MSPR):',KEVENT,MSPR
20863 * WRITE(LO,'(5X,A,3I5,2X,3I5)')
20864 * & 'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
20865 * WRITE(LO,'(5X,A,3I5,2X,3I5)')
20866 * & 'final partons and colors ',IP3,IC1,IC2,IP4,IC3,IC4
20876 *$ CREATE PHO_HARCOR.FOR
20878 CDECK ID>, PHO_HARCOR
20879 SUBROUTINE PHO_HARCOR(ICOLD,ICNEW)
20880 C***********************************************************************
20882 C substituite color in /POEVT2/
20884 C input: ICOLD old color
20887 C***********************************************************************
20888 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20891 C input/output channels
20893 COMMON /POINOU/ LI,LO
20894 C standard particle data interface
20896 PARAMETER (NMXHEP=4000)
20897 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
20898 DOUBLE PRECISION PHEP,VHEP
20899 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
20900 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
20902 C extension to standard particle data interface (PHOJET specific)
20903 INTEGER IMPART,IPHIST,ICOLOR
20904 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
20907 IF(ISTHEP(I).EQ.-1) THEN
20908 IF(ICOLOR(1,I).EQ.ICOLD) THEN
20909 ICOLOR(1,I) = ICNEW
20911 ELSE IF(IDHEP(I).EQ.21) THEN
20912 IF(ICOLOR(2,I).EQ.ICOLD) THEN
20913 ICOLOR(2,I) = ICNEW
20917 * ELSE IF(ISTHEP(I).EQ.20) THEN
20918 * IF(ICOLOR(1,I).EQ.-ICOLD) THEN
20919 * WRITE(LO,*) ' PHO_HARCOR(3): line, old, new:',I,ICOLD,ICNEW
20920 * ICOLOR(1,I) = -ICNEW
20922 * ELSE IF(IDHEP(I).EQ.21) THEN
20923 * IF(ICOLOR(2,I).EQ.-ICOLD) THEN
20924 * WRITE(LO,*) ' PHO_HARCOR(4): line, old, new:',I,ICOLD,ICNEW
20925 * ICOLOR(2,I) = -ICNEW
20933 *$ CREATE PHO_HARREM.FOR
20935 CDECK ID>, PHO_HARREM
20936 SUBROUTINE PHO_HARREM(JM1,JM2,IGEN,IHPOS,IVAL,INDXS,IC1,IC2,
20938 C***********************************************************************
20940 C sample color structure for initial quark/gluon of hard scattering
20941 C and write hadron remnant to /POEVT1/
20943 C input: JM1,2 index of mother particle in POEVT1
20944 C IGEN mother particle production process
20945 C IHPOS hard pomeron number
20946 C INDXH index of hard parton
20947 C positive for labels 1
20948 C negative for labels 2
20949 C IVAL 1 hard valence parton
20950 C 0 hard sea parton connected by color flow with
20952 C -1 hard sea parton independent off valence
20954 C INDXS index of soft partons needed
20956 C output: IC1,IC2 color label of initial parton
20957 C IUSED number of soft X values used
20958 C IREJ rejection flag
20960 C**********************************************************************
20961 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20964 PARAMETER ( TINY = 1.D-10 )
20966 C input/output channels
20968 COMMON /POINOU/ LI,LO
20969 C event debugging information
20971 PARAMETER (NMAXD=100)
20972 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
20973 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20974 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
20975 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20976 C model switches and parameters
20978 INTEGER ISWMDL,IPAMDL
20979 DOUBLE PRECISION PARMDL
20980 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
20981 C data of c.m. system of Pomeron / Reggeon exchange
20982 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
20983 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
20984 & SIDP,CODP,SIFP,COFP
20985 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
20986 & SIDP,CODP,SIFP,COFP,NPOSP(2),
20987 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
20988 C obsolete cut-off information
20989 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
20990 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
20991 C light-cone x fractions and c.m. momenta of soft cut string ends
20993 PARAMETER ( MAXSOF = 50 )
20994 INTEGER IJSI2,IJSI1
20995 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
20996 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
20997 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
20998 & IJSI1(MAXSOF),IJSI2(MAXSOF)
20999 C hard scattering data
21001 PARAMETER ( MSCAHD = 50 )
21002 INTEGER LSCAHD,LSC1HD,LSIDX,
21003 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
21004 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
21005 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
21006 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
21007 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
21008 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
21009 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
21010 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
21011 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
21012 C standard particle data interface
21014 PARAMETER (NMXHEP=4000)
21015 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
21016 DOUBLE PRECISION PHEP,VHEP
21017 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
21018 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
21020 C extension to standard particle data interface (PHOJET specific)
21021 INTEGER IMPART,IPHIST,ICOLOR
21022 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
21023 C internal rejection counters
21025 PARAMETER (NMXJ=60)
21026 CHARACTER*10 REJTIT
21028 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
21032 INDXH = SIGN(LSIDX(ABS(IHPOS)),IHPOS)
21034 IF(INDXH.GT.0) THEN
21035 IJH = IPHO_CNV1(NINHD(INDXH,1))
21037 IJH = IPHO_CNV1(NINHD(-INDXH,2))
21039 C direct process (photon or pomeron)
21043 IF((IJH.EQ.22).OR.(IJH.EQ.990)) RETURN
21045 IHP = 100*ABS(IHPOS)
21047 ***************************************
21048 * IF((IDHEP(JM1).EQ.22).OR.(IDHEP(JM1).EQ.990)) IVSW = 0
21049 ***************************************
21051 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,2I3,1X,5I4)')
21052 & 'PHO_HARREM: JM1,JM2,IHPOS,INDXH,IFLH,IVAL,INDXS:',
21053 & JM1,JM2,IHPOS,INDXH,IJH,IVAL,INDXS
21056 C****************************************************************
21060 C valence quark engaged in hard scattering
21062 CALL PHO_PARREM(JM1,IJH,IREM,IREJ)
21064 WRITE(LO,'(/1X,2A,2I6)') 'PHO_HARREM: ',
21065 & 'invalid valence flavour requested JM,IFLA',JM1,IJH
21068 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21069 IF(((ABS(IREM).GT.6).AND.(IREM.GT.0))
21070 & .OR.((ABS(IREM).LE.6).AND.(IREM.LT.0))) THEN
21075 C remnant of hadron
21076 IF(INDXH.GT.0) THEN
21077 P1 = PSOFT1(1,INDXS)
21078 P2 = PSOFT1(2,INDXS)
21079 P3 = PSOFT1(3,INDXS)
21080 P4 = PSOFT1(4,INDXS)
21081 IJSI1(INDXS) = IREM
21083 P1 = PSOFT2(1,INDXS)
21084 P2 = PSOFT2(2,INDXS)
21085 P3 = PSOFT2(3,INDXS)
21086 P4 = PSOFT2(4,INDXS)
21087 IJSI2(INDXS) = IREM
21090 CALL PHO_REGPAR(-1,IREM,0,JM1,JM2,P1,P2,P3,P4,
21091 & IHP,IGEN,ICA1,IVSW,IPOS,1)
21092 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21093 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21094 & IREM,IPOS,SIGN(INDXS,INDXH)
21097 C sea quark engaged in hard scattering, valence quarks treated
21098 ELSE IF(IVAL.EQ.0) THEN
21099 IF(INDXH.GT.0) THEN
21100 E1 = PSOFT1(4,INDXS)
21101 E2 = PSOFT1(4,INDXS+1)
21103 E1 = PSOFT2(4,INDXS)
21104 E2 = PSOFT2(4,INDXS+1)
21106 CALL PHO_VALFLA(JM1,IVFL1,IVFL2,E1,E2)
21107 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21108 IF(DT_RNDM(P1).LT.0.5D0) THEN
21109 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21111 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21113 IF(((ABS(IVFL1).GT.6).AND.(IVFL1.GT.0))
21114 & .OR.((ABS(IVFL1).LE.6).AND.(IVFL1.LT.0))) THEN
21119 IF(INDXH.GT.0) THEN
21120 P1 = PSOFT1(1,INDXS)
21121 P2 = PSOFT1(2,INDXS)
21122 P3 = PSOFT1(3,INDXS)
21123 P4 = PSOFT1(4,INDXS)
21124 IJSI1(INDXS) = IVFL1
21126 P1 = PSOFT2(1,INDXS)
21127 P2 = PSOFT2(2,INDXS)
21128 P3 = PSOFT2(3,INDXS)
21129 P4 = PSOFT2(4,INDXS)
21130 IJSI2(INDXS) = IVFL1
21133 CALL PHO_REGPAR(-1,IVFL1,0,JM1,JM2,P1,P2,P3,P4,
21134 & IHP,IGEN,ICA1,IVSW,IPOS,1)
21135 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21136 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21137 & IVFL1,IPOS,SIGN(INDXS,INDXH)
21139 IF(INDXH.GT.0) THEN
21140 P1 = PSOFT1(1,INDXS+1)
21141 P2 = PSOFT1(2,INDXS+1)
21142 P3 = PSOFT1(3,INDXS+1)
21143 P4 = PSOFT1(4,INDXS+1)
21144 IJSI1(INDXS+1) = IVFL2
21146 P1 = PSOFT2(1,INDXS+1)
21147 P2 = PSOFT2(2,INDXS+1)
21148 P3 = PSOFT2(3,INDXS+1)
21149 P4 = PSOFT2(4,INDXS+1)
21150 IJSI2(INDXS+1) = IVFL2
21153 CALL PHO_REGPAR(-1,IVFL2,0,JM1,JM2,P1,P2,P3,P4,
21154 & IHP,IGEN,ICB1,IVSW,IPOS,1)
21155 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21156 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21157 & IVFL2,IPOS,SIGN(INDXS+1,INDXH)
21166 IF(INDXH.GT.0) THEN
21167 P1 = PSOFT1(1,INDXS+2)
21168 P2 = PSOFT1(2,INDXS+2)
21169 P3 = PSOFT1(3,INDXS+2)
21170 P4 = PSOFT1(4,INDXS+2)
21171 IJSI1(INDXS+2) = -IJH
21173 P1 = PSOFT2(1,INDXS+2)
21174 P2 = PSOFT2(2,INDXS+2)
21175 P3 = PSOFT2(3,INDXS+2)
21176 P4 = PSOFT2(4,INDXS+2)
21177 IJSI2(INDXS+2) = -IJH
21180 CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
21181 & IHP,IGEN,ICA1,0,IPOS,1)
21182 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21183 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21184 & -IJH,IPOS,SIGN(INDXS+2,INDXH)
21187 C sea quark engaged in hard scattering, valences treated separately
21188 ELSE IF(IVAL.EQ.-1) THEN
21189 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21195 IF(INDXH.GT.0) THEN
21196 P1 = PSOFT1(1,INDXS)
21197 P2 = PSOFT1(2,INDXS)
21198 P3 = PSOFT1(3,INDXS)
21199 P4 = PSOFT1(4,INDXS)
21200 IJSI1(INDXS) = -IJH
21202 P1 = PSOFT2(1,INDXS)
21203 P2 = PSOFT2(2,INDXS)
21204 P3 = PSOFT2(3,INDXS)
21205 P4 = PSOFT2(4,INDXS)
21206 IJSI2(INDXS) = -IJH
21209 CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
21210 & IHP,IGEN,ICA1,0,IPOS,1)
21211 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21212 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21213 & -IJH,IPOS,SIGN(INDXS,INDXH)
21216 WRITE(LO,'(1X,A,2I5)')
21217 & 'PHO_HARREM:ERROR:unsupported combination of IVAL,IJH',
21226 C****************************************************************
21228 C gluon from valence quarks
21231 C purely gluonic pomeron remnant
21232 IF((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0)) THEN
21233 IF(INDXH.GT.0) THEN
21234 P1 = PSOFT1(1,INDXS) + PSOFT1(1,INDXS+1)
21235 P2 = PSOFT1(2,INDXS) + PSOFT1(2,INDXS+1)
21236 P3 = PSOFT1(3,INDXS) + PSOFT1(3,INDXS+1)
21237 P4 = PSOFT1(4,INDXS) + PSOFT1(4,INDXS+1)
21240 P1 = PSOFT2(1,INDXS) + PSOFT2(1,INDXS+1)
21241 P2 = PSOFT2(2,INDXS) + PSOFT2(2,INDXS+1)
21242 P3 = PSOFT2(3,INDXS) + PSOFT2(3,INDXS+1)
21243 P4 = PSOFT2(4,INDXS) + PSOFT2(4,INDXS+1)
21247 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21248 IF(DT_RNDM(P2).LT.0.5D0) THEN
21249 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21251 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21254 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21255 & IHP,IGEN,ICA1,ICB1,IPOS,1)
21256 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21257 & 'PHO_HARREM: val.gluon:(IFL,IPOS,INDXS)',
21258 & IFL1,IPOS,SIGN(INDXS,INDXH)
21260 C valence quark remnant
21262 IF(INDXH.GT.0) THEN
21263 E1 = PSOFT1(4,INDXS)
21264 E2 = PSOFT1(4,INDXS+1)
21266 E1 = PSOFT2(4,INDXS)
21267 E2 = PSOFT2(4,INDXS+1)
21269 CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
21270 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21271 IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21272 & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21277 IF(DT_RNDM(P2).LT.0.5D0) THEN
21278 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21280 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21282 C remnant of hadron
21283 IF(INDXH.GT.0) THEN
21284 P1 = PSOFT1(1,INDXS)
21285 P2 = PSOFT1(2,INDXS)
21286 P3 = PSOFT1(3,INDXS)
21287 P4 = PSOFT1(4,INDXS)
21288 IJSI1(INDXS) = IFL1
21290 P1 = PSOFT2(1,INDXS)
21291 P2 = PSOFT2(2,INDXS)
21292 P3 = PSOFT2(3,INDXS)
21293 P4 = PSOFT2(4,INDXS)
21294 IJSI2(INDXS) = IFL1
21297 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21298 & IHP,IGEN,ICA1,IVSW,IPOS,1)
21299 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21300 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21301 & IFL1,IPOS,SIGN(INDXS,INDXH)
21303 IF(INDXH.GT.0) THEN
21304 P1 = PSOFT1(1,INDXS+1)
21305 P2 = PSOFT1(2,INDXS+1)
21306 P3 = PSOFT1(3,INDXS+1)
21307 P4 = PSOFT1(4,INDXS+1)
21308 IJSI1(INDXS+1) = IFL2
21310 P1 = PSOFT2(1,INDXS+1)
21311 P2 = PSOFT2(2,INDXS+1)
21312 P3 = PSOFT2(3,INDXS+1)
21313 P4 = PSOFT2(4,INDXS+1)
21314 IJSI2(INDXS+1) = IFL2
21317 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21318 & IHP,IGEN,ICB1,IVSW,IPOS,1)
21319 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21320 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21321 & IFL2,IPOS,SIGN(INDXS+1,INDXH)
21325 C gluon from sea quarks connected with valence quarks
21326 ELSE IF(IVAL.EQ.0) THEN
21327 IF(INDXH.GT.0) THEN
21328 E1 = PSOFT1(4,INDXS)
21329 E2 = PSOFT1(4,INDXS+1)
21331 E1 = PSOFT2(4,INDXS)
21332 E2 = PSOFT2(4,INDXS+1)
21334 CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
21335 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21336 IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21337 & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21342 IF(DT_RNDM(P3).LT.0.5D0) THEN
21343 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21345 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21347 C remnant of hadron
21348 IF(INDXH.GT.0) THEN
21349 P1 = PSOFT1(1,INDXS)
21350 P2 = PSOFT1(2,INDXS)
21351 P3 = PSOFT1(3,INDXS)
21352 P4 = PSOFT1(4,INDXS)
21353 IJSI1(INDXS) = IFL1
21355 P1 = PSOFT2(1,INDXS)
21356 P2 = PSOFT2(2,INDXS)
21357 P3 = PSOFT2(3,INDXS)
21358 P4 = PSOFT2(4,INDXS)
21359 IJSI2(INDXS) = IFL1
21362 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21363 & IHP,IGEN,ICA1,IVSW,IPOS,1)
21364 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21365 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21366 & IFL1,IPOS,SIGN(INDXS,INDXH)
21368 IF(INDXH.GT.0) THEN
21369 P1 = PSOFT1(1,INDXS+1)
21370 P2 = PSOFT1(2,INDXS+1)
21371 P3 = PSOFT1(3,INDXS+1)
21372 P4 = PSOFT1(4,INDXS+1)
21373 IJSI1(INDXS+1) = IFL2
21375 P1 = PSOFT2(1,INDXS+1)
21376 P2 = PSOFT2(2,INDXS+1)
21377 P3 = PSOFT2(3,INDXS+1)
21378 P4 = PSOFT2(4,INDXS+1)
21379 IJSI2(INDXS+1) = IFL2
21382 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21383 & IHP,IGEN,ICB1,IVSW,IPOS,1)
21384 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21385 & 'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21386 & IFL2,IPOS,SIGN(INDXS+1,INDXH)
21387 IF(IPAMDL(18).EQ.0) THEN
21389 CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
21397 IF(DT_RNDM(P4).LT.0.5D0) THEN
21399 CALL PHO_SELCOL(ICC1,0,ICA1,ICA2,ICC1,ICC2,2)
21402 CALL PHO_SELCOL(ICC2,0,ICB1,ICB2,ICC1,ICC2,2)
21404 IF(INDXH.GT.0) THEN
21405 P1 = PSOFT1(1,INDXS+2)
21406 P2 = PSOFT1(2,INDXS+2)
21407 P3 = PSOFT1(3,INDXS+2)
21408 P4 = PSOFT1(4,INDXS+2)
21409 IJSI1(INDXS+2) = IFL1
21411 P1 = PSOFT2(1,INDXS+2)
21412 P2 = PSOFT2(2,INDXS+2)
21413 P3 = PSOFT2(3,INDXS+2)
21414 P4 = PSOFT2(4,INDXS+2)
21415 IJSI2(INDXS+2) = IFL1
21418 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21419 & IHP,IGEN,ICA1,0,IPOS,1)
21420 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21421 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21422 & IFL1,IPOS,SIGN(INDXS+2,INDXH)
21424 IF(INDXH.GT.0) THEN
21425 P1 = PSOFT1(1,INDXS+3)
21426 P2 = PSOFT1(2,INDXS+3)
21427 P3 = PSOFT1(3,INDXS+3)
21428 P4 = PSOFT1(4,INDXS+3)
21429 IJSI1(INDXS+3) = IFL2
21431 P1 = PSOFT2(1,INDXS+3)
21432 P2 = PSOFT2(2,INDXS+3)
21433 P3 = PSOFT2(3,INDXS+3)
21434 P4 = PSOFT2(4,INDXS+3)
21435 IJSI2(INDXS+3) = IFL2
21438 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21439 & IHP,IGEN,ICB1,0,IPOS,1)
21440 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21441 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21442 & IFL2,IPOS,SIGN(INDXS+3,INDXH)
21448 C gluon from independent sea quarks
21449 ELSE IF(IVAL.EQ.-1) THEN
21450 IF(IPAMDL(18).EQ.0) THEN
21451 CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21452 CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
21453 IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21454 & .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21459 IF(DT_RNDM(P1).LT.0.5D0) THEN
21460 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21462 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21464 C remainder of hadron
21465 IF(INDXH.GT.0) THEN
21466 P1 = PSOFT1(1,INDXS)
21467 P2 = PSOFT1(2,INDXS)
21468 P3 = PSOFT1(3,INDXS)
21469 P4 = PSOFT1(4,INDXS)
21470 IJSI1(INDXS) = IFL1
21472 P1 = PSOFT2(1,INDXS)
21473 P2 = PSOFT2(2,INDXS)
21474 P3 = PSOFT2(3,INDXS)
21475 P4 = PSOFT2(4,INDXS)
21476 IJSI2(INDXS) = IFL1
21479 CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21480 & IHP,IGEN,ICA1,ICA2,IPOS,1)
21481 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21482 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21483 & IFL1,IPOS,SIGN(INDXS,INDXH)
21485 IF(INDXH.GT.0) THEN
21486 P1 = PSOFT1(1,INDXS-1)
21487 P2 = PSOFT1(2,INDXS-1)
21488 P3 = PSOFT1(3,INDXS-1)
21489 P4 = PSOFT1(4,INDXS-1)
21490 IJSI1(INDXS-1) = IFL2
21492 P1 = PSOFT2(1,INDXS-1)
21493 P2 = PSOFT2(2,INDXS-1)
21494 P3 = PSOFT2(3,INDXS-1)
21495 P4 = PSOFT2(4,INDXS-1)
21496 IJSI2(INDXS-1) = IFL2
21499 CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21500 & IHP,IGEN,ICB1,ICB2,IPOS,1)
21501 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21502 & 'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21503 & IFL2,IPOS,SIGN(INDXS-1,INDXH)
21506 CALL PHO_SELCOL(0,0,ICC1,ICA2,ICC2,ICB2,1)
21507 IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,I5)')
21508 & 'PHO_HARREM: no spectator added:(INDXS)',
21509 & SIGN(INDXS,INDXH)
21514 WRITE(LO,'(1X,A,2I5)')
21515 & 'PHO_HARREM:ERROR: unsupported combination of IVAL,IJH',
21524 *$ CREATE PHO_HARDIR.FOR
21526 CDECK ID>, PHO_HARDIR
21527 SUBROUTINE PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,
21529 C**********************************************************************
21531 C parton orientated formulation of direct scattering processes
21535 C output: II particle combination (1..4)
21536 C IVAL1,2 0 no valence quarks engaged
21537 C 1 valence quarks engaged
21538 C MSPAR1,2 number of realized soft partons
21539 C MHPAR1,2 number of realized hard partons
21543 C**********************************************************************
21544 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21547 C input/output channels
21549 COMMON /POINOU/ LI,LO
21550 C event debugging information
21552 PARAMETER (NMAXD=100)
21553 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
21554 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21555 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
21556 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21557 C model switches and parameters
21559 INTEGER ISWMDL,IPAMDL
21560 DOUBLE PRECISION PARMDL
21561 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21562 C hard scattering parameters used for most recent hard interaction
21564 DOUBLE PRECISION ALQCD2,BQCD
21565 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
21566 C data of c.m. system of Pomeron / Reggeon exchange
21567 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
21568 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
21569 & SIDP,CODP,SIFP,COFP
21570 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
21571 & SIDP,CODP,SIFP,COFP,NPOSP(2),
21572 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
21573 C obsolete cut-off information
21574 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
21575 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
21576 C hard cross sections and MC selection weights
21578 PARAMETER ( Max_pro_2 = 16 )
21579 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
21580 & MH_acc_1,MH_acc_2
21581 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
21582 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
21583 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
21584 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
21585 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
21586 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
21587 C data on most recent hard scattering
21588 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
21589 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
21590 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
21591 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
21592 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
21593 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
21594 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
21595 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
21596 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
21597 C light-cone x fractions and c.m. momenta of soft cut string ends
21599 PARAMETER ( MAXSOF = 50 )
21600 INTEGER IJSI2,IJSI1
21601 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
21602 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
21603 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
21604 & IJSI1(MAXSOF),IJSI2(MAXSOF)
21605 C hard scattering data
21607 PARAMETER ( MSCAHD = 50 )
21608 INTEGER LSCAHD,LSC1HD,LSIDX,
21609 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
21610 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
21611 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
21612 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
21613 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
21614 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
21615 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
21616 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
21617 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
21618 C internal rejection counters
21620 PARAMETER (NMXJ=60)
21621 CHARACTER*10 REJTIT
21623 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
21625 DIMENSION P1(4),P2(4),PD1(-6:6)
21627 PARAMETER ( TINY = 1.D-10 )
21634 C check phase space
21635 IF(ECMP.LT.(2.D0*PTWANT+0.1D0)) THEN
21636 IFAIL(18) = IFAIL(18)+1
21641 AS = (PARMDL(160+II)/ECMP)**2
21642 AH = (2.D0*PTWANT/ECMP)**2
21647 XMAX = MAX(TINY,1.D0-AS)
21651 C main loop to select hard and soft parton kinematics
21652 C -----------------------------------------------------
21658 IFAIL(17) = IFAIL(17)+1
21659 IF(ITRY.GE.NTRY) THEN
21672 CALL PHO_HARSCA(1,II)
21676 IF(IDEB(25).GE.20) THEN
21677 WRITE(LO,'(1X,A,2E12.4,2I5)')
21678 & 'PHO_HARDIR: AS,XMAX,process ID,ITRY',
21679 & AS,XMAX,MSPR,ITRY
21680 WRITE(LO,'(1X,A,4E12.4)') 'HARD X1,2 SUM X1,2',
21684 IF(MSPR.LE.11) THEN
21685 IF((XSS2.GT.XMAX).OR.((1.D0-XSS2).LT.AS)) GOTO 120
21686 ELSE IF(MSPR.LE.13) THEN
21687 IF((XSS1.GT.XMAX).OR.((1.D0-XSS1).LT.AS)) GOTO 120
21704 NBRAHD(1,1)= IDPDG1
21705 NBRAHD(1,2)= IDPDG2
21709 PPH(4+I,1) = PHO1(I)
21710 PPH(4+I,2) = PHO2(I)
21718 IF(MSPR.LE.11) THEN
21719 NINHD(1,1) = IDPDG1
21721 PDFVA(1,2) = PDF2(IB)
21723 ELSE IF(MSPR.LE.13) THEN
21725 PDFVA(1,1) = PDF1(IA)
21726 NINHD(1,2) = IDPDG2
21729 NINHD(1,1) = IDPDG1
21730 NINHD(1,2) = IDPDG2
21733 N0INHD(1,1) = NINHD(1,1)
21734 N0INHD(1,2) = NINHD(1,2)
21735 N0IVAL(1,1) = IVAL1
21736 N0IVAL(1,2) = IVAL2
21740 C reweight according to photon virtuality
21741 IF(MSPR.NE.14) THEN
21742 IF(IPAMDL(115).GE.1) THEN
21744 IF(((MSPR.EQ.10).OR.(MSPR.EQ.11)).AND.(IDPDG2.EQ.22)) THEN
21746 IF(IPAMDL(115).EQ.1) THEN
21747 IF(QQPD.LT.(PVIRTP(2)+PARMDL(144))) THEN
21750 WGX = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
21751 & /LOG(QQPD/PARMDL(144))
21753 IF(NINHD(1,2).EQ.0) WGX = WGX*WGX
21754 ELSE IF(IPAMDL(115).EQ.2) THEN
21755 CALL PHO_PDF(2,X2,QQPD,PVIRTP(2),PD1)
21756 WGX = PD1(IB)/PDFVA(1,2)
21758 ELSE IF(((MSPR.EQ.12).OR.(MSPR.EQ.13))
21759 & .AND.(IDPDG1.EQ.22)) THEN
21761 IF(IPAMDL(115).EQ.1) THEN
21762 IF(QQPD.LT.(PVIRTP(1)+PARMDL(144))) THEN
21765 WGX = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
21766 & /LOG(QQPD/PARMDL(144))
21768 IF(NINHD(1,1).EQ.0) WGX = WGX*WGX
21769 ELSE IF(IPAMDL(115).EQ.2) THEN
21770 CALL PHO_PDF(1,X1,QQPD,PVIRTP(1),PD1)
21771 WGX = PD1(IA)/PDFVA(1,1)
21776 & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
21777 & 're-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
21778 & KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX
21780 IF(WGX.LT.DT_RNDM(WGX)) THEN
21786 & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
21787 & 're-weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
21788 & KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX
21794 IF((MSPR.NE.14).AND.(ISWMDL(8).GE.2)) THEN
21795 IF(IPAMDL(109).EQ.1) THEN
21796 Q2H = PARMDL(93)*PT**2
21798 Q2H = -PARMDL(93)*VHD(1)*XHD(1,1)*XHD(1,2)*ECMP*ECMP
21800 XHMAX1 = 1.D0 - XSS1 - AS + XHD(1,1)
21801 XHMAX2 = 1.D0 - XSS2 - AS + XHD(1,2)
21806 CALL PHO_HARISR(-1,P1,P2,NOUTHD(1,1),NOUTHD(1,2),N0INHD(1,1),
21807 & N0INHD(1,2),N0IVAL(1,1),N0IVAL(1,2),Q2H,X0HD(1,1),X0HD(1,2),
21808 & XHMAX1,XHMAX2,IFL1,IFL2,IVAL1,IVAL2,XISR1,XISR2,IREJ)
21809 XSS1 = XSS1+XISR1-XHD(1,1)
21810 XSS2 = XSS2+XISR2-XHD(1,2)
21822 C add photon/hadron remnant
21826 XMAXX = 1.D0 - XSS2 - AS
21827 XMAXH = MIN(XMAXX,PARMDL(44))
21828 CALL PHO_HADSP2(IDBAM2,XSS2,XMAXH,XS2,IREJ)
21834 ELSE IF(IFL1.EQ.0) THEN
21835 XMAXX = 1.D0 - XSS1 - AS
21836 XMAXH = MIN(XMAXX,PARMDL(44))
21837 CALL PHO_HADSP2(IDBAM1,XSS1,XMAXH,XS1,IREJ)
21845 ELSE IF(ABS(IFL2).LE.12) THEN
21846 IF(IVAL2.EQ.1) THEN
21847 XS2(1) = 1.D0 - XSS2
21853 XMAXX = 1.D0 - XSS2 - AS
21854 XMAXH = MIN(XMAXX,PARMDL(44))
21855 CALL PHO_HADSP3(IDBAM2,XSS2,XMAXH,XS2,IREJ)
21861 ELSE IF(ABS(IFL1).LE.12) THEN
21862 IF(IVAL1.EQ.1) THEN
21863 XS1(1) = 1.D0 - XSS1
21869 XMAXX = 1.D0 - XSS1 - AS
21870 XMAXH = MIN(XMAXX,PARMDL(44))
21871 CALL PHO_HADSP3(IDBAM1,XSS1,XMAXH,XS1,IREJ)
21878 C double direct process
21879 ELSE IF(MSPR.EQ.14) THEN
21887 WRITE(LO,'(/1X,A,I3/)')
21888 & 'PHO_HARDIR:ERROR: unsupported hard process (MSPR)',MSPR
21893 IF(IDEB(25).GE.3) WRITE(LO,'(1X,A,3I5)')
21894 & 'PHO_HARDIR: int. rejection (MSPR,ITRY,NTRY)',MSPR,ITRY,NTRY
21898 C soft particle momenta
21899 IF(MSPAR1.GT.0) THEN
21903 PSOFT1(3,I) = XS1(I)*ECMP/2.D0
21904 PSOFT1(4,I) = XS1(I)*ECMP/2.D0
21907 IF(MSPAR2.GT.0) THEN
21911 PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
21912 PSOFT2(4,I) = XS2(I)*ECMP/2.D0
21916 MH_acc_1(MSPR,II) = MH_acc_1(MSPR,II)+1
21917 KSOFT = MAX(MSPAR1,MSPAR2)
21918 KHARD = MAX(MHPAR1,MHPAR2)
21920 IF(IDEB(25).GE.10) THEN
21921 WRITE(LO,'(/1X,A,2I3,3I5)')
21922 & 'PHO_HARDIR: accepted IVAL1,IVAL2,MSPR,ITRY,NTRY',
21923 & IVAL1,IVAL2,MSPR,ITRY,NTRY
21924 IF(MSPAR1.GT.0) THEN
21925 WRITE(LO,'(5X,A,I4)') 'soft x particle 1:',MSPAR1
21927 WRITE(LO,'(10X,I3,E12.3)') I,XS1(I)
21930 IF(MSPAR2.GT.0) THEN
21931 WRITE(LO,'(5X,A,I4)') 'soft x particle 2:',MSPAR2
21933 WRITE(LO,'(10X,I3,E12.3)') I,XS2(I)
21936 WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavor particle 1:',MHPAR1
21937 WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,1),NINHD(1,1)
21938 WRITE(LO,'(5X,A,I4)') 'fin.hard momenta particle 1:',MHPAR1
21939 WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,1),K=5,8),NOUTHD(1,1)
21940 WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavour particle 2:',MHPAR2
21941 WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,2),NINHD(1,2)
21942 WRITE(LO,'(5X,A,I4)') 'fin.hard momenta particle 2:',MHPAR2
21943 WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,2),K=5,8),NOUTHD(1,2)
21948 IFAIL(16) = IFAIL(16)+1
21949 IF(IDEB(25).GE.2) THEN
21950 WRITE(LO,'(1X,A,3I5)')
21951 & 'PHO_HARDIR: rejection (ITRY,NTRY,IREJ)',ITRY,NTRY,IREJ
21952 WRITE(LO,'(5X,A,E12.4)') 'available energy:',ECMP
21953 IF(IDEB(25).GE.5) THEN
21956 CALL PHO_PREVNT(-1)
21962 *$ CREATE PHO_POMSCA.FOR
21964 CDECK ID>, PHO_POMSCA
21965 SUBROUTINE PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,
21966 & MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
21967 C**********************************************************************
21969 C parton orientated formulation of soft and hard inelastic events
21972 C input: II particle combiantion (1..4)
21973 C MSPOM number of soft pomerons
21974 C MHPOM number of semihard pomerons
21975 C MSREG number of soft reggeons
21977 C output: IVAL1,2 0 no valence quark engaged
21978 C otherwise: position of valence quark engaged
21979 C neg.number: gluon connected to valence quark
21981 C MSPAR1,2 number of realized soft partons
21982 C MHPAR1,2 number of realized hard partons
21986 C**********************************************************************
21987 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21990 PARAMETER (TINY = 1.D-30 )
21992 C input/output channels
21994 COMMON /POINOU/ LI,LO
21995 C event debugging information
21997 PARAMETER (NMAXD=100)
21998 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
21999 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22000 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
22001 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22002 C model switches and parameters
22004 INTEGER ISWMDL,IPAMDL
22005 DOUBLE PRECISION PARMDL
22006 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
22007 C general process information
22008 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
22009 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
22010 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
22011 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
22012 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
22013 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
22014 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
22015 C event weights and generated cross section
22016 INTEGER IPOWGC,ISWCUT,IVWGHT
22017 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
22018 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
22019 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
22020 C hard cross sections and MC selection weights
22022 PARAMETER ( Max_pro_2 = 16 )
22023 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
22024 & MH_acc_1,MH_acc_2
22025 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
22026 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
22027 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
22028 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
22029 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
22030 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
22031 C hard scattering parameters used for most recent hard interaction
22033 DOUBLE PRECISION ALQCD2,BQCD
22034 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
22035 C data of c.m. system of Pomeron / Reggeon exchange
22036 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
22037 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
22038 & SIDP,CODP,SIFP,COFP
22039 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
22040 & SIDP,CODP,SIFP,COFP,NPOSP(2),
22041 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
22042 C obsolete cut-off information
22043 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
22044 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
22045 C some hadron information, will be deleted in future versions
22047 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
22048 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
22049 C data on most recent hard scattering
22050 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22051 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22052 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22053 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22054 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22055 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22056 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22057 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22058 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22059 C light-cone x fractions and c.m. momenta of soft cut string ends
22061 PARAMETER ( MAXSOF = 50 )
22062 INTEGER IJSI2,IJSI1
22063 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
22064 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
22065 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
22066 & IJSI1(MAXSOF),IJSI2(MAXSOF)
22067 C hard scattering data
22069 PARAMETER ( MSCAHD = 50 )
22070 INTEGER LSCAHD,LSC1HD,LSIDX,
22071 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
22072 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
22073 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
22074 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
22075 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
22076 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
22077 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
22078 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
22079 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
22080 C table of particle indices for recursive PHOJET calls
22082 PARAMETER ( MAXIPX = 100 )
22083 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
22084 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
22085 & IPOIX1,IPOIX2,IPOIX3
22086 C internal rejection counters
22088 PARAMETER (NMXJ=60)
22089 CHARACTER*10 REJTIT
22091 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
22093 DIMENSION P1(4),P2(4),PD1(-6:6)
22095 IF(IDEB(24).GT.20) WRITE(LO,'(1X,A,3I5)')
22096 & 'PHO_POMSCA: MSPOM,MHPOM,MSREG',MSPOM,MHPOM,MSREG
22104 C phase space limitation (single hard valence-valence quark scattering)
22105 IF(MHPOM.GT.0) THEN
22106 Emin = 2.D0*PTWANT + 0.2D0
22107 IF(ECMP.LT.Emin) THEN
22108 IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P,3E10.3)') 'PHO_POMSCA: ',
22109 & 'kin. rejection (1) (Ecm,Ptcut,Emin)',ECMP,PTWANT,Emin
22111 IFAIL(6) = IFAIL(6) + 1
22116 SAS = PARMDL(160+II)/ECMP
22117 SAH = 2.D0*PTWANT/ECMP
22121 C save energy for leading particle effect
22123 if(IHFLS(1).ne.0) XMAXP1 = 1.D0-PARMDL(165)*XPSUB
22125 if(IHFLS(2).ne.0) XMAXP2 = 1.D0-PARMDL(165)*XTSUB
22128 C main loop to select hard and soft parton kinematics
22129 C -----------------------------------------------------
22130 IFAIL(31) = IFAIL(31)+MHARD
22136 IF(ITRY.GT.1) IFAIL(5) = IFAIL(5)+1
22137 IF(ITRY.GE.NTRY) THEN
22143 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
22144 XSS1 = MAX(0.D0,1.D0-XPSUB)
22145 XSS2 = MAX(0.D0,1.D0-XTSUB)
22152 C partons needed to construct soft/hard interactions
22153 MSPAR1 = 2*MSPOM+MSREG+MHPOM
22158 C number of strings
22159 MSCHA = 2*MSPOM+MSREG
22165 C check actual phase space limit
22166 XX = SAS*DBLE(MSCHA)+SAH*DBLE(MHCHA)/2.D0
22167 IF(XX.GE.1.D0) THEN
22168 IF(IDEB(24).GE.3) WRITE(LO,'(1X,2A,/1X,4I3,1P4E12.4)')
22169 & 'PHO_POMSCA: internal kin. rejection ',
22170 & '(MSpom,MHpom,MSchain,MHchain,Ecm,AS,AH,XX):',
22171 & MSPOM,MHPOM,MSCHA,MHCHA,ECMP,AS,AH,XX
22172 if(MSPOM+MSREG+MHPOM.gt.1) then
22173 if(MSREG.gt.0) then
22175 else if(MSPOM.gt.0) THEN
22177 else if(MHPOM.gt.1) then
22182 IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P2E10.3)')
22183 & 'PHO_POMSCA: kin. rejection (2) (Ecm,Ptcut)',ECMP,PTWANT
22185 IFAIL(6) = IFAIL(6) + 1
22189 XMAXX1 = MAX(TINY,1.D0-MIN(MSPAR1,1)*AS-MIN(MHPAR1,1)*AH)
22190 XMAXX2 = MAX(TINY,1.D0-MIN(MSPAR2,1)*AS-MIN(MHPAR2,1)*AH)
22192 C very low energy phase space restriction
22193 if(MHARD.gt.0) then
22194 if((XMAXX1*XMAXX2.le.AH)) then
22195 IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P2E10.3)')
22196 & 'PHO_POMSCA: kin. rejection (3) (Ecm,Ptcut)',ECMP,PTWANT
22198 IFAIL(6) = IFAIL(6) + 1
22203 AS = MAX(AS,PSOMIN/PCMP)
22206 Z1MAX = LOG(XMAXX1)
22207 Z2MAX = LOG(XMAXX2)
22208 Z1DIF = Z1MAX+Z2MAX-ALNH
22212 C select hard parton momenta
22213 C ------------------- begin of inner loop -------------------
22214 IF(IPOIX3.EQ.0) IPOWGC(4+II) = 0
22215 IF(MHARD.GT.MSCAHD) THEN
22216 WRITE(LO,'(1X,2A,2I3)') 'PHO_POMSCA: ',
22217 & 'no space left in /POHSLT/ (MHARD,MSCAHD):',MHARD,MSCAHD
22223 C generate one resolved hard scattering
22226 IF((NN.EQ.1).AND.(II.EQ.1).AND.(HSWCUT(4+II).GT.PTWANT)) THEN
22227 CALL PHO_HARINT(-1,ECMP,PVIRTP(1),PVIRTP(2),
22228 & -1,Max_pro_2,1,4,MSPOM+MHPOM)
22234 AH = (2.D0*PTWANT/ECMP)**2
22236 Z1DIF = Z1MAX+Z2MAX-ALNH
22238 IF((Z1DIF.LE.0.01D0).OR.(Z2DIF.LE.0.01D0)) THEN
22239 IF(IDEB(24).GE.1) WRITE(LO,'(1X,2A,/1X,1P4E12.3)')
22240 & 'PHO_POMSCA: kin.rejection, high-pt option ',
22241 & '(Z1/2max,ALNH,Z1dif):',Z1MAX,Z2MAX,ALNH,Z1DIF
22245 CALL PHO_HARSCA(2,II)
22246 CALL PHO_HARINT(1,ECMP,PVIRTP(1),PVIRTP(2),
22247 & -1,Max_pro_2,1,4,MSPOM+MHPOM)
22252 IPOWGC(4+II) = IPOWGC(4+II)+1
22253 HSWGHT(4+II) = XSCUT/HSig(9)*DBLE(MHARD)
22254 C minimum bias option
22256 CALL PHO_HARSCA(2,II)
22273 PDFVA(NN,1) = PDF1(IA)
22274 PDFVA(NN,2) = PDF2(IB)
22285 NBRAHD(NN,1) = IDPDG1
22286 NBRAHD(NN,2) = IDPDG2
22290 PPH(I3+I,1) = PHI1(I)
22291 PPH(I3+I,2) = PHI2(I)
22292 PPH(I4+I,1) = PHO1(I)
22293 PPH(I4+I,2) = PHO2(I)
22298 C sort according to pt-hat
22300 PTMX = PTHD(LSIDX(NN))
22303 IF(PTHD(LSIDX(I)).GT.PTMX) THEN
22305 PTMX = PTHD(LSIDX(I))
22308 IF(IPTM.NE.NN) CALL PHO_SWAPI(LSIDX(NN),LSIDX(IPTM))
22312 C copy partons, generate ISR
22315 XSSS1 = XSS1+XHD(NN,1)
22316 XSSS2 = XSS2+XHD(NN,2)
22318 IF(IDEB(24).GE.10) WRITE(LO,'(1X,A,3I4,1P,3E11.3)')
22319 & 'PHO_POMSCA: NR,LSIDX,MSPR,X1,X2,PT',
22320 & L,NN,NPROHD(NN),XHD(NN,1),XHD(NN,2),PTHD(NN)
22321 C check phase space
22322 IF( (XSSS1.GT.XMAXX1)
22323 & .OR.(XSSS2.GT.XMAXX2)
22324 & .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
22325 IF(IHARD.EQ.0) THEN
22326 IF(ISWMDL(2).NE.1) GOTO 20
22334 C reweight according to photon virtuality
22335 IF(IPAMDL(115).GE.1) THEN
22338 IF(IDPDG1.EQ.22) THEN
22339 IF(IPAMDL(115).EQ.1) THEN
22340 IF(QQPD.LT.PVIRTP(1)+PARMDL(144)) THEN
22343 WG1 = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
22344 & /LOG(QQPD/PARMDL(144))
22346 IF(NINHD(NN,1).EQ.0) WG1 = WG1*WG1
22347 ELSE IF(IPAMDL(115).EQ.2) THEN
22348 CALL PHO_PDF(1,X0HD(NN,1),QQPD,PVIRTP(1),PD1)
22349 WG1 = PD1(NINHD(NN,1))/PDFVA(NN,1)
22354 IF(IDPDG2.EQ.22) THEN
22355 IF(IPAMDL(115).EQ.1) THEN
22356 IF(QQPD.LT.PVIRTP(2)+PARMDL(144)) THEN
22359 WG1 = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
22360 & /LOG(QQPD/PARMDL(144))
22362 IF(NINHD(NN,2).EQ.0) WG1 = WG1*WG1
22363 ELSE IF(IPAMDL(115).EQ.2) THEN
22364 CALL PHO_PDF(2,X0HD(NN,2),QQPD,PVIRTP(2),PD1)
22365 WG1 = PD1(NINHD(NN,2))/PDFVA(NN,2)
22371 & WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_POMSCA: ',
22372 & ' re-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
22373 & KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX
22375 IF(WGX.LT.DT_RNDM(WGX)) THEN
22384 IF(WGX.GT.1.D0) WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)')
22386 & 'weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
22387 & KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX
22392 IF((ISWMDL(8).GE.2)
22393 & .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
22394 IF(IPAMDL(109).EQ.1) THEN
22395 Q2H = PARMDL(93)*PTHD(NN)**2
22397 Q2H = -PARMDL(93)*VHD(NN)
22398 & *XHD(NN,1)*XHD(NN,2)*ECMP*ECMP
22400 XHMAX1 = 1.D0 - XSSS1 - MSCHA*AS + XHD(NN,1)
22401 XHMAX2 = 1.D0 - XSSS2 - MSCHA*AS + XHD(NN,2)
22404 P1(J) = PPH(I3+J,1)
22405 P2(J) = PPH(I3+J,2)
22408 & WRITE(LO,'(1X,A,/5X,2I3,1P,3E12.4)')
22409 & 'PHO_POMSCA: generate ISR for (L,NN,X1,X2,Q2H)',
22410 & L,NN,XHD(NN,1),XHD(NN,2),Q2H
22413 CALL PHO_HARISR(J,P1,P2,NOUTHD(NN,1),NOUTHD(NN,2),
22414 & N0INHD(NN,1),N0INHD(NN,2),N0IVAL(NN,1),N0IVAL(NN,2),Q2H,
22415 & X0HD(NN,1),X0HD(NN,2),XHMAX1,XHMAX2,IFL1,IFL2,
22416 & NIVAL(NN,1),NIVAL(NN,2),XISR1,XISR2,IREJ)
22417 XSSS1 = XSSS1+XISR1-XHD(NN,1)
22418 XSSS2 = XSSS2+XISR2-XHD(NN,2)
22425 C check phase space
22426 IF( (XSSS1.GT.XMAXX1)
22427 & .OR.(XSSS2.GT.XMAXX2)
22428 & .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
22429 IF(IHARD.EQ.0) THEN
22430 IF(ISWMDL(2).NE.1) GOTO 20
22438 C leave energy for leading particle effect
22439 IF((IHARD.GT.0).AND.
22440 & ((XSSS1.GT.XMAXP1).OR.(XSSS2.GT.XMAXP2))) then
22444 C hard scattering accepted
22448 IFAIL(31) = IFAIL(31)-1
22452 C ------------------- end of inner (hard) loop -------------------
22459 C count valences involved in hard scattering
22464 IF((NIVAL(NN,1).NE.0).AND.(IVAL1.EQ.0)) IVAL1 = NN
22465 IF((NIVAL(NN,2).NE.0).AND.(IVAL2.EQ.0)) IVAL2 = NN
22475 C photon, pomeron valences
22476 IF((IVAL1.EQ.0).AND.(NINHD(NN,1).NE.0)) THEN
22477 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
22482 IF((IVAL2.EQ.0).AND.(NINHD(NN,2).NE.0)) THEN
22483 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
22489 C total number of quarks
22490 IF(NINHD(NN,1).NE.0) THEN
22492 ELSE IF(IVGLU1.EQ.0) THEN
22495 IF(NINHD(NN,2).NE.0) THEN
22497 ELSE IF(IVGLU2.EQ.0) THEN
22502 C gluons emitted by valence quarks
22504 IF(II.EQ.1) VALPRO = VALPRG(1)
22507 IVAL1 = MAX(IVAL1,0)
22508 IF(IVAL1.EQ.0) THEN
22510 IF((IVGLU1.NE.0).AND.(DT_RNDM(XSS1).LT.VALPRO)) THEN
22516 IF(II.EQ.1) VALPRO = VALPRG(2)
22519 IVAL2 = MAX(IVAL2,0)
22520 IF(IVAL2.EQ.0) THEN
22522 IF((IVGLU2.NE.0).AND.(DT_RNDM(XSS2).LT.VALPRO)) THEN
22527 MSPOM = MAX(0,MSPOM-IQUA1-IQUA2)
22529 IF(IDEB(24).GE.5) WRITE(LO,'(1X,A,6I4)')
22530 & 'PHO_POMSCA: IVAL1/2,IQUA1/2,IVGLU1/2',
22531 & IVAL1,IVAL2,IQUA1,IQUA2,IVGLU1,IVGLU2
22533 C select soft X values
22535 C number of soft/remnant quarks
22536 IF(MSPOM.EQ.0) THEN
22537 IF(IPAMDL(18).EQ.0) THEN
22538 MSPAR1 = 2+2*MHPOM+MSREG-IQUA1-2*IVQ1-2*IVG1
22539 MSPAR2 = 2+2*MHPOM+MSREG-IQUA2-2*IVQ2-2*IVG2
22541 MSPAR1 = 2+MSREG+IQUA1-2*IVQ1
22542 MSPAR2 = 2+MSREG+IQUA2-2*IVQ2
22545 IF(IPAMDL(18).EQ.0) THEN
22546 MSPAR1 = 2*MSPOM+MSREG+2*MHPOM-IQUA1
22547 MSPAR2 = 2*MSPOM+MSREG+2*MHPOM-IQUA2
22549 MSPAR1 = 2*MSPOM+MSREG+IQUA1+2*IVG1
22550 MSPAR2 = 2*MSPOM+MSREG+IQUA2+2*IVG2
22554 IF(IDEB(24).GE.15) WRITE(LO,'(1X,A,9I3)')
22555 & 'PHO_POMSCA: MSP,MSR,MHP,IVQ1/2,IVG1/2,MSPAR1/2',
22556 & MSPOM,MSREG,MHPOM,IVQ1,IVQ2,IVG1,IVG2,MSPAR1,MSPAR2
22558 XMAX1 = 1.D0 - MAX(MSPAR1-1,0)*AS - XSS1
22559 XMAX2 = 1.D0 - MAX(MSPAR2-1,0)*AS - XSS2
22562 IF(IVAL1.LE.0) I1 = 0
22563 IF(IVAL2.LE.0) I2 = 0
22564 IF((IVQ1+IVG1)*(IVQ2+IVG2).NE.0) THEN
22567 MSDIFF = 2*MAX(0,MSPOM-1)
22571 MSM1 = MSPAR1-MSDIFF
22572 MSM2 = MSPAR2-MSDIFF
22573 XMAXH1 = MIN(XMAX1,PARMDL(44))
22574 XMAXH2 = MIN(XMAX2,PARMDL(44))
22575 CALL PHO_SOFTXX(NPOSP(1),NPOSP(2),MSG1,MSG2,I1,I2,MSM1,MSM2,
22576 & XSS1,XSS2,XMAXH1,XMAXH2,XS1,XS2,IREJ)
22578 C correct for proper simulation of high pt tail
22580 IF(IDEB(48).GE.2) WRITE(LO,'(1X,A,4I4)')
22581 & 'PHO_STDPAR: rejection (PHO_SOFTXX): MSPOM,MHPOM,I1,I2',
22582 & MSPOM,MHPOM,I1,I2
22583 IF(MSPOM*MHPOM.GT.0) THEN
22586 ELSE IF(MSPOM.GT.1) THEN
22589 ELSE IF(MHPOM.GT.1) THEN
22591 IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0)
22592 & .AND.(IPROCE.EQ.1)) THEN
22593 XSS1 = MAX(0.D0,1.D0-XPSUB)
22594 XSS2 = MAX(0.D0,1.D0-XTSUB)
22601 XSS1 = XSS1+ XHD(I,1)
22602 XSS2 = XSS2+ XHD(I,2)
22610 MSPOM = MSPOM-(MSPAR1-MSG1)/2
22613 C ------------ kinematics sampled ---------------
22615 IF(IDEB(24).GE.10) THEN
22616 WRITE(LO,'(1X,A,I3)')
22617 & 'PHO_POMSCA: soft x values, ITRY',ITRY
22618 DO 104 I=2,MAX(MSPAR1,MSPAR2)
22619 WRITE(LO,'(10X,I3,2E12.3)') I,XS1(I),XS2(I)
22622 IF((1.D0-XSS1)*(1.D0-XSS2).LT.AS) GOTO 20
22625 XS1(1) = 1.D0 - XSS1
22626 XS2(1) = 1.D0 - XSS2
22630 MH_acc_1(NPROHD(N),II) = MH_acc_1(NPROHD(N),II)+1
22633 C soft particle momenta
22634 IF(MAX(MSPAR1,MSPAR2).GT.MAXSOF) THEN
22635 WRITE(LO,'(1X,2A,3I4)') 'PHO_POMSCA: no space left in ',
22636 & '/POSOFT/ (MSPAR1/2,MAXSOF):',MSPAR1,MSPAR2,MAXSOF
22643 PSOFT1(3,I) = XS1(I)*ECMP/2.D0
22644 PSOFT1(4,I) = XS1(I)*ECMP/2.D0
22649 PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
22650 PSOFT2(4,I) = XS2(I)*ECMP/2.D0
22653 KSOFT = MAX(MSPAR1,MSPAR2)
22654 KHARD = MAX(MHPAR1,MHPAR2)
22660 IF(IDEB(24).GE.10) THEN
22661 WRITE(LO,'(/1X,A,2I3,2I5)')
22662 & 'PHO_POMSCA: accepted IVAL1,IVAL2,ITRY,NTRY',
22663 & IVAL1,IVAL2,ITRY,NTRY
22664 IF(MSPAR1+MSPAR2.GT.0) THEN
22665 WRITE(LO,'(5X,A)') 'soft x particle1 particle2:'
22668 DO 105 I=1,MAX(MSPAR1,MSPAR2)
22669 IF(I.LE.MIN(MSPAR1,MSPAR2)) THEN
22670 WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),XS2(I)
22671 XTMP1 = XTMP1+XS1(I)
22672 XTMP2 = XTMP2+XS2(I)
22673 ELSE IF(I.LE.MSPAR1) THEN
22674 WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),0.D0
22675 XTMP1 = XTMP1+XS1(I)
22676 ELSE IF(I.LE.MSPAR2) THEN
22677 WRITE(LO,'(10X,I3,2E13.4)') I,0.D0,XS2(I)
22678 XTMP2 = XTMP2+XS2(I)
22681 WRITE(LO,'(5X,A,2E13.4)') 'sum X1/2 (soft):',XTMP1,XTMP2
22683 IF(MHPAR1.GT.0) THEN
22685 & 'NR IDX MSPR hard X / hard X ISR / flavor particle 1,2:'
22688 WRITE(LO,'(5X,3I3,4E12.3,2I3)')
22689 & K,I,NPROHD(I),X0HD(I,1),X0HD(I,2),XHD(I,1),XHD(I,2),
22690 & NINHD(I,1),NINHD(I,2)
22691 XTMP1 = XTMP1+XHD(I,1)
22692 XTMP2 = XTMP2+XHD(I,2)
22694 WRITE(LO,'(1X,A,2E13.4)') 'sum X1/2 (soft+hard):',XTMP1,XTMP2
22695 WRITE(LO,'(5X,A)') 'hard momenta particle1:'
22699 WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,1),L=1,4),
22702 WRITE(LO,'(5X,A)') 'hard momenta particle2:'
22706 WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,2),L=1,4),
22713 C event rejected, print debug information
22715 IFAIL(4) = IFAIL(4)+1
22716 IF(IDEB(24).GE.2) THEN
22717 WRITE(LO,'(1X,2A,/,10X,7I5)') 'PHO_POMSCA: ',
22718 & 'rejection (MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ)',
22719 & MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ
22720 WRITE(LO,'(5X,A,I4,1P,2E12.4)') 'IP,Ecm,PTcut:',II,ECMP,PTWANT
22721 IF(IDEB(24).GE.5) THEN
22724 CALL PHO_PREVNT(-1)
22730 *$ CREATE PHO_HARX12.FOR
22732 CDECK ID>, PHO_HARX12
22733 SUBROUTINE PHO_HARX12
22734 C**********************************************************************
22736 C selection of x1 and x2 according to 1/x1*1/x2
22738 C**********************************************************************
22739 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22742 PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
22744 C input/output channels
22746 COMMON /POINOU/ LI,LO
22747 C data on most recent hard scattering
22748 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22749 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22750 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22751 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22752 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22753 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22754 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22755 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22756 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22759 Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
22760 Z2 = Z2MAX-DT_RNDM(X2)*Z2DIF
22761 IF ( (Z1+Z2).LT.ALNH ) GOTO 10
22765 W = SQRT(MAX(TINY,1.D0-AXX))
22770 *$ CREATE PHO_HARDX1.FOR
22772 CDECK ID>, PHO_HARDX1
22773 SUBROUTINE PHO_HARDX1
22774 C**********************************************************************
22776 C selection of x1 according to 1/x1
22779 C**********************************************************************
22780 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22783 PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
22785 C input/output channels
22787 COMMON /POINOU/ LI,LO
22788 C data on most recent hard scattering
22789 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22790 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22791 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22792 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22793 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22794 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22795 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22796 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22797 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22799 Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
22803 W = SQRT(MAX(TINY,1.D0-AXX))
22808 *$ CREATE PHO_HARKIN.FOR
22810 CDECK ID>, PHO_HARKIN
22811 SUBROUTINE PHO_HARKIN(IREJ)
22812 C***********************************************************************
22814 C selection of kinematic variables
22815 C (resolved and direct processes)
22817 C***********************************************************************
22818 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22821 PARAMETER ( TINY= 1.D-30, TINYP=1.D-14 )
22823 C input/output channels
22825 COMMON /POINOU/ LI,LO
22826 C event debugging information
22828 PARAMETER (NMAXD=100)
22829 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
22830 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22831 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
22832 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22833 C data of c.m. system of Pomeron / Reggeon exchange
22834 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
22835 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
22836 & SIDP,CODP,SIFP,COFP
22837 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
22838 & SIDP,CODP,SIFP,COFP,NPOSP(2),
22839 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
22840 C data on most recent hard scattering
22841 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22842 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22843 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22844 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22845 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22846 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22847 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22848 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22849 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22850 C internal cross check information on hard scattering limits
22851 DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
22852 COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)
22854 PARAMETER ( Max_pro_2 = 16 )
22855 DIMENSION RM(-1:Max_pro_2)
22856 DATA RM / 3.31D0, 0.0D0,
22857 & 7.60D0, 0.65D0, 4.00D0, 0.65D0, 0.89D0,
22858 & 0.45D0, 0.89D0, 0.89D0, 0.0D0, 4.776D0,
22859 & 0.615D0,4.776D0,0.615D0,1.0D0, 0.0D0,
22865 C------------- resolved processes -----------
22868 V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
22870 R = (1.D0+W)*2.25D0*(V*V*(3.D0-U*V-V/(U*U))-U)
22871 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22872 & 'PHO_HARKIN:weight error',M
22873 IF ( R*W.LT.RM(1)*DT_RNDM(X2) ) GOTO 10
22874 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22875 ELSEIF ( M.EQ.2 .OR. M.EQ.4 ) THEN
22878 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
22880 R = (U*U+V*V)*((16.D0/27.D0)/U-(4.D0/3.D0)*V)*(WL/W)*AXX
22881 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22882 & 'PHO_HARKIN:weight error',M
22883 IF ( R*W.LT.RM(M)*DT_RNDM(X2) ) GOTO 20
22884 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22885 ELSEIF ( M.EQ.3 ) THEN
22887 V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
22889 R = (1.D0+W)*(1.D0+U*U)*(1.D0-(4.D0/9.D0)*V*V/U)
22890 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22891 & 'PHO_HARKIN:weight error',M
22892 IF ( R*W.LT.RM(3)*DT_RNDM(X2) ) GOTO 30
22893 ELSEIF ( M.EQ.5 ) THEN
22895 V =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
22897 R = (4.D0/9.D0)*(1.D0+U*U+V*V*(U*U+V*V))-(8.D0/27.D0)*U*U*V
22898 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22899 & 'PHO_HARKIN:weight error',M
22900 IF ( R*W.LT.RM(5)*DT_RNDM(X2) ) GOTO 50
22901 ELSEIF ( M.EQ.6 ) THEN
22903 V =-0.5D0*(1.D0+W)+DT_RNDM(X1)*W
22905 R = (4.D0/9.D0)*(U*U+V*V)*AXX
22906 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22907 & 'PHO_HARKIN:weight error',M
22908 IF ( R*W.LT.RM(6)*DT_RNDM(V) ) GOTO 60
22909 ELSEIF ( M.EQ.7 ) THEN
22911 V =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
22913 R = (1.D0+W)*((2.D0/9.D0)*(1.D0+U*U+(1.D0+V*V)*V*V/(U*U))
22914 & -(4.D0/27.D0)*V/U)
22915 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22916 & 'PHO_HARKIN:weight error',M
22917 IF ( R*W.LT.RM(7)*DT_RNDM(X2) ) GOTO 70
22918 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22919 ELSEIF ( M.EQ.8 ) THEN
22921 V =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
22923 R = (4.D0/9.D0)*(1.D0+U*U)
22924 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22925 & 'PHO_HARKIN:weight error',M
22926 IF ( R*W.LT.RM(8)*DT_RNDM(X2) ) GOTO 80
22927 ELSEIF ( M.EQ.-1 ) THEN
22930 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
22932 R = (1.D0+V*V)*(V/(U*U)-(4.D0/9.D0))*(WL/W)*AXX
22933 IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22934 & 'PHO_HARKIN:weight error',M
22935 IF ( R*W.LT.RM(-1)*DT_RNDM(X2) ) GOTO 90
22936 C------------- direct / single-resolved processes -----------
22937 ELSEIF ( M.EQ.10 ) THEN
22938 100 CALL PHO_HARDX1
22939 WL = LOG(AXX/(1.D0+W)**2)
22940 U =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
22941 R = -(8.D0/3.D0)*(U*U+1.D0)*WL*AXX
22942 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22943 & 'PHO_HARKIN:weight error',M
22944 IF ( R.LT.RM(10)*DT_RNDM(U) ) GOTO 100
22948 ELSEIF ( M.EQ.11) THEN
22949 110 CALL PHO_HARDX1
22951 U =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
22953 R = (U*U+V*V)/V*WL*AXX
22954 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22955 & 'PHO_HARKIN:weight error',M
22956 IF ( R.LT.RM(11)*DT_RNDM(X2) ) GOTO 110
22957 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22960 ELSEIF ( M.EQ.12 ) THEN
22961 120 CALL PHO_HARDX1
22962 WL = LOG(AXX/(1.D0+W)**2)
22963 V =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
22964 R = -(8.D0/3.D0)*(V*V+1.D0)*WL*AXX
22965 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22966 & 'PHO_HARKIN:weight error',M
22967 IF ( R.LT.RM(12)*DT_RNDM(V) ) GOTO 120
22968 ELSEIF ( M.EQ.13) THEN
22969 130 CALL PHO_HARDX1
22971 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
22973 R = (U*U+V*V)/U*WL*AXX
22974 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22975 & 'PHO_HARKIN:weight error',M
22976 IF ( R.LT.RM(13)*DT_RNDM(X2) ) GOTO 130
22977 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22978 C------------- (double) direct process -----------
22979 ELSEIF ((M.EQ.14).OR.(M.EQ.16)) THEN
22983 W = SQRT(MAX(TINY,1.D0-AXX))
22986 140 V =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
22989 IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22990 & 'PHO_HARKIN:weight error',M
22991 IF ( R.LT.RM(14)*DT_RNDM(X2) ) GOTO 140
22992 IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22993 C---------------------------------------------
22995 WRITE(LO,'(/1X,A,I3)')
22996 & 'PHO_HARKIN:ERROR:unsupported process (MSPR)',MSPR
23000 V = MAX(MIN(V,-TINYP ),-1.D0+TINYP)
23002 U = MAX(MIN(U,-TINYP ),-1.D0+TINYP)
23003 PT = SQRT(U*V*X1*X2)*ECMP
23004 ETAC = 0.5D0*LOG((U*X1)/(V*X2))
23005 ETAD = 0.5D0*LOG((V*X1)/(U*X2))
23007 ***************************************************************
23010 ETAMI(1,MM) = MIN(ETAMI(1,MM),ETAC)
23011 ETAMA(1,MM) = MAX(ETAMA(1,MM),ETAC)
23012 ETAMI(2,MM) = MIN(ETAMI(2,MM),ETAD)
23013 ETAMA(2,MM) = MAX(ETAMA(2,MM),ETAD)
23014 XXMI(1,MM) = MIN(XXMI(1,MM),X1)
23015 XXMA(1,MM) = MAX(XXMA(1,MM),X1)
23016 XXMI(2,MM) = MIN(XXMI(2,MM),X2)
23017 XXMA(2,MM) = MAX(XXMA(2,MM),X2)
23018 ***************************************************************
23020 IF(IDEB(81).GE.25) WRITE(LO,'(1X,A,/5X,6E12.3)')
23021 & 'PHO_HARKIN: V,PT,ETAC,ETAD,X1,X2',V,PT,ETAC,ETAD,X1,X2
23025 *$ CREATE PHO_HARWGH.FOR
23027 CDECK ID>, PHO_HARWGH
23028 SUBROUTINE PHO_HARWGH(PDS,PDA,PDB,FDISTR)
23029 C***********************************************************************
23031 C calculate product of PDFs and coupling constants
23032 C according to selected MSPR (process type)
23036 C output: PDS resulting from PDFs alone
23037 C FDISTR complete weight function
23038 C PDA,PDB fields containing the PDFs
23040 C***********************************************************************
23041 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23044 PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
23046 C input/output channels
23048 COMMON /POINOU/ LI,LO
23049 C event debugging information
23051 PARAMETER (NMAXD=100)
23052 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
23053 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23054 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
23055 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23056 C model switches and parameters
23058 INTEGER ISWMDL,IPAMDL
23059 DOUBLE PRECISION PARMDL
23060 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
23061 C data of c.m. system of Pomeron / Reggeon exchange
23062 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23063 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23064 & SIDP,CODP,SIFP,COFP
23065 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23066 & SIDP,CODP,SIFP,COFP,NPOSP(2),
23067 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
23068 C currently activated parton density parametrizations
23070 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
23071 DOUBLE PRECISION PDFLAM,PDFQ2M
23072 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
23073 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
23074 C hard scattering parameters used for most recent hard interaction
23076 DOUBLE PRECISION ALQCD2,BQCD
23077 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
23078 C some hadron information, will be deleted in future versions
23080 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
23081 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
23082 C scale parameters for parton model calculations
23083 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
23084 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
23085 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
23086 & NQQAL,NQQALI,NQQALF,NQQPD
23087 C data on most recent hard scattering
23088 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23089 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23090 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23091 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23092 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23093 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23094 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23095 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23096 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23097 C hard cross sections and MC selection weights
23099 PARAMETER ( Max_pro_2 = 16 )
23100 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
23101 & MH_acc_1,MH_acc_2
23102 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
23103 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
23104 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
23105 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
23106 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
23107 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
23109 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
23110 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
23111 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
23113 DOUBLE PRECISION PHO_ALPHAS,pho_alphae
23114 DIMENSION PDA(-6:6),PDB(-6:6)
23117 C set hard scale QQ for alpha and partondistr.
23118 IF ( NQQAL.EQ.1 ) THEN
23120 ELSEIF ( NQQAL.EQ.2 ) THEN
23121 QQAL = AQQAL*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
23122 ELSEIF ( NQQAL.EQ.3 ) THEN
23123 QQAL = AQQAL*X1*X2*ECMP*ECMP
23124 ELSEIF ( NQQAL.EQ.4 ) THEN
23125 QQAL = AQQAL*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
23127 IF ( NQQPD.EQ.1 ) THEN
23129 ELSEIF ( NQQPD.EQ.2 ) THEN
23130 QQPD = AQQPD*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
23131 ELSEIF ( NQQPD.EQ.3 ) THEN
23132 QQPD = AQQPD*X1*X2*ECMP*ECMP
23133 ELSEIF ( NQQPD.EQ.4 ) THEN
23134 QQPD = AQQPD*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
23136 C coupling constants, PDFs
23138 ALPHA1 = PHO_ALPHAS(QQAL,3)
23140 CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
23141 CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
23142 IF ( MSPR.EQ.1 .OR. MSPR.EQ.4 ) THEN
23143 PDS = PDA(0)*PDB(0)
23150 S2 = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
23151 S3 = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
23152 S4 = S4+PDA(I)+PDA(-I)
23153 S5 = S5+PDB(I)+PDB(-I)
23155 IF ((MSPR.EQ.2).OR.(MSPR.EQ.5).OR.(MSPR.EQ.6)) THEN
23157 ELSE IF((MSPR.EQ.3).OR.(MSPR.EQ.-1)) THEN
23158 PDS = PDA(0)*S5+PDB(0)*S4
23159 ELSE IF(MSPR.EQ.7) THEN
23161 ELSE IF(MSPR.EQ.8) THEN
23162 PDS = S4*S5-(S2+S3)
23165 ELSE IF(MSPR.LT.12) THEN
23166 ALPHA2 = PHO_ALPHAS(QQAL,2)
23167 IF(IDPDG1.EQ.22) THEN
23168 ALPHA1 = pho_alphae(QQAL)
23169 ELSE IF(IDPDG1.EQ.990) THEN
23170 ALPHA1 = PARMDL(74)
23172 CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
23176 S4 = S4+PDB(I)+PDB(-I)
23178 * IF(MOD(I,2).EQ.0) THEN
23179 * S6 = S6+(PDB(I)+PDB(-I))*4.D0/9.D0
23181 * S6 = S6+(PDB(I)+PDB(-I))*1.D0/9.D0
23183 S6 = S6+(PDB(I)+PDB(-I))*Q_ch2(I)
23185 IF(MSPR.EQ.10) THEN
23186 IF(IDPDG1.EQ.990) THEN
23194 ELSE IF(MSPR.LT.14) THEN
23195 ALPHA1 = PHO_ALPHAS(QQAL,1)
23196 IF(IDPDG2.EQ.22) THEN
23197 ALPHA2 = pho_alphae(QQAL)
23198 ELSE IF(IDPDG2.EQ.990) THEN
23199 ALPHA2 = PARMDL(74)
23201 CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
23205 S4 = S4+PDA(I)+PDA(-I)
23207 * IF(MOD(I,2).EQ.0) THEN
23208 * S6 = S6+(PDA(I)+PDA(-I))*4.D0/9.D0
23210 * S6 = S6+(PDA(I)+PDA(-I))*1.D0/9.D0
23212 S6 = S6+(PDA(I)+PDA(-I))*Q_ch2(I)
23214 IF(MSPR.EQ.12) THEN
23215 IF(IDPDG2.EQ.990) THEN
23223 ELSE IF(MSPR.EQ.14) THEN
23224 SSR = X1*X2*ECMP*ECMP
23225 IF(IDPDG1.EQ.22) THEN
23226 ALPHA1 = pho_alphae(SSR)
23227 ELSE IF(IDPDG1.EQ.990) THEN
23228 ALPHA1 = PARMDL(74)
23230 IF(IDPDG2.EQ.22) THEN
23231 ALPHA2 = pho_alphae(SSR)
23232 ELSE IF(IDPDG2.EQ.990) THEN
23233 ALPHA2 = PARMDL(74)
23237 WRITE(LO,'(/1X,A,I4)')
23238 & 'PHO_HARWGH:ERROR: invalid hard process number (MSPR)',MSPR
23243 FDISTR = HFac(MSPR)*ALPHA1*ALPHA2*PDS
23246 IF(IDEB(15).GE.20) WRITE(LO,'(1X,A,/5X,I3,2I6,4E10.3)')
23247 & 'PHO_HARWGH: MSPR,ID1,ID2,AL1,AL2,PDS,FDIS',
23248 & MSPR,IDPDG1,IDPDG2,ALPHA1,ALPHA2,PDS,FDISTR
23252 *$ CREATE PHO_HARSCA.FOR
23254 CDECK ID>, PHO_HARSCA
23255 SUBROUTINE PHO_HARSCA(IMODE,IP)
23256 C***********************************************************************
23258 C PHO_HARSCA determines the type of hard subprocess, the partons
23259 C taking part in this subprocess and the kinematic variables
23261 C input: IMODE 1 direct processes
23262 C 2 resolved processes
23263 C -1 initialization
23264 C -2 output of statistics
23265 C IP 1-4 particle combination (hadron/photon)
23267 C***********************************************************************
23268 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23271 PARAMETER( EPS = 1.D-10,
23274 C input/output channels
23276 COMMON /POINOU/ LI,LO
23277 C event debugging information
23279 PARAMETER (NMAXD=100)
23280 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
23281 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23282 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
23283 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23284 C model switches and parameters
23286 INTEGER ISWMDL,IPAMDL
23287 DOUBLE PRECISION PARMDL
23288 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
23289 C internal rejection counters
23291 PARAMETER (NMXJ=60)
23292 CHARACTER*10 REJTIT
23294 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
23295 C hard scattering parameters used for most recent hard interaction
23297 DOUBLE PRECISION ALQCD2,BQCD
23298 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
23299 C data of c.m. system of Pomeron / Reggeon exchange
23300 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23301 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23302 & SIDP,CODP,SIFP,COFP
23303 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23304 & SIDP,CODP,SIFP,COFP,NPOSP(2),
23305 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
23306 C names of hard scattering processes
23308 PARAMETER ( Max_pro_1 = 16 )
23310 COMMON /POHPRO/ PROC(0:Max_pro_1)
23311 C data on most recent hard scattering
23312 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23313 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23314 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23315 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23316 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23317 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23318 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23319 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23320 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23321 C hard scattering data
23323 PARAMETER ( MSCAHD = 50 )
23324 INTEGER LSCAHD,LSC1HD,LSIDX,
23325 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
23326 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
23327 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
23328 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
23329 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
23330 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
23331 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
23332 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
23333 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
23334 C hard cross sections and MC selection weights
23336 PARAMETER ( Max_pro_2 = 16 )
23337 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
23338 & MH_acc_1,MH_acc_2
23339 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
23340 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
23341 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
23342 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
23343 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
23344 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
23346 INTEGER IPFIL,IFAFIL,IFBFIL
23347 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
23348 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
23349 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
23350 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
23351 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
23352 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
23353 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
23354 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
23355 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
23356 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
23357 & IPFIL,IFAFIL,IFBFIL
23359 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
23360 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
23361 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
23365 C resolved processes
23366 IF(IMODE.EQ.2) THEN
23368 MH_pro_on(0,IP) = 0
23371 IF(MH_pro_on(M,IP).EQ.1) HWgx(9) = HWgx(9)+HWgx(M)
23373 IF(HWgx(9).LT.DEPS) THEN
23374 WRITE(LO,'(/1X,2A,I4,1P,E12.4)') 'PHO_HARSCA:ERROR: ',
23375 & 'no resolved process possible for IP',IP,HWgx(9)
23379 C ----------------------------------------------I
23380 C begin of iteration loop (resolved processes) I
23385 IF(IREJSC.GT.1000) THEN
23386 WRITE(LO,'(/1X,A,I10)')
23387 & 'PHO_HARSCA:ERROR: too many rejections (resolved)',IREJSC
23392 B = DT_RNDM(X1)*HWgx(9)
23396 IF ( MH_pro_on(MSPR,IP).EQ.1 ) SUM = SUM+HWgx(MSPR)
23397 IF ( SUM.LT.B .AND. MSPR.LT.8 ) GOTO 20
23399 IF(IDEB(78).GE.20) WRITE(LO,'(1x,a,i3,i6)')
23400 & 'PHO_HARSCA: resolved process (MSPR,IREJSC)',MSPR,IREJSC
23402 C find kin. variables X1,X2 and V
23403 CALL PHO_HARKIN(IREJ)
23405 IFAIL(29) = IFAIL(29)+1
23408 C calculate remaining distribution
23409 CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
23410 C actualize counter for cross-section calculation
23411 if(F.LE.1.D-15) then
23415 * XSECT(5,MSPR) = XSECT(5,MSPR)+F
23416 * XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
23417 MH_tried(MSPR,IP) = MH_tried(MSPR,IP)+1
23418 C check F against FMAX
23419 WEIGHT = F/(HWgx(MSPR)+DEPS)
23420 IF ( WEIGHT.LT.DT_RNDM(X2) ) GOTO 10
23421 C-------------------------------------------------------------------
23422 IF(WEIGHT.GT.1.D0) THEN
23423 WRITE(LO,1234) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR),WEIGHT
23424 1234 FORMAT(/,' PHO_HARSCA: (resolved) W>1 (MSPR,IP,ID1,2)',
23425 & 2I3,2I7,/' F,HWgx(MSPR),W',3E12.4)
23426 WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
23427 & ECMP,PTWANT,AS,AH,PT
23428 WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
23429 & ETAC,ETAD,X1,X2,V
23430 CALL PHO_PREVNT(-1)
23432 C-------------------------------------------------------------------
23434 C end of iteration loop (resolved processes) I
23435 C --------------------------------------------I
23437 C*********************************************************************
23441 ELSE IF(IMODE.EQ.1) THEN
23443 C single-resolved processes kinematically forbidden
23444 if(Z1DIF.lt.0.D0) then
23452 if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
23454 IF(MH_pro_on(M,IP).EQ.1) then
23455 if((M.eq.10).or.(M.eq.11)) then
23456 fac = FSUH(1)*FSUP(2)
23457 else if((M.eq.12).or.(M.eq.13)) then
23458 fac = FSUP(1)*FSUH(2)
23460 fac = FSUH(1)*FSUH(2)
23462 HWgx(15) = HWgx(15)+HWgx(M)*fac
23467 IF(MH_pro_on(M,IP).EQ.1) HWgx(15)=HWgx(15)+HWgx(M)
23470 IF(HWgx(15).LT.DEPS) THEN
23471 WRITE(LO,'(/1X,2A,I4)') 'PHO_HARSCA:ERROR: ',
23472 & 'no direct/single-resolved process possible (IP)',IP
23476 C ----------------------------------------------I
23477 C begin of iteration loop (direct processes) I
23482 IF(IREJSC.GT.1000) THEN
23483 WRITE(LO,'(/1X,A,I10)')
23484 & 'PHO_HARSCA:ERROR: too many rejections (direct)',IREJSC
23489 B = DT_RNDM(X1)*HWgx(15)
23492 if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
23495 IF(MH_pro_on(MSPR,IP).EQ.1) then
23496 if((MSPR.eq.10).or.(MSPR.eq.11)) then
23497 fac = FSUH(1)*FSUP(2)
23498 else if((MSPR.eq.12).or.(MSPR.eq.13)) then
23499 fac = FSUP(1)*FSUH(2)
23501 fac = FSUH(1)*FSUH(2)
23503 SUM = SUM+HWgx(MSPR)*fac
23505 IF ( SUM.LT.B .AND. MSPR.LT.14 ) GOTO 150
23509 IF(MH_pro_on(MSPR,IP).EQ.1) SUM = SUM+HWgx(MSPR)
23510 IF ( SUM.LT.B .AND. MSPR.LT.14 ) GOTO 200
23513 IF(IDEB(78).GE.20) WRITE(LO,'(1x,a,i3,i6)')
23514 & 'PHO_HARSCA: direct process (MSPR,IREJSC)',MSPR,IREJSC
23516 C find kin. variables X1,X2 and V
23517 CALL PHO_HARKIN(IREJ)
23519 IFAIL(28) = IFAIL(28)+1
23523 C calculate remaining distribution
23524 CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
23526 C counter for cross-section calculation
23527 if(F.LE.1.D-15) then
23531 * XSECT(5,MSPR) = XSECT(5,MSPR)+F
23532 * XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
23533 MH_tried(MSPR,IP) = MH_tried(MSPR,IP)+1
23534 C check F against FMAX
23535 WEIGHT = F/(HWgx(MSPR)+DEPS)
23536 IF(WEIGHT.LT.DT_RNDM(X2)) GOTO 100
23537 C-------------------------------------------------------------------
23538 IF(WEIGHT.GT.1.D0) THEN
23539 WRITE(LO,1235) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR),WEIGHT
23540 1235 FORMAT(/,' PHO_HARSCA: (direct) W>1 (MSPR,IP,ID1,2)',
23541 & 2I3,2I7,/,' F,HWgx(MSPR),W',3E12.4)
23542 WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
23543 & ECMP,PTWANT,AS,AH,PT
23544 WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
23545 & ETAC,ETAD,X1,X2,V
23546 CALL PHO_PREVNT(-1)
23548 C-------------------------------------------------------------------
23550 C end of iteration loop (direct processes) I
23551 C --------------------------------------------I
23553 ELSE IF(IMODE.EQ.-1) THEN
23555 C initialize cross section calculations
23557 DO 40 M=-1,Max_pro_2
23559 * XSECT(I,M) = 0.D0
23568 IF(IDEB(78).GE.0) THEN
23569 WRITE(LO,'(/1X,A,/1X,A)')
23570 & 'PHO_HARSCA: activated hard processes',
23571 & '------------------------------------'
23572 WRITE(LO,'(5X,A)') 'PROCESS, IP= 1 ... 4 (on/off)'
23573 DO 42 M=1,Max_pro_2
23574 WRITE(LO,'(1X,I3,5X,A,4I3)') M,PROC(M),
23575 & (MH_pro_on(M,J),J=1,4)
23580 ELSE IF(IMODE.EQ.-2) THEN
23582 C calculation of process statistics
23596 MH_tried(3,K) = MH_tried(3,K)+MH_tried(-1,K)
23597 MH_acc_1(3,K) = MH_acc_1(3,K)+MH_acc_1(-1,K)
23598 MH_acc_2(3,K) = MH_acc_2(3,K)+MH_acc_2(-1,K)
23601 MH_tried(9,K) = MH_tried(9,K)+MH_tried(M,K)
23602 MH_acc_1(9,K) = MH_acc_1(9,K)+MH_acc_1(M,K)
23603 MH_acc_2(9,K) = MH_acc_2(9,K)+MH_acc_2(M,K)
23606 MH_tried(15,K) = MH_tried(15,K)+MH_tried(M,K)
23607 MH_acc_1(15,K) = MH_acc_1(15,K)+MH_acc_1(M,K)
23608 MH_acc_2(15,K) = MH_acc_2(15,K)+MH_acc_2(M,K)
23610 MH_tried(0,K) = MH_tried(9,K)+MH_tried(15,K)
23611 MH_acc_1(0,K) = MH_acc_1(9,K)+MH_acc_1(15,K)
23612 MH_acc_2(0,K) = MH_acc_2(9,K)+MH_acc_2(15,K)
23615 IF(IDEB(78).GE.1) THEN
23616 WRITE(LO,'(/1X,A,/1X,A)')
23617 & 'PHO_HARSCA: internal rejection statistics',
23618 & '-----------------------------------------'
23620 IF(MH_tried(0,K).GT.0) THEN
23621 WRITE(LO,'(5X,A,I3)')
23622 & 'process (sampled/accepted) for IP:',K
23624 WRITE(LO,'(1X,I3,1X,A,2X,3I12,F10.4)') M,PROC(M),
23625 & MH_tried(M,K),MH_acc_1(M,K),MH_acc_2(K,K),
23626 & dble(MH_acc_1(M,K))/dble(max(1,MH_tried(M,K)))
23634 WRITE(LO,'(/1X,2A,I10)') 'PHO_HARSCA:ERROR: ',
23635 & 'unsupported mode',IMODE
23639 C the event is accepted now
23640 C actualize counter for accepted events
23641 MH_acc_1(MSPR,IP) = MH_acc_1(MSPR,IP)+1
23642 IF(MSPR.EQ.-1) MSPR = 3
23644 C find flavor of initial partons
23647 SCHECK = DT_RNDM(SUM)*PDS-EPS
23648 IF ( MSPR.EQ.1 .OR. MSPR.EQ.4 ) THEN
23651 ELSEIF ( MSPR.EQ.2 .OR. MSPR.EQ.5 .OR. MSPR.EQ.6 ) THEN
23653 IF ( IA.EQ.0 ) GOTO 610
23654 SUM = SUM+PDF1(IA)*PDF2(-IA)
23655 IF ( SUM.GE.SCHECK ) GOTO 620
23658 ELSEIF ( MSPR.EQ.3 ) THEN
23661 IF ( IA.EQ.0 ) GOTO 630
23662 SUM = SUM+PDF1(0)*PDF2(IA)
23663 IF ( SUM.GE.SCHECK ) GOTO 640
23664 SUM = SUM+PDF1(IA)*PDF2(0)
23665 IF ( SUM.GE.SCHECK ) GOTO 650
23670 ELSEIF ( MSPR.EQ.7 ) THEN
23672 IF ( IA.EQ.0 ) GOTO 660
23673 SUM = SUM+PDF1(IA)*PDF2(IA)
23674 IF ( SUM.GE.SCHECK ) GOTO 670
23677 ELSEIF ( MSPR.EQ.8 ) THEN
23679 IF ( IA.EQ.0 ) GOTO 690
23681 IF ( ABS(IB).EQ.ABS(IA) .OR. IB.EQ.0 ) GOTO 680
23682 SUM = SUM+PDF1(IA)*PDF2(IB)
23683 IF ( SUM.GE.SCHECK ) GOTO 700
23687 ELSEIF ( MSPR.EQ.10 ) THEN
23690 IF ( IB.NE.0 ) THEN
23691 IF(IDPDG1.EQ.22) THEN
23692 * IF(MOD(ABS(IB),2).EQ.0) THEN
23693 * SUM = SUM+PDF2(IB)*4.D0/9.D0
23695 * SUM = SUM+PDF2(IB)*1.D0/9.D0
23697 SUM = SUM+PDF2(IB)*Q_ch2(IB)
23701 IF ( SUM.GE.SCHECK ) GOTO 720
23705 ELSEIF ( MSPR.EQ.12 ) THEN
23708 IF ( IA.NE.0 ) THEN
23709 IF(IDPDG2.EQ.22) THEN
23710 * IF(MOD(ABS(IA),2).EQ.0) THEN
23711 * SUM = SUM+PDF1(IA)*4.D0/9.D0
23713 * SUM = SUM+PDF1(IA)*1.D0/9.D0
23715 SUM = SUM+PDF1(IA)*Q_ch2(IA)
23719 IF ( SUM.GE.SCHECK ) GOTO 820
23723 ELSEIF ((MSPR.EQ.11).OR.(MSPR.EQ.13).OR.(MSPR.EQ.14)) THEN
23728 IF((ABS(IA).GT.NF).OR.(ABS(IB).GT.NF)) THEN
23729 WRITE(LO,*) 'PHO_HARSCA: rejection, final check IA,IB',IA,IB
23730 WRITE(LO,*) 'EVENT,MSPR,IA,IB,NF: ',KEVENT,MSPR,IA,IB,NF
23734 C find flavour of final partons
23738 IF ( MSPR.EQ.2 ) THEN
23741 ELSEIF ( MSPR.EQ.4 ) THEN
23742 IC = INT(FLOAT(NF+NF)*DT_RNDM(SUM))+1
23743 IF ( IC.GT.NF ) IC = NF-IC
23745 ELSEIF ( MSPR.EQ.6 ) THEN
23746 IC = INT(FLOAT(NF+NF-2)*DT_RNDM(SUM))+1
23747 IF ( IC.GT.NF-1 ) IC = NF-1-IC
23748 IF ( ABS(IC).EQ.ABS(IA) ) IC = SIGN(NF,IC)
23750 ELSEIF ( MSPR.EQ.11) THEN
23753 IF ( IC.NE.0 ) THEN
23754 IF(IDPDG1.EQ.22) THEN
23755 * IF(MOD(ABS(IC),2).EQ.0) THEN
23760 SUM = SUM + Q_ch2(IC)
23766 SCHECK = DT_RNDM(SUM)*SUM-EPS
23769 IF ( IC.NE.0 ) THEN
23770 IF(IDPDG1.EQ.22) THEN
23771 * IF(MOD(ABS(IC),2).EQ.0) THEN
23776 SUM = SUM + Q_ch2(IC)
23780 IF ( SUM.GE.SCHECK ) GOTO 750
23785 ELSEIF ( MSPR.EQ.12) THEN
23788 ELSEIF ( MSPR.EQ.13) THEN
23791 IF ( IC.NE.0 ) THEN
23792 IF(IDPDG2.EQ.22) THEN
23793 * IF(MOD(ABS(IC),2).EQ.0) THEN
23798 SUM = SUM + Q_ch2(IC)
23804 SCHECK = DT_RNDM(SUM)*SUM-EPS
23807 IF ( IC.NE.0 ) THEN
23808 IF(IDPDG2.EQ.22) THEN
23809 * IF(MOD(ABS(IC),2).EQ.0) THEN
23814 SUM = SUM + Q_ch2(IC)
23818 IF ( SUM.GE.SCHECK ) GOTO 850
23823 ELSEIF ( MSPR.EQ.14) THEN
23828 IF(MOD(ABS(IC),2).EQ.0) THEN
23829 IF(IDPDG1.EQ.22) FAC1 = 4.D0
23830 IF(IDPDG2.EQ.22) FAC2 = 4.D0
23832 SUM = SUM + FAC1*FAC2
23834 IF(IPAMDL(64).NE.0) THEN
23835 IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) SUM = SUM + 81.D0
23837 SCHECK = DT_RNDM(SUM)*SUM-EPS
23842 IF(MOD(ABS(IC),2).EQ.0) THEN
23843 IF(IDPDG1.EQ.22) FAC1 = 4.D0
23844 IF(IDPDG2.EQ.22) FAC2 = 4.D0
23846 SUM = SUM + FAC1*FAC2
23847 IF ( SUM.GE.SCHECK ) GOTO 950
23852 IF(DT_RNDM(FAC1).GT.0.5D0) CALL PHO_SWAPI(IC,ID)
23857 XM3 = PHO_PMASS(IC,3)
23862 XM4 = PHO_PMASS(ID,3)
23864 IF(ABS(IC).EQ.15) GOTO 955
23866 C valence quarks involved?
23869 IF(IDPDG1.EQ.22) THEN
23870 CALL PHO_QPMPDF(IA,X1,QQPD,0.D0,PVIRTP(1),FXP)
23871 IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(IA)-FXP) IV1 = 1
23873 IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(-IA)) IV1 = 1
23878 IF(IDPDG2.EQ.22) THEN
23879 CALL PHO_QPMPDF(IB,X2,QQPD,0.D0,PVIRTP(2),FXP)
23880 IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(IB)-FXP) IV2 = 1
23882 IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(-IB)) IV2 = 1
23886 C fill event record
23889 CALL PHO_SFECFE(SINPHI,COSPHI)
23903 PHO1(1) = PT*COSPHI
23904 PHO1(2) = PT*SINPHI
23905 PHO1(3) = -ECM2*(U*X1-V*X2)
23906 PHO1(4) = -ECM2*(U*X1+V*X2)
23910 PHO2(3) = -ECM2*(V*X1-U*X2)
23911 PHO2(4) = -ECM2*(V*X1+U*X2)
23914 C convert to mass shell
23915 CALL PHO_MSHELL(PHO1,PHO2,XM3,XM4,PHO1,PHO2,IREJ)
23917 IF(IDEB(78).GE.5) WRITE(LO,'(1X,A,1P,3E11.3)')
23918 & 'PHO_HARSCA: rejection by PHO_MSHELL (PT,M1,M2)',
23922 PTfin = SQRT(PHO1(1)**2+PHO1(2)**2)
23925 IF(IDEB(78).GE.20) THEN
23926 SHAT = X1*X2*ECMP*ECMP
23927 WRITE(LO,'(1X,A,5I4)') 'PHO_HARSCA: MSPR,IA,IB,IC,ID',
23929 WRITE(LO,'(5X,A,1P,4E11.3)') 'X1/2,MU2,Q2 ',X1,X2,QQPD,QQAL
23930 WRITE(LO,'(5X,A,1P,4E11.3)') 'U,V,PT,SHAT ',U,V,PT,SHAT
23931 WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI1 ',PHI1
23932 WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI2 ',PHI2
23933 WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO1 ',PHO1
23934 WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO2 ',PHO2
23939 *$ CREATE PHO_HARFAC.FOR
23941 CDECK ID>, PHO_HARFAC
23942 SUBROUTINE PHO_HARFAC(PTCUT,ECMI)
23943 C*********************************************************************
23945 C initialization: find scaling factors and maxima of remaining
23948 C input: PTCUT transverse momentum cutoff
23951 C output: Hfac(-1:Max_pro_2) field for sampling hard processes
23953 C*********************************************************************
23954 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23957 PARAMETER ( MXABWT = 96 )
23959 C input/output channels
23961 COMMON /POINOU/ LI,LO
23962 C data of c.m. system of Pomeron / Reggeon exchange
23963 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23964 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23965 & SIDP,CODP,SIFP,COFP
23966 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23967 & SIDP,CODP,SIFP,COFP,NPOSP(2),
23968 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
23970 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
23971 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
23972 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
23973 C hard scattering parameters used for most recent hard interaction
23975 DOUBLE PRECISION ALQCD2,BQCD
23976 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
23977 C integration precision for hard cross sections (obsolete)
23978 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
23979 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
23980 C data on most recent hard scattering
23981 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23982 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23983 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23984 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23985 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23986 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23987 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23988 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23989 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23990 C hard cross sections and MC selection weights
23992 PARAMETER ( Max_pro_2 = 16 )
23993 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
23994 & MH_acc_1,MH_acc_2
23995 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
23996 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
23997 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
23998 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
23999 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24000 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24002 DIMENSION ABSZ(MXABWT),WEIG(MXABWT)
24003 DIMENSION S(-1:Max_pro_2),S1(-1:Max_pro_2),S2(-1:Max_pro_2),
24004 & F124(-1:Max_pro_2)
24005 DATA F124 / 1.D0,0.D0,
24006 & 4.D0,2.D0,2.D0,2.D0,4.D0,1.D0,4.D0,4.D0,0.D0,1.D0,
24007 & 2.D0,1.D0,2.D0,1.D0,0.D0,1.D0 /
24010 AH = (2.D0*PTCUT/ECMI)**2
24014 CALL PHO_GAUSET(0.D0,1.D0,NPOINT,ABSZ,WEIG)
24015 DO 10 M=-1,Max_pro_2
24019 C resolved processes
24028 Z2 = (1.D0-Z1)*ABSZ(I2)
24031 W = SQRT(1.D0-FAXX)
24041 VA =-0.5D0*W1/(W1+Z*W)
24043 VB =-0.5D0*FAXX/(W1+2.D0*W*Z)
24045 VC =-EXP(HLN+Z*WLOG)
24047 VE =-0.5D0*(1.D0+W)+Z*W
24049 S(1) = S(1)+(1.+W)*2.25*(VA*VA*(3.-UA*VA-VA/(UA*UA))-UA)*
24051 S(2) = S(2)+(VC*VC+UC*UC)*((16./27.)/UC-(4./3.)*VC)*FWW*
24053 S(3) = S(3)+(1.+W)*(1.+UA*UA)*(1.-(4./9.)*VA*VA/UA)*WEIG(I)
24054 S(5) = S(5)+((4./9.)*(1.+UB*UB+(UB*UB+VB*VB)*VB*VB)-
24055 & (8./27.)*UA*UA*VA)*WEIG(I)
24056 S(6) = S(6)+(4./9.)*(UE*UE+VE*VE)*FAXX*WEIG(I)
24057 S(7) = S(7)+(1.+W)*((2./9.)*(1.+UA*UA+(1.+VA*VA)*VA*VA/
24058 & (UA*UA))-(4./27.)*VA/UA)*WEIG(I)
24059 S(8) = S(8)+(4./9.)*(1.+UB*UB)*WEIG(I)
24060 S(-1) = S(-1)+(1.+VC*VC)*(VC/(UC*UC)-(4./9.))*FWW*WEIG(I)
24062 S(4) = S(2)*(9./32.)
24064 S2(M) = S2(M)+S(M)*WEIG(I2)*W
24068 S1(M) = S1(M)+S2(M)*(1.D0-Z1)*WEIG(I1)
24072 S1(6) = S1(6)*MAX(0,NF-1)
24075 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
24076 & .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24081 W = SQRT(1.D0-FAXX)
24084 WL = LOG(FAXX/(1.D0+W)**2)
24086 FWW2 = FAXX*WLOG/ALN
24093 UA =-(1.D0+W)/2.D0*EXP(Z*WL)
24095 VB =-EXP(HLN+Z*WLOG)
24097 S(10) = S(10)+(8.D0/3.D0)*(1.D0+UA*UA)*WEIG(I)*FWW1
24098 S(11) = S(11)-(VB*VB+UB*UB)/UB*WEIG(I)*FWW2
24101 S1(M) = S1(M)+S(M)*WEIG(I1)
24106 C quark charges fractions
24107 IF(IDPDG1.EQ.22) THEN
24110 CHRNF = CHRNF + Q_ch2(I)
24112 S1(11) = S1(11)*CHRNF
24113 ELSE IF(IDPDG1.EQ.990) THEN
24118 IF(IDPDG2.EQ.22) THEN
24121 CHRNF = CHRNF + Q_ch2(I)
24123 S1(13) = S1(13)*CHRNF
24124 ELSE IF(IDPDG2.EQ.990) THEN
24132 FFF = PI*GEV2MB*ALN*ALN/(AH*SS)
24133 DO 90 M=-1,Max_pro_2
24134 Hfac(M) = MAX(FFF*F124(M)*S1(M),0.D0)
24137 C double direct process
24138 IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
24139 & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
24142 IF(IDPDG1.EQ.22) THEN
24147 IF(IDPDG2.EQ.22) THEN
24152 FAC = FAC+F1*F2*3.D0
24154 ZZ = SQRT(1.D0-4.D0*PTCUT*PTCUT/SS)
24155 Hfac(14) = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)
24160 *$ CREATE PHO_HARWGX.FOR
24162 CDECK ID>, PHO_HARWGX
24163 SUBROUTINE PHO_HARWGX(PTCUT,ECM)
24164 C**********************************************************************
24166 C find maximum of remaining weight for MC sampling
24168 C input: PTCUT transverse momentum cutoff
24171 C output: HWgx(-1:Max_pro_2) field for sampling hard processes
24173 C**********************************************************************
24174 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24177 PARAMETER ( NKM = 10 )
24178 PARAMETER ( TINY = 1.D-20 )
24180 C input/output channels
24182 COMMON /POINOU/ LI,LO
24183 C event debugging information
24185 PARAMETER (NMAXD=100)
24186 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24187 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24188 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24189 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24190 C data on most recent hard scattering
24191 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24192 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24193 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24194 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24195 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24196 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24197 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24198 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24199 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24200 C hard cross sections and MC selection weights
24202 PARAMETER ( Max_pro_2 = 16 )
24203 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
24204 & MH_acc_1,MH_acc_2
24205 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
24206 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
24207 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
24208 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
24209 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24210 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24212 DIMENSION Z(3),D(3),FF(0:NKM),PDA(-6:6),PDB(-6:6),XM1(NKM),
24213 & XM2(NKM),PTM(NKM),ZMX(3,NKM),DMX(3,NKM),IMX(NKM),IPO(NKM)
24214 DIMENSION IFTAB(-1:Max_pro_2)
24215 DATA IFTAB / 4,0,1,2,4,1,2,2,3,5,0,6,7,8,9,10,0,10 /
24218 AH = (2.D0*PTCUT/ECM)**2
24240 C start configuration
24242 Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24248 ELSE IF(IST.EQ.2) THEN
24255 ELSE IF(IST.EQ.3) THEN
24256 Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24262 ELSE IF(IST.EQ.4) THEN
24263 Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24271 CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F2)
24272 C process possible?
24273 IF(F2.LE.0.D0) GOTO 35
24281 CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
24282 IF ( F2.GT.F3 ) Z(I) = Z(I)-D(I)
24283 IF ( F2.GT.F3 ) D(I) =-D(I)
24288 CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
24289 IF ( F3.GT.F2 ) GOTO 20
24291 Z(I) = ZZ+0.5*D(I)*(F3-F1)/MAX(TINY,F2+F2-F1-F3)
24292 IF ( ABS(ZZ-Z(I)).GT.D(I)*0.1D0 )
24293 & CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F1)
24294 IF ( F1.LE.F2 ) Z(I) = ZZ
24297 IF((ABS(FOLD-F2)/MAX(TINY,F2).GT.0.002D0).OR.(IT.LT.3)) GOTO 10
24299 IF(F2.GT.FF(NKON)) THEN
24300 FF(NKON) = MAX(F2,0.D0)
24319 IF(IDEB(38).GE.5) THEN
24320 WRITE(LO,'(/1X,A)')
24321 & 'PHO_HARWGX: maximum of weight (I,IT,IS,FF,Z(1-3),D(1-3))'
24323 IF(IMX(I).NE.0) WRITE(LO,'(1X,I2,I3,I2,7E10.3)') I,IMX(I),
24324 & IPO(I),FF(I),ZMX(1,I),ZMX(2,I),ZMX(3,I),DMX(1,I),
24325 & DMX(2,I),DMX(3,I)
24329 DO 70 I=-1,Max_pro_2
24330 HWgx(I) = MAX(FF(IFTAB(I))*Hfac(I),0.D0)
24334 IF(IDEB(38).GE.5) THEN
24335 WRITE(LO,'(/1X,A)') 'PHO_HARWGX: total weights'
24336 WRITE(LO,'(5X,A)') 'I X1 X2 PT HWgx(I) FDIS'
24337 DO 80 I=-1,Max_pro_2
24338 IF((IFTAB(I).NE.0).AND.(HWgx(I).GT.0.D0)) THEN
24340 X1 = MIN(XM1(IFTAB(I)),0.9999999999D0)
24341 X2 = MIN(XM2(IFTAB(I)),0.9999999999D0)
24343 CALL PHO_HARWGH(PDS,PDA,PDB,FDIS)
24344 WRITE(LO,'(1X,I3,5E12.3)') I,X1,X2,PT,HWgx(I),FDIS
24351 *$ CREATE PHO_HARWGI.FOR
24353 CDECK ID>, PHO_HARWGI
24354 SUBROUTINE PHO_HARWGI(ECMX,PTCUT,NKON,Z,FDIS)
24355 C**********************************************************************
24357 C auxiliary subroutine to find maximum of remaining weight
24359 C input: ECMX current CMS energy
24360 C PTCUT current pt cutoff
24361 C NKON process label 1..5 resolved
24362 C 6..7 direct particle 1
24363 C 8..9 direct particle 2
24365 C Z(3) transformed variable
24367 C output: remaining weight
24369 C**********************************************************************
24370 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24375 PARAMETER ( NKM = 10 )
24376 PARAMETER ( TINY = 1.D-30,
24379 C input/output channels
24381 COMMON /POINOU/ LI,LO
24382 C event debugging information
24384 PARAMETER (NMAXD=100)
24385 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24386 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24387 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24388 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24389 C model switches and parameters
24391 INTEGER ISWMDL,IPAMDL
24392 DOUBLE PRECISION PARMDL
24393 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24394 C data of c.m. system of Pomeron / Reggeon exchange
24395 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
24396 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
24397 & SIDP,CODP,SIFP,COFP
24398 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
24399 & SIDP,CODP,SIFP,COFP,NPOSP(2),
24400 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
24401 C currently activated parton density parametrizations
24403 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
24404 DOUBLE PRECISION PDFLAM,PDFQ2M
24405 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
24406 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
24407 C hard scattering parameters used for most recent hard interaction
24409 DOUBLE PRECISION ALQCD2,BQCD
24410 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
24411 C some hadron information, will be deleted in future versions
24413 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
24414 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
24415 C scale parameters for parton model calculations
24416 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24417 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24418 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24419 & NQQAL,NQQALI,NQQALF,NQQPD
24420 C data on most recent hard scattering
24421 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24422 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24423 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24424 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24425 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24426 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24427 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24428 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24429 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24431 DOUBLE PRECISION PHO_ALPHAS,pho_alphae
24432 DIMENSION F(NKM),PDA(-6:6),PDB(-6:6)
24436 IF(IDEB(64).GE.25) WRITE(LO,'(1X,A,/5X,5E12.3,I5)')
24437 & 'PHO_HARWGI: ECM,PT,Z,NK',ECMX,PTCUT,Z,NKON
24438 C check input values
24439 IF ( Z(1).LT.0.D0 .OR. Z(1).GT.1.D0 ) RETURN
24440 IF ( Z(2).LT.0.D0 .OR. Z(2).GT.1.D0 ) RETURN
24441 IF ( Z(3).LT.0.D0 .OR. Z(3).GT.1.D0 ) RETURN
24443 Y1 = EXP(ALNH*Z(1))
24445 C resolved kinematic
24446 Y2 =-(1.D0-Y1)+2.D0*(1.D0-Y1)*Z(2)
24447 X1 = 0.5D0*(Y2+SQRT(Y2*Y2+4.D0*Y1))
24449 X1 = MIN(X1,0.999999999999D0)
24450 X2 = MIN(X2,0.999999999999D0)
24451 ELSE IF(NKON.LE.7) THEN
24452 C direct kinematic 1
24454 X2 = MIN(Y1,0.999999999999D0)
24455 ELSE IF(NKON.LE.9) THEN
24456 C direct kinematic 2
24457 X1 = MIN(Y1,0.999999999999D0)
24460 C double direct kinematic
24464 W = SQRT(MAX(TINY,1.D0-AH/Y1))
24465 V =-0.5D0+W*(Z(3)-0.5D0)
24467 PT = MAX(SQRT(U*V*Y1*ECMX*ECMX),PTCUT)
24469 C set hard scale QQ for alpha and partondistr.
24470 IF ( NQQAL.EQ.1 ) THEN
24472 ELSEIF ( NQQAL.EQ.2 ) THEN
24473 QQAL = AQQAL*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
24474 ELSEIF ( NQQAL.EQ.3 ) THEN
24475 QQAL = AQQAL*Y1*ECMX*ECMX
24476 ELSEIF ( NQQAL.EQ.4 ) THEN
24477 QQAL = AQQAL*Y1*ECMX*ECMX*(U*V)**(1./3.)
24479 IF ( NQQPD.EQ.1 ) THEN
24481 ELSEIF ( NQQPD.EQ.2 ) THEN
24482 QQPD = AQQPD*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
24483 ELSEIF ( NQQPD.EQ.3 ) THEN
24484 QQPD = AQQPD*Y1*ECMX*ECMX
24485 ELSEIF ( NQQPD.EQ.4 ) THEN
24486 QQPD = AQQPD*Y1*ECMX*ECMX*(U*V)**(1./3.)
24493 C resolved processes
24494 ALPHA1 = PHO_ALPHAS(QQAL,3)
24496 CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
24497 CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
24498 C calculate full distribution FDIS
24500 F(2) = F(2)+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
24501 F(3) = F(3)+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
24502 F(4) = F(4)+PDA(I)+PDA(-I)
24503 F(5) = F(5)+PDB(I)+PDB(-I)
24505 F(1) = PDA(0)*PDB(0)
24506 T = PDA(0)*F(5)+PDB(0)*F(4)
24507 F(5) = F(4)*F(5)-(F(2)+F(3))
24509 ELSE IF(NKON.LE.7) THEN
24510 C direct processes particle 1
24511 IF(IDPDG1.EQ.22) THEN
24512 ALPHA1 = pho_alphae(QQAL)
24515 ELSE IF(IDPDG1.EQ.990) THEN
24516 ALPHA1 = PARMDL(74)
24523 ALPHA2 = PHO_ALPHAS(QQAL,2)
24524 CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
24527 F(6) = F(6)+(PDB(I)+PDB(-I))*(CH1-CH2*MOD(I,2))
24530 ELSE IF(NKON.LE.9) THEN
24531 C direct processes particle 2
24532 ALPHA1 = PHO_ALPHAS(QQAL,1)
24533 IF(IDPDG2.EQ.22) THEN
24534 ALPHA2 = pho_alphae(QQAL)
24537 ELSE IF(IDPDG2.EQ.990) THEN
24538 ALPHA2 = PARMDL(74)
24545 CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
24548 F(8) = F(8)+(PDA(I)+PDA(-I))*(CH1-CH2*MOD(I,2))
24552 C double direct process
24554 IF(IDPDG1.EQ.22) THEN
24555 ALPHA1 = pho_alphae(SSR)
24556 ELSE IF(IDPDG1.EQ.990) THEN
24557 ALPHA1 = PARMDL(74)
24562 IF(IDPDG2.EQ.22) THEN
24563 ALPHA2 = pho_alphae(SSR)
24564 ELSE IF(IDPDG2.EQ.990) THEN
24565 ALPHA2 = PARMDL(74)
24573 FDIS = MAX(0.D0,F(NKON)*ALPHA1*ALPHA2)
24576 IF(IDEB(64).GE.20) WRITE(LO,'(1X,A,/2X,I3,2I6,7E11.3)')
24577 & 'PHO_HARWGI: NKON,ID1,ID2,AL1,AL2,X1,X2,PT,F(NKON),FDIS',
24578 & NKON,IDPDG1,IDPDG2,ALPHA1,ALPHA2,X1,X2,PT,F(NKON),FDIS
24582 *$ CREATE PHO_HARINI.FOR
24584 CDECK ID>, PHO_HARINI
24585 SUBROUTINE PHO_HARINI(IP,IDP1,IDP2,PV1,PV2,NOUT,MODE)
24586 C**********************************************************************
24588 C initialize calculation of hard cross section
24590 C must not be called during MC generation
24592 C***********************************************************************
24593 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24596 PARAMETER ( DEPS = 1.D-10 )
24598 C input/output channels
24600 COMMON /POINOU/ LI,LO
24601 C event debugging information
24603 PARAMETER (NMAXD=100)
24604 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24605 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24606 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24607 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24608 C model switches and parameters
24610 INTEGER ISWMDL,IPAMDL
24611 DOUBLE PRECISION PARMDL
24612 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24613 C currently activated parton density parametrizations
24615 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
24616 DOUBLE PRECISION PDFLAM,PDFQ2M
24617 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
24618 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
24620 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
24621 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
24622 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
24623 C scale parameters for parton model calculations
24624 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24625 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24626 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24627 & NQQAL,NQQALI,NQQALF,NQQPD
24628 C data of c.m. system of Pomeron / Reggeon exchange
24629 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
24630 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
24631 & SIDP,CODP,SIFP,COFP
24632 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
24633 & SIDP,CODP,SIFP,COFP,NPOSP(2),
24634 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
24635 C obsolete cut-off information
24636 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
24637 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
24638 C hard scattering parameters used for most recent hard interaction
24640 DOUBLE PRECISION ALQCD2,BQCD
24641 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
24643 double precision pho_alphas
24647 C set local Pomeron c.m. system data
24653 CALL PHO_ACTPDF(IDPDG1,1)
24654 CALL PHO_ACTPDF(IDPDG2,2)
24655 C initialize alpha_s calculation
24656 DUMMY = PHO_ALPHAS(0.D0,-4)
24657 C initialize scales with defaults
24658 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
24659 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24661 AQQALI = PARMDL(86)
24662 AQQALF = PARMDL(89)
24665 NQQALI = IPAMDL(86)
24666 NQQALF = IPAMDL(89)
24670 AQQALI = PARMDL(85)
24671 AQQALF = PARMDL(88)
24674 NQQALI = IPAMDL(85)
24675 NQQALF = IPAMDL(88)
24678 ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24680 AQQALI = PARMDL(85)
24681 AQQALF = PARMDL(88)
24684 NQQALI = IPAMDL(85)
24685 NQQALF = IPAMDL(88)
24689 AQQALI = PARMDL(84)
24690 AQQALF = PARMDL(87)
24693 NQQALI = IPAMDL(84)
24694 NQQALF = IPAMDL(87)
24697 IF(PARMDL(109+IP).LT.DEPS) PARMDL(109+IP) = AQQAL
24698 IF(PARMDL(113+IP).LT.DEPS) PARMDL(113+IP) = AQQALI
24699 IF(PARMDL(117+IP).LT.DEPS) PARMDL(117+IP) = AQQALF
24700 IF(PARMDL(121+IP).LT.DEPS) PARMDL(121+IP) = AQQPD
24701 IF(IPAMDL(64+IP).LT.0) IPAMDL(64+IP) = NQQAL
24702 IF(IPAMDL(68+IP).LT.0) IPAMDL(68+IP) = NQQALI
24703 IF(IPAMDL(72+IP).LT.0) IPAMDL(72+IP) = NQQALF
24704 IF(IPAMDL(76+IP).LT.0) IPAMDL(76+IP) = NQQPD
24705 AQQAL = PARMDL(109+IP)
24706 AQQALI = PARMDL(113+IP)
24707 AQQALF = PARMDL(117+IP)
24708 AQQPD = PARMDL(121+IP)
24709 NQQAL = IPAMDL(64+IP)
24710 NQQALI = IPAMDL(68+IP)
24711 NQQALF = IPAMDL(72+IP)
24712 NQQPD = IPAMDL(76+IP)
24713 PTCUT(1) = PARMDL(36)
24714 PTCUT(2) = PARMDL(37)
24715 PTCUT(3) = PARMDL(38)
24716 PTCUT(4) = PARMDL(39)
24717 PTANO(1) = PARMDL(130)
24718 PTANO(2) = PARMDL(131)
24719 PTANO(3) = PARMDL(132)
24720 PTANO(4) = PARMDL(133)
24721 RFLAG = '(energy-independent)'
24722 IF(IPAMDL(7).GT.0) RFLAG = '(energy-dependent)'
24724 C write out all settings
24725 IF((IDEB(66).GE.15).OR.(MODE.GT.0)) THEN
24726 WRITE(NOUT,1050) IP,IDPDG1,IDPDG2,PTCUT(IP),RFLAG,
24727 & PDFNAM(1),IGRP(1),ISET(1),IEXT(1),
24728 & PDFNAM(2),IGRP(2),ISET(2),IEXT(2),
24729 & PDFLAM,NF,NQQAL,AQQAL,NQQPD,AQQPD
24731 & ' PHO_HARINI: hard scattering parameters for IP:',I3/,
24732 & 5X,'particle 1 / particle 2:',2I8,/,
24733 & 5X,'min. PT :',F7.1,2X,A,/,
24734 & 5X,'PDF side 1:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
24735 & 5X,'PDF side 2:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
24736 & 5X,'LAMBDA1,2 (4 active flavours):',2F8.3,/,
24737 & 5X,'max. number of active flavours NF :',I3,/,
24738 & 5X,'NQQAL/AQQAL/NQQPD/AQQPD:',I5,F8.3,I5,F8.3)
24743 *$ CREATE PHO_HARINT.FOR
24745 CDECK ID>, PHO_HARINT
24746 SUBROUTINE PHO_HARINT(IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM)
24747 C**********************************************************************
24749 C interpolate cross sections and weights for hard scattering
24751 C input: IPP particle combination (neg. for add. user cuts)
24752 C ECM CMS energy (GeV)
24753 C P2V1/2 particle virtualities (pos., GeV**2)
24754 C I1 first subprocess to calculate
24755 C I2 last subprocess to calculate
24756 C <-1 only scales and cutoffs calculated
24757 C K1 first variable to calculate
24758 C K2 last variable to calculate
24759 C MSPOM cross sections to use for pt distribution
24763 C for K1 < 3 the soft pt distribution is also calculated
24765 C output: interpolated values in HWgx, HSig, Hdpt
24767 C***********************************************************************
24768 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24771 PARAMETER ( DEPS = 1.D-15,
24774 C input/output channels
24776 COMMON /POINOU/ LI,LO
24777 C event debugging information
24779 PARAMETER (NMAXD=100)
24780 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24781 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24782 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24783 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24784 C model switches and parameters
24786 INTEGER ISWMDL,IPAMDL
24787 DOUBLE PRECISION PARMDL
24788 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24789 C Reggeon phenomenology parameters
24790 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
24791 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
24792 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
24793 & ALREG,ALREGP,GR(2),B0REG(2),
24794 & GPPP,GPPR,B0PPP,B0PPR,
24795 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
24796 C parameters of 2x2 channel model
24797 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
24798 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
24799 C data needed for soft-pt calculation
24800 DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
24801 COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
24802 C scale parameters for parton model calculations
24803 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24804 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24805 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24806 & NQQAL,NQQALI,NQQALF,NQQPD
24807 C obsolete cut-off information
24808 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
24809 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
24810 C event weights and generated cross section
24811 INTEGER IPOWGC,ISWCUT,IVWGHT
24812 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
24813 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
24814 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
24815 C parameters for DGLAP backward evolution in ISR
24817 DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
24818 COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
24819 C hard cross sections and MC selection weights
24821 PARAMETER ( Max_pro_2 = 16 )
24822 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
24823 & MH_acc_1,MH_acc_2
24824 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
24825 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
24826 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
24827 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
24828 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24829 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24830 C interpolation tables for hard cross section and MC selection weights
24831 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
24832 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
24833 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
24834 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
24835 & HQ2a_tab,HQ2b_tab,HEcm_tab
24837 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24838 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24839 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24840 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24841 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
24842 & HEcm_tab(1:Max_tab_E,0:4),
24843 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
24844 C data on most recent hard scattering
24845 INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24846 DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24847 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24848 & PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24849 COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24850 & PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24851 & QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24852 & PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24853 & IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24854 C energy-interpolation table
24856 PARAMETER ( IEETA2 = 20 )
24858 DOUBLE PRECISION SIGTAB,SIGECM
24859 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
24861 DOUBLE PRECISION XP,PTS
24862 DIMENSION XP(2),PTS(0:2,2)
24867 IF(IDEB(58).GE.25) WRITE(LO,'(1X,2A,/,5X,I2,3E12.3,5I4)')
24868 & 'PHO_HARINT: called with ',
24869 & 'IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM',
24870 & IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM
24874 C default minimum bias cutoff
24875 PTCUT(IP) = pho_ptcut(ECM,IP)
24877 C user defined additional cutoff
24878 PTCUT(IP) = HSWCUT(4+IP)
24883 Q2CUT = MIN(PTWANT**2,PARMDL(125+IP))
24884 Q2MISR(1) = MAX(P2V1,Q2CUT)
24885 Q2MISR(2) = MAX(P2V2,Q2CUT)
24886 C cutoff for direct photon contribution to photon PDF
24887 PTANO(IP) = MIN(PTCUT(IP),PARMDL(129+IP))
24889 C scales for hard scattering
24890 AQQAL = PARMDL(109+IP)
24891 AQQALI = PARMDL(113+IP)
24892 AQQALF = PARMDL(117+IP)
24893 AQQPD = PARMDL(121+IP)
24894 NQQAL = IPAMDL(64+IP)
24895 NQQALI = IPAMDL(68+IP)
24896 NQQALF = IPAMDL(72+IP)
24897 NQQPD = IPAMDL(76+IP)
24898 IF(IDEB(58).GE.15) WRITE(LO,'(1X,A,4I3,4E10.3)')
24899 & 'PHO_HARINT: scales:',
24900 & NQQAL,NQQALI,NQQALF,NQQPD,AQQAL,AQQALI,AQQALF,AQQPD
24902 IF(I2.LT.-1) RETURN
24905 IF(IPP.LT.0) IL = 0
24907 C double-log interpolation
24908 IF(ECM.LT.2.1D0*PTCUT(IP)) THEN
24919 IF((ECM.GT.HEcm_tab(I,IL)).AND.(I.LT.IH_Ecm_up(IL))) GOTO 310
24923 fac = LOG(ECM/HEcm_tab(I-1,IL))
24924 & /LOG(HEcm_tab(I,IL)/HEcm_tab(I-1,IL))
24926 C factor due to phase space integration
24927 XX = LOG(Hfac_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
24928 & *LOG((Hfac_tab(M,I,Ia,Ib,IL)+DEPS)
24929 & /(Hfac_tab(M,I-1,Ia,Ib,IL)+DEPS))
24931 IF(XX.LT.DEPS2) XX = 0.D0
24934 XX = LOG(HWgx_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
24935 & *LOG((HWgx_tab(M,I,Ia,Ib,IL)+DEPS)
24936 & /(HWgx_tab(M,I-1,Ia,Ib,IL)+DEPS))
24938 IF(XX.LT.DEPS2) XX = 0.D0
24940 C hard cross section
24941 XX = LOG(HSig_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
24942 & *LOG((HSig_tab(M,I,Ia,Ib,IL)+DEPS)
24943 & /(HSig_tab(M,I-1,Ia,Ib,IL)+DEPS))
24945 IF(XX.LT.DEPS2) XX = 0.D0
24947 C differential hard cross section
24948 XX = LOG(Hdpt_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
24949 & *LOG((Hdpt_tab(M,I,Ia,Ib,IL)+DEPS)
24950 & /(Hdpt_tab(M,I-1,Ia,Ib,IL)+DEPS))
24952 IF(XX.LT.DEPS2) XX = 0.D0
24957 IF((K1.LT.3).AND.(K2.GE.3)) THEN
24959 IF((I1.GT.9).OR.(I2.LT.9)) THEN
24960 WRITE(LO,'(1X,2A,2I4)') 'PHO_HARINT: ',
24961 & 'hard cross section not calculated ',I1,I2
24965 C load soft cross sections from interpolation table
24966 IF(ECM.LE.SIGECM(IP,1)) THEN
24969 ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
24971 IF(ECM.LE.SIGECM(IP,I)) GOTO 205
24977 WRITE(LO,'(/1X,A,I3,1P,2E11.3)')
24978 & 'PHO_HARINT: energy too high (IP,Ecm,Emax)',
24979 & IP,ECM,SIGECM(IP,ISIMAX)
24980 CALL PHO_PREVNT(-1)
24985 IF(L1.NE.L2) FAC2=LOG(ECM/SIGECM(IP,L1))
24986 & /LOG(SIGECM(IP,L2)/SIGECM(IP,L1))
24988 SIGS = FAC2*(SIGTAB(IP,56,L2)+SIGTAB(IP,57,L2))+
24989 & FAC1*(SIGTAB(IP,56,L1)+SIGTAB(IP,57,L1))
24993 CALL PHO_SOFTPT(-1,PTWANT,PTWANT,XP,IV,PTS)
24999 IF(IDEB(58).GE.15) THEN
25000 WRITE(LO,'(1X,A,I10,3I2,2E10.3)')
25001 & 'PHO_HARINT: weights EV,IP,K1/2,ECM,PTC',
25002 & KEVENT,IP,K1,K2,ECM,PTCUT(IP)
25004 WRITE(LO,'(5X,2I3,1p,4E12.3)')
25005 & M,MH_pro_on(M,IP),Hfac(M),HWgx(M),HSig(M),Hdpt(M)
25011 *$ CREATE PHO_PTCUT.FOR
25013 DOUBLE PRECISION FUNCTION PHO_PTCUT(ECM,IP)
25014 C***********************************************************************
25016 C calculate energy-dependent transverse momentum cutoff
25018 C***********************************************************************
25022 double precision ECM
25025 C input/output channels
25027 COMMON /POINOU/ LI,LO
25028 C event debugging information
25030 PARAMETER (NMAXD=100)
25031 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
25032 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25033 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
25034 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25035 C model switches and parameters
25037 INTEGER ISWMDL,IPAMDL
25038 DOUBLE PRECISION PARMDL
25039 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25041 pho_ptcut = PARMDL(35+IP)
25043 IF(IPAMDL(7).EQ.1) THEN
25044 C Bopp et al. type (DPMJET)
25045 pho_ptcut = PARMDL(35+IP)
25046 & + max(0.D0,0.12D0*(LOG10(ECM/50.D0))**3)
25047 ELSE IF(IPAMDL(7).EQ.2) THEN
25048 C Gribov-Levin-Ryskin type
25049 pho_ptcut = PARMDL(35+IP)
25050 & + 0.065D0*exp(0.9D0*sqrt(2.D0*log(Ecm)))
25055 *$ CREATE PHO_HARMCI.FOR
25057 CDECK ID>, PHO_HARMCI
25058 SUBROUTINE PHO_HARMCI(IP,EMAXF)
25059 C**********************************************************************
25061 C initialize MC sampling and calculate hard cross section
25063 C input: IP particle combination (neg. number for user cut)
25064 C EMAXF maximum CMS energy for
25065 C interpolation table in reference to PTCUT(1..4)
25067 C***********************************************************************
25068 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25071 PARAMETER (DEPS = 1.D-10,
25074 C input/output channels
25076 COMMON /POINOU/ LI,LO
25077 C event debugging information
25079 PARAMETER (NMAXD=100)
25080 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
25081 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25082 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
25083 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25085 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25086 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25087 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25088 C global event kinematics and particle IDs
25089 INTEGER IFPAP,IFPAB
25090 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
25091 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
25092 C data of c.m. system of Pomeron / Reggeon exchange
25093 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25094 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25095 & SIDP,CODP,SIFP,COFP
25096 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25097 & SIDP,CODP,SIFP,COFP,NPOSP(2),
25098 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
25099 C model switches and parameters
25101 INTEGER ISWMDL,IPAMDL
25102 DOUBLE PRECISION PARMDL
25103 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25104 C obsolete cut-off information
25105 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
25106 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
25107 C scale parameters for parton model calculations
25108 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25109 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25110 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25111 & NQQAL,NQQALI,NQQALF,NQQPD
25112 C names of hard scattering processes
25114 PARAMETER ( Max_pro_1 = 16 )
25116 COMMON /POHPRO/ PROC(0:Max_pro_1)
25117 C hard cross sections and MC selection weights
25119 PARAMETER ( Max_pro_2 = 16 )
25120 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
25121 & MH_acc_1,MH_acc_2
25122 DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
25123 COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
25124 & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
25125 & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
25126 & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
25127 & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
25128 C interpolation tables for hard cross section and MC selection weights
25129 INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
25130 PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
25131 INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
25132 DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
25133 & HQ2a_tab,HQ2b_tab,HEcm_tab
25135 & Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25136 & HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25137 & HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25138 & Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25139 & HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
25140 & HEcm_tab(1:Max_tab_E,0:4),
25141 & IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
25142 C event weights and generated cross section
25143 INTEGER IPOWGC,ISWCUT,IVWGHT
25144 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
25145 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
25146 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
25149 DIMENSION DSIG(0:Max_pro_2),DSPT(0:Max_pro_2)
25151 C initialization for all pt cutoffs
25158 PTC = pho_ptcut(parmdl(19),I)
25161 C skip unassigned PTCUT
25162 IF(PTC.LT.0.5D0) GOTO 1000
25170 Hfac_tab(M,Ie,Ia,Ib,I) = 0.D0
25171 HWgx_tab(M,Ie,Ia,Ib,I) = 0.D0
25172 HSig_tab(M,Ie,Ia,Ib,I) = 0.D0
25173 Hdpt_tab(M,Ie,Ia,Ib,I) = 0.D0
25179 ELLOW = LOG(2.05*PTC)
25180 DELTA = (LOG(EMAXF)-ELLOW)/DBLE(IH_Ecm_up(I)-1)
25182 IF(DELTA.LE.0.D0) GOTO 1000
25184 C switch between external particles and Pomeron
25190 ELSE IF(I.EQ.3) THEN
25195 ELSE IF(I.EQ.2) THEN
25207 C initialize PT scales
25208 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
25209 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25210 FPS(I) = PARMDL(105)
25211 FPH(I) = PARMDL(106)
25213 FPS(I) = PARMDL(103)
25214 FPH(I) = PARMDL(104)
25216 ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25217 FPS(I) = PARMDL(103)
25218 FPH(I) = PARMDL(104)
25220 FPS(I) = PARMDL(101)
25221 FPH(I) = PARMDL(102)
25224 C initialize hard scattering
25226 CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8)+1)
25228 CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8))
25231 C energy/virtuality grid
25232 do Ie=1,IH_Ecm_up(IL)
25233 HEcm_tab(Ie,IL) = EXP(ELLOW+DELTA*(IE-1))
25235 do Ia=1,IH_Q2a_up(IL)
25236 HQ2a_tab(Ia,IL) = 0.D0
25238 do Ib=1,IH_Q2b_up(IL)
25239 HQ2b_tab(Ib,IL) = 0.D0
25242 C initialization for several energies and particle virtualities
25243 do Ie=1,IH_Ecm_up(IL)
25244 do Ia=1,IH_Q2a_up(IL)
25245 do Ib=1,IH_Q2b_up(IL)
25247 EE = HEcm_tab(IE,IL)
25248 Q2a = HQ2a_tab(Ia,IL)
25249 Q2b = HQ2b_tab(Ib,IL)
25250 CALL PHO_HARINT(IP,EE,0.D0,0.D0,0,-2,0,0,1)
25251 IF(IDEB(8).GE.5) WRITE(LO,'(1X,A,2E10.3,2I7)')
25252 & 'PHO_HARMCI: initialization PT,ECM,ID1,ID2:',
25253 & PTCUT(I),EE,IDPDG1,IDPDG2
25254 Hfac_tab(0,Ie,Ia,Ib,IL) = PTCUT(I)
25255 CALL PHO_HARFAC(PTCUT(I),EE)
25256 CALL PHO_HARWGX(PTCUT(I),EE)
25257 CALL PHO_HARXTO(EE,PTCUT(I),PTCUT(I),DSIG,DSPT)
25258 IF(IDEB(8).GE.10) THEN
25259 WRITE(LO,'(1X,A,/,1X,A)')
25260 & 'hard cross sections SIGH(mb),DSIG/DPT(mb/GeV**2)',
25261 & '------------------------------------------------'
25263 WRITE(LO,'(10X,A,1P2E14.4)')
25264 & PROC(M),DREAL(DSIG(M)),DSPT(M)
25268 C store in interpolation tables
25269 Hfac_tab(-1,IE,Ia,Ib,IL) = Hfac(-1)
25270 HWgx_tab(-1,IE,Ia,Ib,IL) = HWgx(-1)
25272 Hfac_tab(M,IE,Ia,Ib,IL) = Hfac(M)
25273 HWgx_tab(M,IE,Ia,Ib,IL) = HWgx(M)
25274 HSig_tab(M,IE,Ia,Ib,IL) = DREAL(DSIG(M))*MH_pro_on(M,I)
25275 Hdpt_tab(M,IE,Ia,Ib,IL) = DSPT(M)*MH_pro_on(M,I)
25278 C summed quantities
25279 HSig_tab(9,IE,Ia,Ib,IL) = 0.D0
25280 Hdpt_tab(9,IE,Ia,Ib,IL) = 0.D0
25282 IF(MH_pro_on(M,I).GT.0) THEN
25283 HSig_tab(9,IE,Ia,Ib,IL) =
25284 & HSig_tab(9,IE,Ia,Ib,IL) + HSig_tab(M,IE,Ia,Ib,IL)
25285 Hdpt_tab(9,IE,Ia,Ib,IL) =
25286 & Hdpt_tab(9,IE,Ia,Ib,IL) + Hdpt_tab(M,IE,Ia,Ib,IL)
25289 HSig_tab(15,IE,Ia,Ib,IL) = 0.D0
25290 Hdpt_tab(15,IE,Ia,Ib,IL) = 0.D0
25292 IF(MH_pro_on(M,I).GT.0) THEN
25293 HSig_tab(15,IE,Ia,Ib,IL) =
25294 & HSig_tab(15,IE,Ia,Ib,IL) + HSig_tab(M,IE,Ia,Ib,IL)
25295 Hdpt_tab(15,IE,Ia,Ib,IL) =
25296 & Hdpt_tab(15,IE,Ia,Ib,IL) + Hdpt_tab(M,IE,Ia,Ib,IL)
25299 HSig_tab(0,IE,Ia,Ib,IL) =
25300 & HSig_tab(9,IE,Ia,Ib,IL) + HSig_tab(15,IE,Ia,Ib,IL)
25301 Hdpt_tab(0,IE,Ia,Ib,IL) =
25302 & Hdpt_tab(9,IE,Ia,Ib,IL) + Hdpt_tab(15,IE,Ia,Ib,IL)
25308 C debug output of weights
25310 IF(IDEB(8).GE.5) THEN
25311 WRITE(LO,'(/1X,A,5X,2I7,I3,F7.2,/1X,A)')
25312 & 'PHO_HARMCI: weights, maxima (ID1/2,IP,PTC)',
25313 & IDPDG1,IDPDG2,IP,PTCUT(I),
25314 & '------------------------------------------'
25316 IF((M.EQ.0).OR.(M.EQ.9).OR.(M.EQ.15)) GOTO 512
25317 WRITE(LO,'(2X,A,I3,2I7)')
25318 & 'PHO_HARMCI: ECM Hfac, HWgx, HSig, Hdpt for MSTR,ID1,ID2',
25320 do k=1,IH_Ecm_up(IL)
25321 do ia=1,IH_Q2a_up(IL)
25322 do ib=1,IH_Q2b_up(IL)
25323 WRITE(LO,'(3X,1p,7E10.3)') HEcm_tab(k,IL),
25324 & HQ2a_tab(ia,IL),HQ2b_tab(ib,IL),
25325 & Hfac_tab(M,k,ia,ib,IL),HWgx_tab(M,k,ia,ib,IL),
25326 & HSig_tab(M,k,ia,ib,IL),Hdpt_tab(M,k,ia,ib,IL)
25336 *$ CREATE PHO_HARXR3.FOR
25338 CDECK ID>, PHO_HARXR3
25339 SUBROUTINE PHO_HARXR3(ECMH,PT,ETAC,ETAD,DSIGMC)
25340 C**********************************************************************
25342 C differential cross section DSIG/(DETAC*DETAD*DPT)
25344 C input: ECMH CMS energy
25346 C ETAC pseudorapidity of parton C
25347 C ETAD pseudorapidity of parton D
25349 C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac/detad
25351 C**********************************************************************
25352 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25355 PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-20)
25357 PARAMETER ( Max_pro_2 = 16 )
25359 DIMENSION DSIGMC(0:Max_pro_2)
25360 DIMENSION DSIGM(0:Max_pro_2)
25362 C input/output channels
25364 COMMON /POINOU/ LI,LO
25366 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25367 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25368 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25369 C Reggeon phenomenology parameters
25370 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25371 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25372 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25373 & ALREG,ALREGP,GR(2),B0REG(2),
25374 & GPPP,GPPR,B0PPP,B0PPR,
25375 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25376 C currently activated parton density parametrizations
25378 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
25379 DOUBLE PRECISION PDFLAM,PDFQ2M
25380 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
25381 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
25382 C hard scattering parameters used for most recent hard interaction
25384 DOUBLE PRECISION ALQCD2,BQCD
25385 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25386 C scale parameters for parton model calculations
25387 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25388 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25389 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25390 & NQQAL,NQQALI,NQQALF,NQQPD
25392 DOUBLE PRECISION PHO_ALPHAS
25393 DIMENSION PDA(-6:6),PDB(-6:6)
25396 DSIGMC(I) = CMPLX(0.D0,0.D0)
25402 C kinematic conversions
25403 XA = PT*(EC+ED)/ECMH
25405 IF((XA.GE.1.D0).OR.(XB.GE.1.D0)) THEN
25406 WRITE(LO,'(/1X,A,2E12.4)') 'PHO_HARXR3:ERROR:X1 OR X2 > 1',XA,XB
25409 SP = XA*XB*ECMH*ECMH
25415 C set hard scale QQ for alpha and partondistr.
25416 IF ( NQQAL.EQ.1 ) THEN
25418 ELSEIF ( NQQAL.EQ.2 ) THEN
25419 QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25420 ELSEIF ( NQQAL.EQ.3 ) THEN
25422 ELSEIF ( NQQAL.EQ.4 ) THEN
25423 QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25425 IF ( NQQPD.EQ.1 ) THEN
25427 ELSEIF ( NQQPD.EQ.2 ) THEN
25428 QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25429 ELSEIF ( NQQPD.EQ.3 ) THEN
25431 ELSEIF ( NQQPD.EQ.4 ) THEN
25432 QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25435 ALPHA = PHO_ALPHAS(QQAL,3)
25436 FACTOR = PI2*GEV2MB*PT*(ALPHA/SP)**2*AKFAC
25437 C parton distributions (times x)
25438 CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
25439 CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
25446 S2 = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
25447 S3 = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
25448 S4 = S4+PDA(I)+PDA(-I)
25449 S5 = S5+PDB(I)+PDB(-I)
25451 C partial cross sections (including color and symmetry factors)
25452 C resolved photon matrix elements (light quarks)
25453 DSIGM(1) = 2.25D0*(3.-((UP*TP)+UP/TT+TP/UU))
25454 DSIGM(6) = (4.D0/9.D0)*(UU+TT)
25455 DSIGM(8) = (4.D0/9.D0)*(1.D0+UU)/TT
25456 DSIGM(2) = (16.D0/27.D0)*(UU+TT)/(UP*TP)-3.D0*DSIGM(6)
25457 DSIGM(3) = ((1.D0+UU)/TT)-(4.D0/9.D0)*(1.D0+UU)/UP
25458 DSIGM(4) = (9.D0/32.D0)*DSIGM(2)
25459 DSIGM(5) = DSIGM(6)+DSIGM(8)-(8.D0/27.D0)*UU/TP
25460 DSIGM(7) = 0.5D0*(DSIGM(8)+(4.D0/9.D0)*(1.D0+TT)/UU-
25461 & (8.D0/27.D0)/(UP*TP))
25463 DSIGM(1) = FACTOR*DSIGM(1)*S1
25464 DSIGM(2) = FACTOR*DSIGM(2)*S2
25465 DSIGM(3) = FACTOR*DSIGM(3)*(PDA(0)*S5+PDB(0)*S4)
25466 DSIGM(4) = FACTOR*DSIGM(4)*S1*NF
25467 DSIGM(5) = FACTOR*DSIGM(5)*S2
25468 DSIGM(6) = FACTOR*DSIGM(6)*S2*MAX(0,(NF-1))
25469 DSIGM(7) = FACTOR*DSIGM(7)*S3
25470 DSIGM(8) = FACTOR*DSIGM(8)*(S4*S5-(S2+S3))
25473 FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25476 IF(DSIGM(I).LT.EPS) DSIGM(I) = 0.D0
25477 DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25478 DSIGMC(9) = DSIGMC(9)+DSIGMC(I)
25482 *$ CREATE PHO_HARXR2.FOR
25484 CDECK ID>, PHO_HARXR2
25485 SUBROUTINE PHO_HARXR2(ECMH,PT,ETAC,DSIGMC)
25486 C**********************************************************************
25488 C differential cross section DSIG/(DETAC*DPT)
25490 C input: ECMH CMS energy
25492 C ETAC pseudorapidity of parton C
25494 C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
25496 C**********************************************************************
25497 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25500 PARAMETER ( TINY= 1.D-20 )
25502 PARAMETER ( Max_pro_2 = 16 )
25504 DIMENSION DSIGMC(0:Max_pro_2)
25506 C input/output channels
25508 COMMON /POINOU/ LI,LO
25509 C integration precision for hard cross sections (obsolete)
25510 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25511 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25514 DIMENSION DSIG1(0:Max_pro_2)
25515 DIMENSION ABSZ(32),WEIG(32)
25518 DSIGMC(M) = CMPLX(0.D0,0.D0)
25524 IF ( ARG.LE.EC .OR. ARG.LE.1.D0/EC ) RETURN
25526 EDL =-LOG(ARG-1.D0/EC)
25528 CALL PHO_GAUSET(EDL,EDU,NPOINT,ABSZ,WEIG)
25530 CALL PHO_HARXR3(ECMH,PT,ETAC,ABSZ(I),DSIG1)
25532 PCTRL= DREAL(DSIG1(M))/TINY
25533 IF( PCTRL.GE.1.D0 ) THEN
25534 DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
25540 *$ CREATE PHO_HARXD2.FOR
25542 CDECK ID>, PHO_HARXD2
25543 SUBROUTINE PHO_HARXD2(ECMH,PT,ETAC,DSIGMC)
25544 C**********************************************************************
25546 C differential cross section DSIG/(DETAC*DPT) for direct processes
25548 C input: ECMH CMS energy of scattering system
25550 C ETAC pseudorapidity of parton C
25552 C output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
25554 C**********************************************************************
25555 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25558 PARAMETER ( Max_pro_2 = 16 )
25560 DIMENSION DSIGMC(0:Max_pro_2)
25561 PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-25)
25563 C input/output channels
25565 COMMON /POINOU/ LI,LO
25566 C model switches and parameters
25568 INTEGER ISWMDL,IPAMDL
25569 DOUBLE PRECISION PARMDL
25570 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25571 C data of c.m. system of Pomeron / Reggeon exchange
25572 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25573 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25574 & SIDP,CODP,SIFP,COFP
25575 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25576 & SIDP,CODP,SIFP,COFP,NPOSP(2),
25577 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
25578 C Reggeon phenomenology parameters
25579 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25580 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25581 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25582 & ALREG,ALREGP,GR(2),B0REG(2),
25583 & GPPP,GPPR,B0PPP,B0PPR,
25584 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25585 C currently activated parton density parametrizations
25587 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
25588 DOUBLE PRECISION PDFLAM,PDFQ2M
25589 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
25590 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
25591 C hard scattering parameters used for most recent hard interaction
25593 DOUBLE PRECISION ALQCD2,BQCD
25594 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25595 C some hadron information, will be deleted in future versions
25597 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
25598 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
25599 C scale parameters for parton model calculations
25600 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25601 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25602 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25603 & NQQAL,NQQALI,NQQALF,NQQPD
25605 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25606 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25607 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25609 DOUBLE PRECISION PHO_ALPHAS,pho_alphae
25610 DIMENSION PDA(-6:6),PDB(-6:6),DSIGM(0:Max_pro_2)
25615 DSIGMC(I) = CMPLX(0.D0,0.D0)
25618 DSIGMC(15) = CMPLX(0.D0,0.D0)
25621 C direct particle 1
25622 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
25625 C kinematic conversions
25628 IF ( XB.GE.1.D0 ) THEN
25629 WRITE(LO,'(/1X,A,2E12.4)')
25630 & 'PHO_HARXD2:ERROR: XB>1 (XA,XB)',XA,XB
25633 SP = XA*XB*ECMH*ECMH
25639 C set hard scale QQ for alpha and partondistr.
25640 IF ( NQQAL.EQ.1 ) THEN
25642 ELSEIF ( NQQAL.EQ.2 ) THEN
25643 QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25644 ELSEIF ( NQQAL.EQ.3 ) THEN
25646 ELSEIF ( NQQAL.EQ.4 ) THEN
25647 QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25649 IF ( NQQPD.EQ.1 ) THEN
25651 ELSEIF ( NQQPD.EQ.2 ) THEN
25652 QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25653 ELSEIF ( NQQPD.EQ.3 ) THEN
25655 ELSEIF ( NQQPD.EQ.4 ) THEN
25656 QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25659 ALPHA2 = PHO_ALPHAS(QQAL,2)
25660 IF(IDPDG1.EQ.22) THEN
25661 ALPHA1 = pho_alphae(QQAL)
25662 ELSE IF(IDPDG1.EQ.990) THEN
25663 ALPHA1 = PARMDL(74)
25665 FACTOR = -PI2*GEV2MB*UP/PT*ALPHA1*ALPHA2/SP*AKFAC
25666 C parton distribution (times x)
25667 CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
25672 IF(IDPDG1.EQ.22) THEN
25674 * IF(MOD(I,2).EQ.0) THEN
25675 * S2 = S2 + (PDB(I)+PDB(-I))*TWO32
25678 * S2 = S2 + (PDB(I)+PDB(-I))*ONE32
25681 S2 = S2 + (PDB(I)+PDB(-I))*Q_ch2(I)
25684 ELSE IF(IDPDG1.EQ.990) THEN
25686 S2 = S2 + PDB(I)+PDB(-I)
25690 C partial cross sections (including color and symmetry factors)
25691 C direct photon matrix elements
25692 DSIGM(10) = -8.D0/3.D0*(UU+1.D0)/UP
25693 DSIGM(11) = (UU+TT)/(UP*TP)
25695 DSIGM(10) = FACTOR*DSIGM(10)*S2
25696 DSIGM(11) = FACTOR*DSIGM(11)*S1*S3
25699 FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25702 IF(DSIGM(I).LT.0.D0) THEN
25703 WRITE(LO,'(1X,A,I3,1P,2E12.4)')
25704 & 'PHO_HARXD2: neg. cross section',I,DSIGM(I),ECMH
25707 DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25708 DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
25712 C direct particle 2
25713 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25715 ED = 1.D0/(ECMH/PT-1.D0/EC)
25716 C kinematic conversions
25717 XA = PT*(EC+ED)/ECMH
25719 IF ( XA.GE.1.D0 ) THEN
25720 WRITE(LO,'(/1X,A,2E12.4)')
25721 & 'PHO_HARXD2:ERROR:XA>1 (XA,XB)',XA,XB
25724 SP = XA*XB*ECMH*ECMH
25730 C set hard scale QQ for alpha and partondistr.
25731 IF ( NQQAL.EQ.1 ) THEN
25733 ELSEIF ( NQQAL.EQ.2 ) THEN
25734 QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25735 ELSEIF ( NQQAL.EQ.3 ) THEN
25737 ELSEIF ( NQQAL.EQ.4 ) THEN
25738 QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25740 IF ( NQQPD.EQ.1 ) THEN
25742 ELSEIF ( NQQPD.EQ.2 ) THEN
25743 QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25744 ELSEIF ( NQQPD.EQ.3 ) THEN
25746 ELSEIF ( NQQPD.EQ.4 ) THEN
25747 QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25750 ALPHA1 = PHO_ALPHAS(QQAL,1)
25751 IF(IDPDG2.EQ.22) THEN
25752 ALPHA2 = pho_alphae(QQAL)
25753 ELSE IF(IDPDG2.EQ.990) THEN
25754 ALPHA2 = PARMDL(74)
25756 FACTOR = -PI2*GEV2MB*TP/PT*ALPHA1*ALPHA2/SP*AKFAC
25757 C parton distribution (times x)
25758 CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
25763 IF(IDPDG2.EQ.22) THEN
25765 * IF(MOD(I,2).EQ.0) THEN
25766 * S2 = S2 + (PDA(I)+PDA(-I))*TWO32
25769 * S2 = S2 + (PDA(I)+PDA(-I))*ONE32
25772 S2 = S2 + (PDA(I)+PDA(-I))*Q_ch2(I)
25775 ELSE IF(IDPDG2.EQ.990) THEN
25777 S2 = S2 + PDA(I)+PDA(-I)
25781 C partial cross sections (including color and symmetry factors)
25782 C direct photon matrix elements
25783 DSIGM(12) = -8.D0/3.D0*(TT+1.D0)/TP
25784 DSIGM(13) = (UU+TT)/(UP*TP)
25786 DSIGM(12) = FACTOR*DSIGM(12)*S2
25787 DSIGM(13) = FACTOR*DSIGM(13)*S3*S1
25790 FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25793 IF(DSIGM(I).LT.0.D0) THEN
25794 WRITE(LO,'(1X,A,I3,1P,2E12.4)')
25795 & 'PHO_HARXD2: neg. cross section:',I,DSIGM(I),ECMH
25798 DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25799 DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
25804 *$ CREATE PHO_HARXPT.FOR
25806 CDECK ID>, PHO_HARXPT
25807 SUBROUTINE PHO_HARXPT(ECMH,PT,IPRO,DSIGMC)
25808 C**********************************************************************
25810 C differential cross section DSIG/DPT
25812 C input: ECMH CMS energy of scattering system
25814 C IPRO 1 resolved processes
25815 C 2 direct processes
25816 C 3 resolved and direct processes
25818 C output: DSIGMC(0:12) QCD-PM cross sections dsigma/dpt
25820 C**********************************************************************
25821 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25824 PARAMETER ( Max_pro_2 = 16 )
25826 DIMENSION DSIGMC(0:Max_pro_2)
25827 PARAMETER ( TINY= 1.D-10, ONEP1=1.1, EPS=1.D-25)
25829 C input/output channels
25831 COMMON /POINOU/ LI,LO
25833 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25834 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25835 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25836 C model switches and parameters
25838 INTEGER ISWMDL,IPAMDL
25839 DOUBLE PRECISION PARMDL
25840 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25841 C data of c.m. system of Pomeron / Reggeon exchange
25842 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25843 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25844 & SIDP,CODP,SIFP,COFP
25845 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25846 & SIDP,CODP,SIFP,COFP,NPOSP(2),
25847 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
25848 C Reggeon phenomenology parameters
25849 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25850 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25851 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25852 & ALREG,ALREGP,GR(2),B0REG(2),
25853 & GPPP,GPPR,B0PPP,B0PPR,
25854 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25855 C integration precision for hard cross sections (obsolete)
25856 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25857 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25858 C hard scattering parameters used for most recent hard interaction
25860 DOUBLE PRECISION ALQCD2,BQCD
25861 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25862 C some hadron information, will be deleted in future versions
25864 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
25865 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
25867 double precision pho_alphae
25870 DIMENSION DSIG1(0:Max_pro_2)
25871 DIMENSION ABSZ(32),WEIG(32)
25873 DO 10 M=0,Max_pro_2
25874 DSIGMC(M) = CMPLX(0.D0,0.D0)
25875 DSIG1(M) = CMPLX(0.D0,0.D0)
25878 C resolved and direct processes
25880 IF ( AMT.GE.1.D0 ) RETURN
25881 ECU = LOG((SQRT(1.D0-AMT*AMT)+1.D0)/AMT)
25884 CALL PHO_GAUSET(ECL,ECU,NPOINT,ABSZ,WEIG)
25886 DSIG1(9) = CMPLX(0.D0,0.D0)
25887 DSIG1(15) = CMPLX(0.D0,0.D0)
25889 CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
25890 ELSE IF(IPRO.EQ.2) THEN
25891 CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
25893 CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
25894 CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
25896 DO 20 M=1,Max_pro_2
25897 DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
25902 IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
25903 & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
25906 ALPHAE = pho_alphae(SS)
25908 IF(IDPDG1.EQ.22) THEN
25909 * F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
25910 F1 = Q_ch2(I)*ALPHAE
25914 IF(IDPDG2.EQ.22) THEN
25915 * F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
25916 F2 = Q_ch2(I)*ALPHAE
25920 FAC = FAC+F1*F2*3.D0
25922 C direct cross sections
25923 ZZ = SQRT(1.D0-4.D0*PT*PT/SS+TINY)
25924 T1 = -SS/2.D0*(1.D0+ZZ)
25925 T2 = -SS/2.D0*(1.D0-ZZ)
25926 XM = -2.D0*PT/ZZ*((SS+T1)/T1+T1/(SS+T1)+(SS+T2)/T2+T2/(SS+T2))
25928 DSIGMC(14) = GEV2MB*2.D0*PI*FAC/(SS*SS)*XM*AKFAC
25930 C leptonic part (e, mu, tau)
25932 IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
25933 DSIGMC(16) = DSIGMC(14)/FAC*3.D0*ALPHAE**2
25934 C simulation of tau together with quarks
25935 IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
25939 DSIGMC(15) = DSIGMC(15)+DSIGMC(14)
25940 DSIGMC(0) = DSIGMC(9)+DSIGMC(15)
25944 *$ CREATE PHO_HARXTO.FOR
25946 CDECK ID>, PHO_HARXTO
25947 SUBROUTINE PHO_HARXTO(ECMH,PTCUTR,PTCUTD,DSIGMC,DSDPTC)
25948 C**********************************************************************
25950 C total hard cross section (perturbative QCD, Parton Model)
25952 C input: ECMH CMS energy of scattering system
25953 C PTCUTR PT cutoff for resolved processes
25954 C PTCUTD PT cutoff for direct processes (photon, Pomeron)
25956 C output: DSIGMC(0:MARPR2) cross sections for given cutoff
25957 C DSDPTC(0:MARPR2) differential cross sections at cutoff
25959 C note: COMPLEX*16 DSIGMC
25960 C DOUBLE PRECISION DSDPTC
25962 C**********************************************************************
25963 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25966 PARAMETER ( Max_pro_2 = 16 )
25968 DIMENSION DSIGMC(0:Max_pro_2),DSDPTC(0:Max_pro_2)
25970 C input/output channels
25972 COMMON /POINOU/ LI,LO
25973 C model switches and parameters
25975 INTEGER ISWMDL,IPAMDL
25976 DOUBLE PRECISION PARMDL
25977 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25978 C data of c.m. system of Pomeron / Reggeon exchange
25979 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25980 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25981 & SIDP,CODP,SIFP,COFP
25982 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25983 & SIDP,CODP,SIFP,COFP,NPOSP(2),
25984 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
25985 C Reggeon phenomenology parameters
25986 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25987 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25988 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25989 & ALREG,ALREGP,GR(2),B0REG(2),
25990 & GPPP,GPPR,B0PPP,B0PPR,
25991 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25993 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25994 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25995 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25996 C integration precision for hard cross sections (obsolete)
25997 INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25998 COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25999 C some hadron information, will be deleted in future versions
26001 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
26002 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
26003 C hard scattering parameters used for most recent hard interaction
26005 DOUBLE PRECISION ALQCD2,BQCD
26006 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
26008 double precision pho_alphae
26011 DIMENSION DSIG1(0:Max_pro_2)
26012 DIMENSION ABSZ(32),WEIG(32)
26016 DO 10 M=0,Max_pro_2
26017 DSIGMC(M)= CMPLX(0.D0,0.D0)
26021 IF ( PTCUTR.GE.EEC ) GOTO 100
26023 C integration for resolved processes
26025 PTMAX = MIN(FAC*PTMIN,EEC)
26027 CALL PHO_HARXPT(ECMH,PTMIN,1,DSIG1)
26029 DSDPTC(M) = DREAL(DSIG1(M))
26031 DSIGH = DREAL(DSIG1(9))
26032 PTMXX = 0.95D0*PTMAX
26033 CALL PHO_HARXPT(ECMH,PTMXX,1,DSIG1)
26034 DSIGL = DREAL(DSIG1(9))
26035 EX = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
26038 IF ( PTMIN.GE.PTMAX ) GOTO 40
26041 CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
26044 PT = R**(1.0D0/EX1)
26045 CALL PHO_HARXPT(ECMH,PT,1,DSIG1)
26046 F = WEIG(I)*PT/(R*EX1)
26048 DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
26056 DSIGMC(0) = DSIGMC(9)
26057 DSDPTC(0) = DSDPTC(9)
26059 C integration for direct processes
26060 IF((PTCUTD.GE.EEC).OR.(PTCUTD.LT.0.5D0)) RETURN
26062 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
26063 & .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
26065 PTMAX = MIN(FAC*PTMIN,EEC)
26067 CALL PHO_HARXPT(ECMH,PTMIN,2,DSIG1)
26068 IF(DREAL(DSIG1(15)).LT.1.D-15) GOTO 170
26070 DSDPTC(M) = DREAL(DSIG1(M))
26072 DSIGH = DREAL(DSIG1(15)-DSIG1(14))
26073 PTMXX = 0.95D0*PTMAX
26074 CALL PHO_HARXPT(ECMH,PTMXX,2,DSIG1)
26075 DSIGL = DREAL(DSIG1(15)-DSIG1(14))
26076 EX = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
26079 IF ( PTMIN.GE.PTMAX ) GOTO 140
26082 CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
26085 PT = R**(1.0D0/EX1)
26086 CALL PHO_HARXPT(ECMH,PT,2,DSIG1)
26087 F = WEIG(I)*PT/(R*EX1)
26089 DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
26100 C double direct process
26101 IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
26102 & .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
26105 ALPHAE = pho_alphae(SS)
26107 IF(IDPDG1.EQ.22) THEN
26108 * F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
26109 F1 = Q_ch2(I)*ALPHAE
26113 IF(IDPDG2.EQ.22) THEN
26114 * F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
26115 F2 = Q_ch2(I)*ALPHAE
26119 FACC = FACC + F1*F2*3.D0
26122 ZZ = SQRT(1.D0-4.D0*PTCUTD*PTCUTD/SS)
26123 R = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)*GEV2MB
26124 C hadronic cross section
26125 DSIGMC(14) = R*FACC*AKFAC
26126 C leptonic cross section
26127 IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
26128 DSIGMC(16) = R*3.D0*ALPHAE**2*AKFAC
26129 C simulation of tau together with quarks
26130 IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
26131 DSIGMC(16) = DSIGMC(16)*2.D0/3.D0
26133 DSIGMC(16) = CMPLX(0.D0,0.D0)
26135 C sum of direct part
26136 DSIGMC(15) = CMPLX(0.D0,0.D0)
26138 DSIGMC(15) = DSIGMC(15) + DSIGMC(I)
26141 C total sum (hadronic)
26142 DSIGMC(0) = DSIGMC(9) + DSIGMC(15)
26143 DSDPTC(0) = DSDPTC(9) + DSDPTC(15)
26147 *$ CREATE PHO_HARISR.FOR
26149 CDECK ID>, PHO_HARISR
26150 SUBROUTINE PHO_HARISR(IHPOM,P1,P2,IPF1,IPF2,IPA1,IPA2,IV1,IV2,Q2H,
26151 & XH1,XH2,XHMAX1,XHMAX2,IPB1,IPB2,IVO1,IVO2,XISR1,XISR2,IREJ)
26152 C********************************************************************
26154 C initial state radiation according to DGLAP evolution equations
26155 C (backward evolution, no spin effects)
26157 C input: IHPOM index of hard Pomeron
26158 C negative: delete all previous entries
26159 C P1,P2 4 momenta of hard scattered final partons
26160 C (in CMS of hard scattering)
26161 C IPF1,2 flavours of final partons
26162 C IPA1,2 flavours of initial partons
26163 C IV1,2 valence quark labels (0/1)
26164 C Q2H momentum transfer (squared, positive)
26165 C XH1,XH2 x values of initial partons
26166 C XHMAX1,2 max. x values allowed
26168 C output: all emitted partons in /POPISR/, final state
26169 C partons are the first two entries
26170 C shower evolution traced in /PODGL1/
26171 C IPB1,2 flavours of new initial partons
26172 C XISR1,2 x values of new initial partons
26173 C IVO1,2 valence quark labels (0/1)
26175 C attention: quark numbering according to PDG convention,
26178 C********************************************************************
26179 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26182 PARAMETER (RHOMAS = 0.766D0,
26186 DIMENSION P1(4),P2(4)
26188 C input/output channels
26190 COMMON /POINOU/ LI,LO
26191 C event debugging information
26193 PARAMETER (NMAXD=100)
26194 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
26195 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26196 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
26197 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26198 C internal rejection counters
26200 PARAMETER (NMXJ=60)
26201 CHARACTER*10 REJTIT
26203 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
26204 C model switches and parameters
26206 INTEGER ISWMDL,IPAMDL
26207 DOUBLE PRECISION PARMDL
26208 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
26209 C data of c.m. system of Pomeron / Reggeon exchange
26210 INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
26211 DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
26212 & SIDP,CODP,SIFP,COFP
26213 COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
26214 & SIDP,CODP,SIFP,COFP,NPOSP(2),
26215 & IDPDG1,IDBAM1,IDPDG2,IDBAM2
26216 C some hadron information, will be deleted in future versions
26218 DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
26219 COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
26220 C currently activated parton density parametrizations
26222 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
26223 DOUBLE PRECISION PDFLAM,PDFQ2M
26224 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
26225 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
26226 C scale parameters for parton model calculations
26227 INTEGER NQQAL,NQQALI,NQQALF,NQQPD
26228 DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
26229 COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
26230 & NQQAL,NQQALI,NQQALF,NQQPD
26231 C parameters for DGLAP backward evolution in ISR
26233 DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
26234 COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
26235 C initial state parton radiation (internal part)
26236 INTEGER MXISR3,MXISR4
26237 PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
26238 INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
26239 DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
26240 COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
26241 & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
26242 & IFL1(2,MXISR3),IFL2(2,MXISR3),
26243 & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
26245 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
26246 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
26247 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
26248 C particles created by initial state evolution
26249 INTEGER MXISR1,MXISR2
26250 PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
26251 INTEGER IFLISR,IPOISR,IMXISR
26252 DOUBLE PRECISION PHISR
26253 COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
26254 & IPOISR(2,2,MXISR2),IMXISR(2)
26256 DOUBLE PRECISION PYP,EER,THER,QMAXR
26259 DIMENSION XHMA(2),NEXT(2),PD1(-6:6),PD2(-6:6),WGGAP(-6:6),
26260 & WGPDF(-6:6),XHMI(2),GB(4),PM(4),PN(4),PC(2,4),Q2(2),
26261 & IVAL(2),IPAL(2),IL(2),IFSUM(2),IDMO(2)
26267 IF(IDEB(79).GE.10) THEN
26268 WRITE(LO,'(1X,A,/1X,I10,3I3,5E11.3,2(/5X,4E12.3))')
26269 & 'PHO_HARISR: KEV,IHPOM,IP1,IP2,Q2H,XH1,XH2,XHM1,XHM2:',
26270 & KEVENT,IHPOM,IPA1,IPA2,Q2H,XH1,XH2,XHMAX1,XHMAX2,P1,P2
26272 IF(IHPOM.EQ.0) RETURN
26279 C copy final state partons to local fields
26281 IF(IHIDX.GT.MXISR2) THEN
26282 WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26283 & '/POPISR/ for hard scattering labels (IHIDX,MXISR2):',
26288 IF(IHPOM.LT.0) IMXISR(K) = 0
26289 IPOISR(K,1,IHIDX) = IMXISR(K)+1
26290 IPAL(K) = IPOISR(K,1,IHIDX)
26293 PHISR(1,I,IPAL(1)) = P1(I)
26294 PHISR(2,I,IPAL(2)) = P2(I)
26296 IFLISR(1,IPAL(1)) = IPF1
26297 IFLISR(2,IPAL(2)) = IPF2
26299 C check limitations, initialize /PODGL1/
26300 IF((Q2H.GT.Q2MISR(1)).AND.(XH1.LT.XHMAX1)) THEN
26307 IF((Q2H.GT.Q2MISR(2)).AND.(XH2.LT.XHMAX2)) THEN
26322 IF((IPA1.EQ.22).OR.(IPA1.EQ.990)) NEXT(1) = 0
26325 IF((IPA2.EQ.22).OR.(IPA2.EQ.990)) NEXT(2) = 0
26327 IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,/5X,2I2,3E12.3)')
26328 & 'PHO_HARISR:INITIAL TESTS (NEXT1,2 Q2H Q21,2)',NEXT,Q2H,Q2MISR
26329 IF(NEXT(1)+NEXT(2).EQ.0) GOTO 800
26331 C initialize parton shower loop
26332 B0QCD = (33.D0-2.D0*NFSISR)/6.D0
26333 AL2ISR(1) = PDFLAM(1)
26334 AL2ISR(2) = PDFLAM(2)
26337 XHMI(1) = PMISR(1)/PCMP
26338 XHMI(2) = PMISR(2)/PCMP
26341 SHAT1 = XH1*XH2*ECMP**2
26342 IF(IPAMDL(109).EQ.1) THEN
26345 PT2SH(1,1) = Q2H*(1.D0-Q2H/SHAT1)
26347 PT2SH(2,1) = PT2SH(1,1)
26348 IF(PT2SH(1,1).LT.Q2MISR(1)) NEXT(1) = 0
26349 IF(PT2SH(2,1).LT.Q2MISR(2)) NEXT(2) = 0
26350 THSH(1,1) = 2.D0*SQRT(Q2H/SHAT1)
26351 THSH(2,1) = THSH(1,1)
26355 IF(IREJ.NE.0) GOTO 800
26357 C main generation loop
26358 C -------------------------------------------------
26360 C choose parton side to become solved
26361 IF((NEXT(1)+NEXT(2)).EQ.2) THEN
26362 IF(Q2SH(1,ISH(1)).GT.Q2SH(2,ISH(2))) THEN
26364 ELSE IF(Q2SH(2,ISH(2)).GT.Q2SH(1,ISH(1))) THEN
26367 IP = MAX(INT(DT_RNDM(SHAT1)*2.D0+0.999999D0),1)
26369 ELSE IF(NEXT(1).EQ.1) THEN
26371 ELSE IF(NEXT(2).EQ.1) THEN
26377 C INDX now parton position of parton to become solved
26378 C IP now side to be treated
26380 Q2P = Q2SH(IP,INDX)
26381 PT2 = PT2SH(IP,INDX)
26382 IFLB = IFL1(IP,INDX)
26383 C check available x
26385 C cutoff by x limitation: no further development
26386 IF((XHMA(IP)-XP).LT.XMIP*2.D0) THEN
26388 Q2SH(IP,INDX) = 0.D0
26389 IF(IDEB(79).GE.17) THEN
26390 WRITE(LO,'(1X,A,/5X,3E12.4,2I3)')
26391 & 'PHO_HARISR: evolution x-stop (XP,XMIP,XHMA,IP,INDX)',
26392 & XP,XMIP,XHMA(IP),IP,INDX
26396 C initial value of evolution variable t
26397 TT = LOG(AQQALI*Q2P/AL2ISR(IP))
26398 DO 110 I=-NFSISR,NFSISR
26404 ZMAX = XP/(XP+XMIP)
26406 C q --> q g, g --> g g
26408 WGGAP(0) = CF*((ZMAX**2-ZMIN**2)/2.D0-2.D0*(ZMAX-ZMIN)
26409 & +2.D0*LOG(ZMAX/ZMIN))
26411 WGGAP(I) = WGGAP(0)
26412 WGGAP(-I) = WGGAP(0)
26414 WGGAP(0) = 6.D0*((ZMIN**3-ZMAX**3)/3.D0+(ZMAX**2-ZMIN**2)/2.D0
26415 & -2.D0*(ZMAX-ZMIN)+LOG(ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)))
26416 C q --> g q, g --> q qb
26417 ELSE IF(ABS(IFLB).LE.6) THEN
26418 WGGAP(IFLB) = CF*((ZMIN**2-ZMAX**2)/2.D0-ZMAX+ZMIN
26419 & -2.D0*LOG((1.D0-ZMAX)/(1.D0-ZMIN)))
26420 IF(IVAL(IP).EQ.0) WGGAP(0) = 0.5D0*(2./3.*(ZMAX**3-ZMIN**3)
26421 & -ZMAX**2+ZMIN**2+ZMAX-ZMIN)
26423 WRITE(LO,'(/1X,A,I7)')
26424 & 'PHO_HARISR:ERROR: unsupported particle ID',IFLB
26427 C anomalous/resolved evolution
26429 IF(IPAMDL(110).GE.1) THEN
26430 IF((IDMO(IP).EQ.22).AND.(IFLB.NE.0)
26431 & .AND.(IFLB.NE.21)) THEN
26433 IF(NQQALI.EQ.1) THEN
26438 CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26440 CALL PHO_QPMPDF(IFLB,XP,SCALE2,PTA1,PVIRTP(IP),WGDIR)
26441 XI = DT_RNDM(XP)*PD1(IFLB)
26442 IF(WGDIR.GT.XI) THEN
26444 IF(IDEB(79).GE.17) WRITE(LO,'(1X,2A,/5X,4E12.5,I2,I3)')
26446 & 'direct splitting (WGDIR,WGPDF,X,SCALE2,IP,IFLB)',
26447 & WGDIR,PD1(IFLB),XP,SCALE2,IP,IFLB
26448 Q2SH(IP,INDX) = 0.D0
26456 C rejection loop for z,t sampling
26457 C ------------------------------------
26460 IF(NITER.GE.NTRY) THEN
26461 WRITE(LO,'(1X,A,2I6)')
26462 & 'PHO_HARISR: too many rejections',NITER,NTRY
26463 CALL PHO_PREVNT(-1)
26469 IF(IPDFC.EQ.0) THEN
26470 IF(NQQALI.EQ.1) THEN
26475 CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26480 DO 210 I=-NFSISR,NFSISR
26481 WGPDF(I) = PD1(I)/(PD1(IFLB)+1.D-12)*5.D0
26482 WGTOT = WGTOT+WGPDF(I)*WGGAP(I)
26486 C sample new t value
26487 TT = TT*EXP(MAX(-10.D0,LOG(DT_RNDM(SHAT1))*B0QCD/WGTOT))
26488 Q2NEW = AL2ISR(IP)*EXP(TT)/AQQALI
26490 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.5)')
26491 & 'PHO_HARISR: pre-selected Q2:',Q2NEW
26492 C compare to limits
26493 IF(Q2NEW.LT.Q2MISR(IP)) THEN
26494 Q2SH(IP,INDX) = 0.D0
26496 IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,2E10.3,2I3)')
26497 & 'PHO_HARISR: evolution Q2-stop (Q2,Q2MIN,IP,INDX):',
26498 & Q2NEW,Q2MISR(IP),IP,INDX
26501 Q2SH(IP,INDX) = Q2NEW
26502 TT = LOG(AQQALI*Q2NEW/AL2ISR(IP))
26503 C selection of flavours
26504 XI = WGTOT*DT_RNDM(TT)
26508 XI = XI-WGPDF(IFLA)*WGGAP(IFLA)
26509 IF((XI.GT.0.D0).AND.(IFLA.LT.NFSISR)) GOTO 220
26511 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,2I3)')
26512 & 'PHO_HARISR: pre-selected IFLA (IFLA,IFLB):',IFLA,IFLB
26514 CALL PHO_HARZSP(IFLA,IFLB,NFSISR,ZMIN,ZMAX,ZZ)
26516 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.3)')
26517 & 'PHO_HARISR: pre-selected ZZ',ZZ
26519 THETA = 4.D0*ZZ**2*Q2NEW/((ECMP*XP)**2*(1.D0-ZZ))
26520 IF(THETA.GT.THSH(IP,INDX)) THEN
26521 IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,2E12.3)')
26522 & 'PHO_HARISR: reject by angle (NEW/OLD)',
26523 & THETA,THSH(IP,INDX)
26526 C rejection weight given by new PDFs
26528 PT2NEW = Q2NEW*(1.D0-ZZ)
26529 IF(NQQALI.EQ.1) THEN
26530 SCALE2 = PT2NEW*AQQPD
26532 SCALE2 = Q2NEW*AQQPD
26534 IF(SCALE2.LT.Q2MISR(IP)) THEN
26535 Q2SH(IP,INDX) = 0.D0
26537 IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,2E10.3,2I3)')
26538 & 'PHO_HARISR: evol.Q2-stop (SCALE2,Q2MIN,IP,INDX):',
26539 & Q2NEW,Q2MISR(IP),IP,INDX
26542 CALL PHO_PDF(IP,XNEW,SCALE2,0.D0,PD2)
26543 IF(PD2(IFLA).LT.1.D-10) GOTO 200
26544 CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26545 PD1(IFLB) = MAX(PD1(IFLB),1.D-10)
26546 WGF = PD2(IFLA)/PD1(IFLB)/(WGPDF(IFLA)+1.D-12)
26547 IF(NQQALI.EQ.1) WGF = WGF*LOG(Q2NEW*AQQALI/AL2ISR(IP))
26548 & /LOG(PT2NEW*AQQALI/AL2ISR(IP))
26549 IF((WGF.GT.1.D0).AND.(IDEB(79).GE.2)) THEN
26550 WRITE(LO,'(1X,A,E12.3)')
26551 & 'PHO_HARISR: final weight:',WGF
26552 WRITE(LO,'(6X,A,I7,2I3,3E11.3)')
26553 & 'EV,IFLA,IFLB,Q2,PT2,Z:',KEVENT,IFLA,IFLB,Q2NEW,PT2NEW,ZZ
26555 IF(WGF.LT.DT_RNDM(XNEW)) GOTO 200
26557 IF(IDEB(79).GE.15) THEN
26558 WRITE(LO,'(1X,A,/3X,3I3,3E11.3)')
26559 & 'PHO_HARISR: accepted IP,IFLA,IFLB,PT2,Q2,Z:',
26560 & IP,IFLA,IFLB,PT2NEW,Q2NEW,ZZ
26563 IF(INDX.GE.MXISR3) THEN
26564 WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26565 & '/POINT6/ for parton radiation (INDX,MXISR3):',INDX,MXISR3
26569 C branching accepted, registration
26570 Q2SH(IP,INDX) = Q2NEW
26571 PT2SH(IP,INDX) = PT2NEW
26573 IFL2(IP,INDX) = IFLA-IFLB
26574 Q2SH(IP,INDX+1) = Q2NEW
26575 PT2SH(IP,INDX+1) = PT2SH(IP,INDX)
26576 XPSH(IP,INDX+1) = XNEW
26577 THSH(IP,INDX+1) = THETA
26578 IFL1(IP,INDX+1) = IFLA
26579 ISH(IP) = ISH(IP)+1
26582 IF(NACC.GT.MXISR4) THEN
26583 WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26584 & '/POINT6/ for parton radiation (NACC,MXISR4):',NACC,MXISR4
26590 IBRA(2,NACC) = INDX
26593 C generation of next branching
26594 IF(NEXT(1)+NEXT(2).NE.0) GOTO 100
26598 C new initial flavours, x values
26599 IPB1 = IFL1(1,ISH(1))
26600 IPB2 = IFL1(2,ISH(2))
26601 XISR1 = XPSH(1,ISH(1))
26602 XISR2 = XPSH(2,ISH(2))
26607 IF(ISH(1).GT.1) THEN
26608 CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
26609 IF(IDPDG1.EQ.22) THEN
26610 CALL PHO_QPMPDF(IPB1,XISR1,Q2MISR(1),0.D0,PVIRTP(1),FXP)
26611 IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(IPB1)-FXP) IVAL(1) = 1
26613 CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
26614 IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(-IPB1)) IVAL(1) = 1
26619 IF(ISH(2).GT.1) THEN
26620 CALL PHO_PDF(2,XISR2,Q2MISR(2),0.D0,PD1)
26621 IF(IDPDG2.EQ.22) THEN
26622 CALL PHO_QPMPDF(IPB2,XISR2,Q2MISR(2),0.D0,PVIRTP(2),FXP)
26623 IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(IPB2)-FXP) IVAL(2) = 1
26625 IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(-IPB2)) IVAL(2) = 1
26630 C parton kinematics
26632 C final partons in CMS
26633 PM(3) = (XH1-XH2)*ECMP/2.D0
26634 PM(4) = (XH1+XH2)*ECMP/2.D0
26635 SH = XH1*XH2*ECMP**2
26639 CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P1(1),P1(2),P1(3),
26640 & P1(4),PTOT1,PHISR(1,1,IPAL(1)),PHISR(1,2,IPAL(1)),
26641 & PHISR(1,3,IPAL(1)),PHISR(1,4,IPAL(1)))
26642 CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P2(1),P2(2),P2(3),
26643 & P2(4),PTOT1,PHISR(2,1,IPAL(2)),PHISR(2,2,IPAL(2)),
26644 & PHISR(2,3,IPAL(2)),PHISR(2,4,IPAL(2)))
26650 IL(IPA) = IBRA(2,I)
26651 C new initial partons in CMS
26654 SHZ = SH/ZPSH(IPA,IL(IPA))
26656 Q2(1) = Q2SH(1,IL(1))
26657 Q2(2) = Q2SH(2,IL(2))
26660 PC(1,3) = SQRT((SH+Q2(1)+Q2(2))**2-4.D0*Q2(1)*Q2(2))
26662 PC(1,4) = (SH-Q2(1)+Q2(2))/(2.D0*SSH)
26666 PC(2,4) = SSH-PC(1,4)
26667 XMS4 = PHO_PMASS(IFL2(IPA,IL(IPA)),1)**2
26668 EE3 = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
26669 S1 = SH+Q2(IPA)+Q2(IPB)
26670 S3 = SHZ+Q2(IPB)+Q2SH(IPA,IL(IPA)+1)
26671 R1 = SQRT(S1**2-4.D0*Q2(IPA)*Q2(IPB))
26672 R3 = SQRT(S3**2-4.D0*Q2(IPB)*Q2SH(IPA,IL(IPA)+1))
26673 IF(Q2(IPB).LT.0.1D0) THEN
26674 XMS4M = (Q2(IPA)/ZPSH(IPA,IL(IPA))-Q2SH(IPA,IL(IPA)+1))
26675 & *(SH/(SH+Q2(IPA))-SH/(SHZ+Q2SH(IPA,IL(IPA)+1)))
26677 XMS4M = (S1*S3-R1*R3)/(2.D0*Q2(IPB))
26678 & -Q2(IPA)-Q2SH(IPA,IL(IPA)+1)
26681 C max. virtuality for time-like showers
26682 QMAX = MIN(XMS4M,PARMDL(95)*Q2(IPA))
26683 IF((IPAMDL(111).GE.1).AND.(QMAX.GT.PARMDL(94))) THEN
26684 C generate time-like parton shower
26685 KF = IFL2(IPA,IL(IPA))
26686 IF(KF.EQ.0) KF = 21
26687 EER = MIN(EE3-PC(IPA,4),ECMP)
26689 CALL PY1ENT(1,KF,EER,THER,THER)
26691 CALL PYSHOW(1,0,QMAXR)
26693 IF(IDEB(79).GE.25) THEN
26694 WRITE(LO,'(1X,2A,/,5X,1P,4E12.4)') 'PHO_HARISR: ',
26695 & 'PYSHOW called for EE,QMAX,XMS4M,Q2(IPA)',
26696 & EER,QMAX,XMS4M,Q2(IPA)
26707 IF(PYK(K,1).LE.4) THEN
26709 IF(KK.GT.MXISR1) THEN
26710 WRITE(LO,'(1X,2A,2I5)') 'PHO_HARISR: no space ',
26711 & 'left in /POPISR/ (KK,MXISR1):',KK,MXISR1
26715 PHISR(IPA,1,KK) = PYP(K,1)
26716 PJX = PJX+PHISR(IPA,1,KK)
26717 PHISR(IPA,2,KK) = PYP(K,2)
26718 PJY = PJY+PHISR(IPA,2,KK)
26719 PHISR(IPA,3,KK) = PYP(K,3)
26720 PJZ = PJZ+PHISR(IPA,3,KK)
26721 PHISR(IPA,4,KK) = PYP(K,4)
26722 PJE = PJE+PHISR(IPA,4,KK)
26723 IFLISR(IPA,KK) = PYK(K,2)
26724 IF(IFLISR(IPA,KK).EQ.21) IFLISR(IPA,KK) = 0
26725 IF(IFLISR(IPA,KK).EQ.5) IFLISR(IPA,KK) = 3
26726 IF(IFLISR(IPA,KK).EQ.-5) IFLISR(IPA,KK) = -3
26729 NGEN = KK-IPAL(IPA)
26730 XMS4 = (PJE+PJZ)*(PJE-PJZ)-PJX**2-PJY**2
26731 PP4 = SQRT(PJE**2-XMS4)
26732 EE3 = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
26734 IF(IDEB(79).GE.20) WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)')
26736 & 'time-like shower: PJE,PJX,PJY,PJZ,PP4,XMS4',
26737 & PJE,PJX,PJY,PJZ,PP4,XMS4
26740 PZ3 = (2.D0*PC(IPA,4)*EE3+Q2(IPA)+Q2SH(IPA,IL(IPA)+1)+XMS4)
26741 & /(2.D0*PC(IPA,3))
26742 PT3 = (EE3+PZ3)*(EE3-PZ3)+Q2SH(IPA,IL(IPA)+1)
26743 IF(PT3.LT.0.D0) THEN
26744 IF(IDEB(79).GE.5) WRITE(LO,'(1X,A,E12.3)')
26745 & 'PHO_HARISR: rejection due to PT3',PT3
26749 CALL PHO_SFECFE(SFE,CFE)
26754 C time-like shower generated
26755 EE4 = EE3-PC(IPA,4)
26756 PZ4 = PZ3-PC(IPA,3)
26757 PP4 = SQRT(PT3**2+PZ4**2)
26759 GAM = (EE4*PJE-PP4*PJZ)/XMS4
26760 BEG = (PJE*PP4-EE4*PJZ)/XMS4
26763 SIDD = SQRT(PX3**2+PY3**2)/PP4
26766 IF(PP4*SIDD.GT.1.D-5) THEN
26767 COFD = PX3/(SIDD*PP4)
26768 SIFD = PY3/(SIDD*PP4)
26769 ANORF = SQRT(COFD*COFD+SIFD*SIFD)
26773 C copy partons back
26777 PX = PHISR(IPA,1,KK)
26778 PY = PHISR(IPA,2,KK)
26779 PZ = PHISR(IPA,3,KK)
26780 COH= PHISR(IPA,4,KK)
26781 EE = GAM*COH+BEG*PZ
26782 PZ = GAM*PZ +BEG*COH
26783 PHISR(IPA,4,KK) = EE
26784 CALL PHO_TRANS(PX,PY,PZ,CODD,SIDD,COFD,SIFD,
26785 & PHISR(IPA,1,KK),PHISR(IPA,2,KK),PHISR(IPA,3,KK))
26789 C no time-like shower generated
26790 IPAL(IPA) = IPAL(IPA)+1
26791 PHISR(IPA,1,IPAL(IPA)) = PX3
26792 PHISR(IPA,2,IPAL(IPA)) = PY3
26793 PHISR(IPA,3,IPAL(IPA)) = PZ3-PC(IPA,3)
26794 PHISR(IPA,4,IPAL(IPA)) = EE3-PC(IPA,4)
26795 IFLISR(IPA,IPAL(IPA)) = IFL2(IPA,IL(IPA))
26801 C boost / rotate into new CMS
26803 GB(K) = (PC(1,K)+PC(2,K))/SSHZ
26805 CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),PC(1,1),PC(1,2),
26806 & PC(1,3),PC(1,4),PTOT1,PM(1),PM(2),PM(3),PM(4))
26808 SIG= SQRT(PM(1)**2+PM(2)**2)/PTOT1
26811 IF(PTOT1*SIG.GT.1.D-5) THEN
26812 COH=PM(1)/(SIG*PTOT1)
26813 SIH=PM(2)/(SIG*PTOT1)
26814 ANORF=SQRT(COH*COH+SIH*SIH)
26819 DO 844 L=IPOISR(K,1,IHIDX),IPAL(K)
26820 CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),
26821 & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),
26822 & PTOT1,PM(1),PM(2),PM(3),PM(4))
26823 CALL PHO_TRANI(PM(1),PM(2),PM(3),COG,SIG,COH,SIH,PN(1),
26825 CALL PHO_TRANS(PN(1),PN(2),PN(3),1.D0,0.D0,COH,SIH,
26826 & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L))
26827 PHISR(K,4,L) = PM(4)
26831 C boost back to global CMS
26832 PM(3) = (XISR1-XISR2)/2.D0
26833 PM(4) = (XISR1+XISR2)/2.D0
26834 SSH = SQRT(XISR1*XISR2)
26838 DO 944 L=IPOISR(K,1,IHIDX),IPAL(K)
26839 CALL PHO_ALTRA(GB(4),0.D0,0.D0,GB(3),PHISR(K,1,L),
26840 & PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),PTOT1,PM(1),
26841 & PM(2),PM(3),PM(4))
26842 PHISR(K,1,L) = PM(1)
26843 PHISR(K,2,L) = PM(2)
26844 PHISR(K,3,L) = PM(3)
26845 PHISR(K,4,L) = PM(4)
26849 IPOISR(1,2,IHIDX) = IPAL(1)
26850 IPOISR(2,2,IHIDX) = IPAL(2)
26851 IMXISR(1) = IPAL(1)
26852 IMXISR(2) = IPAL(2)
26855 IF(IDEB(79).GE.10) THEN
26856 WRITE(LO,'(1X,A,2I10/,6X,A,2E12.3,2I5)') 'NUMBER OF EMISSIONS',
26857 & ISH(1)-1,ISH(2)-1,'NEW X1,X2,IFL1,ILF2',XISR1,XISR2,IPB1,IPB2
26859 WRITE(LO,'(1X,A,2I5,/6X,A)')
26860 & 'PHO_HARISR: ISR configuration (NITER,NACC)',NITER,NACC,
26861 & ' SIDE NO. IFLB IFLC Q2SH PT2SH XH ZZ'
26865 WRITE(LO,'(5X,4I5,4E11.3)')
26866 & K,I,IFL1(K,I),IFL2(K,I),Q2SH(K,I),PT2SH(K,I),XPSH(K,I),
26870 C check of final configuration
26877 WRITE(LO,'(1X,A)') 'PHO_HARISR: outgoing partons'
26879 DO 744 L=IPOISR(K,1,IHIDX),IPOISR(K,2,IHIDX)
26880 WRITE(LO,'(6X,2I4,I6,4E11.3)') K,L,IFLISR(K,L),
26881 & PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L)
26882 IFSUM(K) = IFSUM(K)+ IFLISR(K,L)
26883 PX3 = PX3 + PHISR(K,1,L)
26884 PY3 = PY3 + PHISR(K,2,L)
26885 PZ3 = PZ3 + PHISR(K,3,L)
26886 EE3 = EE3 + PHISR(K,4,L)
26889 IFSUM(1) = IFSUM(1)-IPB1
26890 IFSUM(2) = IFSUM(2)-IPB2
26891 PZ3 = PZ3 -(XISR1-XISR2)*ECMP/2.D0
26892 EE3 = EE3 -(XISR1+XISR2)*ECMP/2.D0
26893 WRITE(LO,'(1X,A,2I4,4E11.3)') 'CHECK:IFL1,2 PCM(1-4)',
26894 & IFSUM,PX3,PY3,PZ3,EE3
26898 *$ CREATE PHO_HARZSP.FOR
26900 CDECK ID>, PHO_HARZSP
26901 SUBROUTINE PHO_HARZSP(IFLA,IFLB,NFSH,ZMIN,ZMAX,ZZ)
26902 C*********************************************************************
26904 C sampling of z values from DGLAP kernels
26906 C input: IFLA,IFLB parton flavours
26907 C NFSH flavours involved in hard processes
26908 C ZMIN minimal ZZ allowed
26909 C ZMAX maximal ZZ allowed
26911 C output: ZZ z value
26913 C*********************************************************************
26914 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26917 PARAMETER ( DEPS = 1.D-10 )
26919 C input/output channels
26921 COMMON /POINOU/ LI,LO
26922 C event debugging information
26924 PARAMETER (NMAXD=100)
26925 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
26926 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26927 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
26928 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26929 C internal rejection counters
26931 PARAMETER (NMXJ=60)
26932 CHARACTER*10 REJTIT
26934 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
26936 IF(ZMAX.LE.ZMIN) THEN
26937 WRITE(LO,'(1X,A,2E12.3)')
26938 & 'PHO_HARZSP: ZMAX<ZMIN (ZMAX,ZMIN)',ZMAX,ZMIN
26939 CALL PHO_PREVNT(-1)
26947 C1 = ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)
26948 C2 = (1.D0-ZMIN)/ZMIN
26950 ZZ = 1.D0/(1.D0+C2/C1**DT_RNDM(ZMIN))
26951 IF(((1.D0-ZZ*(1.D0-ZZ))**2).LT.DT_RNDM(ZMAX)) GOTO 100
26952 ELSE IF(ABS(IFLA).LE.NFSH) THEN
26956 ZZ = ZMIN*C1**DT_RNDM(ZMIN)
26957 IF((0.5D0*(1.D0+(1.D0-ZZ)**2)).LT.DT_RNDM(ZMAX)) GOTO 200
26961 ELSE IF(ABS(IFLB).LE.NFSH) THEN
26966 ZZ = ZMIN+C1*DT_RNDM(ZMIN)
26967 IF((2.D0*ZZ*(ZZ-1.D0)+1.D0).LT.DT_RNDM(ZMAX)) GOTO 300
26968 ELSE IF(ABS(IFLA).LE.NFSH) THEN
26970 C1 = (1.D0-ZMAX)/(1.D0-ZMIN)
26973 ZZ = 1.D0-C2*C1**DT_RNDM(ZMIN)
26974 IF(0.5D0*(1.D0+ZZ**2).LT.DT_RNDM(ZMAX)) GOTO 400
26982 IF(IDEB(80).GE.20) WRITE(LO,'(1X,A,2I3,3E11.3)')
26983 & 'PHO_HARZSP: IFLA,IFLB,ZZ,ZMIN,ZMAX',
26984 & IFLA,IFLB,ZZ,ZMIN,ZMAX
26988 WRITE(LO,'(/1X,A,2I7)') 'PHO_HARZSP:ERROR: invalid flavours A,B',
26994 *$ CREATE PHO_ALPHAE.FOR
26996 CDECK ID>, PHO_ALPHAE
26997 DOUBLE PRECISION FUNCTION PHO_ALPHAE(Q2)
26998 C**********************************************************************
27000 C calculation of ALPHA_em
27002 C input: Q2 scale in GeV**2
27004 C**********************************************************************
27008 DOUBLE PRECISION Q2
27010 C input/output channels
27012 COMMON /POINOU/ LI,LO
27013 C model switches and parameters
27015 INTEGER ISWMDL,IPAMDL
27016 DOUBLE PRECISION PARMDL
27017 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27019 DOUBLE PRECISION PYALEM
27021 pho_alphae = 1.D0/137.D0
27023 if(ipamdl(120).eq.1) then
27024 pho_alphae = PYALEM(Q2)
27029 *$ CREATE PHO_ALPHAS.FOR
27031 CDECK ID>, PHO_ALPHAS
27032 DOUBLE PRECISION FUNCTION PHO_ALPHAS(Q2,IMODE)
27033 C**********************************************************************
27035 C calculation of ALPHA_S
27037 C input: IMODE = 1 lambda_QCD**2 for PDF 1 evolution
27038 C 2 lambda_QCD**2 for PDF 2 evolution
27039 C 3 lambda_QCD**2 for hard scattering
27040 C Q2 scale in GeV**2
27042 C initialization needed:
27043 C IMODE = 0 lambda values taken from PDF table
27044 C -1 given Q2 is 4-flavour lambda 1
27045 C -2 given Q2 is 4-flavour lambda 2
27046 C -3 given Q2 is 4-flavour lambda 3
27049 C**********************************************************************
27053 DOUBLE PRECISION Q2
27056 C input/output channels
27058 COMMON /POINOU/ LI,LO
27059 C model switches and parameters
27061 INTEGER ISWMDL,IPAMDL
27062 DOUBLE PRECISION PARMDL
27063 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27064 C hard scattering parameters used for most recent hard interaction
27066 DOUBLE PRECISION ALQCD2,BQCD
27067 COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
27068 C currently activated parton density parametrizations
27070 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
27071 DOUBLE PRECISION PDFLAM,PDFQ2M
27072 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
27073 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
27079 IF(IMODE.GT.0) THEN
27081 IF(Q2.LT.PARMDL(148)) THEN
27083 ELSE IF(Q2.LT.PARMDL(149)) THEN
27085 ELSE IF(Q2.LT.PARMDL(150)) THEN
27091 PHO_ALPHAS = BQCD(NFbeta)/LOG(Q2/ALQCD2(IMODE,NFbeta))
27094 ELSE IF(IMODE.EQ.0) THEN
27098 ALQCD2(I,2) = PDFLAM(1)*PDFLAM(2)
27100 ALQCD2(I,2) = PDFLAM(I)*PDFLAM(I)
27102 ALQCD2(I,1) = PARMDL(148)
27103 & *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
27104 ALQCD2(I,3) = PARMDL(149)
27105 & *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
27106 ALQCD2(I,4) = PARMDL(150)
27107 & *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))
27111 ELSE IF(IMODE.LT.0) THEN
27113 if(IMODE.eq.-4) then
27115 ALQCD2(I,2) = SQRT(ALQCD2(1,2)*ALQCD2(2,2))
27120 ALQCD2(I,1) = PARMDL(148)
27121 & *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
27122 ALQCD2(I,3) = PARMDL(149)
27123 & *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
27124 ALQCD2(I,4) = PARMDL(150)
27125 & *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))
27131 *$ CREATE PHO_DFWRAP.FOR
27133 CDECK ID>, PHO_DFWRAP
27134 SUBROUTINE PHO_DFWRAP(MODE,JM1,JM2)
27135 C**********************************************************************
27137 C wrapper for diffraction dissociation in hadron-nucleus and
27138 C nucleus-nucleus collisions with DPMJET
27140 C input: MODE 1: transformation into CMS
27141 C 2: transformation into Lab
27142 C JM1/2 indices of old mother particles
27143 C JM1/2N indices of new mother particles
27145 C**********************************************************************
27149 INTEGER MODE,JM1,JM2
27151 C input/output channels
27153 COMMON /POINOU/ LI,LO
27154 C event debugging information
27156 PARAMETER (NMAXD=100)
27157 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27158 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27159 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27160 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27161 C standard particle data interface
27163 PARAMETER (NMXHEP=4000)
27164 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
27165 DOUBLE PRECISION PHEP,VHEP
27166 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27167 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
27169 C extension to standard particle data interface (PHOJET specific)
27170 INTEGER IMPART,IPHIST,ICOLOR
27171 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
27172 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
27173 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
27174 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
27175 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
27176 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
27178 DOUBLE PRECISION GAMBED(4),P1(4),P2(4),P3(4),P4(4),XM1,XM2
27179 DOUBLE PRECISION SS,ECMD,PTOT1,CODD,SIDD,COFD,SIFD,ANORF
27181 INTEGER I,NHEPS,JM1S,JM2S,JM1N,JM2N,IREJ
27183 C transformation into CMS
27195 P1(1) = PHEP(1,JM1)+PHEP(1,JM2)
27196 P1(2) = PHEP(2,JM1)+PHEP(2,JM2)
27197 P1(3) = PHEP(3,JM1)+PHEP(3,JM2)
27198 P1(4) = PHEP(4,JM1)+PHEP(4,JM2)
27199 SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
27202 GAMBED(I) = P1(I)/ECMD
27204 CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
27205 & PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
27206 & PHEP(4,JM1),PTOT1,P1(1),P1(2),P1(3),P1(4))
27209 SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
27212 IF(PTOT1*SIDD.GT.1.D-5) THEN
27213 COFD = P1(1)/(SIDD*PTOT1)
27214 SIFD = P1(2)/(SIDD*PTOT1)
27215 ANORF= SQRT(COFD*COFD+SIFD*SIFD)
27220 C initial particles in CMS
27224 P1(3) = ECMD/2.D0*XPSUB
27229 P2(3) = -ECMD/2.D0*XTSUB
27232 CALL PHO_MSHELL(P1,P2,XM1,XM2,P3,P4,IREJ)
27234 CALL PHO_REGPAR(1,IDHEP(JM1),IMPART(JM1),JM1,JM2,
27235 & P3(1),P3(2),P3(3),P3(4),IPHIST(1,JM1),IPHIST(2,JM1),
27236 & ICOLOR(1,JM1),ICOLOR(2,JM1),JM1N,1)
27238 CALL PHO_REGPAR(1,IDHEP(JM2),IMPART(JM2),JM2,JM1,
27239 & P4(1),P4(2),P4(3),P4(4),IPHIST(1,JM2),IPHIST(2,JM2),
27240 & ICOLOR(1,JM2),ICOLOR(2,JM2),JM2N,1)
27245 C transformation into lab.
27247 ELSE IF(MODE.EQ.2) THEN
27249 CALL PHO_LTRHEP(JM1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
27250 & GAMBED(1),GAMBED(2),GAMBED(3))
27255 C clean up after rejection
27257 ELSE IF(MODE.EQ.-2) THEN
27266 WRITE(LO,'(1X,A,I6)') 'PHO_DFWRAP: invalid MODE parameter:',MODE
27272 *$ CREATE PHO_DIFDIS.FOR
27274 CDECK ID>, PHO_DIFDIS
27275 SUBROUTINE PHO_DIFDIS(IDIF1,IDIF2,IMOTH1,IMOTH2,SPROB,IMODE,
27276 & MSOFT,MHARD,IREJ)
27277 C***********************************************************************
27279 C sampling of diffractive events of different kinds,
27280 C (produced particles stored in /POEVT1/)
27282 C input: IDIF1/2 diffractive process particle 1/2
27283 C 0 elastic/quasi-elastic scattering
27284 C 1 diffraction dissociation
27285 C IMOTH1/2 index of mother particles in /POEVT1/
27286 C SPROB suppression factor (survival probability) for
27287 C resolved diffraction dissociation
27288 C IMODE mode of operation
27289 C 0 sampling of diffractive cut
27290 C 1 sampling of enhanced cut
27291 C 2 sampling of diffractive cut without
27292 C scattering (needed for double-pomeron)
27293 C -1 initialization
27294 C -2 output of statistics
27296 C output: MSOFT number of generated soft strings
27297 C MHARD number of generated hard strings
27298 C IDIF1/2 diffraction label for particle 1/2 in /PROCES/
27299 C 0 quasi elastic scattering
27300 C 1 low-mass diffractive dissociation
27301 C 2 soft high-mass diffractive dissociation
27302 C 3 hard resolved diffractive dissociation
27303 C 4 hard direct diffractive dissociation
27304 C IREJ rejection label
27305 C 0 successful generation of partons
27308 C***********************************************************************
27309 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27312 PARAMETER ( EPS = 1.D-7,
27315 C input/output channels
27317 COMMON /POINOU/ LI,LO
27318 C event debugging information
27320 PARAMETER (NMAXD=100)
27321 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27322 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27323 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27324 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27325 C general process information
27326 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
27327 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
27328 C internal rejection counters
27330 PARAMETER (NMXJ=60)
27331 CHARACTER*10 REJTIT
27333 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
27334 C global event kinematics and particle IDs
27335 INTEGER IFPAP,IFPAB
27336 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
27337 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
27338 C c.m. kinematics of diffraction
27340 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
27341 & SIDD,CODD,SIFD,COFD,PDCMS
27342 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
27343 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
27344 C obsolete cut-off information
27345 DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
27346 COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
27348 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
27349 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
27350 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
27351 C model switches and parameters
27353 INTEGER ISWMDL,IPAMDL
27354 DOUBLE PRECISION PARMDL
27355 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27356 C Reggeon phenomenology parameters
27357 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
27358 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
27359 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
27360 & ALREG,ALREGP,GR(2),B0REG(2),
27361 & GPPP,GPPR,B0PPP,B0PPR,
27362 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
27363 C parameters of 2x2 channel model
27364 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
27365 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
27366 C table of particle indices for recursive PHOJET calls
27368 PARAMETER ( MAXIPX = 100 )
27369 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
27370 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
27371 & IPOIX1,IPOIX2,IPOIX3
27372 C standard particle data interface
27374 PARAMETER (NMXHEP=4000)
27375 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
27376 DOUBLE PRECISION PHEP,VHEP
27377 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27378 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
27380 C extension to standard particle data interface (PHOJET specific)
27381 INTEGER IMPART,IPHIST,ICOLOR
27382 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
27383 C event weights and generated cross section
27384 INTEGER IPOWGC,ISWCUT,IVWGHT
27385 DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
27386 COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
27387 & IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
27389 DOUBLE PRECISION P1,P2,XMASS,AMP,PP,PD1,PD2
27390 DIMENSION P1(5),P2(5),XMASS(2),AMP(2),PP(7,2),PD1(7),PD2(7)
27391 DIMENSION IDPDG(2),IDBAM(2),IPAR(2),IPOSP(2,2),IRPDG(2),IVEC(2),
27392 & IRBAM(2),IFL1P(2),IFL2P(2),ISAM(2),JSAM(2),KSAM(2),
27395 IF(IMODE.EQ.-1) THEN
27398 ELSE IF(IMODE.EQ.-2) THEN
27399 C output of statistics
27407 IF(IDEB(45).GE.10) THEN
27408 WRITE(LO,'(1X,2A,/16X,7I6)') 'PHO_DIFDIS: (1) ',
27409 & 'IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
27410 & IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE
27414 C save current status
27424 JDA11 = JDAHEP(1,IMOTH1)
27425 JDA21 = JDAHEP(2,IMOTH1)
27426 JDA12 = JDAHEP(1,IMOTH2)
27427 JDA22 = JDAHEP(2,IMOTH2)
27428 ISTH1 = ISTHEP(IMOTH1)
27429 ISTH2 = ISTHEP(IMOTH2)
27435 IDPDG(I) = IDHEP(NPOSD(I))
27436 IDBAM(I) = IMPART(NPOSD(I))
27437 AMP(I) = PHO_PMASS(IDBAM(I),0)
27438 IF(IDPDG(I).EQ.22) THEN
27439 PMASSD(I) = 0.765D0
27440 PVIRTD(I) = PHEP(5,NPOSD(I))**2
27442 PMASSD(I) = PHO_PMASS(IDBAM(I),0)
27447 P1(1) = PHEP(1,IMOTH1)+PHEP(1,IMOTH2)
27448 P1(2) = PHEP(2,IMOTH1)+PHEP(2,IMOTH2)
27449 P1(3) = PHEP(3,IMOTH1)+PHEP(3,IMOTH2)
27450 P1(4) = PHEP(4,IMOTH1)+PHEP(4,IMOTH2)
27451 SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
27453 IF(IDEB(45).GE.15) WRITE(LO,'(1X,A,E12.4)')
27454 & 'PHO_DIFDIS: availabe energy',ECMD
27455 C check total available energy
27456 IF((AMP(1)+AMP(2)+0.1D0).GE.ECMD) THEN
27457 IF(IDEB(45).GE.2) WRITE(LO,'(1X,2A,/5X,A,1P,3E11.3)')
27459 & 'not enough energy for inelastic diffraction',
27460 & 'ECM, particle masses:',ECMD,AMP
27461 IFAIL(7) = IFAIL(7)+1
27467 GAMBED(I) = P1(I)/ECMD
27469 CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
27470 & PHEP(1,IMOTH1),PHEP(2,IMOTH1),PHEP(3,IMOTH1),
27471 & PHEP(4,IMOTH1),PTOT1,P1(1),P1(2),P1(3),P1(4))
27474 SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
27477 IF(PTOT1*SIDD.GT.1.D-5) THEN
27478 COFD = P1(1)/(SIDD*PTOT1)
27479 SIFD = P1(2)/(SIDD*PTOT1)
27480 ANORF= SQRT(COFD*COFD+SIFD*SIFD)
27484 C initial particles in CMS
27491 PDCMS(3,2) = -PTOT1
27492 PDCMS(4,2) = ECMD-P1(4)
27493 C get new CM momentum
27494 AM12 = PMASSD(1)**2
27495 AM22 = PMASSD(2)**2
27496 PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)
27498 C coherence constraint (min/max diffractive mass allowed)
27499 IF(IMODE.EQ.2) THEN
27500 THRM1 = PARMDL(71)/SQRT(1-PARMDL(72))
27501 THRM1 = MAX(THRM1,PARMDL(70)*PARMDL(71))
27502 THRM2 = SQRT(1-PARMDL(72))*ECMD
27503 THRM2 = MIN(THRM2,ECMD/PARMDL(70))
27506 THRM2 = PARMDL(45)*ECMD
27507 C check kinematic limits
27508 IF(THRM2.LE.(4.D0*PARMDL(162))) IPAR(1) = MIN(IPAR(1),1)
27509 IF(THRM2.LE.(4.D0*PARMDL(163))) IPAR(2) = MIN(IPAR(2),1)
27512 C check energy vs. coherence constraints
27513 IF(MAX(PARMDL(162),PMASSD(1)+THRM1).GE.THRM2) IPAR(1) = 0
27514 IF(MAX(PARMDL(163),PMASSD(2)+THRM1).GE.THRM2) IPAR(2) = 0
27516 C no phase space available
27517 IF(IPAR(1)+IPAR(2).EQ.0) THEN
27518 IF(IDEB(45).GE.2) WRITE(LO,'(1X,2A,1P,E11.3,2(/5X,A,2E11.3))')
27520 & 'not enough phase space for ine. diffraction (Ecm)',ECMD,
27521 & 'side 1: min. mass, upper mass limit:',
27522 & MAX(PARMDL(162),PMASSD(1)+THRM1),THRM2,
27523 & 'side 2: min. mass, upper mass limit:',
27524 & MAX(PARMDL(163),PMASSD(2)+THRM1),THRM2
27525 IFAIL(7) = IFAIL(7)+1
27535 C main rejection loop
27536 C -------------------------------
27540 IFAIL(13) = IFAIL(13)+1
27541 IF(ITRY.GE.ITRYM) THEN
27542 IF(IDEB(45).GE.2) WRITE(LO,'(1X,A,I10,2I3)')
27543 & 'PHO_DIFDIS: rejection (KEVE,IPAR1/2) ',KEVENT,IPAR
27544 IFAIL(7) = IFAIL(7)+1
27555 C reset mother-daugther relations
27557 JDAHEP(1,IMOTH1) = JDA11
27558 JDAHEP(2,IMOTH1) = JDA21
27559 JDAHEP(1,IMOTH2) = JDA12
27560 JDAHEP(2,IMOTH2) = JDA22
27561 ISTHEP(IMOTH1) = ISTH1
27562 ISTHEP(IMOTH2) = ISTH2
27571 C calculation of kinematics
27573 C sampling of masses
27576 IFL1P(I) = IDPDG(I)
27577 IFL2P(I) = IDBAM(I)
27583 IF(IPAR(I).EQ.0) THEN
27584 C vector meson dominance assumed
27586 CALL PHO_VECRES(IVEC(I),XMASS(I),IFL1P(I),IFL2P(I))
27587 C diffraction dissociation
27588 ELSE IF(IPAR(I).EQ.1) THEN
27589 XMMIN = MAX(PARMDL(161+I),PMASSD(I)+THRM1)
27590 PREF2 = PMASSD(I)**2
27591 XMASS(I) = PHO_DFMASS(XMMIN,THRM2,PREF2,PVIRTD(I),ISWMDL(22))
27593 WRITE(LO,'(/1X,A,2I3)')
27594 & 'PHO_DIFDIS:ERROR:invalid IPAR1,IPAR2',IPAR(1),IPAR(2)
27599 C sampling of momentum transfer
27600 CALL PHO_DIFSLP(IPAR(1),IPAR(2),IVEC(1),IVEC(2),XMASS(1),XMASS(2),
27601 & THRM2,TT,SLWGHT,IREJ)
27604 IF(NSLP.LT.100) GOTO 55
27605 WRITE(LO,'(1X,2A,/10X,2I3,2E12.3)') 'PHO_DIFDIS: ',
27606 & 'too many slope rejections:IPAR1,IPAR2,M1,M2',IPAR,XMASS
27611 C correct for t-M^2 correlation in diffraction
27612 IF(DT_RNDM(TT).GT.SLWGHT) THEN
27614 IF(NCOR.LT.100) GOTO 55
27615 WRITE(LO,'(1X,2A,I10)') 'PHO_DIFDIS: ',
27616 & 'too many rejections due to t-M**2 correlation (EVE)',KEVENT
27622 IF(IDEB(45).GE.5) THEN
27623 WRITE(LO,'(1X,A,/5X,2I3,3E12.3)')
27624 & 'PHO_DIFDIS: IPAR1,IPAR2,XMASS1,XMASS2,TT',IPAR,XMASS,TT
27626 C not double pomeron scattering
27627 IF(IMODE.NE.2) THEN
27628 C sample diffractive interaction processes
27630 IF(IPAR(I).NE.0) THEN
27631 C find particle combination
27632 IF(IDPDG(I).EQ.IFPAP(1)) THEN
27634 ELSE IF(IDPDG(I).EQ.IFPAP(2)) THEN
27636 ELSE IF(IDPDG(I).EQ.990) THEN
27641 C sample dissociation process
27642 CALL PHO_DIFPRO(IP,ISWMDL(16),IDPDG(I),990,XMASS(I),
27643 & PVIRTD(I),0.D0,SPROB,IPROC(I),ISAM(I),JSAM(I),
27645 IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
27646 C store process label
27647 IF(IDIR(I).GT.0) THEN
27649 ELSE IF(KSAM(I).GT.0) THEN
27651 ELSE IF(ISAM(I).GT.0) THEN
27655 C mass fine correction
27656 CALL PHO_MASSAD(IDPDG(I),IFL1P(I),IFL2P(I),PMASSD(I),
27657 & XMASS(I),XMNEW,IRPDG(I),IRBAM(I))
27661 C diffractive pomeron-hadron interaction
27662 IPAR(I) = 10+IPROC(I)
27665 IF(IDEB(45).GE.15) WRITE(LO,'(1X,A,/10X,I3,E12.4,5I3)')
27666 & 'PHO_DIFDIS: IP,XMASS,IPROC,ISAM,JSAM,KSAM,IDIR',
27667 & IP,XMASS(I),IPROC(I),ISAM(I),JSAM(I),KSAM(I),IDIR(I)
27671 C actualize debug information
27672 IF(IMODE.EQ.1) THEN
27676 C calculate new momenta in CMS
27677 CALL PHO_DIFKIN(XMASS(1),XMASS(2),TT,P1,P2,IREJ)
27678 IF(IREJ.NE.0) GOTO 50
27684 C comment line for diffraction
27685 CALL PHO_REGPAR(30,IPROCE,IMODE,NPOSD(1),NPOSD(2),XMASS(1),
27686 & XMASS(2),TT,ECMD,IPAR(1),IPAR(2),IDPDG(1),IDPDG(2),ICPOS,1)
27687 C write diffractive strings/particles
27695 PP(6,I1) = SIGN(PHEP(5,NPOSD(I1))**2,PHEP(5,NPOSD(I1)))
27697 IGEN = IPHIST(2,NPOSD(I1))
27698 if(IGEN.eq.0) IGEN = -I1*10
27699 CALL PHO_DIFPAR(NPOSD(I1),NPOSD(I2),IGEN,IFL1P(I1),IFL2P(I1),
27700 & IPAR(I1),PD1,PD2,IPOSP(1,I1),IPOSP(2,I1),IMODE,IREJ)
27702 IFAIL(7+I) = IFAIL(7+I)+1
27703 IF(IDEB(45).GE.3) WRITE(LO,'(1X,A,2I3,E11.3)')
27704 & 'PHO_DIFDIS: rejection by PHO_DIFPAR (I,IPAR,XM)',
27705 & I,IPAR(I),XMASS(I)
27708 ICOLOR(I1,ICPOS) = IPOSP(1,I1)
27710 C double-pomeron scattering?
27711 IF(IMODE.EQ.2) GOTO 150
27713 C diffractive final states
27716 IF(IPAR(I).EQ.0) THEN
27717 C vector meson production
27718 IF(IDPDG(I).EQ.22) THEN
27719 IF(ISWMDL(21).GE.0) THEN
27721 IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
27722 CALL PHO_SDECAY(IPOSP(1,I),ISP,2)
27724 C hadronic state of multi-pomeron coupling
27725 ELSE IF(IDPDG(I).EQ.990) THEN
27726 CALL PHO_SDECAY(IPOSP(1,I),0,2)
27729 IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
27730 IF(ISAM(I)+JSAM(I)+KSAM(I).EQ.0) JSAM(I) = 1
27731 IF(IDIR(I).GT.0) THEN
27733 ELSE IF(KSAM(I).GT.0) THEN
27735 ELSE IF(ISAM(I).GT.0) THEN
27741 IPAR(I) = 10+IPROC(I)
27743 IPHIST(I,ICPOS) = IPAR(I)
27744 C update debug informantion
27751 IF((IRPDG(I).NE.0).AND.(ISWMDL(23).GT.0)) THEN
27753 C resonance decay, pi+pi- background
27754 P1(1) = PHEP(1,IPOSP(1,I))+PHEP(1,IPOSP(2,I))
27755 P1(2) = PHEP(2,IPOSP(1,I))+PHEP(2,IPOSP(2,I))
27756 P1(3) = PHEP(3,IPOSP(1,I))+PHEP(3,IPOSP(2,I))
27757 P1(4) = PHEP(4,IPOSP(1,I))+PHEP(4,IPOSP(2,I))
27758 CALL PHO_REGPAR(1,IRPDG(I),IRBAM(I),IPOSP(1,I),IPOSP(2,I),
27759 & P1(1),P1(2),P1(3),P1(4),0,2,0,0,IPOS,1)
27761 IF(IDPDG(I).EQ.22) THEN
27763 IF(ISWMDL(21).GE.0) THEN
27765 IF(ISWMDL(21).GE.2) ISP = IPAMDL(4)
27766 CALL PHO_SDECAY(IPOS,ISP,2)
27769 CALL PHO_SDECAY(IPOS,IPAMDL(3),2)
27774 C particle-pomeron scattering
27775 IF(IPAR(I).LE.4) THEN
27776 C non-diffractive particle-pomeron scattering
27777 IGEN = IPHIST(2,NPOSD(I))
27785 CALL PHO_STDPAR(IPOSP(1,I),IPOSP(2,I),IGEN,
27786 & ISAM(I),JSAM(I),KSAM(I),IDIR(I),IREJ)
27788 C diffractive particle-pomeron scattering
27790 IPORES(IPOIX2) = IPROC(I)
27791 IPOPOS(1,IPOIX2) = IPOSP(1,I)
27792 IPOPOS(2,IPOIX2) = IPOSP(2,I)
27799 IFAIL(20+I) = IFAIL(20+I)+1
27800 IF(IPAR(I).GT.1) THEN
27801 IF(IPAR(I).EQ.3) IFAIL(7+2*I) = IFAIL(7+2*I)+1
27802 IF(IPAR(I).EQ.4) IFAIL(8+2*I) = IFAIL(8+2*I)+1
27803 IF(IDIR(I).GT.0) THEN
27805 ELSE IF(KSAM(I).GT.0) THEN
27806 KSAM(I) = KSAM(I)-1
27807 ELSE IF(ISAM(I).GT.0) THEN
27808 ISAM(I) = ISAM(I)-1
27812 IF(IDEB(45).GE.2) WRITE(LO,'(1X,A,2I3,E11.3)')
27813 & 'PHO_DIFDIS: rejection PHO_STDPAR (I,IPAR,XM)',
27814 & I,IPAR(I),XMASS(I)
27822 C update debug information
27823 KSPOM = KSPOMS+ISAM(1)+ISAM(2)
27824 KSREG = KSREGS+JSAM(1)+JSAM(2)
27825 KHPOM = KHPOMS+KSAM(1)+KSAM(2)
27826 KHDIR = KHDIRS+IDIR(1)+IDIR(2)
27831 IF(IDEB(45).GE.10) THEN
27832 WRITE(LO,'(1X,2A,/18X,7I6)') 'PHO_DIFDIS: (2) ',
27833 & 'IPAR1,IPAR2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
27834 & IPAR,NPOSD,MSOFT,MHARD,IMODE
27836 IF(IDEB(45).GE.15) THEN
27837 WRITE(LO,'(2(/1X,A))') 'PHO_DIFDIS: output of /POEVT1/',
27838 & '------------------------------'
27844 *$ CREATE PHO_DIFPRO.FOR
27846 CDECK ID>, PHO_DIFPRO
27847 SUBROUTINE PHO_DIFPRO(IP,ICUT,ID1,ID2,XMASS,P2V1,P2V2,SPROB,
27848 & IPROC,ISAM,JSAM,KSAM,IDIR)
27849 C*********************************************************************
27851 C sampling of diffraction dissociation process
27853 C input: IP particle combination
27854 C ICUT user imposed limitations
27855 C ID1/2 PDG particle code of scattering particles
27856 C XMASS diffractively produced mass (GeV)
27857 C P2V1/2 virtuality of scattering particles (Gev**2)
27858 C SPROB suppression factor for resolved single and
27859 C double diffraction dissociation
27861 C output: IRPOC process ID
27862 C ISAM number of cut pomerons (soft)
27863 C JSAM number of cut reggeons
27864 C KSAM number of cut pomerons (hard)
27865 C IDIR direct hard interaction
27867 C*********************************************************************
27868 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27871 C input/output channels
27873 COMMON /POINOU/ LI,LO
27874 C event debugging information
27876 PARAMETER (NMAXD=100)
27877 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27878 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27879 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27880 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27881 C general process information
27882 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
27883 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
27884 C model switches and parameters
27886 INTEGER ISWMDL,IPAMDL
27887 DOUBLE PRECISION PARMDL
27888 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27889 C energy-interpolation table
27891 PARAMETER ( IEETA2 = 20 )
27893 DOUBLE PRECISION SIGTAB,SIGECM
27894 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
27901 IF(XMASS.GT.3.D0) THEN
27902 C rapidity gap survival probability
27904 IF(ISWMDL(28).GE.1) SPRO = SPROB
27905 C sample interaction
27907 CALL PHO_SAMPRO(IP,ID1,ID2,XMASS,P2V1,P2V2,SPRO,IPROC)
27911 IF(IPROC.EQ.1) CALL PHO_SAMPRB(XMASS,IP,ISAM,JSAM,KSAM)
27912 C non-diffractive hadron-pomeron interaction
27913 IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
27914 C option for suppression of multiple interaction
27917 IF(ISAM+KSAM+IDIR.GT.0) THEN
27925 ELSE IF(ICUT.EQ.1) THEN
27927 ELSE IF(KSAM.GT.0) THEN
27931 ELSE IF(ISAM.GT.0) THEN
27937 ELSE IF(ICUT.EQ.2) THEN
27939 ELSE IF(ICUT.EQ.3) THEN
27945 *$ CREATE PHO_DIFPAR.FOR
27947 CDECK ID>, PHO_DIFPAR
27948 SUBROUTINE PHO_DIFPAR(IMOTH1,IMOTH2,IGENM,IFL1,IFL2,IPAR,P1,P2,
27949 & IPOSH1,IPOSH2,IMODE,IREJ)
27950 C***********************************************************************
27952 C perform string construction for diffraction dissociation
27954 C input: IMOTH1,2 index of mother particles in POEVT1
27955 C IGENM production process of mother particles
27956 C IFL1,IFL2 particle numbers
27957 C (IDPDG,IDBAM for quasi-elas. hadron)
27958 C IPAR 0 quasi-elasic scattering
27959 C 1 single string configuration
27960 C 2 two string configuration
27961 C P1 massive 4 momentum of first
27962 C P1(6) virtuality/squ.mass of particle (GeV**2)
27963 C P1(7) virtuality of Pomeron (neg, GeV**2)
27964 C P2 massive 4 momentum of second particle
27965 C IMODE 1 diffraction dissociation
27966 C 2 double-pomeron scattering
27968 C output: IPOSH1,2 index of the particles in /POEVT1/
27969 C IREJ 0 successful string construction
27970 C 1 no string construction possible
27972 C***********************************************************************
27973 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27976 DIMENSION P1(7),P2(7)
27978 PARAMETER ( EPS = 1.D-7,
27981 C input/output channels
27983 COMMON /POINOU/ LI,LO
27984 C event debugging information
27986 PARAMETER (NMAXD=100)
27987 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27988 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27989 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27990 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27991 C internal rejection counters
27993 PARAMETER (NMXJ=60)
27994 CHARACTER*10 REJTIT
27996 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
27997 C c.m. kinematics of diffraction
27999 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
28000 & SIDD,CODD,SIFD,COFD,PDCMS
28001 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
28002 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
28003 C model switches and parameters
28005 INTEGER ISWMDL,IPAMDL
28006 DOUBLE PRECISION PARMDL
28007 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28009 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28010 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28011 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28012 C standard particle data interface
28014 PARAMETER (NMXHEP=4000)
28015 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28016 DOUBLE PRECISION PHEP,VHEP
28017 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28018 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28020 C extension to standard particle data interface (PHOJET specific)
28021 INTEGER IMPART,IPHIST,ICOLOR
28022 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28024 DIMENSION PCH1(2,4)
28031 if(IGENM.le.-10) IGEN = 0
28035 IF((IFL1.EQ.92).OR.(IFL1.EQ.91)) THEN
28036 if(IGEN.eq.0) IGEN = 3
28037 C pi+/pi- isotropic background
28038 CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,
28039 & P1(1),P1(2),P1(3),P1(4),0,IGEN,0,0,IPOSH1,1)
28040 CALL PHO_SDECAY(IPOSH1,0,-2)
28044 if(IFL1.ne.IDHEP(IMOTH1)) IGEN = 3
28046 C registration of particle or resonance
28047 CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,P1(1),P1(2),P1(3),
28048 & P1(4),0,IGEN,0,0,IPOSH1,1)
28051 C diffraction dissociation
28052 ELSE IF((IPAR.GE.1).AND.(IPAR.LE.18)) THEN
28053 C calculation of resulting particle momenta
28054 IF(IMOTH1.EQ.NPOSD(1)) THEN
28060 PCH1(2,I) = PDCMS(I,K)-P2(I)
28061 PCH1(1,I) = P1(I)-PCH1(2,I)
28065 if(IMODE.LT.2) then
28066 if(IGEN.eq.0) IGEN = -IGENM/10+4
28067 CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,PCH1(1,1),
28068 & PCH1(1,2),PCH1(1,3),PCH1(1,4),-1,IGEN,IC1,IC2,IPOSH1,1)
28070 if(IGEN.eq.0) IGEN = 4
28072 CALL PHO_REGPAR(1,990,0,IMOTH2,IMOTH1,PCH1(2,1),PCH1(2,2),
28073 & PCH1(2,3),PCH1(2,4),-1,IGEN,IC1,IC2,IPOSH2,1)
28077 WRITE(LO,'(/1X,A,I6)') 'PHO_DIFPAR:ERROR: invalid IPAR:',IPAR
28081 C back transformation
28082 CALL PHO_LTRHEP(ILTR1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
28083 & GAMBED(1),GAMBED(2),GAMBED(3))
28087 *$ CREATE PHO_QELAST.FOR
28089 CDECK ID>, PHO_QELAST
28090 SUBROUTINE PHO_QELAST(IPROC,JM1,JM2,IREJ)
28091 C**********************************************************************
28093 C sampling of quasi elastic processes
28095 C input: IPROC 2 purely elastic scattering
28096 C IPROC 3 q-ela. omega/omega/phi/pi+pi- production
28097 C IPROC 4 double pomeron scattering
28098 C IPROC -1 initialization
28099 C IPROC -2 output of statistics
28100 C JM1/2 index of initial particle 1/2
28102 C output: initial and final particles in /POEVT1/ involving
28103 C polarized resonances in /POEVT1/ and decay
28106 C IREJ 0 successful
28108 C 50 user rejection
28110 C**********************************************************************
28111 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28114 PARAMETER ( NTAB = 20,
28119 C input/output channels
28121 COMMON /POINOU/ LI,LO
28122 C event debugging information
28124 PARAMETER (NMAXD=100)
28125 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28126 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28127 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28128 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28129 C global event kinematics and particle IDs
28130 INTEGER IFPAP,IFPAB
28131 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28132 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28133 C c.m. kinematics of diffraction
28135 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
28136 & SIDD,CODD,SIFD,COFD,PDCMS
28137 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
28138 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
28139 C model switches and parameters
28141 INTEGER ISWMDL,IPAMDL
28142 DOUBLE PRECISION PARMDL
28143 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28145 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28146 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28147 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28149 INTEGER IPFIL,IFAFIL,IFBFIL
28150 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
28151 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
28152 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
28153 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
28154 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
28155 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
28156 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
28157 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
28158 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
28159 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
28160 & IPFIL,IFAFIL,IFBFIL
28161 C standard particle data interface
28163 PARAMETER (NMXHEP=4000)
28164 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28165 DOUBLE PRECISION PHEP,VHEP
28166 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28167 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28169 C extension to standard particle data interface (PHOJET specific)
28170 INTEGER IMPART,IPHIST,ICOLOR
28171 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28173 DOUBLE PRECISION P,PK1,PK2,PMI,RMASS
28174 DIMENSION P(4,2),PK1(5),PK2(5),PMI(2),RMASS(2)
28175 DIMENSION IFL(2),IDPRO(4)
28176 character*15 pho_pname
28177 CHARACTER*8 VMESA(0:4),VMESB(0:4)
28178 DIMENSION ISAMVM(4,4)
28179 DATA IDPRO / 113,223,333,92 /
28180 DATA VMESA / 'vmeson ','rho ','omega ','phi ',
28182 DATA VMESB / 'vmeson ','rho ','omega ','phi ',
28185 C sampling of elastic/quasi-elastic processes
28186 IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
28191 PMI(I) = PHEP(5,NPOSD(I))
28192 IF(PMI(I).LT.0.1D0) PMI(I) = 0.765D0
28195 PK1(1) = PHEP(1,JM1)+PHEP(1,JM2)
28196 PK1(2) = PHEP(2,JM1)+PHEP(2,JM2)
28197 PK1(3) = PHEP(3,JM1)+PHEP(3,JM2)
28198 PK1(4) = PHEP(4,JM1)+PHEP(4,JM2)
28199 SS = (PK1(4)+PK1(3))*(PK1(4)-PK1(3))-PK1(1)**2-PK1(2)**2
28202 IF(ECMD.LE.PMI(1)+PMI(2)) THEN
28203 IF(IDEB(34).GE.3) WRITE(LO,'(1X,A,I12,3E12.4)')
28204 & 'PHO_QELAST: too small mass (EV,ECM,M1,M2)',KEVENT,
28211 GAMBED(I) = PK1(I)/ECMD
28213 CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
28214 & PHEP(1,NPOSD(1)),PHEP(2,NPOSD(1)),PHEP(3,NPOSD(1)),
28215 & PHEP(4,NPOSD(1)),PTOT1,PK1(1),PK1(2),PK1(3),PK1(4))
28217 CODD = PK1(3)/PTOT1
28218 SIDD = SQRT(PK1(1)**2+PK1(2)**2)/PTOT1
28221 IF(PTOT1*SIDD.GT.1.D-5) THEN
28222 COFD = PK1(1)/(SIDD*PTOT1)
28223 SIFD = PK1(2)/(SIDD*PTOT1)
28224 ANORF = SQRT(COFD*COFD+SIFD*SIFD)
28231 PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)
28233 C production process of mother particles
28234 IGEN = IPHIST(2,NPOSD(1))
28235 if(IGEN.eq.0) IGEN = IPROC
28238 C main rejection label
28240 C determine process and final particles
28241 IFL(1) = IDHEP(NPOSD(1))
28242 IFL(2) = IDHEP(NPOSD(2))
28243 IF(IPROC.EQ.3) THEN
28247 IF(ITRY.GT.50) THEN
28248 IF(IDEB(34).GE.3) WRITE(LO,'(1X,A,I12,I5,E12.4)')
28249 & 'PHO_QELAST: mass rejection (EV,ITRY,ECM)',KEVENT,
28254 XI = DT_RNDM(PCMD)*SIGVM(0,0)-DEPS
28258 IF(XI.LE.0.D0) GOTO 130
28262 IF(IFL(1).EQ.22) IFL(1) = IDPRO(I)
28263 IF(IFL(2).EQ.22) IFL(2) = IDPRO(J)
28264 ISAMVM(I,J) = ISAMVM(I,J)+1
28266 C sample new masses
28267 CALL PHO_SAMASS(IFL(1),RMASS(1))
28268 CALL PHO_SAMASS(IFL(2),RMASS(2))
28269 IF(RMASS(1)+RMASS(2).GE.ECMD) GOTO 100
28270 ELSE IF(IPROC.EQ.2) THEN
28274 RMASS(1) = PHO_PMASS(NPOSD(1),2)
28275 RMASS(2) = PHO_PMASS(NPOSD(2),2)
28277 WRITE(LO,'(/1X,A,I6)') 'PHO_QELAST:ERROR: invalid IPROC',IPROC
28280 C sample momentum transfer
28281 CALL PHO_DIFSLP(0,0,I,J,RMASS(1),RMASS(2),RMASS(1),TT,
28283 IF(IDEB(34).GE.5) WRITE(LO,'(1X,A,2I6,I3,3E11.3)')
28284 & 'PHO_QELAST: IF1,2,T,RM1,RM2',IFL,IPROC,TT,RMASS
28285 C calculate new momenta
28286 CALL PHO_DIFKIN(RMASS(1),RMASS(2),TT,PK1,PK2,IREJ)
28287 IF(IREJ.NE.0) GOTO 50
28292 C comment line for elastic/quasi-elastic scattering
28293 CALL PHO_REGPAR(35,IPROC,0,NPOSD(1),NPOSD(2),RMASS(1),RMASS(2),
28294 & TT,ECMD,IFL(1),IFL(2),IDHEP(NPOSD(1)),IDHEP(NPOSD(2)),ICPOS,1)
28300 IF((IFL(I).EQ.92).OR.(IFL(I).EQ.91)) THEN
28301 C pi+/pi- isotropic background
28303 CALL PHO_REGPAR(1,113,0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
28304 & P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
28305 ICOLOR(I,ICPOS) = IPOS
28306 CALL PHO_SDECAY(IPOS,0,-2)
28310 if(IFL(I).ne.IDHEP(NPOSD(I))) IGEN = 3
28311 CALL PHO_REGPAR(1,IFL(I),0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
28312 & P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
28313 ICOLOR(I,ICPOS) = IPOS
28317 C search for vector mesons
28319 C decay according to polarization
28320 IF((IDHEP(JMOHEP(1,I)).EQ.22).AND.(ISWMDL(21).GE.0)) THEN
28322 IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
28323 CALL PHO_SDECAY(I,ISP,2)
28327 C back transformation
28328 CALL PHO_LTRHEP(I1,I2,CODD,SIDD,COFD,SIFD,GAMBED(4),GAMBED(1),
28329 & GAMBED(2),GAMBED(3))
28331 C initialization of tables
28332 ELSE IF(IPROC.EQ.-1) THEN
28340 IF(IFPAP(1).NE.22) VMESA(1) = PHO_PNAME(IFPAP(1),1)
28341 IF(IFPAP(2).NE.22) VMESB(1) = PHO_PNAME(IFPAP(2),1)
28342 CALL PHO_SAMASS(-1,RMASS(1))
28345 C output of statistics
28346 ELSE IF(IPROC.EQ.-2) THEN
28347 IF(ICALL.LT.10) RETURN
28348 WRITE(LO,'(/,1X,A,I10/,1X,A)')
28349 & 'PHO_QELAST: statistics of (quasi-)elastic processes',ICALL,
28350 & '---------------------------------------------------'
28351 WRITE(LO,'(1X,A,I10)')
28352 & 'sampled elastic processes:',ISAMEL
28353 WRITE(LO,'(1X,A,I10)')
28354 & 'sampled quasi-elastic vectormeson production:',ISAMQE
28355 WRITE(LO,'(15X,4(4X,A))') (VMESB(I),I=1,4)
28357 WRITE(LO,'(5X,A,4I12)') VMESA(I),(ISAMVM(I,K),K=1,4)
28359 CALL PHO_SAMASS(-2,RMASS(1))
28361 WRITE(LO,'(/1X,2A,I3)') 'PHO_QELAST:ERROR: ',
28362 & 'unknown process ID',IPROC
28368 *$ CREATE PHO_CDIFF.FOR
28370 CDECK ID>, PHO_CDIFF
28371 SUBROUTINE PHO_CDIFF(IMOTH1,IMOTH2,MSOFT,MHARD,IMODE,IREJ)
28372 C**********************************************************************
28374 C preparation of /POEVT1/ for double-pomeron scattering
28376 C input: IMOTH1/2 index of mother particles in /POEVT1/
28378 C IMODE 1 sampling of pomeron-pomeron scattering
28379 C -1 initialization
28380 C -2 output of statistics
28382 C output: MSOFT number of generated soft strings
28383 C MHARD number of generated hard strings
28386 C 50 user rejection
28388 C**********************************************************************
28389 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28392 PARAMETER ( EPS = 1.D-10,
28395 C input/output channels
28397 COMMON /POINOU/ LI,LO
28398 C event debugging information
28400 PARAMETER (NMAXD=100)
28401 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28402 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28403 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28404 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28405 C internal rejection counters
28407 PARAMETER (NMXJ=60)
28408 CHARACTER*10 REJTIT
28410 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
28411 C model switches and parameters
28413 INTEGER ISWMDL,IPAMDL
28414 DOUBLE PRECISION PARMDL
28415 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28416 C general process information
28417 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
28418 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
28419 C Reggeon phenomenology parameters
28420 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
28421 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
28422 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
28423 & ALREG,ALREGP,GR(2),B0REG(2),
28424 & GPPP,GPPR,B0PPP,B0PPR,
28425 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
28426 C parameters of 2x2 channel model
28427 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
28428 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
28430 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28431 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28432 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28433 C energy-interpolation table
28435 PARAMETER ( IEETA2 = 20 )
28437 DOUBLE PRECISION SIGTAB,SIGECM
28438 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
28439 C table of particle indices for recursive PHOJET calls
28441 PARAMETER ( MAXIPX = 100 )
28442 INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
28443 COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
28444 & IPOIX1,IPOIX2,IPOIX3
28445 C standard particle data interface
28447 PARAMETER (NMXHEP=4000)
28448 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28449 DOUBLE PRECISION PHEP,VHEP
28450 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28451 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28453 C extension to standard particle data interface (PHOJET specific)
28454 INTEGER IMPART,IPHIST,ICOLOR
28455 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28459 if(IMODE.ne.1) return
28463 C select first diffraction
28464 IF(DT_RNDM(DUM).GT.0.5D0) THEN
28474 C save current status
28484 JDA11 = JDAHEP(1,IMOTH1)
28485 JDA21 = JDAHEP(2,IMOTH1)
28486 JDA12 = JDAHEP(1,IMOTH2)
28487 JDA22 = JDAHEP(2,IMOTH2)
28488 ISTH1 = ISTHEP(IMOTH1)
28489 ISTH2 = ISTHEP(IMOTH2)
28492 C find mother particle production process
28493 IGEN = IPHIST(2,IMOTH1)
28494 if(IGEN.eq.0) IGEN = 4
28496 C main generation loop
28505 C reset mother-daugther relations
28507 JDAHEP(1,IMOTH1) = JDA11
28508 JDAHEP(2,IMOTH1) = JDA21
28509 JDAHEP(1,IMOTH2) = JDA12
28510 JDAHEP(2,IMOTH2) = JDA22
28511 ISTHEP(IMOTH1) = ISTH1
28512 ISTHEP(IMOTH2) = ISTH2
28516 C rejection counter
28518 IF(ITRY2.GT.1) THEN
28519 IFAIL(39) = IFAIL(39)+1
28520 IF(ITRY2.GE.ITRYM) GOTO 50
28522 C generate two diffractive events
28523 CALL PHO_DIFDIS(I1,I2,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
28524 IF(IREJ.NE.0) GOTO 50
28525 CALL PHO_DIFDIS(I2,I1,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
28526 IF(IREJ.NE.0) GOTO 50
28527 C mass of pomeron-pomeron system
28528 DO 100 I2 = NHEP,1,-1
28529 IF(IDHEP(I2).EQ.990) GOTO 110
28532 DO 120 I1 = I2-1,1,-1
28533 IF(IDHEP(I1).EQ.990) GOTO 130
28537 PD(I) = PHEP(I,I1)+PHEP(I,I2)
28539 XMASS = (PD(4)-PD(3))*(PD(4)+PD(3))-PD(1)**2-PD(2)**2
28540 IF(IDEB(59).GE.20) WRITE(LO,'(1X,A,2I3,E12.4)')
28541 & 'PHO_CDIFF: IPOM1,IPOM2,MASS**2',I1,I2,XMASS
28542 IF(XMASS.LT.0.1D0) GOTO 60
28543 XMASS = SQRT(XMASS)
28544 IF(XMASS.LT.PARMDL(71)) GOTO 60
28546 C sample pomeron-pomeron interaction process
28547 CALL PHO_DIFPRO(4,ISWMDL(17),990,990,XMASS,0.D0,0.D0,1.D0,
28548 & IPROC,ISAM,JSAM,KSAM,IDIR)
28550 C non-diffractive pomeron-pomeron interactions
28551 IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
28553 IF(ISAM+JSAM+KSAM+IDIR.EQ.0) JSAM = 1
28555 IF(IDEB(59).GE.15) WRITE(LO,'(1X,A,/5X,I3,E12.4,4I5)')
28556 & 'PHO_CDIFF: IP,XMASS,ISAM,JSAM,KSAM,IDIR,',
28557 & IP,XMASS,ISAM,JSAM,KSAM,IDIR
28558 C store debug information
28561 ELSE IF(KSAM.GT.0) THEN
28563 ELSE IF(ISAM.GT.0) THEN
28569 IF(ISAM+JSAM.GT.0) KSDPO = 1
28570 IF(KSAM+IDIR.GT.0) KHDPO = 1
28577 C generate pomeron-pomeron interaction
28578 CALL PHO_STDPAR(I1,I2,IGEN,ISAM,JSAM,KSAM,IDIR,IREJ)
28580 IFAIL(3) = IFAIL(3)+1
28582 IF(IPAR.EQ.3) IFAIL(9) = IFAIL(9)+1
28584 IFAIL(10) = IFAIL(10)+1
28586 ELSE IF(KSAM.GT.0) THEN
28588 ELSE IF(ISAM.GT.0) THEN
28593 IF(IDEB(59).GE.2) WRITE(LO,'(1X,A,2I3,E11.3)')
28594 & 'PHO_CDIFF: rejection by PHO_STDPAR (I,IPAR,XM)',
28600 C diffractive pomeron-pomeron interactions
28603 IPORES(IPOIX2) = IPROC
28604 IPOPOS(1,IPOIX2) = I1
28605 IPOPOS(2,IPOIX2) = I2
28610 C update debug information
28611 KSPOM = KSPOMS+ISAM
28612 KSREG = KSREGS+JSAM
28613 KHPOM = KHPOMS+KSAM
28614 KHDIR = KHDIRS+IDIR
28615 C comment line for central diffraction
28616 CALL PHO_REGPAR(40,4,IPAR,IMOTH1,IMOTH2,PD(1),PD(2),PD(3),PD(4),
28617 & I1,I2,IDHEP(IMOTH1),IDHEP(IMOTH2),IPOS,1)
28618 PHEP(5,IPOS) = XMASS
28620 IF(IDEB(59).GE.15) THEN
28621 WRITE(LO,'(2(/1X,A))') 'PHO_CDIFF: output of /POEVT1/',
28622 & '-----------------------------'
28627 C treatment of rejection
28630 IFAIL(40) = IFAIL(40)+1
28631 IF(IDEB(59).GE.3) THEN
28633 & 'PHO_CDIFF: rejection (ITRY,ITRYM)',ITRY2,ITRYM
28634 IF(IDEB(59).GE.10) THEN
28637 CALL PHO_PREVNT(-1)
28643 *$ CREATE PHO_SAMASS.FOR
28645 CDECK ID>, PHO_SAMASS
28646 SUBROUTINE PHO_SAMASS(IFLA,RMASS)
28647 C**********************************************************************
28649 C resonance mass sampling of quasi elastic processes
28651 C input: IFLA PDG number of particle
28652 C IFLA -1 initialization
28653 C IFLA -2 output of statistics
28655 C output: RMASS particle mass (in GeV)
28657 C**********************************************************************
28658 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28661 PARAMETER(EPS = 1.D-10 )
28663 C input/output channels
28665 COMMON /POINOU/ LI,LO
28666 C event debugging information
28668 PARAMETER (NMAXD=100)
28669 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28670 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28671 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28672 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28673 C model switches and parameters
28675 INTEGER ISWMDL,IPAMDL
28676 DOUBLE PRECISION PARMDL
28677 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28678 C parameters of the "simple" Vector Dominance Model
28679 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
28680 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
28682 PARAMETER(NTABM=50)
28683 DIMENSION XMA(4,NTABM),XMC(4,NTABM),RMA(4,NTABM)
28684 DIMENSION SUM(4),ICALL(4)
28686 C*****************************************************************
28687 C initialization of tables
28688 IF(IFLA.EQ.-1) THEN
28693 DELTAM=(RMAX(I)-RMIN(I))/DBLE(NSTEP-1)
28695 RMA(I,K)=RMIN(I)+DELTAM*DBLE(K-1)
28698 C calculate table of dsig/dm
28699 CALL PHO_DSIGDM(RMA,XMA,NSTEP)
28701 IF(IDEB(35).GE.1) THEN
28702 WRITE(LO,'(/5X,A)') 'table: mass (GeV) DSIG/DM (mub/GeV)'
28703 WRITE(LO,'(1X,A,/1X,A)')
28704 & ' (m, rho, m, omega, m, phi, m, pi+pi-)',
28705 & ' -------------------------------------------------------'
28707 WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMA(1,K),
28708 & RMA(2,K),XMA(2,K),RMA(3,K),XMA(3,K),RMA(4,K),XMA(4,K)
28711 C make second table for sampling
28715 SUM(I) = SUM(I) + (XMA(I,K-1)+XMA(I,K))/2.D0
28722 XMC(I,K) = XMC(I,K)/XMC(I,NSTEP)
28725 IF(IDEB(35).GE.10) THEN
28726 WRITE(LO,'(/5X,A)') 'PHO_DSIGDM: normalized summed table:'
28727 WRITE(LO,'(1X,A,/1X,A)')
28728 & ' (m, rho, m, omega, m, phi, m, pi+pi-)',
28729 & ' -------------------------------------------------------'
28731 WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMC(1,K),
28732 & RMA(2,K),XMC(2,K),RMA(3,K),XMC(3,K),RMA(4,K),XMC(4,K)
28736 C**************************************************
28737 C output of statistics
28738 ELSE IF(IFLA.EQ.-2) THEN
28739 WRITE(LO,'(2(/1X,A))') 'PHO_SAMASS: statistics',
28740 & '----------------------'
28741 WRITE(LO,'(4(/8X,A,I10))') 'rho: ',ICALL(1),
28742 & 'omega: ',ICALL(2),'phi: ',ICALL(3),'pi+pi-:',ICALL(4)
28744 C********************************************************
28745 C sampling of RMASS
28747 C quasi-elastic vector meson production
28748 IF(IFLA.EQ.113) THEN
28750 ELSE IF(IFLA.EQ.223) THEN
28752 ELSE IF(IFLA.EQ.333) THEN
28754 ELSE IF(IFLA.EQ.92) THEN
28756 C quasi-elastic production of h*
28757 ELSE IF(IFLA.EQ.91) THEN
28760 C elastic hadron scattering
28762 RMASS = PHO_PMASS(IFLA,1)
28763 IF(IDEB(35).GE.20) WRITE(LO,'(1X,A,I7,E12.3)')
28764 & 'PHO_SAMASS: IFLA,MASS',IFLA,RMASS
28768 C sample mass of vector mesonsn / two-pi background
28769 XI = DT_RNDM(RMASS) + EPS
28771 IF((XMC(KP,1).LE.XI).AND.(XMC(KP,NSTEP).GE.XI)) THEN
28775 IF((KMAX-KMIN).EQ.1) GOTO 400
28777 IF(XI.LE.XMC(KP,KK)) THEN
28785 WRITE(LO,'(1X,A)') 'PHO_SAMASS:ERROR:XI out of range'
28786 WRITE(LO,'(5X,A,I7,I6,3E12.4)') 'EVENT,IFLA,XI,XImin,XImax',
28787 & KEVENT,IFLA,XI,XMC(KP,1),XMC(KP,NSTEP)
28790 C fine interpolation
28791 RMASS = RMA(KP,KMIN)+
28792 & (RMA(KP,KMAX)-RMA(KP,KMIN))/
28793 & (XMC(KP,KMAX)-XMC(KP,KMIN))
28794 & *(XI-XMC(KP,KMIN))
28795 IF(IDEB(35).GE.20) THEN
28796 IF(IDEB(35).GE.25) WRITE(LO,'(1X,A,3E15.3)')
28797 & 'PHO_SAMASS: MLEFT,MRIGHT,RMASS',
28798 & RMA(KP,KMIN),RMA(KP,KMAX),RMASS
28799 WRITE(LO,'(1X,A,I7,E12.3)') 'PHO_SAMASS: IFLA,MASS',
28802 ICALL(KP) = ICALL(KP)+1
28806 *$ CREATE PHO_DSIGDM.FOR
28808 CDECK ID>, PHO_DSIGDM
28809 SUBROUTINE PHO_DSIGDM(RMA,XMA,NSTEP)
28810 C**********************************************************************
28812 C differential cross section DSIG/DM of low mass enhancement
28814 C input: RMA(4,NTABM) mass values
28815 C output: XMA(4,NTABM) DSIG/DM of resonances
28817 C 2 omega production
28819 C 4 pi-pi continuum
28821 C**********************************************************************
28822 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28825 PARAMETER ( EPS = 1.D-10 )
28827 PARAMETER(NTABM=50)
28828 DIMENSION XMA(4,NTABM),RMA(4,NTABM)
28830 C input/output channels
28832 COMMON /POINOU/ LI,LO
28833 C event debugging information
28835 PARAMETER (NMAXD=100)
28836 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28837 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28838 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28839 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28840 C model switches and parameters
28842 INTEGER ISWMDL,IPAMDL
28843 DOUBLE PRECISION PARMDL
28844 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28845 C parameters of the "simple" Vector Dominance Model
28846 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
28847 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
28850 C rho meson shape (mass dependent width)
28851 QRES = SQRT(VMAS(1)**2 - 4.D0*PIMASS**2)
28854 QQ = SQRT(XMASS**2 - 4.D0*PIMASS**2)
28855 GAMMA = GAMM(1)*(QQ/QRES)**3
28856 XMA(1,I) = XMASS*GAMMA*(VMAS(1)/XMASS)**PARMDL(170)
28857 & /((VMAS(1)**2-XMASS**2)**2+VMAS(1)**2*GAMMA**2)
28859 C omega/phi meson (constant width)
28863 XMA(K,I) = XMASS*GAMM(K)
28864 & /((VMAS(K)**2-XMASS**2)**2+VMAS(K)**2*GAMM(K)**2)
28870 XMA(4,I) = (XMASS-0.29D0)**2/XMASS
28875 *$ CREATE PHO_SDECAY.FOR
28877 CDECK ID>, PHO_SDECAY
28878 SUBROUTINE PHO_SDECAY(NPOS,ISP,ILEV)
28879 C**********************************************************************
28881 C decay of single resonance of /POEVT1/:
28882 C decay in helicity frame according to polarization, isotropic
28883 C decay and decay with limited transverse phase space possible
28886 C reference to particle number of CPC has to exist
28888 C input: NPOS position in /POEVT1/
28889 C ISP 0 decay according to phase space
28890 C 1 decay according to transversal polarization
28891 C 2 decay according to longitudinal polarization
28892 C 3 decay with limited phase space
28893 C ILEV decay mode to use
28895 C 2 strong and ew of tau, charm, and bottom
28896 C 3 strong and electro-weak decays
28897 C negative: remove mother resonance after decay
28899 C output: /POEVT1/,/POEVT2/ final particles according to decay mode
28901 C**********************************************************************
28902 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28905 PARAMETER ( EPS = 1.D-15,
28908 C input/output channels
28910 COMMON /POINOU/ LI,LO
28911 C event debugging information
28913 PARAMETER (NMAXD=100)
28914 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28915 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28916 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28917 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28918 C model switches and parameters
28920 INTEGER ISWMDL,IPAMDL
28921 DOUBLE PRECISION PARMDL
28922 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28924 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28925 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28926 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28927 C standard particle data interface
28929 PARAMETER (NMXHEP=4000)
28930 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28931 DOUBLE PRECISION PHEP,VHEP
28932 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28933 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28935 C extension to standard particle data interface (PHOJET specific)
28936 INTEGER IMPART,IPHIST,ICOLOR
28937 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28938 C general particle data
28939 double precision xm_list,tau_list,gam_list,
28940 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
28941 & xm_bb82_list,xm_bb102_list
28942 integer ich3_list,iba3_list,iq_list,
28943 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
28944 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
28945 & xm_psm2_list(6,6),xm_vem2_list(6,6),
28946 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
28947 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
28948 & ich3_list(300),iba3_list(300),iq_list(3,300),
28949 & id_psm_list(6,6),id_vem_list(6,6),
28950 & id_b8_list(6,6,6),id_b10_list(6,6,6)
28951 C particle decay data
28952 double precision wg_sec_list
28953 integer idec_list,isec_list
28954 COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
28956 C auxiliary data for three particle decay
28957 DOUBLE PRECISION ECM,PCM,COD,COF,SIF
28958 COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
28960 DIMENSION WGHD(20),KCH(20),ID(3)
28963 IF(IDEB(36).GE.15) WRITE(LO,'(1X,A,3I5)')
28964 & 'PHO_SDECAY: NPOS,ISP,ILEV',NPOS,ISP,ILEV
28967 IF(ISTHEP(NPOS).GT.11) RETURN
28970 IDcpc = IMPART(NPOS)
28971 IF(IDcpc.EQ.0) return
28972 IDabs = iabs(IDcpc)
28973 if(idec_list(1,IDabs).eq.0) return
28975 C different decay modi (times)
28976 IF(IMODE.EQ.1) THEN
28977 if(idec_list(1,IDabs).ne.1) return
28978 ELSE IF(IMODE.EQ.2) THEN
28979 if(idec_list(1,IDabs).gt.2) return
28980 ELSE IF(IMODE.EQ.3) THEN
28981 if(idec_list(1,IDabs).gt.3) return
28983 WRITE(LO,'(/1X,A,I5)') 'PHO_SDECAY: invalid mode (ILEV)',ILEV
28987 C decay products, check for mass limitations
28990 AMIST = PHEP(5,NPOS)
28991 DO 100 I=idec_list(2,IDabs),idec_list(3,IDabs)
28994 ID(L) = isec_list(L,I)
28995 IF(ID(L).NE.0) AMSUM = AMSUM+pho_pmass(ID(L),0)
28997 IF(AMSUM.LT.AMIST) THEN
28999 WGHD(K) = wg_sec_list(I)
29004 WRITE(LO,'(/1X,A,I6,3E12.4)')
29005 & 'PHO_SDECAY: particle mass too small (NPOS,MA,DCYM)',
29011 C sample new decay channel
29012 XI = (DT_RNDM(AMSUM)-EPS)*WGSUM
29017 WGSUM = WGSUM+WGHD(K)
29018 IF(XI.GT.WGSUM) GOTO 500
29020 ID(1) = isec_list(1,IK)
29021 ID(2) = isec_list(2,IK)
29022 ID(3) = isec_list(3,IK)
29023 if(IDcpc.lt.0) then
29024 ID(1) = ipho_anti(ID(1))
29025 ID(2) = ipho_anti(ID(2))
29026 if(ID(3).ne.0) ID(3) = ipho_anti(ID(3))
29030 PTOT = SQRT(PHEP(1,NPOS)**2+PHEP(2,NPOS)**2+PHEP(3,NPOS)**2)
29031 CXS = PHEP(1,NPOS)/PTOT
29032 CYS = PHEP(2,NPOS)/PTOT
29033 CZS = PHEP(3,NPOS)/PTOT
29036 GAM = PHEP(4,NPOS)/AMIST
29038 IF(ID(3).EQ.0) THEN
29039 C two particle decay
29040 CALL PHO_SDECY2(AMIST,pho_pmass(ID(1),0),pho_pmass(ID(2),0),ISP)
29042 C three particle decay
29043 CALL PHO_SDECY3(AMIST,pho_pmass(ID(1),0),pho_pmass(ID(2),0),
29044 & pho_pmass(ID(3),0),ISP)
29048 IF(NHEP.NE.NPOS) THEN
29049 WRITE(LO,'(/1X,2A,2I5)') 'PHO_SDECAY:ERROR: ',
29050 & 'cannot remove resonance (NPOS,NHEP)',NPOS,NHEP
29053 IMO1 = JMOHEP(1,NPOS)
29054 IMO2 = JMOHEP(2,NPOS)
29060 IPH1 = IPHIST(1,NPOS)
29061 IPH2 = IPHIST(2,NPOS)
29063 C back transformation and registration
29065 IF(ID(I).NE.0) THEN
29066 CALL PHO_LTRANS(GAM,GBET,CXS,CYS,CZS,COD(I),COF(I),SIF(I),
29067 & PCM(I),ECM(I),PTOT,CX,CY,CZ,EE)
29071 CALL PHO_REGPAR(1,0,ID(I),IMO1,IMO2,XX,YY,ZZ,EE,
29072 & IPH1,IPH2,0,0,IPOS,1)
29078 IF(IDEB(36).GE.20) THEN
29079 WRITE(LO,'(2(/1X,A))') 'PHO_SDECAY: /POEVT1/',
29080 & '--------------------'
29086 *$ CREATE PHO_SDECY2.FOR
29088 CDECK ID>, PHO_SDECY2
29089 SUBROUTINE PHO_SDECY2(UMO,AM1,AM2,ISP)
29090 C**********************************************************************
29092 C isotropic/anisotropic two particle decay in CM system,
29093 C (transversely/longitudinally polarized boson into two
29094 C pseudo-scalar mesons)
29096 C**********************************************************************
29097 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29100 C input/output channels
29102 COMMON /POINOU/ LI,LO
29103 C auxiliary data for three particle decay
29104 DOUBLE PRECISION ECM,PCM,COD,COF,SIF
29105 COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
29110 ECM(1)=(UMO2+AM11-AM22)/(2.D0*UMO)
29112 WAU=ECM(1)*ECM(1)-AM11
29113 IF(WAU.LT.0.D0) THEN
29114 WRITE(LO,'(/1X,A,E12.4)') 'PHO_SDECY2:ERROR:too small mass',WAU
29120 CALL PHO_SFECFE(SIF(1),COF(1))
29123 COD(1) = 2.D0*DT_RNDM(UMO)-1.D0
29124 ELSE IF(ISP.EQ.1) THEN
29125 C transverse polarization
29127 COD(1) = 2.D0*DT_RNDM(AM22)-1.D0
29128 SID12 = 1.D0-COD(1)*COD(1)
29129 IF(SID12.LT.DT_RNDM(AM1)) GOTO 400
29130 ELSE IF(ISP.EQ.2) THEN
29131 C longitudinal polarization
29133 COD(1) = 2.D0*DT_RNDM(AM2)-1.D0
29134 COD12 = COD(1)*COD(1)
29135 IF(COD12.LT.DT_RNDM(AM11)) GOTO 500
29137 WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY2:ERROR: ',
29138 & 'invalid polarization',ISP
29148 *$ CREATE PHO_SDECY3.FOR
29150 CDECK ID>, PHO_SDECY3
29151 SUBROUTINE PHO_SDECY3(UMO,AM1,AM2,AM3,ISP)
29152 C**********************************************************************
29154 C isotropic/anisotropic three particle decay in CM system,
29155 C (transversely/longitudinally polarized boson into three
29156 C pseudo-scalar mesons)
29158 C**********************************************************************
29159 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29162 PARAMETER ( DEPS = 1.D-30,
29165 C input/output channels
29167 COMMON /POINOU/ LI,LO
29168 C auxiliary data for three particle decay
29169 DOUBLE PRECISION ECM,PCM,COD,COF,SIF
29170 COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
29172 DIMENSION F(5),XX(5)
29174 C calculation of maximum of S2 phase space weight
29178 UFAK=1.0000000000001D0
29179 IF (GU.GT.GO) UFAK=0.99999999999999D0
29192 S22=GU+(I-1.D0)*DS2
29194 RHO2=PHO_XLAM(S22,UMO2,AM11)*PHO_XLAM(S22,AM22,AM33)/(S22+EPS)
29195 IF(RHO2.LT.RHO1) GOTO 125
29199 S2SUP=(S22-S21)/2.D0+S21
29200 SUPRHO=PHO_XLAM(S2SUP,UMO2,AM11)*PHO_XLAM(S2SUP,AM22,AM33)
29202 SUPRHO=SUPRHO*1.05D0
29204 IF(GU.LT.GO.AND.XO.LT.GU) XO=GU
29205 IF(GU.GT.GO.AND.XO.GT.GU) XO=GU
29211 F(1)=PHO_XLAM(XO,UMO2,AM11)*PHO_XLAM(XO,AM22,AM33)/(XO+EPS)
29212 F(2)=PHO_XLAM(X1,UMO2,AM11)*PHO_XLAM(X1,AM22,AM33)/(X1+EPS)
29214 X4=(XX(1)+XX(2))*0.5D0
29215 X5=(XX(2)+XX(3))*0.5D0
29216 F(4)=PHO_XLAM(X4,UMO2,AM11)*PHO_XLAM(X4,AM22,AM33)/(X4+EPS)
29217 F(5)=PHO_XLAM(X5,UMO2,AM11)*PHO_XLAM(X5,AM22,AM33)/(X5+EPS)
29223 IF(F(II).LT.F(III)) THEN
29238 IF (XX(II).LT.XX(III)) THEN
29256 IF(ITH.GT.200) THEN
29257 WRITE(LO,'(/1X,A,I10)')
29258 & 'PHO_SDECY3:ERROR: too many iterations',ITH
29261 S2=AM23+DT_RNDM(AM2)*((UMO-AM1)**2-AM23)
29262 Y=DT_RNDM(AM23)*SUPRHO
29263 RHO=PHO_XLAM(S2,UMO2,AM11)*PHO_XLAM(S2,AM22,AM33)/S2
29264 IF(Y.GT.RHO) GOTO 200
29267 S1=DT_RNDM(AM2)*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)
29268 & /(2.D0*S2)-RHO/2.D0
29269 S3=UMO2+AM11+AM22+AM33-S1-S2
29270 ECM(1)=(UMO2+AM11-S2)/UMOO
29271 ECM(2)=(UMO2+AM22-S3)/UMOO
29272 ECM(3)=(UMO2+AM33-S1)/UMOO
29273 PCM(1)=SQRT((ECM(1)+AM1)*(ECM(1)-AM1))
29274 PCM(2)=SQRT((ECM(2)+AM2)*(ECM(2)-AM2))
29275 PCM(3)=SQRT((ECM(3)+AM3)*(ECM(3)-AM3))
29277 C calculation of angles: TH between p1,p2; TH1 p3,p1; TH2 p3,p2
29278 IF((PCM(1).LE.EPS).OR.(PCM(2).LE.EPS)) THEN
29279 COSTH=(DT_RNDM(S1)-0.5D0)*2.D0
29281 COSTH=(ECM(1)*ECM(2)+0.5D0*(AM11+AM22-S1))/(PCM(1)*PCM(2))
29283 COSTH2=(PCM(3)*PCM(3)+PCM(2)*PCM(2)-PCM(1)*PCM(1))
29284 & /(2.D0*PCM(2)*PCM(3))
29285 SINTH2=SQRT(1.D0-COSTH2*COSTH2)
29286 SINTH1=COSTH2*SQRT(1.D0-COSTH*COSTH)-COSTH*SINTH2
29287 COSTH1=COSTH*COSTH2+SINTH2*SQRT(1.D0-COSTH*COSTH)
29289 C selection of the sperical coordinates of particle 3
29290 CALL PHO_SFECFE(SIF(3),COF(3))
29293 COD(3) = 2.D0*DT_RNDM(S2)-1.D0
29294 ELSE IF(ISP.EQ.1) THEN
29295 C transverse polarization
29297 COD(3) = 2.D0*DT_RNDM(S1)-1.D0
29298 SID32 = 1.D0-COD(3)*COD(3)
29299 IF(SID32.LT.DT_RNDM(COSTH)) GOTO 400
29300 ELSE IF(ISP.EQ.2) THEN
29301 C longitudinal polarization
29303 COD(3) = 2.D0*DT_RNDM(COSTH2)-1.D0
29304 COD32 = COD(3)*COD(3)
29305 IF(COD32.LT.DT_RNDM(SINTH1)) GOTO 500
29307 WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY3:ERROR: ',
29308 & 'invalid polarization',ISP
29312 C selection of the rotation angle of p1-p2 plane along p3
29314 CALL PHO_SFECFE(SFE,CFE)
29326 SID3 = SQRT((1.D0+COD(3))*(1.D0-COD(3)))
29327 COD(1)=CX11*COD(3)+CZ11*SID3
29328 IF((1.D0-COD(1)*COD(1)).LT.DEPS) THEN
29329 WRITE(LO,'(1X,A,5E12.4)') 'PHO_SDECY3: COS(TH1) > 1',
29330 & COD(1),COF(3),SID3,CX11,CZ11
29331 CALL PHO_PREVNT(-1)
29334 SID1=SQRT((1.D0+COD(1))*(1.D0-COD(1)))
29335 COF(1)=(CX11*SID3*COF(3)-CY11*SIF(3)-CZ11*COD(3)*COF(3))/SID1
29336 SIF(1)=(CX11*SID3*SIF(3)+CY11*COF(3)-CZ11*COD(3)*SIF(3))/SID1
29337 COD(2)=CX22*COD(3)+CZ22*SID3
29338 SID2=SQRT((1.D0+COD(2))*(1.D0-COD(2)))
29339 COF(2)=(CX22*SID3*COF(3)-CY22*SIF(3)-CZ22*COD(3)*COF(3))/SID2
29340 SIF(2)=(CX22*SID3*SIF(3)+CY22*COF(3)-CZ22*COD(3)*SIF(3))/SID2
29344 *$ CREATE PHO_DFMASS.FOR
29346 CDECK ID>, PHO_DFMASS
29347 DOUBLE PRECISION FUNCTION PHO_DFMASS(XMIN,XMAX,PREF2,PVIRT2,IMODE)
29348 C**********************************************************************
29350 C sampling of Mx diffractive mass distribution within
29351 C limits XMIN, XMAX
29353 C input: XMIN,XMAX mass limitations (GeV)
29354 C PREF2 original particle mass/ reference mass
29355 C (squared, GeV**2)
29356 C PVIRT2 particle virtuality
29357 C IMODE M**2 mass distribution
29359 C 2 1/(M**2+Q**2)**alpha
29360 C -1 1/(M**2-Mref**2+Q**2)
29361 C -2 1/(M**2-Mref**2+Q**2)**alpha
29363 C output: diffractive mass (GeV)
29365 C**********************************************************************
29366 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29369 PARAMETER(EPS = 1.D-10)
29371 C input/output channels
29373 COMMON /POINOU/ LI,LO
29374 C event debugging information
29376 PARAMETER (NMAXD=100)
29377 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29378 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29379 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29380 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29381 C model switches and parameters
29383 INTEGER ISWMDL,IPAMDL
29384 DOUBLE PRECISION PARMDL
29385 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29387 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29388 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29389 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29391 IF((XMIN.GE.XMAX).OR.(XMIN.LE.0.3D0)) THEN
29392 WRITE(LO,'(/1X,2A,3E12.4)') 'PHO_DFMASS:ERROR: ',
29393 & 'invalid mass limits',XMIN,XMAX,PREF2
29394 CALL PHO_PREVNT(-1)
29395 PHO_DFMASS = 0.135D0
29399 IF(IMODE.GT.0) THEN
29402 PM2 = PREF2 - PVIRT2
29406 IF(ABS(IMODE).EQ.1) THEN
29407 XMIN2 = LOG(XMIN**2-PM2)
29408 XMAX2 = LOG(XMAX**2-PM2)
29409 XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
29412 C supercritical pomeron
29413 ELSE IF(ABS(IMODE).EQ.2) THEN
29414 DDELTA = 1.D0-PARMDL(48)
29415 XMIN2 = (XMIN**2-PM2)**DDELTA
29416 XMAX2 = (XMAX**2-PM2)**DDELTA
29417 XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
29418 XMA2 = XI**(1.D0/DDELTA)+PM2
29420 WRITE(LO,'(/,1X,A,I3)')
29421 & 'PHO_DFMASS:ERROR: unsupported mode',IMODE
29425 PHO_DFMASS = SQRT(XMA2)
29427 IF(IDEB(43).GE.15) THEN
29428 WRITE(LO,'(1X,A,4E12.3)') 'PHO_DFMASS:Mmin,Mmax,Mref,Mass',
29429 & XMIN,XMAX,PREF2,SQRT(XMA2)
29434 *$ CREATE PHO_DIFSLP.FOR
29436 CDECK ID>, PHO_DIFSLP
29437 SUBROUTINE PHO_DIFSLP(IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,XMX,
29439 C**********************************************************************
29441 C sampling of T (Mandelstam variable) distribution within
29442 C certain limits TMIN, TMAX
29444 C input: IDF1,2 type of diffractive vertex
29445 C 0 elastic/quasi-elastic scattering
29446 C 1 diffraction dissociation
29447 C IVEC1,2 vector meson IDs in case of quasi-elastic
29448 C scattering, otherwise 0
29449 C XM1 mass of diffractive system 1 (GeV)
29450 C XM2 mass of diffractive system 2 (GeV)
29451 C XMX max. mass of diffractive system (GeV)
29453 C output: TT squared momentum transfer ( < 0, GeV**2)
29454 C SLWGHT weight to allow for mass-dependent slope
29455 C IREJ 0 successful sampling
29456 C 1 masses too big for given T range
29458 C**********************************************************************
29459 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29462 PARAMETER(EPS = 1.D-10)
29464 C input/output channels
29466 COMMON /POINOU/ LI,LO
29467 C event debugging information
29469 PARAMETER (NMAXD=100)
29470 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29471 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29472 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29473 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29474 C model switches and parameters
29476 INTEGER ISWMDL,IPAMDL
29477 DOUBLE PRECISION PARMDL
29478 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29479 C internal rejection counters
29481 PARAMETER (NMXJ=60)
29482 CHARACTER*10 REJTIT
29484 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
29485 C c.m. kinematics of diffraction
29487 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
29488 & SIDD,CODD,SIFD,COFD,PDCMS
29489 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
29490 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
29492 INTEGER IPFIL,IFAFIL,IFBFIL
29493 DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
29494 & SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
29495 & SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
29496 & SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
29497 & FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
29498 COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
29499 & SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
29500 & SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
29501 & SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
29502 & FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
29503 & IPFIL,IFAFIL,IFBFIL
29504 C Reggeon phenomenology parameters
29505 DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
29506 & GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
29507 COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
29508 & ALREG,ALREGP,GR(2),B0REG(2),
29509 & GPPP,GPPR,B0PPP,B0PPR,
29510 & VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
29511 C parameters of 2x2 channel model
29512 DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
29513 COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
29514 C parameters of the "simple" Vector Dominance Model
29515 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
29516 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
29518 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29519 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29520 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29527 C range of momentum transfer t
29530 C determine min. abs(t) necessary to produce masses
29532 PCMP2 = PHO_XLAM(SS,XM12,XM22)**2/(4.D0*SS)
29533 IF(PCMP2.LE.0.D0) THEN
29538 TMINP = PMASSD(1)**2+XM12+2.D0*PCMD*SQRT(PCMP2)
29539 & -2.D0*SQRT((PMASSD(1)**2+PCM2)*(XM12+PCMP2))
29541 IF(TMINP.LT.TMAX) THEN
29542 IF(IDEB(44).GE.3) THEN
29543 WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
29544 & 'too large Tmin (XM1/2,TMIN,TMAX,TMINP)',
29545 & XM1,XM2,TMIN,TMAX,TMINP
29547 IFAIL(32) = IFAIL(32)+1
29552 TMINA = MIN(TMIN,TMINP)
29554 C calculation of slope (mass-dependent parametrization)
29555 IF(IDF1+IDF2.GT.0) THEN
29556 C diffraction dissociation
29557 XMP12 = XM1**2+PVIRTD(1)
29558 XMP22 = XM2**2+PVIRTD(2)
29561 CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
29562 FAC = 4.D0*(PMASSD(1)*PMASSD(2))**2
29563 SLOPE = DBLE(IDF1+IDF2)*B0PPP
29564 & +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
29565 & /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
29566 SLOPE = MAX(SLOPE,1.D0)
29572 ELSE IF(IDF1.EQ.0) THEN
29575 XMP12 = XMA1**2+PVIRTD(1)
29576 XMP22 = XMA2**2+PVIRTD(2)
29579 CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
29580 SLMIN = DBLE(IDF1+IDF2)*B0PPP
29581 & +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
29582 & /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
29583 SLMIN = MAX(SLMIN,1.D0)
29585 C elastic/quasi-elastic scattering
29586 IF(ISWMDL(13).EQ.0) THEN
29587 C external slope values
29588 WRITE(LO,*) 'PHO_DIFSLP:ERROR: this option is not installed !'
29590 ELSE IF(ISWMDL(13).EQ.1) THEN
29592 IF(IVEC1*IVEC2.EQ.0) THEN
29595 SLOPE = SLOVM(IVEC1,IVEC2)
29599 WRITE(LO,'(/1X,A,I5)') 'SASDSDT:ERROR: invalid ISWMDL(13)',
29605 C determine max. abs(t) to avoid underflows
29606 TMAXP = -25.D0/SLOPE
29607 TMAXA = MAX(TMAX,TMAXP)
29609 IF(TMINA.LT.TMAXA) THEN
29610 IF(IDEB(44).GE.3) THEN
29611 WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
29612 & 'too small Tmax (XM1/2,TMINA,TMAXA,SLOPE)',
29613 & XM1,XM2,TMINA,TMAXA,SLOPE
29615 IFAIL(32) = IFAIL(32)+1
29621 C sampling from corrected range of T
29622 TMINE = EXP(SLMIN*TMINA)
29623 TMAXE = EXP(SLMIN*TMAXA)
29624 XI = (TMINE-TMAXE)*DT_RNDM(SLMIN)+TMAXE
29626 SLWGHT = EXP((SLOPE-SLMIN)*TT)
29629 IF(IDEB(44).GE.15) THEN
29630 WRITE(LO,'(1X,A,1P,E12.3/5X,A,2I2,2X,2I2,2E10.2,/5X,A,5E10.2)')
29631 & 'PHO_DIFSLP: sampled momentum transfer:',TT,
29632 & 'IDF1/2,IVEC1/2,XM1/2:',IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,
29633 & 'Tmi,Tmx,SLMIN,SLOPE,WGHT:',TMINP,TMAXP,SLMIN,SLOPE,SLWGHT
29637 *$ CREATE PHO_DIFKIN.FOR
29639 CDECK ID>, PHO_DIFKIN
29640 SUBROUTINE PHO_DIFKIN(XMP1,XMP2,TT,PMOM1,PMOM2,IREJ)
29641 C**********************************************************************
29643 C calculation of diffractive kinematics
29645 C input: XMP1 mass of outgoing particle system 1 (GeV)
29646 C XMP2 mass of outgoing particle system 2 (GeV)
29647 C TT momentum transfer (GeV**2, negative)
29649 C output: PMOM1(5) four momentum of outgoing system 1
29650 C PMOM2(5) four momentum of outgoing system 2
29651 C IREJ 0 kinematics consistent
29652 C 1 kinematics inconsistent
29654 C**********************************************************************
29655 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29658 PARAMETER(EPS = 1.D-10,
29661 C input/output channels
29663 COMMON /POINOU/ LI,LO
29664 C event debugging information
29666 PARAMETER (NMAXD=100)
29667 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29668 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29669 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29670 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29671 C c.m. kinematics of diffraction
29673 DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
29674 & SIDD,CODD,SIFD,COFD,PDCMS
29675 COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
29676 & SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
29678 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29679 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29680 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29682 DOUBLE PRECISION PMOM1,PMOM2
29683 DIMENSION PMOM1(5),PMOM2(5)
29686 IF(IDEB(49).GT.10) WRITE(LO,'(1X,A,/5X,5E12.4)')
29687 & 'PHO_DIFKIN: Ecmd,Pcmd,Mini-1,Mini-2,TT:',
29688 & ECMD,PCMD,XMP1,XMP2,TT
29690 C general kinematic constraints
29692 IF(ECMD.LE.1.1D0*(XMP1+XMP2)) RETURN
29694 C new squared cms momentum
29699 PCMP2 = PHO_XLAM(SS,XMP12,XMP22)**2/(4.D0*SS)
29701 C new longitudinal/transverse momentum
29702 E1I = SQRT(PCM2+PMASSD(1)**2)
29703 E1F = SQRT(PCMP2+XMP12)
29704 E2F = SQRT(PCMP2+XMP22)
29705 PLONG = (TT+PCM2+PCMP2-(E1I-E1F)**2)/(2.D0*PCMD)
29706 PTRAN = PCMP2-PLONG**2
29708 C check consistency of kinematics
29709 IF(PTRAN.LT.0.D0) THEN
29710 IF(IDEB(49).GE.1) THEN
29711 WRITE(LO,'(1X,2A,I10)') 'PHO_DIFKIN: ',
29712 & 'inconsistent kinematics in event call: ',KEVENT
29713 WRITE(LO,'(1X,A,/5X,1p,6E11.3)')
29714 & 'PHO_DIFKIN: XMP1,XMP2,TT,PCMP,PLONG,PTRANS',
29715 & XMP1,XMP2,TT,SQRT(PCMP2),PLONG,SIGN(SQRT(ABS(PTRAN)),PTRAN)
29720 PTRAN = SQRT(PTRAN)
29722 XI = PI2*DT_RNDM(PTRAN)
29724 C outgoing momenta in cm. system
29726 PMOM1(1) = PTRAN*COS(XI)
29727 PMOM1(2) = PTRAN*SIN(XI)
29732 PMOM2(1) = -PMOM1(1)
29733 PMOM2(2) = -PMOM1(2)
29738 C debug output / precision check
29739 IF(IDEB(49).GE.0) THEN
29741 XM1 = (PMOM1(4)-PMOM1(3))*(PMOM1(4)+PMOM1(3))
29742 & -PMOM1(1)**2-PMOM1(2)**2
29743 XM1 = SIGN(SQRT(ABS(XM1)),XM1)
29744 XM2 = (PMOM2(4)-PMOM2(3))*(PMOM2(4)+PMOM2(3))
29745 & -PMOM2(1)**2-PMOM2(2)**2
29746 XM2 = SIGN(SQRT(ABS(XM2)),XM2)
29747 IF((ABS(XM1-XMP1).GT.DEPS).OR.(ABS(XM1-XMP1).GT.DEPS)) THEN
29748 WRITE(LO,'(1X,2A,/5X,4E11.4)') 'PHO_DIFKIN: ',
29749 & 'inconsistent masses: MINI-1,MOUT-1,MINI-2,MOUT-2',
29750 & XMP1,XM1,XMP2,XM2
29751 CALL PHO_PREVNT(-1)
29754 IF(IDEB(49).GT.10) THEN
29755 WRITE(LO,'(1X,A,5E11.3,/1X,A,5E11.3)')
29756 & 'PHO_DIFKIN: P1',PMOM1,' P2',PMOM2
29762 *$ CREATE PHO_VECRES.FOR
29764 CDECK ID>, PHO_VECRES
29765 SUBROUTINE PHO_VECRES(IVEC,RMASS,IDPDG,IDBAM)
29766 C**********************************************************************
29768 C sampling of vector meson resonance in diffractive processes
29769 C (nothing done for hadrons)
29771 C input: /POSVDM/ VDMFAC factors
29773 C output: IVEC 0 incoming hadron
29777 C 4 pi+/pi- background
29778 C RMASS mass of vector meson (GeV)
29779 C IDPDG particle ID according to PDG
29780 C IDBAM particle ID according to CPC
29782 C**********************************************************************
29783 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29786 PARAMETER(EPS = 1.D-10)
29788 C input/output channels
29790 COMMON /POINOU/ LI,LO
29791 C event debugging information
29793 PARAMETER (NMAXD=100)
29794 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29795 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29796 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29797 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29798 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
29799 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
29800 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
29801 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
29802 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
29803 C parameters of the "simple" Vector Dominance Model
29804 DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
29805 COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
29807 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29808 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29809 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29811 C particle code translation
29812 DIMENSION ITRANS(4)
29813 C rho0,omega,phi,pi+/pi-
29814 DATA ITRANS /113, 223, 333, 92 /
29818 C vector meson production
29819 IF(IDPDG.EQ.22) THEN
29820 XI = DT_RNDM(RMASS)*(VMFA(1)+VMFA(2)+VMFA(3)+VMFA(4))
29823 SUM = SUM + VMFA(K)
29824 IF(XI.LE.SUM) GOTO 65
29829 IDBAM = ipho_pdg2id(IDPDG)
29831 C sample mass of vector meson
29832 CALL PHO_SAMASS(IDPDG,RMASS)
29834 C hadronic resonance of multi-pomeron coupling
29835 ELSE IF(IDPDG.EQ.990) THEN
29838 IDBAM = ipho_pdg2id(IDPDG)
29840 C sample mass of two-pion system
29841 CALL PHO_SAMASS(IDPDG,RMASS)
29843 C hadron remnants in inucleus interactions
29844 ELSE IF(IDPDG.EQ.81) THEN
29845 IF(IHFLD(1,1).EQ.0) THEN
29846 CALL PHO_SEAFLA(1,IFL1,IFL2,RMASS)
29847 CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
29849 CALL PHO_HACODE(IHFLD(1,1),IHFLD(1,2),IDBA1,IDBA2)
29851 RMAS1 = PHO_PMASS(IDBA1,0)
29852 RMAS2 = PHO_PMASS(IDBA2,0)
29853 IF((IDBA2.NE.0).AND.
29854 & (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
29861 IDPDG = IPHO_ID2PDG(IDBAM)
29863 ELSE IF(IDPDG.EQ.82) THEN
29864 IF(IHFLD(2,1).EQ.0) THEN
29865 CALL PHO_SEAFLA(2,IFL1,IFL2,RMASS)
29866 CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
29868 CALL PHO_HACODE(IHFLD(2,1),IHFLD(2,2),IDBA1,IDBA2)
29870 RMAS1 = PHO_PMASS(IDBA1,0)
29871 RMAS2 = PHO_PMASS(IDBA2,0)
29872 IF((IDBA2.NE.0).AND.
29873 & (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
29880 IDPDG = IPHO_ID2PDG(IDBAM)
29884 IF(IDEB(47).GE.5) THEN
29885 WRITE(LO,'(1X,A,/10X,3I7,E12.4)')
29886 & 'PHO_VECRES: IDPDG-OLD,IDPDG,IDBAM,MASS',
29887 & IDPDO,IDPDG,IDBAM,RMASS
29892 *$ CREATE PHO_DIFRES.FOR
29894 CDECK ID>, PHO_DIFRES
29895 SUBROUTINE PHO_DIFRES(IDMOTH,IVAL1,IVAL2,
29896 & IDPDG,IDBAM,RMASS,RGAM,RWG,LISTL)
29897 C**********************************************************************
29899 C list of resonance states for low mass resonances
29901 C input: IDMOTH PDG ID of mother particle
29902 C IVAL1,2 quarks (photon only)
29904 C output: IDPDG list of PDG IDs for possible resonances
29905 C IDBAM list of corresponding CPC IDs
29907 C RGAMS decay width
29908 C RMASS additional weight factor
29909 C LISTL entries in current list
29911 C**********************************************************************
29912 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29915 DIMENSION IDPDG(10),IDBAM(10),RMASS(10),RGAM(10),RWG(10)
29917 PARAMETER (EPS = 1.D-10,
29920 C input/output channels
29922 COMMON /POINOU/ LI,LO
29923 C event debugging information
29925 PARAMETER (NMAXD=100)
29926 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29927 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29928 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29929 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29930 C particle ID translation table
29931 integer ID_pdg_list,ID_list,ID_pdg_max
29932 character*12 name_list
29933 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
29935 C general particle data
29936 double precision xm_list,tau_list,gam_list,
29937 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
29938 & xm_bb82_list,xm_bb102_list
29939 integer ich3_list,iba3_list,iq_list,
29940 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
29941 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
29942 & xm_psm2_list(6,6),xm_vem2_list(6,6),
29943 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
29944 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
29945 & ich3_list(300),iba3_list(300),iq_list(3,300),
29946 & id_psm_list(6,6),id_vem_list(6,6),
29947 & id_b8_list(6,6,6),id_b10_list(6,6,6)
29949 DIMENSION RWGHT(20),IRPDG(20),IRBAM(20)
29950 DATA IRPDG /113, 223, 333, 50223, 40113, 60223, 10333, 30113,
29951 & 12212, 42212, -12212, -42212,
29953 DATA RWGHT /1.D0, 0.11D0, 0.1D0, 0.11D0, 1.D0, 0.11D0, 0.1D0,
29954 & 1.D0, 1.D0, 1.D0, 1.D0, 1.D0,
29962 if(IRPDG(i).ne.0) then
29963 IRBAM(i) = ipho_pdg2id(IRPDG(i))
29969 C copy table with particles and isospin weights
29971 IF(IDMOTH.EQ.22) THEN
29974 ELSE IF(IDMOTH.EQ.2212) THEN
29977 ELSE IF(IDMOTH.EQ.-2212) THEN
29986 IDBAM(LISTL) = IRBAM(I)
29987 IDPDG(LISTL) = IRPDG(I)
29988 RMASS(LISTL) = xm_list(iabs(IDBAM(LISTL)))
29989 RGAM(LISTL) = gam_list(iabs(IDBAM(LISTL)))
29990 RWG(LISTL) = RWGHT(I)
29994 IF(IDEB(85).GE.20) THEN
29995 WRITE(LO,'(1X,A,3I7)') 'PHO_DIFRES: mother,quarks',IDMOTH,
29998 WRITE(LO,'(1X,I3,2I7,E12.4)') I,IDBAM(I),IDPDG(I),RMASS(I)
30004 *$ CREATE PHO_MASSAD.FOR
30006 CDECK ID>, PHO_MASSAD
30007 SUBROUTINE PHO_MASSAD(IFLMO,IFL1,IFL2,
30008 & PMASS,XMCON,XMOUT,IDPDG,IDcpc)
30009 C***********************************************************************
30011 C fine-correction of low mass strings to mass of corresponding
30012 C resonance or two particle threshold
30014 C input: IFLMO PDG ID of mother particle
30015 C IFL1,2 requested parton flavours
30016 C (not used at the moment)
30017 C PMASS reference mass (mass of mother particle)
30018 C XMCON conjecture of mass
30020 C output: XMOUT output mass (adjusted input mass)
30021 C moved ot nearest mass possible
30022 C IDPDG PDG resonance ID
30023 C IDcpc CPC resonance ID
30025 C**********************************************************************
30026 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30029 PARAMETER ( DEPS = 1.D-8 )
30031 C input/output channels
30033 COMMON /POINOU/ LI,LO
30034 C event debugging information
30036 PARAMETER (NMAXD=100)
30037 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30038 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30039 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30040 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30041 C model switches and parameters
30043 INTEGER ISWMDL,IPAMDL
30044 DOUBLE PRECISION PARMDL
30045 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
30046 C general particle data
30047 double precision xm_list,tau_list,gam_list,
30048 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
30049 & xm_bb82_list,xm_bb102_list
30050 integer ich3_list,iba3_list,iq_list,
30051 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
30052 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
30053 & xm_psm2_list(6,6),xm_vem2_list(6,6),
30054 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
30055 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
30056 & ich3_list(300),iba3_list(300),iq_list(3,300),
30057 & id_psm_list(6,6),id_vem_list(6,6),
30058 & id_b8_list(6,6,6),id_b10_list(6,6,6)
30059 C particle decay data
30060 double precision wg_sec_list
30061 integer idec_list,isec_list
30062 COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
30065 DIMENSION XWG(10),RMA(10),RGA(10),RWG(10),IRPDG(10),IRBAM(10)
30072 C resonance treatment activated?
30073 IF(ISWMDL(23).EQ.0) RETURN
30075 CALL PHO_DIFRES(IFLMO,IFL1,IFL2,IRPDG,IRBAM,RMA,RGA,RWG,LISTL)
30076 IF(LISTL.LT.1) THEN
30077 IF(IDEB(7).GE.2) WRITE(LO,'(1X,A,3I7)')
30078 & 'PHO_MASSAD: no resonances for (IFMO,IF1,IF2)',
30083 PMASSL = (PMASS+0.15D0)**2
30085 C determine resonance probability
30087 RPROB = (PMASSL+DM2)*(XMINP2-PMASSL)/(DM2*XMINP2)
30088 IF(RPROB.LT.DT_RNDM(PMASSL)) THEN
30089 C sample new resonance
30092 XWG(I) = RWG(I)/RMA(I)**2
30093 XWGSUM = XWGSUM+XWG(I)
30107 XI = XWGSUM*DT_RNDM(XMOUT)
30110 XWGSUM = XWGSUM-XWG(I)
30111 IF((XI.LT.XWGSUM).AND.(I.LT.LISTL)) GOTO 200
30117 C sample new mass (from Breit-Wigner cross section)
30118 ALO = ATAN((PMASSL-XMRES2)/(XMRES*GARES))
30119 AHI = ATAN((5.D0-XMRES2)/(XMRES*GARES))
30120 XI = (AHI-ALO)*DT_RNDM(XMRES)+ALO
30121 XMOUT = XMRES*GARES*TAN(XI)+XMRES2
30122 XMOUT = SQRT(XMOUT)
30124 C check mass for decay
30127 DO 250 IK=idec_list(2,ID),idec_list(3,ID)
30130 IF(isec_list(I,IK).NE.0)
30131 & AMSUM = AMSUM + xm_list(iabs(isec_list(I,IK)))
30133 AMDCY = MIN(AMDCY,AMSUM)
30135 IF(AMDCY.GE.XMOUT) GOTO 150
30139 & WRITE(LO,'(1X,2A,/1X,3I6,2E10.3,2I7,2E10.3)')
30141 & 'IFMO,IF1,IF2,XMCON,XMOUT,IDPDG,IDcpc,RMA,RGA',
30142 & IFLMO,IFL1,IFL2,XMCON,XMOUT,IDPDG,IDcpc,RMA(I),RGA(I)
30149 & WRITE(LO,'(1X,A,/1X,3I6,2E10.3)')
30150 & 'PHO_MASSAD: string sampled: IFMO,IF1,IF2,XMCON,XMOUT',
30151 & IFLMO,IFL1,IFL2,XMCON,XMOUT
30155 *$ CREATE PHO_PDF.FOR
30158 SUBROUTINE PHO_PDF(NPAR,X,SCALE2,P2VIR,PD)
30159 C***************************************************************
30161 C call different PDF sets for different particle types
30163 C input: NPAR 1 IGRP(1),ISET(1)
30164 C 2 IGRP(2),ISET(2)
30165 C X momentum fraction
30166 C SCALE2 squared scale (GeV**2)
30167 C P2VIR particle virtuality (positive, GeV**2)
30169 C output PD(-6:6) field containing the x*PDF fractions
30171 C***************************************************************
30172 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30177 C input/output channels
30179 COMMON /POINOU/ LI,LO
30180 C currently activated parton density parametrizations
30182 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
30183 DOUBLE PRECISION PDFLAM,PDFQ2M
30184 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
30185 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
30186 C event debugging information
30188 PARAMETER (NMAXD=100)
30189 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30190 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30191 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30192 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30193 C model switches and parameters
30195 INTEGER ISWMDL,IPAMDL
30196 DOUBLE PRECISION PARMDL
30197 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
30199 DIMENSION PARAM(20),VALUE(20)
30202 REAL XR,P2R,Q2R,F2GM,XPDFGM
30203 DIMENSION XPDFGM(-6:6)
30205 C check of kinematic boundaries
30208 IF(IDEB(37).GE.0) THEN
30209 WRITE(LO,'(/,1X,A,E15.8/)')
30210 & 'PHO_PDF: x>1 (corrected to x=1)',X
30211 CALL PHO_PREVNT(-1)
30213 XI = 0.99999999999D0
30214 ELSE IF(X.LE.0.D0) THEN
30215 IF(IDEB(37).GE.0) THEN
30216 WRITE(LO,'(/,1X,A,E15.8/)') 'PHO_PDF: X <= 0 ',X
30217 CALL PHO_PREVNT(-1)
30227 IF((NPAR.EQ.1).OR.(NPAR.EQ.2)) THEN
30231 IF(IEXT(NPAR).EQ.0) THEN
30232 IF(ITYPE(NPAR).EQ.1) THEN
30234 IF(IGRP(NPAR).EQ.5) THEN
30235 IF(ISET(NPAR).EQ.3) THEN
30236 CALL PHO_DOR92HO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
30241 ELSE IF(ISET(NPAR).EQ.4) THEN
30242 CALL PHO_DOR92LO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
30247 ELSE IF(ISET(NPAR).EQ.5) THEN
30248 CALL PHO_DOR94HO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
30249 C heavy quarks from GRV92-HO
30251 ALAM2 = 0.248 * 0.248
30252 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30256 AKC = -0.625 - 0.523 * S
30258 BC = 1.896 + 1.616 * S
30259 DC = 4.12 + 0.683 * S
30260 EC = 4.36 + 1.328 * S
30261 ESC = 0.677 + 0.679 * S
30262 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30266 AKB = 0.0 - 0.193 * S
30269 DB = 3.447 + 0.927 * S
30270 EB = 4.68 + 1.259 * S
30271 ESB = 1.892 + 2.199 * S
30272 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30274 ELSE IF(ISET(NPAR).EQ.6) THEN
30275 CALL PHO_DOR94LO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
30276 C heavy quarks from GRV92-LO
30279 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30285 BC = 4.24 - 0.804 * S
30286 DC = 3.46 + 1.076 * S
30287 EC = 4.61 + 1.490 * S
30288 ESC = 2.555 + 1.961 * S
30289 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30296 DB = 2.929 + 1.396 * S
30297 EB = 4.71 + 1.514 * S
30298 ESB = 4.02 + 1.239 * S
30299 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30301 ELSE IF(ISET(NPAR).EQ.7) THEN
30302 CALL PHO_DOR94DI(XI,SCALE2, UV, DV, DEL, UDB, SB, GL)
30303 C heavy quarks from GRV92-HO
30305 ALAM2 = 0.248 * 0.248
30306 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30310 AKC = -0.625 - 0.523 * S
30312 BC = 1.896 + 1.616 * S
30313 DC = 4.12 + 0.683 * S
30314 EC = 4.36 + 1.328 * S
30315 ESC = 0.677 + 0.679 * S
30316 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30320 AKB = 0.0 - 0.193 * S
30323 DB = 3.447 + 0.927 * S
30324 EB = 4.68 + 1.259 * S
30325 ESB = 1.892 + 2.199 * S
30326 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30328 ELSE IF(ISET(NPAR).EQ.8) THEN
30329 CALL PHO_DOR98LO(XI,SCALE2,UV,DV,US,DS,SB,GL)
30332 C heavy quarks from GRV92-LO
30335 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30341 BC = 4.24 - 0.804 * S
30342 DC = 3.46 + 1.076 * S
30343 EC = 4.61 + 1.490 * S
30344 ESC = 2.555 + 1.961 * S
30345 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30352 DB = 2.929 + 1.396 * S
30353 EB = 4.71 + 1.514 * S
30354 ESB = 4.02 + 1.239 * S
30355 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30357 ELSE IF(ISET(NPAR).EQ.9) THEN
30358 * CALL PHO_DOR98SC(XI,SCALE2,UV,DV,US,DS,SB,GL)
30361 C heavy quarks from GRV92-LO
30364 S = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30370 BC = 4.24 - 0.804 * S
30371 DC = 3.46 + 1.076 * S
30372 EC = 4.61 + 1.490 * S
30373 ESC = 2.555 + 1.961 * S
30374 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30381 DB = 2.929 + 1.396 * S
30382 EB = 4.71 + 1.514 * S
30383 ESB = 4.02 + 1.239 * S
30384 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30390 PD(-2) = 0.5D0*(UDB-DEL)
30391 PD(-1) = 0.5D0*(UDB+DEL)
30399 ELSE IF(ITYPE(NPAR).EQ.2) THEN
30400 C pion PDFs (default for pi+)
30401 IF(IGRP(NPAR).EQ.5) THEN
30402 IF(ISET(NPAR).EQ.1) THEN
30403 CALL PHO_DORPHO (XI,SCALE2,VA,GL,QB,CB,BB)
30405 ELSE IF(ISET(NPAR).EQ.2) THEN
30406 CALL PHO_DORPLO (XI,SCALE2,VA,GL,QB,CB,BB)
30421 ELSE IF(ITYPE(NPAR).EQ.3) THEN
30423 IF(IGRP(NPAR).EQ.5) THEN
30424 IF(ISET(NPAR).EQ.1) THEN
30425 CALL PHO_DORGH0 (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30427 ELSE IF(ISET(NPAR).EQ.2) THEN
30428 CALL PHO_DORGHO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30430 ELSE IF(ISET(NPAR).EQ.3) THEN
30431 CALL PHO_DORGLO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30434 C reweight with Drees-Godbole factor
30436 IF(P2VIR.GT.0.001D0) THEN
30437 WGX = LOG(SCALE2/(P2VIR+PARMDL(144)))
30438 & /LOG(SCALE2/PARMDL(144))
30439 WGX = MAX(WGX,0.D0)
30441 PD(-5) = BB*WGX/137.D0
30442 PD(-4) = CB*WGX/137.D0
30443 PD(-3) = SB*WGX/137.D0
30444 PD(-2) = UB*WGX/137.D0
30445 PD(-1) = DB*WGX/137.D0
30446 PD(0) = GL*WGX*WGX/137.D0
30452 ELSE IF(IGRP(NPAR).EQ.8) THEN
30453 IF(ISET(NPAR).EQ.1) THEN
30454 CALL PHO_PHGAL (XI,SCALE2,PD)
30458 ELSE IF(ITYPE(NPAR).EQ.20) THEN
30462 PD(0) = 6.D0*(1.D0-XI)**5*PARMDL(26)*PARMDL(78)
30464 ELSE IF(MODE.EQ.2) THEN
30465 PD(0) = 6.D0*XI*(1.D0-XI)*PARMDL(26)*PARMDL(78)
30467 ELSE IF(MODE.EQ.3) THEN
30468 PD(0) = (0.18D0/XI+5.46D0)*(1.D0-XI)*PARMDL(26)*PARMDL(78)
30470 ELSE IF(MODE.EQ.4) THEN
30471 CALL PHO_CKMTPD(990,XI,SCALE2,PD)
30473 PD(I) = PD(I)*PARMDL(78)
30481 ELSE IF(IEXT(NPAR).EQ.2) THEN
30482 C PDFLIB call: new PDF numbering
30483 IF(NPAR.NE.NPAOLD) THEN
30484 PARAM(1) = 'NPTYPE'
30485 PARAM(2) = 'NGROUP'
30488 VALUE(1) = ITYPE(NPAR)
30489 VALUE(2) = ABS(IGRP(NPAR))
30490 VALUE(3) = ISET(NPAR)
30491 CALL PDFSET(PARAM,VALUE)
30493 IF(ITYPE(NPAR).EQ.3) THEN
30495 CALL STRUCTP(XI,SCALE2,P2VIR,IP2,PD(2),PD(1),PD(-2),PD(-1),
30496 & PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
30498 SCALE = SQRT(SCALE2)
30499 CALL STRUCTM(XI,SCALE,PD(2),PD(1),PD(-2),PD(-1),
30500 & PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
30505 IF(ITYPE(NPAR).EQ.1) THEN
30506 C proton valence quarks
30507 PD(1) = PD(1)+PD(-1)
30508 PD(2) = PD(2)+PD(-2)
30509 ELSE IF(ITYPE(NPAR).EQ.2) THEN
30513 PD(-1) = DVAL+PD(1)
30514 PD(2) = PD(2)+PD(-2)
30515 ELSE IF(ITYPE(NPAR).EQ.3) THEN
30516 C photon conventions
30522 ELSE IF(IEXT(NPAR).EQ.3) THEN
30523 C PHOLIB call: version 2.0
30524 CALL PHVAL(IGRP(NPAR),ISET(NPAR),XI,SCALE2,PD,IRET)
30526 WRITE(LO,'(/1X,A,I2)')
30527 & 'PHO_PDF:ERROR: non-vanishing PHVAL return code',IRET
30532 C photon PDFs depending on photon virtuality
30534 ELSE IF(IEXT(NPAR).EQ.4) THEN
30535 IF(IGRP(NPAR).EQ.1) THEN
30536 C Schuler/Sjostrand PDF (interface to single precision)
30541 CALL PHO_SASGAM(ISET(NPAR),XR,Q2R,P2R,IP2,F2GM,XPDFGM)
30543 PD(I) = DBLE(XPDFGM(I))
30546 ELSE IF(IGRP(NPAR).EQ.5) THEN
30547 C Gluck/Reya/Stratmann
30548 IF(ISET(NPAR).EQ.4) THEN
30549 CALL PHO_DORGLV (XI,SCALE2,P2VIR, UB, DB, SB, GL)
30550 CALL PHO_QPMPDF(4,XI,SCALE2,0.D0,P2VIR,CB)
30571 WRITE(LO,'(/1X,A,/10X,5I6)')
30572 & 'PHO_PDF:ERROR:unsupported PDF(NPAR,IEXT,ITYPE,IGRP,ISET)',
30573 & NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
30578 WRITE(LO,'(/1X,A,I5)') 'PHO_PDF:ERROR:invalid NPAR(1,2) ',NPAR
30583 C valence quark treatment
30585 IF(ITYPE(NPAR).EQ.2) THEN
30586 C meson conventions
30587 IF(IPARID(NPAR).EQ.111) THEN
30588 C pi0 valence quarks
30589 PD(-1) = (PD(1)+PD(-1))/2.D0
30591 PD(-2) = (PD(2)+PD(-2))/2.D0
30593 ELSE IF(ABS(IPARID(NPAR)).EQ.321) THEN
30595 VALS = PD(-1)-PD(1)
30597 PD(-3) = PD(-3)+VALS
30598 ELSE IF( (IPARID(NPAR).EQ.311)
30599 & .OR.(IPARID(NPAR).EQ.310)
30600 & .OR.(IPARID(NPAR).EQ.130)) THEN
30602 VALS = PD(-1)-PD(1)
30603 VALU = PD(2)-PD(-2)
30606 PD(2) = PD(2)+VALU/2.D0
30607 PD(-2) = PD(-2)+VALU/2.D0
30608 PD(3) = PD(3)+VALS/2.D0
30609 PD(-3) = PD(-3)+VALS/2.D0
30611 ELSE IF(ITYPE(NPAR).EQ.1) THEN
30612 C nucleon conventions
30613 IF(ABS(IPARID(NPAR)).EQ.2112) THEN
30614 C neutron valence quarks
30618 ELSE IF(ABS(IPARID(NPAR)).EQ.3222) THEN
30620 VALS = PD(1)-PD(-1)
30623 ELSE IF(ABS(IPARID(NPAR)).EQ.3112) THEN
30625 VALS = PD(1)-PD(-1)
30626 VALD = PD(2)-PD(-2)
30631 ELSE IF( (ABS(IPARID(NPAR)).EQ.3122)
30632 & .OR.(ABS(IPARID(NPAR)).EQ.3212)) THEN
30633 C (anti-)sigma0 and (anti-)lambda
30634 VALS = PD(1)-PD(-1)
30635 VALD = (PD(2)-PD(-2))/2.D0
30645 IF(IPARID(NPAR).LT.0) THEN
30653 C optionally remove valence quarks
30654 IF(IPAVA(NPAR).EQ.0) THEN
30656 PD(I) = MIN(PD(-I),PD(I))
30661 C debug information
30662 IF(IDEB(37).GE.30) WRITE(LO,
30663 & '(1X,A,I4,1P,3E12.4/,2X,A,6E10.3,/2X,A,E10.3,/2X,A,6E10.3)')
30664 & 'PHO_PDF: NPAR,X,SCALE**2,P2VIR',
30665 & NPAR,X,SCALE2,P2VIR,'PD(-6..-1)',(PD(I),I=-6,-1),
30666 & 'PD(0) ',PD(0),'PD(1..6) ',(PD(I),I=1,6)
30670 *$ CREATE PHO_QPMPDF.FOR
30672 CDECK ID>, PHO_QPMPDF
30673 SUBROUTINE PHO_QPMPDF(IQ,X,SCALE2,PTREF,PVIRT,FXP)
30674 C***************************************************************
30676 C contribution to photon PDF from box graph
30677 C (Bethe-Heitler process)
30679 C input: IQ quark flavour
30680 C SCALE2 scale (GeV**2, positive)
30681 C PTREF reference scale (GeV, positive)
30682 C X parton momentum fraction
30683 C PVIRT photon virtuality (GeV**2, positive)
30684 C FXP x*f(x,Q**2), x times parton density
30686 C***************************************************************
30687 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30690 C input/output channels
30692 COMMON /POINOU/ LI,LO
30693 C event debugging information
30695 PARAMETER (NMAXD=100)
30696 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30697 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30698 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30699 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30700 C internal rejection counters
30702 PARAMETER (NMXJ=60)
30703 CHARACTER*10 REJTIT
30705 COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
30707 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
30708 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
30709 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
30712 DATA QM / 0.2D0,0.25D0,0.5D0,1.5D0,4.5D0,174.D0 /
30717 * QM2 = MAX(QM(I),PTREF)**2
30718 * QM2 = MAX(QM2,PVIRT)
30719 * BBE = (1.D0-X)*SCALE2
30720 * IF(BBE.LE.0.D0) THEN
30721 * IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
30722 * & 'PHO_QPMPDF: over mass limit (X,Q2,P2,QM)',X,SCALE2,
30725 * FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(2.D0*137.D0*PI)
30726 * & *((X**2+(1.D0-X)**2)*LOG(BBE/(QM2*X))+8.D0*X*(1.D0-X)-1.D0)
30727 C Bethe-Heitler process approximation for 2*x*p2/q2 << 1
30728 QM2 = MAX(QM(I),PTREF)**2
30729 W2 = SCALE2/X*(1.D0-X-X*PVIRT/SCALE2)
30730 IF(W2.GT.4.D0*QM2) THEN
30731 BE = SQRT(1.D0-4.D0*QM2/W2)
30732 BP = SQRT(1.D0+BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
30733 BM = SQRT(1.D0-BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
30734 * FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(137.D0*PI)*(BE*(-1.D0
30735 FXP = X*Q_ch2(I)*3.D0/(137.D0*PI)*(BE*(-1.D0
30736 & +6.D0*X-6.D0*X*X)+2.D0*X*X*((2.D0*QM2-PVIRT)/SCALE2
30737 & -4.D0*QM2*QM2/SCALE2**2)*(1.D0/BM-1.D0/BP)
30738 & +(X*X+(1.D0-X)**2+X*(1-3.D0*X)*4.D0*QM2/SCALE2
30739 & -X*X*8.D0*QM2*QM2/SCALE2**2)*LOG(BP/BM))
30741 IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
30742 & 'PHO_QPMPDF: under mass limit (X,Q2,P2,QM)',X,SCALE2,
30746 IF(IDEB(27).GE.20) WRITE(LO,'(1X,A,I3,1P,5E10.3)')
30747 & 'PHO_QPMPDF: X,Q2,P2,QM',I,X,SCALE2,PVIRT,QM(I),FXP
30750 *$ CREATE PHO_SETPDF.FOR
30752 CDECK ID>, PHO_SETPDF
30753 SUBROUTINE PHO_SETPDF(IDPDG,ITYP,IPAR,ISET,IEXT,IPAVAL,MODE)
30754 C***************************************************************
30756 C assigns PDF numbers to particles
30758 C input: IDPDG PDG number of particle
30759 C ITYP particle type
30760 C IPAR PDF paramertization
30761 C ISET number of set
30762 C IEXT library number for PDF calculation
30763 C IPAVAL (only output)
30764 C 1 PDF with valence quarks
30765 C 0 PDF without valence quarks
30766 C MODE -1 add entry to table
30767 C 1 read from table
30768 C 2 output of table
30770 C***************************************************************
30771 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30774 C input/output channels
30776 COMMON /POINOU/ LI,LO
30777 C event debugging information
30779 PARAMETER (NMAXD=100)
30780 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30781 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30782 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30783 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30784 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
30785 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
30786 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
30787 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
30788 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
30790 DIMENSION IPDFS(5,50)
30795 IF(IDPDG.EQ.81) THEN
30798 ELSE IF(IDPDG.EQ.82) THEN
30806 IF(IDCMP.EQ.IPDFS(1,I)) THEN
30811 IF(IDEB(80).GE.15) WRITE(LO,'(1X,A,I7,5X,3I4)')
30812 & 'PHO_SETPDF: ID,IPAR,ISET,IEXT',IDCMP,IPAR,ISET,IEXT
30816 IF(I.GT.IENTRY) THEN
30817 WRITE(LO,'(/1X,A,I7)')
30818 & 'PHO_SETPDF: no PDF assigned to ',IDCMP
30822 ELSE IF(MODE.EQ.-1) THEN
30824 IF(IDPDG.EQ.IPDFS(1,I)) THEN
30825 WRITE(LO,'(/1X,A,5I6)')
30826 & 'PHO_SETPDF: overwrite old particle PDF',
30827 & IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
30833 WRITE(LO,'(/1X,A,/1x,6I6)')
30834 & 'PHO_SETPDF:ERROR: no space left in IPDFS:',
30835 & I,IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
30841 IF(IDPDG.EQ.990) THEN
30843 ELSE IF(IDPDG.EQ.22) THEN
30845 ELSE IF(ABS(IDPDG).LT.1000) THEN
30854 ELSE IF(MODE.EQ.-2) THEN
30855 WRITE(LO,'(/1X,A)') 'PHO_SETPDF: PDFs assigned by user:'
30857 WRITE(LO,'(5X,I4,A,I7,A,4I5)') I,' particle:',IPDFS(1,I),
30858 & ' PDF-set ',IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
30861 WRITE(LO,'(/1X,A,I5)') 'PHO_SETPDF:ERROR: invalid mode ',MODE
30865 *$ CREATE PHO_GETPDF.FOR
30867 CDECK ID>, PHO_GETPDF
30868 SUBROUTINE PHO_GETPDF(NPAR,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
30869 C***************************************************************
30871 C get PDF information
30873 C input: NPAR 1 first PDF in /POPPDF/
30874 C 2 second PDF in /POPPDF/
30876 C output: PDFNA name of PDf parametrization
30877 C ALA QCD LAMBDA (4 flavours, in GeV)
30883 C***************************************************************
30884 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30889 C input/output channels
30891 COMMON /POINOU/ LI,LO
30893 C PHOLIB 4.15 common
30894 COMMON /W50512/ QCDL4,QCDL5
30895 COMMON /W50513/ XMIN,XMAX,Q2MIN,Q2MAX
30897 C PHOPDF version 2.0 common
30898 PARAMETER (MAXS=6,MAXP=10)
30900 COMMON/PHCOM1/ XLIM(MAXP,0:MAXS,2), Q2LIM(MAXP,0:MAXS,2),
30901 & NSET(MAXP,2),NFL(MAXP)
30902 COMMON/PHCOM2/ ALM(MAXP,0:MAXS),CHPAR(MAXP),IORD(MAXP,-MAXS:MAXS)
30904 C currently activated parton density parametrizations
30906 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
30907 DOUBLE PRECISION PDFLAM,PDFQ2M
30908 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
30909 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
30911 DIMENSION PARAM(20),VALUE(20)
30914 IF((NPAR.NE.1).AND.(NPAR.NE.2)) THEN
30915 WRITE(LO,'(/1X,A,I6)')
30916 & 'PHO_GETPDF:ERROR: invalid PDF number (1,2)',NPAR
30921 IF(IEXT(NPAR).EQ.0) THEN
30923 C internal parametrizations
30925 IF(ITYPE(NPAR).EQ.1) THEN
30927 IF(IGRP(NPAR).EQ.5) THEN
30928 IF(ISET(NPAR).EQ.3) THEN
30932 ELSE IF(ISET(NPAR).EQ.4) THEN
30936 ELSE IF(ISET(NPAR).EQ.5) THEN
30940 ELSE IF(ISET(NPAR).EQ.6) THEN
30944 ELSE IF(ISET(NPAR).EQ.7) THEN
30948 ELSE IF(ISET(NPAR).EQ.8) THEN
30952 ELSE IF(ISET(NPAR).EQ.9) THEN
30958 ELSE IF(ITYPE(NPAR).EQ.2) THEN
30960 IF(IGRP(NPAR).EQ.5) THEN
30961 IF(ISET(NPAR).EQ.1) THEN
30965 ELSE IF(ISET(NPAR).EQ.2) THEN
30971 ELSE IF(ITYPE(NPAR).EQ.3) THEN
30973 IF(IGRP(NPAR).EQ.5) THEN
30974 IF(ISET(NPAR).EQ.1) THEN
30978 ELSE IF(ISET(NPAR).EQ.2) THEN
30982 ELSE IF(ISET(NPAR).EQ.3) THEN
30987 ELSE IF(IGRP(NPAR).EQ.8) THEN
30988 IF(ISET(NPAR).EQ.1) THEN
30994 ELSE IF(ITYPE(NPAR).EQ.20) THEN
30996 IF(IGRP(NPAR).EQ.4) THEN
30997 CALL PHO_CKMTPA(990,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
31005 C external parametrizations
31007 ELSE IF(IEXT(NPAR).EQ.1) THEN
31008 C PDFLIB call: old numbering
31011 VALUE(1) = IGRP(NPAR)
31012 CALL PDFSET(PARAM,VALUE)
31019 ELSE IF(IEXT(NPAR).EQ.2) THEN
31020 C PDFLIB call: new numbering
31021 PARAM(1) = 'NPTYPE'
31022 PARAM(2) = 'NGROUP'
31025 VALUE(1) = ITYPE(NPAR)
31026 VALUE(2) = IGRP(NPAR)
31027 VALUE(3) = ISET(NPAR)
31028 CALL PDFSET(PARAM,VALUE)
31035 ELSE IF(IEXT(NPAR).EQ.3) THEN
31037 ALA = ALM(IGRP(NPAR),ISET(NPAR))
31039 PDFNA = CHPAR(IGRP(NPAR))
31041 C some special internal parametrizations
31043 ELSE IF(IEXT(NPAR).EQ.4) THEN
31044 C photon PDFs depending on virtualities
31045 IF(IGRP(NPAR).EQ.1) THEN
31046 C Schuler/Sjostrand parametrization
31048 IF(ISET(NPAR).EQ.1) THEN
31051 ELSE IF(ISET(NPAR).EQ.2) THEN
31054 ELSE IF(ISET(NPAR).EQ.3) THEN
31057 ELSE IF(ISET(NPAR).EQ.4) THEN
31061 ELSE IF(IGRP(NPAR).EQ.5) THEN
31062 C Gluck/Reya/Stratmann parametrization
31063 IF(ISET(NPAR).EQ.4) THEN
31069 ELSE IF(IEXT(NPAR).EQ.5) THEN
31070 C Schuler/Sjostrand anomalous only
31075 IF(ALA.LT.0.01D0) THEN
31076 WRITE(LO,'(/1X,2A,/10X,5I6)')
31077 & 'PHO_GETPDF:ERROR: ',
31078 & 'unsupported PDF (NPAR,IEXT,ITYPE,IGRP,ISET)',
31079 & NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
31085 *$ CREATE PHO_ACTPDF.FOR
31087 CDECK ID>, PHO_ACTPDF
31088 SUBROUTINE PHO_ACTPDF(IDPDG,K)
31089 C***************************************************************
31091 C activate PDF for QCD calculations
31093 C input: IDPDG PDG particle number
31094 C K 1 first PDF in /POPPDF/
31095 C 2 second PDF in /POPPDF/
31096 C -2 write current settings
31100 C***************************************************************
31101 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31104 C input/output channels
31106 COMMON /POINOU/ LI,LO
31107 C event debugging information
31109 PARAMETER (NMAXD=100)
31110 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31111 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31112 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31113 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31114 C currently activated parton density parametrizations
31116 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
31117 DOUBLE PRECISION PDFLAM,PDFQ2M
31118 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
31119 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
31123 C read PDF from table
31124 CALL PHO_SETPDF(IDPDG,ITYPE(K),IGRP(K),ISET(K),IEXT(K),
31127 C get PDF parameters
31128 CALL PHO_GETPDF(K,PDFNAM(K),PDFLAM(K),PDFQ2M(K),Q2MA,XMI,XMA)
31129 C initialize alpha_s calculation
31130 alam2 = PDFLAM(K)*PDFLAM(K)
31131 DUMMY = PHO_ALPHAS(alam2,-K)
31133 IF(IDEB(2).GE.20) THEN
31135 & 'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
31136 WRITE(LO,'(1X,A,I2,2E12.3,2X,A8,4I4,I7)') 'SIDE',K,
31137 & PDFLAM(K),PDFQ2M(K),PDFNAM(K),ITYPE(K),IGRP(K),ISET(K),
31138 & IEXT(K),IPARID(K)
31142 ELSE IF(K.EQ.-2) THEN
31144 C write table of current PDFs
31146 & 'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
31147 WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 1:',PDFLAM(1),
31148 & PDFQ2M(1),PDFNAM(1),ITYPE(1),IGRP(1),ISET(1),IEXT(1),
31150 WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 2:',PDFLAM(2),
31151 & PDFQ2M(2),PDFNAM(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),
31156 WRITE(LO,'(/1X,A,2I4)')
31157 & 'PHO_ACTPDF:ERROR: invalid arguments',IDPDG,K
31164 *$ CREATE PHO_PDFTST.FOR
31166 CDECK ID>, PHO_PDFTST
31167 SUBROUTINE PHO_PDFTST(IDPDG,SCALE2,P2MASS)
31168 C*********************************************************************
31170 C structure function test utility
31172 C input: IDPDG PDG ID of particle
31173 C SCALE2 squared scale (GeV**2)
31174 C P2MASS particle virtuality (pos, GeV**2)
31176 C output: tables of PDF, sum rule checking, table of F2
31178 C*********************************************************************
31179 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31182 C input/output channels
31184 COMMON /POINOU/ LI,LO
31185 C currently activated parton density parametrizations
31187 INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
31188 DOUBLE PRECISION PDFLAM,PDFQ2M
31189 COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
31190 & IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
31192 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
31193 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
31194 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
31196 DIMENSION PD(-6:6),PDSUM(-6:6),PDAVE(-6:6),FXP(4)
31199 CALL PHO_ACTPDF(IDPDG,1)
31200 CALL PHO_GETPDF(1,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
31202 WRITE(LO,'(/,A)') ' *** Structure Function Test Utility ***'
31203 WRITE(LO,'(A)') ' ======================================='
31205 WRITE(LO,'(/,A,3I10)')
31206 & ' used structure function:',ITYPE(1),IGRP(1),ISET(1)
31207 WRITE(LO,'(A,A)') ' corresponds to ',PDFNA
31208 WRITE(LO,'(A,E12.3)') ' used squared scale (GeV**2):',SCALE2
31209 WRITE(LO,'(A,E12.3)') ' particle virtuality (GeV**2):',P2MASS
31210 WRITE(LO,'(/1X,A)') 'x times parton densities'
31211 WRITE(LO,'(1X,A)') ' X PD(-4 - 4)'
31213 & ' ============================================================'
31215 C logarithmic loop over x values
31224 XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
31228 CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
31229 IF(X.NE.XCONTR) THEN
31230 WRITE(LO,*) ' x changed! old: ',XCONTR,' new: ',X
31232 WRITE(LO,'(1X,1P,10E11.4)') XCONTR,(PD(K),K=-4,4)
31233 XFIRST=XFIRST+XDELTA
31236 IF(IDPDG.EQ.22) THEN
31237 WRITE(LO,'(/1X,A)')
31238 & 'comparison PDF to contribution due to box diagram'
31239 WRITE(LO,'(1X,A)') ' X PD(1),PB(1), .... ,PD(4),PB(4)'
31241 & ' ============================================================'
31243 XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
31246 CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
31248 CALL PHO_QPMPDF(K,X,SCALE2,0.D0,P2MASS,FXP(K))
31250 WRITE(LO,'(1X,1P,9E11.4)') X,(PD(K),FXP(K),K=1,4)
31251 XFIRST=XFIRST+XDELTA
31255 C check momentum sum rule
31257 WRITE(LO,'(/1X,A)') 'PHO_PDFTST: estimate of quark sum rules'
31264 XX=DBLE(I)/DBLE(ITER)
31265 IF(XX.EQ.1.D0) XX = 0.999999D0
31266 CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
31268 PDSUM(K) = PDSUM(K)+PD(K)/XX
31269 PDAVE(K) = PDAVE(K)+PD(K)
31273 & 'Table: parton-ID, dx-integral over Q(X,Q**2), X*Q(X,Q**2)'
31276 PDSUM(I) = PDSUM(I)/DBLE(ITER)
31277 PDAVE(I) = PDAVE(I)/DBLE(ITER)
31278 XSUM = XSUM+PDAVE(I)
31279 WRITE(LO,'(9X,I3,3X,2E15.4)') I,PDSUM(I),PDAVE(I)
31281 WRITE(LO,'(1X,A)') 'PHO_PDFTST: valence flavours'
31283 WRITE(LO,'(9X,I3,E12.4)') I,PDSUM(I)-PDSUM(-I)
31285 WRITE(LO,'(1X,A,E12.4)') 'momentum sum rule',XSUM
31286 WRITE(LO,'(A/)') ' ============================================='
31290 WRITE(LO,'(/1X,A,E12.4,/1X,A)')
31291 & 'PHO_PDFTST: TABLE OF X, F2(X,Q**2) FOR Q**2',SCALE2,
31292 & '-----------------------------------------------------'
31295 XX=DBLE(I)/DBLE(ITER)
31296 IF(XX.EQ.1.D0) XX = 0.9999D0
31297 CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
31300 IF(K.NE.0) F2 = F2 + Q_ch2(K)*PD(K)
31302 WRITE(LO,'(5X,1P,2E14.5)') XX,F2
31304 WRITE(LO,'(A/)') ' ============================================='
31307 *$ CREATE PHO_REGPAR.FOR
31309 CDECK ID>, PHO_REGPAR
31310 SUBROUTINE PHO_REGPAR(ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4,
31311 & IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE)
31312 C**********************************************************************
31314 C registration of particle in /POEVT1/ and /POEVT2/
31316 C input: ISTH status code of particle
31317 C -2 initial parton hard scattering
31320 C 1 visible particle (no color)
31321 C 2 decayed particle
31322 C IDPDG PDG particle ID code
31323 C IDBAM CPC particle ID code
31324 C JM1,JM2 first and second mother index
31325 C P1..P4 four momentum
31326 C IPHIS1 extended history information
31327 C IPHIS1<100: JM1 from particle 1
31328 C IPHIS1>100: JM1 from particle 2
31330 C 2 valence diquark
31333 C (neg. for antipartons)
31334 C IPHIS2 extended history information
31335 C positive: JM2 from particle 1
31336 C negative: JM2 from particle 2
31338 C IC1,IC2 color labels for partons
31339 C IMODE 1 register given parton
31340 C 0 reset /POEVT1/ and /POEVT2/
31341 C 2 return data of entry IPOS
31343 C IPOS position of particle in /POEVT1/
31345 C**********************************************************************
31346 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31349 PARAMETER (DEPS = 1.D-20)
31351 C input/output channels
31353 COMMON /POINOU/ LI,LO
31354 C event debugging information
31356 PARAMETER (NMAXD=100)
31357 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31358 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31359 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31360 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31361 C standard particle data interface
31363 PARAMETER (NMXHEP=4000)
31364 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
31365 DOUBLE PRECISION PHEP,VHEP
31366 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
31367 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
31369 C extension to standard particle data interface (PHOJET specific)
31370 INTEGER IMPART,IPHIST,ICOLOR
31371 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
31373 IF(IMODE.EQ.1) THEN
31374 IF(IDEB(76).GE.26) THEN
31375 WRITE(LO,'(1X,A,/2X,I3,I6,3I4,4E10.3)')
31376 & 'PHO_REGPAR: ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4',
31377 & ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4
31378 WRITE(LO,'(1X,A,/2X,6I6)')
31379 & 'PHO_REGPAR: IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE',
31380 & IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE
31382 IF(NHEP.EQ.NMXHEP) THEN
31383 WRITE(LO,'(/1X,2A,2I6/)') 'PHO_REGPAR: ',
31384 & 'no space left in /POEVT1/ (NHEP,NMXHEP):',NHEP,NMXHEP
31390 IF(ABS(ISTH).LE.2) THEN
31391 IF((IDBAM.NE.0).AND.(IDPDG.EQ.0)) THEN
31392 IDPDGI = ipho_id2pdg(IDBAM)
31393 ELSE IF((IDBAM.EQ.0).AND.(IDPDG.NE.0)) THEN
31394 IDBAMI = ipho_pdg2id(IDPDG)
31398 ISTHEP(NHEP) = ISTH
31399 IDHEP(NHEP) = IDPDGI
31400 JMOHEP(1,NHEP) = JM1
31401 JMOHEP(2,NHEP) = JM2
31402 C update of mother-daugther relations
31403 IF(ABS(ISTH).LE.1) THEN
31405 IF(JDAHEP(1,JM1).EQ.0) THEN
31406 JDAHEP(1,JM1) = NHEP
31409 JDAHEP(2,JM1) = NHEP
31411 IF((JM2.NE.JM1).AND.(JM2.GT.0)) THEN
31412 IF(JDAHEP(1,JM2).EQ.0) THEN
31413 JDAHEP(1,JM2) = NHEP
31416 JDAHEP(2,JM2) = NHEP
31417 ELSE IF(JM2.LT.0) THEN
31418 DO 100 II=JM1+1,-JM2
31419 IF(JDAHEP(1,II).EQ.0) THEN
31420 JDAHEP(1,II) = NHEP
31423 JDAHEP(2,II) = NHEP
31431 IF((ABS(ISTH).LE.3).OR.(ISTH.EQ.20).OR.(ISTH.EQ.21)) THEN
31432 TMP=(P4-P3)*(P4+P3)-P1**2-P2**2
31433 PHEP(5,NHEP) = SIGN(SQRT(ABS(TMP)),TMP)
31435 PHEP(5,NHEP) = 0.D0
31439 C extended information
31440 IMPART(NHEP) = IDBAMI
31441 C extended history information
31442 IPHIST(1,NHEP) = IPHIS1
31443 IPHIST(2,NHEP) = IPHIS2
31444 C charge/baryon number or color labels
31446 ICOLOR(1,NHEP) = IPHO_CHR3(NHEP,2)
31447 ICOLOR(2,NHEP) = IPHO_BAR3(NHEP,2)
31449 ICOLOR(1,NHEP) = IC1
31450 ICOLOR(2,NHEP) = IC2
31454 IF(IDEB(76).GE.26) THEN
31455 WRITE(LO,'(1X,A,2I4,2X,2I4,E12.3,I5)')
31456 & 'PHO_REGPAR: IPHIST1/2,IC1/2,MASS,IPOS',IPHIST(1,NHEP),
31457 & IPHIST(2,NHEP),ICOLOR(1,NHEP),ICOLOR(2,NHEP),
31458 & PHEP(5,NHEP),IPOS
31461 ELSE IF(IMODE.EQ.0) THEN
31463 ELSE IF(IMODE.EQ.2) THEN
31464 IF((IPOS.LT.1).OR.(IPOS.GT.NHEP)) THEN
31465 WRITE(LO,'(1X,2A,2I8)') 'PHO_REGPAR: ',
31466 & 'index out of bounds (NHEP,IPOS)',NHEP,IPOS
31469 ISTH = ISTHEP(IPOS)
31470 IDPDG = IDHEP(IPOS)
31471 IDBAM = IMPART(IPOS)
31472 JM1 = JMOHEP(1,IPOS)
31473 JM2 = JMOHEP(2,IPOS)
31478 IPHIS1= IPHIST(1,IPOS)
31479 IPHIS2= IPHIST(2,IPOS)
31480 IC1 = ICOLOR(1,IPOS)
31481 IC2 = ICOLOR(2,IPOS)
31483 WRITE(LO,'(1X,A,I8)') 'PHO_REGPAR: invalid mode',IMODE
31487 *$ CREATE IPHO_CNV1.FOR
31489 CDECK ID>, IPHO_CNV1
31490 INTEGER FUNCTION IPHO_CNV1(IPART)
31491 C*********************************************************************
31493 C conversion of quark numbering scheme to PARTICLE DATA GROUP
31496 C input: old internal particle code of hard scattering
31502 C valence quarks changed to standard numbering
31504 C output: standard particle codes
31506 C*********************************************************************
31507 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31511 C change gluon number
31514 C change valence quark
31515 ELSE IF((II.GT.6).AND.(II.LT.13)) THEN
31516 IPHO_CNV1 = SIGN(II-6,IPART)
31522 *$ CREATE PHO_HACODE.FOR
31524 CDECK ID>, PHO_HACODE
31525 SUBROUTINE PHO_HACODE(ID1,ID2,IDcpc1,IDcpc2)
31526 C*********************************************************************
31528 C determination of hadron index from quarks
31530 C input: ID1,ID2 parton code according to PDG conventions
31532 C output: IDcpc1,2 CPC particle codes
31534 C*********************************************************************
31538 integer ID1,ID2,IDcpc1,IDcpc2
31540 C input/output channels
31542 COMMON /POINOU/ LI,LO
31543 C event debugging information
31545 PARAMETER (NMAXD=100)
31546 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31547 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31548 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31549 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31550 C general particle data
31551 double precision xm_list,tau_list,gam_list,
31552 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
31553 & xm_bb82_list,xm_bb102_list
31554 integer ich3_list,iba3_list,iq_list,
31555 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
31556 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
31557 & xm_psm2_list(6,6),xm_vem2_list(6,6),
31558 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
31559 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
31560 & ich3_list(300),iba3_list(300),iq_list(3,300),
31561 & id_psm_list(6,6),id_vem_list(6,6),
31562 & id_b8_list(6,6,6),id_b10_list(6,6,6)
31565 integer ii,jj,kk,i1,i2
31570 if(ID1*ID2.lt.0) then
31579 IDcpc1 = ID_psm_list(ii,jj)
31580 IDcpc2 = ID_vem_list(ii,jj)
31588 jj = (i1-ii*1000)/100
31593 kk = (i2-jj*1000)/100
31595 IDcpc1 = sign(ID_b8_list(ii,jj,kk),ID1)
31596 IDcpc2 = sign(ID_b10_list(ii,jj,kk),ID1)
31602 *$ CREATE PHO_ID2STR.FOR
31604 CDECK ID>, PHO_ID2STR
31605 SUBROUTINE PHO_ID2STR(ID1,ID2,NOBAM,IBAM1,IBAM2,IBAM3,IBAM4)
31606 C*********************************************************************
31608 C conversion of quark numbering scheme
31610 C input: standard particle codes:
31614 C output: NOBAM CPC string code
31615 C quark codes (PDG convention):
31621 C NOBAM = -1 invalid flavour combinations
31623 C*********************************************************************
31624 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31627 C input/output channels
31629 COMMON /POINOU/ LI,LO
31634 C quark-antiquark string
31635 IF((IDA1.LE.6).AND.(IDA2.LE.6)) THEN
31636 IF((ID1*ID2).GE.0) GOTO 100
31642 C quark-diquark string
31643 ELSE IF((IDA2.GT.6).AND.(IDA1.LE.6)) THEN
31644 IF((ID1*ID2).LE.0) GOTO 100
31647 IBAM3 = (ID2-IBAM2*1000)/100
31650 C diquark-quark string
31651 ELSE IF((IDA1.GT.6).AND.(IDA2.LE.6)) THEN
31652 IF((ID1*ID2).LE.0) GOTO 100
31654 IBAM2 = (ID1-IBAM1*1000)/100
31658 C gluon-gluon string
31659 ELSE IF((IDA1.EQ.21).AND.(IDA2.EQ.21)) THEN
31665 C diquark-antidiquark string
31666 ELSE IF((IDA1.GT.6).AND.(IDA2.GT.6)) THEN
31667 IF((ID1*ID2).GE.0) GOTO 100
31669 IBAM2 = (ID1-IBAM1*1000)/100
31671 IBAM4 = (ID2-IBAM3*1000)/100
31676 C invalid combination
31678 WRITE(LO,'(//1X,A,2I10)')
31679 & 'PHO_ID2STR: invalid flavors for string (ID1,ID2)',ID1,ID2
31684 *$ CREATE PHO_MKSLTR.FOR
31686 CDECK ID>, PHO_MKSLTR
31687 SUBROUTINE PHO_MKSLTR(P1,P2,GAM,GAMB)
31688 C********************************************************************
31690 C calculate successive Lorentz boots for arbitrary Lorentz trans.
31692 C input: P1 initial 4 vector
31693 C GAM(3),GAMB(3) Lorentz boost parameters
31695 C output: P2 final 4 vector
31697 C********************************************************************
31698 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31701 DIMENSION P1(4),P2(4),GAM(3),GAMB(3)
31705 P2(I)=GAM(I)*P1(I)+GAMB(I)*P2(4)
31706 P2(4)=GAM(I)*P2(4)+GAMB(I)*P1(I)
31710 *$ CREATE PHO_GETLTR.FOR
31712 CDECK ID>, PHO_GETLTR
31713 SUBROUTINE PHO_GETLTR(P1,P2,GAM,GAMB,DELE,IREJ)
31714 C********************************************************************
31716 C calculate Lorentz boots for arbitrary Lorentz transformation
31718 C input: P1 initial 4 vector
31719 C P2 final 4 vector
31721 C output: GAM(3),GAMB(3)
31722 C DELE energy deviation
31726 C********************************************************************
31727 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31730 PARAMETER ( DREL = 0.001D0 )
31732 C input/output channels
31734 COMMON /POINOU/ LI,LO
31736 DIMENSION P1(4),P2(4),GAM(3),GAMB(3),PA(4),PP(4)
31743 PM1 = P1(4)**2-P1(1)**2-P1(2)**2-P1(3)**2
31746 PP(4) = PM1+PP(1)**2+PP(2)**2+PP(3)**2
31747 IF(PP(4).LE.0.D0) RETURN
31748 PP(4) = SQRT(PP(4))
31749 GAMB(I) = (SQRT(PA(4)**2-PA(I)**2+PP(I)**2)*PP(I)
31750 & -PA(4)*PA(I))/(PA(4)**2+PP(I)**2)
31751 GAM(I) = 1.D0/SQRT(1.D0-GAMB(I)**2)
31752 GAMB(I) = GAMB(I)*GAM(I)
31759 C consistency check
31760 * IF(ABS(P2(4)-PP(4))/MAX(P2(4),PP(4)).GT.DREL) THEN
31761 * PM2 = P2(4)**2-P2(1)**2-P2(2)**2-P2(3)**2
31762 * WRITE(LO,'(/1X,A,2E12.5)')
31763 * & 'PHO_GETLTR: INCONSISTENT ENERGIES',P2(4),PP(4)
31764 * WRITE(LO,'(1X,A,2E12.4)') 'INPUT MASSES',PM1,PM2
31765 * WRITE(LO,'(1X,A,4E12.4)') 'INPUT ',P1
31766 * WRITE(LO,'(1X,A,4E12.4)') 'OUTPUT',P2
31767 * WRITE(LO,'(1X,A,4E12.4)') 'INTERN',PP
31771 *$ CREATE PHO_ALTRA.FOR
31773 CDECK ID>, PHO_ALTRA
31774 SUBROUTINE PHO_ALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
31775 C*********************************************************************
31777 C arbitrary Lorentz transformation
31779 C*********************************************************************
31780 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31783 EP=PCX*BGX+PCY*BGY+PCZ*BGZ
31788 P=SQRT(PX*PX+PY*PY+PZ*PZ)
31793 *$ CREATE PHO_LTRANS.FOR
31795 CDECK ID>, PHO_LTRANS
31796 SUBROUTINE PHO_LTRANS(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
31797 & PL,CXL,CYL,CZL,EL)
31798 C**********************************************************************
31800 C Lorentz transformation into lab - system
31802 C**********************************************************************
31803 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31806 PARAMETER ( TINY=1.D-08,TINY2=1.D-30 )
31808 C input/output channels
31810 COMMON /POINOU/ LI,LO
31812 SID=SQRT(1.D0-COD*COD)
31816 PLZ=GAM*PCMZ+BGAM*ECM
31817 PL=SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
31818 EL=GAM*ECM+BGAM*PCMZ
31820 C rotation into the original direction
31822 SIZ=SQRT(MAX((1.D0-COZ)*(1.D0+COZ),0.D0))
31824 * CALL PHO_DTRANS(CX,CY,CZ,COZ,SIZ,COF,SIF,CXL,CYL,CZL)
31835 IF (ABS(CX)-TINY) 1,1,2
31836 1 IF (ABS(CY)-TINY) 3,3,2
31839 * WRITE(LO,*) ' PHO_DTRANS CX CY CZ =',CX,CY,CZ
31843 * WRITE(LO,*) ' PHO_DTRANS CXL=SIZ*COF CYL=SIZ*SIF CZL=COZ'
31844 * WRITE(LO,*) CXL,CYL,CZL
31848 IF(AMAX.GT.TINY2) THEN
31851 A=AMAX*SQRT(1.D0+AR)
31853 * WRITE(LO,*) ' PHO_DTRANS AMAX LE TINY2 '
31859 CXL=-CY*XI/A-CZ*CX*YI/A+CX*ZI
31860 CYL=CX*XI/A-CZ*CY*YI/A+CY*ZI
31865 *$ CREATE PHO_TRANS.FOR
31867 CDECK ID>, PHO_TRANS
31868 SUBROUTINE PHO_TRANS(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
31869 C**********************************************************************
31871 C rotation of coordinate frame (1) de rotation around y axis
31872 C (2) fe rotation around z axis
31873 C (inverse rotation to PHO_TRANI)
31875 C**********************************************************************
31876 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31879 X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
31880 Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
31881 Z=-SDE *XO +CDE *ZO
31885 *$ CREATE PHO_TRANI.FOR
31887 CDECK ID>, PHO_TRANI
31888 SUBROUTINE PHO_TRANI(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
31889 C**********************************************************************
31891 C rotation of coordinate frame (1) -fe rotation around z axis
31892 C (2) -de rotation around y axis
31893 C (inverse rotation to PHO_TRANS)
31895 C**********************************************************************
31896 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31899 X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
31901 Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
31905 *$ CREATE pho_cpcini.FOR
31907 CDECK ID>, pho_cpcini
31908 SUBROUTINE pho_cpcini(Nrows,Number,List)
31909 C***********************************************************************
31911 C initialization of particle hash table
31913 C input: Number vector with Nrows entries according to PDG
31916 C output: List vector with hash table
31918 C (this code is based on the function initpns written by
31919 C Gerry Lynch, LBL, January 1990)
31921 C***********************************************************************
31925 C input/output channels
31927 COMMON /POINOU/ LI,LO
31929 integer Number(*),List(*),Nrows
31931 Integer Nin,Nout,Ip,I
31937 C Loop over all of the elements in the Number vector
31939 Do 500 Ip = 1,Nrows
31942 C Calculate a list number for this particle id number
31943 If(Nin.Gt.99999.or.Nin.Le.0) Then
31945 Else If(Nin.Le.577) Then
31948 Nout = Mod(Nin,577)
31954 C Count the bad entries
31955 WRITE(LO,'(1x,a,i10)')
31956 & 'pho_cpcini: invalid particle ID',Nin
31959 If(List(Nout).eq.0) Then
31962 If(Nin.eq.Number(List(Nout))) Then
31963 WRITE(LO,'(1x,a,i10)')
31964 & 'pho_cpcini: double particle ID',Nin
31967 If(Nout.Gt.577) Nout = Mod(Nout, 577)
31975 *$ CREATE ipho_pdg2id.FOR
31977 CDECK ID>, ipho_pdg2id
31978 INTEGER FUNCTION ipho_pdg2id(IDpdg)
31979 C**********************************************************************
31981 C calculation internal particle code using the particle index i
31982 C according to the PDG proposal.
31984 C input: IDpdg PDG particle number
31985 C output: ipho_pdg2id internal particle code
31986 C (0 for invalid IDpdg)
31988 C the hash algorithm is based on a program by Gerry Lynch
31990 C**********************************************************************
31996 C input/output channels
31998 COMMON /POINOU/ LI,LO
31999 C event debugging information
32001 PARAMETER (NMAXD=100)
32002 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32003 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32004 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32005 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32006 C particle ID translation table
32007 integer ID_pdg_list,ID_list,ID_pdg_max
32008 character*12 name_list
32009 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32016 if((Nin.gt.99999).or.(Nin.eq.0)) then
32017 C invalid particle number
32018 if(ideb(71).gt.5) WRITE(LO,'(1x,A,I10)')
32019 & 'ipho_pdg2id: invalid PDG ID number ',IDpdg
32022 else If(Nin.le.577) then
32026 C use hash algorithm
32027 Nout = mod(Nin,577)
32032 C particle not in table
32033 if(ID_list(Nout).Eq.0) then
32034 if(ideb(71).ge.0) WRITE(LO,'(1x,A,I10)')
32035 & 'ipho_pdg2id: particle not in table ',IDpdg
32040 if(ID_pdg_list(ID_list(Nout)).eq.Nin) then
32041 C particle ID found
32042 ipho_pdg2id = sign(ID_list(Nout),IDpdg)
32045 C increment and try again
32047 If(Nout.gt.577) Nout = Mod(Nout,577)
32053 *$ CREATE IPHO_ID2PDG.FOR
32055 CDECK ID>, IPHO_ID2PDG
32056 INTEGER FUNCTION ipho_id2pdg(IDcpc)
32057 C**********************************************************************
32059 C conversion of internal particle code to PDG standard
32061 C input: IDcpc internal particle number
32062 C output: ipho_id2pdg PDG particle number
32063 C (0 for invalid IDcpc)
32065 C**********************************************************************
32071 C input/output channels
32073 COMMON /POINOU/ LI,LO
32074 C event debugging information
32076 PARAMETER (NMAXD=100)
32077 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32078 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32079 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32080 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32081 C particle ID translation table
32082 integer ID_pdg_list,ID_list,ID_pdg_max
32083 character*12 name_list
32084 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32090 if((IDabs.lt.1).or.(IDabs.gt.ID_pdg_max)) then
32095 ipho_id2pdg = sign(ID_pdg_list(IDabs),IDcpc)
32099 *$ CREATE IPHO_LU2PDG.FOR
32101 CDECK ID>, IPHO_LU2PDG
32102 INTEGER FUNCTION IPHO_LU2PDG(LUKF)
32103 C**********************************************************************
32105 C conversion of JETSET KF code to PDG code
32107 C**********************************************************************
32108 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32110 PARAMETER (NTAB=10)
32111 DIMENSION LU2PD(2,NTAB)
32112 DATA LU2PD / 4232, 4322,
32124 IF(LU2PD(1,I).EQ.LUKF) THEN
32125 IPHO_LU2PDG=LU2PD(2,I)
32133 *$ CREATE IPHO_PDG2LU.FOR
32135 CDECK ID>, IPHO_PDG2LU
32136 INTEGER FUNCTION IPHO_PDG2LU(IPDG)
32137 C**********************************************************************
32139 C conversion of PDG code to JETSET code
32141 C**********************************************************************
32142 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32145 DIMENSION LU2PD(2,NTAB)
32146 DATA LU2PD / 4232, 4322,
32156 IF(LU2PD(2,I).EQ.IPDG) THEN
32157 IPHO_PDG2LU=LU2PD(1,I)
32165 *$ CREATE pho_pname.FOR
32167 CDECK ID>, pho_pname
32168 CHARACTER*15 FUNCTION pho_pname(ID,mode)
32169 C***********************************************************************
32171 C returns particle name for given ID number
32173 C input: ID particle ID number
32174 C mode 0: ID treated as compressed particle code
32175 C 1: ID treated as PDG number
32177 C***********************************************************************
32183 C input/output channels
32185 COMMON /POINOU/ LI,LO
32186 C standard particle data interface
32188 PARAMETER (NMXHEP=4000)
32189 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32190 DOUBLE PRECISION PHEP,VHEP
32191 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32192 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32194 C extension to standard particle data interface (PHOJET specific)
32195 INTEGER IMPART,IPHIST,ICOLOR
32196 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32197 C particle ID translation table
32198 integer ID_pdg_list,ID_list,ID_pdg_max
32199 character*12 name_list
32200 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32202 C general particle data
32203 double precision xm_list,tau_list,gam_list,
32204 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32205 & xm_bb82_list,xm_bb102_list
32206 integer ich3_list,iba3_list,iq_list,
32207 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32208 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32209 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32210 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32211 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32212 & ich3_list(300),iba3_list(300),iq_list(3,300),
32213 & id_psm_list(6,6),id_vem_list(6,6),
32214 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32216 C external functions
32217 integer ipho_id2pdg,ipho_pdg2id
32220 integer IDpdg,i,ii,k,l,ichar,i_anti
32223 pho_pname = '(?????????????)'
32227 IDpdg = ipho_id2pdg(ID)
32228 if(IDpdg.eq.0) return
32229 else if(mode.eq.1) then
32230 i = ipho_pdg2id(ID)
32233 else if(mode.eq.2) then
32234 if(ISTHEP(ID).gt.11) then
32235 if(ISTHEP(ID).eq.20) then
32236 pho_pname = 'hard ini. part.'
32237 else if(ISTHEP(ID).eq.21) then
32238 pho_pname = 'hard fin. part.'
32239 else if(ISTHEP(ID).eq.25) then
32240 pho_pname = 'hard scattering'
32241 else if(ISTHEP(ID).eq.30) then
32242 pho_pname = 'diff. diss. '
32243 else if(ISTHEP(ID).eq.35) then
32244 pho_pname = 'elastic scatt. '
32245 else if(ISTHEP(ID).eq.40) then
32246 pho_pname = 'central scatt. '
32253 WRITE(LO,'(1x,a,2i4)')
32254 & 'pho_pname: invalid arguments (ID,mode): ',ID,mode
32259 if((ii.eq.0).or.(ii.gt.ID_pdg_max)) return
32261 name = name_list(ii)
32262 ichar = ich3_list(ii)*sign(1,i)
32263 if(mod(ichar,3).ne.0) then
32269 C find position of first blank character
32273 if(name(k:k).ne.' ') goto 100
32275 C append anti-particle sign
32279 i_anti = i_anti+iq_list(l,ii)
32281 if(iba3_list(ii).ne.0) then
32284 else if(((i_anti.ne.0).and.(ichar.eq.0))
32285 & .or.(IDpdg.eq.-12)
32286 & .or.(IDpdg.eq.-14)
32287 & .or.(IDpdg.eq.-16)) then
32293 C append charge sign
32294 if(ichar.eq.-2) then
32296 else if(ichar.eq.-1) then
32298 else if(ichar.eq.1) then
32300 else if(ichar.eq.2) then
32308 *$ CREATE ipho_anti.FOR
32310 CDECK ID>, ipho_anti
32311 INTEGER FUNCTION ipho_anti(ID)
32312 C**********************************************************************
32314 C determine antiparticle for given ID
32316 C input: ID gives CPC particle number
32318 C output: ipho_anti antiparticle code
32320 C**********************************************************************
32326 C input/output channels
32328 COMMON /POINOU/ LI,LO
32329 C event debugging information
32331 PARAMETER (NMAXD=100)
32332 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32333 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32334 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32335 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32336 C particle ID translation table
32337 integer ID_pdg_list,ID_list,ID_pdg_max
32338 character*12 name_list
32339 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32341 C general particle data
32342 double precision xm_list,tau_list,gam_list,
32343 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32344 & xm_bb82_list,xm_bb102_list
32345 integer ich3_list,iba3_list,iq_list,
32346 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32347 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32348 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32349 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32350 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32351 & ich3_list(300),iba3_list(300),iq_list(3,300),
32352 & id_psm_list(6,6),id_vem_list(6,6),
32353 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32354 C standard particle data interface
32356 PARAMETER (NMXHEP=4000)
32357 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32358 DOUBLE PRECISION PHEP,VHEP
32359 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32360 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32362 C extension to standard particle data interface (PHOJET specific)
32363 INTEGER IMPART,IPHIST,ICOLOR
32364 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32366 C external functions
32367 integer ipho_id2pdg,ipho_pdg2id
32370 integer IDabs,IDpdg,i_anti,l
32376 if(iba3_list(IDabs).ne.0) return
32378 C charged particles
32379 if(ich3_list(IDabs).ne.0) return
32382 IDpdg = ipho_id2pdg(ID)
32383 if(IDpdg.eq.310) then
32384 ID = ipho_pdg2id(130)
32386 else if(IDpdg.eq.130) then
32387 ID = ipho_pdg2id(310)
32391 C neutral mesons with open strangeness, charm, or beauty
32394 i_anti = i_anti+iq_list(l,IDabs)
32396 if(i_anti.ne.0) return
32400 if((IDpdg.eq.12).or.(IDpdg.eq.14).or.(IDpdg.eq.16)) return
32406 *$ CREATE ipho_chr3.FOR
32408 CDECK ID>, ipho_chr3
32409 INTEGER FUNCTION ipho_chr3(ID,mode)
32410 C**********************************************************************
32412 C output of three times the electric charge
32415 C 0 ID gives CPC particle number
32416 C 1 ID gives PDG particle number
32417 C 2 ID gives position of particle in /POEVT1/
32419 C**********************************************************************
32425 C input/output channels
32427 COMMON /POINOU/ LI,LO
32428 C event debugging information
32430 PARAMETER (NMAXD=100)
32431 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32432 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32433 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32434 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32435 C standard particle data interface
32437 PARAMETER (NMXHEP=4000)
32438 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32439 DOUBLE PRECISION PHEP,VHEP
32440 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32441 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32443 C extension to standard particle data interface (PHOJET specific)
32444 INTEGER IMPART,IPHIST,ICOLOR
32445 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32446 C particle ID translation table
32447 integer ID_pdg_list,ID_list,ID_pdg_max
32448 character*12 name_list
32449 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32451 C general particle data
32452 double precision xm_list,tau_list,gam_list,
32453 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32454 & xm_bb82_list,xm_bb102_list
32455 integer ich3_list,iba3_list,iq_list,
32456 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32457 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32458 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32459 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32460 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32461 & ich3_list(300),iba3_list(300),iq_list(3,300),
32462 & id_psm_list(6,6),id_vem_list(6,6),
32463 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32465 C external functions
32466 integer ipho_pdg2id
32475 else if(mode.eq.1) then
32476 i = ipho_pdg2id(ID)
32479 else if(mode.eq.2) then
32480 if(ISTHEP(ID).gt.11) return
32483 IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32484 ipho_chr3 = ICOLOR(1,ID)
32488 WRITE(LO,'(1x,a,2i4)')
32489 & 'ipho_chr3: invalid mode (ID,mode): ',ID,mode
32493 if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32494 WRITE(LO,'(1x,a,3i8)')
32495 & 'ipho_chr3: invalid arguments (ID,mode,i): ',ID,mode,i
32496 ipho_chr3 = 1.D0/dble(i)
32501 ipho_chr3 = ich3_list(iabs(i))*sign(1,i)
32505 *$ CREATE ipho_bar3.FOR
32507 CDECK ID>, ipho_bar3
32508 INTEGER FUNCTION ipho_bar3(ID,mode)
32509 C**********************************************************************
32511 C output of three times the baryon charge
32514 C 0 ID gives CPC particle number
32515 C 1 ID gives PDG particle number
32516 C 2 ID gives position of particle in /POEVT1/
32518 C**********************************************************************
32524 C input/output channels
32526 COMMON /POINOU/ LI,LO
32527 C event debugging information
32529 PARAMETER (NMAXD=100)
32530 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32531 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32532 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32533 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32534 C standard particle data interface
32536 PARAMETER (NMXHEP=4000)
32537 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32538 DOUBLE PRECISION PHEP,VHEP
32539 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32540 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32542 C extension to standard particle data interface (PHOJET specific)
32543 INTEGER IMPART,IPHIST,ICOLOR
32544 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32545 C particle ID translation table
32546 integer ID_pdg_list,ID_list,ID_pdg_max
32547 character*12 name_list
32548 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32550 C general particle data
32551 double precision xm_list,tau_list,gam_list,
32552 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32553 & xm_bb82_list,xm_bb102_list
32554 integer ich3_list,iba3_list,iq_list,
32555 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32556 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32557 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32558 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32559 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32560 & ich3_list(300),iba3_list(300),iq_list(3,300),
32561 & id_psm_list(6,6),id_vem_list(6,6),
32562 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32564 C external functions
32565 integer ipho_pdg2id
32574 else if(mode.eq.1) then
32575 i = ipho_pdg2id(ID)
32578 else if(mode.eq.2) then
32579 if(ISTHEP(ID).gt.11) return
32582 IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32583 ipho_bar3 = ICOLOR(2,ID)
32587 WRITE(LO,'(1x,a,2i4)')
32588 & 'ipho_bar3: invalid mode (ID,mode): ',ID,mode
32592 if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32593 WRITE(LO,'(1x,a,3i8)')
32594 & 'ipho_bar3: invalid arguments (ID,mode,i): ',ID,mode,i
32595 ipho_bar3 = 1.D0/dble(i)
32599 ipho_bar3 = iba3_list(iabs(i))*sign(1,i)
32603 *$ CREATE pho_pmass.FOR
32605 CDECK ID>, pho_pmass
32606 DOUBLE PRECISION FUNCTION pho_pmass(ID,mode)
32607 C***********************************************************************
32611 C input: mode -1 initialization
32612 C 0 ID gives CPC particle number
32613 C 1 ID gives PDG particle number,
32614 C (for quarks current masses are returned)
32615 C 2 ID gives position of particle in /POEVT1/
32616 C 3 ID gives PDG parton number,
32617 C (for quarks constituent masses are returned)
32619 C output: average particle mass (in GeV)
32621 C***********************************************************************
32625 integer ID,mode,MSTJ24
32627 C input/output channels
32629 COMMON /POINOU/ LI,LO
32630 C event debugging information
32632 PARAMETER (NMAXD=100)
32633 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32634 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32635 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32636 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32637 C model switches and parameters
32639 INTEGER ISWMDL,IPAMDL
32640 DOUBLE PRECISION PARMDL
32641 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
32642 C standard particle data interface
32644 PARAMETER (NMXHEP=4000)
32645 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32646 DOUBLE PRECISION PHEP,VHEP
32647 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32648 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32650 C extension to standard particle data interface (PHOJET specific)
32651 INTEGER IMPART,IPHIST,ICOLOR
32652 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32653 C particle ID translation table
32654 integer ID_pdg_list,ID_list,ID_pdg_max
32655 character*12 name_list
32656 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32658 C general particle data
32659 double precision xm_list,tau_list,gam_list,
32660 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32661 & xm_bb82_list,xm_bb102_list
32662 integer ich3_list,iba3_list,iq_list,
32663 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32664 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32665 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32666 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32667 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32668 & ich3_list(300),iba3_list(300),iq_list(3,300),
32669 & id_psm_list(6,6),id_vem_list(6,6),
32670 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32672 DOUBLE PRECISION PARU,PARJ
32673 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32675 C external functions
32676 integer ipho_pdg2id,ipho_id2pdg
32677 DOUBLE PRECISION PYMASS
32686 else if(mode.eq.1) then
32687 i = ipho_pdg2id(ID)
32689 else if(mode.eq.2) then
32690 if(ISTHEP(ID).gt.11) return
32693 IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32694 pho_pmass = PHEP(5,ID)
32697 else if(mode.eq.3) then
32699 if((i.gt.0).and.(i.le.6)) then
32700 pho_pmass = PARMDL(150+i)
32703 i = ipho_pdg2id(ID)
32706 else if(mode.eq.-1) then
32707 C initialization: take masses for quarks and di-quarks from JETSET
32711 IDpdg = ipho_id2pdg(i)
32712 xm_list(i) = PYMASS(IDpdg)
32717 WRITE(LO,'(1x,a,2i4)')
32718 & 'pho_pmass: invalid arguments (ID,mode): ',ID,mode
32722 if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32723 WRITE(LO,'(1x,a,2i8)')
32724 & 'pho_pmass: invalid arguments (ID,mode): ',ID,mode
32725 pho_pmass = 1.D0/dble(i)
32729 pho_pmass = xm_list(iabs(i))
32733 *$ CREATE PHO_MEMASS.FOR
32735 CDECK ID>, PHO_MEMASS
32736 SUBROUTINE PHO_MEMASS(I,J,AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
32737 C**********************************************************************
32739 C determine meson masses corresponding to the input flavours
32741 C input: I,J,K quark flavours (PDG convention)
32743 C output: AMPS pseudo scalar meson mass
32744 C AMPS2 next possible two particle configuration
32745 C (two pseudo scalar mesons)
32746 C AMVE vector meson mass
32747 C AMVE2 next possible two particle configuration
32748 C (two vector mesons)
32749 C IPS,IVE meson numbers in CPC
32751 C**********************************************************************
32755 integer I,J,IPS,IVE
32756 double precision AMPS,AMPS2,AMVE,AMVE2
32758 C input/output channels
32760 COMMON /POINOU/ LI,LO
32761 C event debugging information
32763 PARAMETER (NMAXD=100)
32764 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32765 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32766 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32767 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32768 C particle ID translation table
32769 integer ID_pdg_list,ID_list,ID_pdg_max
32770 character*12 name_list
32771 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32773 C general particle data
32774 double precision xm_list,tau_list,gam_list,
32775 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32776 & xm_bb82_list,xm_bb102_list
32777 integer ich3_list,iba3_list,iq_list,
32778 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32779 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32780 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32781 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32782 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32783 & ich3_list(300),iba3_list(300),iq_list(3,300),
32784 & id_psm_list(6,6),id_vem_list(6,6),
32785 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32799 IPS = id_psm_list(ii,jj)
32800 IVE = id_vem_list(ii,jj)
32803 AMPS = xm_list(iabs(IPS))
32808 AMVE = xm_list(iabs(IVE))
32813 C next possible two-particle configurations (add phase space)
32814 AMPS2 = xm_psm2_list(ii,jj)*1.5D0
32815 AMVE2 = xm_vem2_list(ii,jj)*1.1D0
32819 *$ CREATE PHO_BAMASS.FOR
32821 CDECK ID>, PHO_BAMASS
32822 SUBROUTINE PHO_BAMASS(I,J,K,AM8,AM82,AM10,AM102,I8,I10)
32823 C**********************************************************************
32825 C determine baryon masses corresponding to the input flavours
32827 C input: I,J,K quark flavours (PDG convention)
32829 C output: AM8 octett baryon mass
32830 C AM82 next possible two particle configuration
32831 C (octett baryon and meson)
32832 C AM10 decuplett baryon mass
32833 C AM102 next possible two particle configuration
32834 C (decuplett baryon and meson,
32835 C baryon built up from first two quarks)
32836 C I8,I10 internal baryon numbers
32838 C**********************************************************************
32842 integer I,J,K,I8,I10
32843 double precision AM8,AM82,AM10,AM102
32845 C input/output channels
32847 COMMON /POINOU/ LI,LO
32848 C event debugging information
32850 PARAMETER (NMAXD=100)
32851 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32852 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32853 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32854 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32855 C particle ID translation table
32856 integer ID_pdg_list,ID_list,ID_pdg_max
32857 character*12 name_list
32858 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32860 C general particle data
32861 double precision xm_list,tau_list,gam_list,
32862 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32863 & xm_bb82_list,xm_bb102_list
32864 integer ich3_list,iba3_list,iq_list,
32865 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32866 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32867 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32868 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32869 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32870 & ich3_list(300),iba3_list(300),iq_list(3,300),
32871 & id_psm_list(6,6),id_vem_list(6,6),
32872 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32877 C find particle ID's
32881 I8 = id_b8_list(ii,jj,kk)
32882 I10 = id_b10_list(ii,jj,kk)
32884 C masses (if combination possible)
32892 AM10 = xm_list(I10)
32898 C next possible two-particle configurations (add phase space)
32899 AM82 = xm_b82_list(ii,jj,kk)*1.5D0
32900 AM102 = xm_b102_list(ii,jj,kk)*1.1D0
32904 *$ CREATE PHO_DQMASS.FOR
32906 CDECK ID>, PHO_DQMASS
32907 SUBROUTINE PHO_DQMASS(I,J,K,L,AM82,AM102)
32908 C**********************************************************************
32910 C determine minimal masses corresponding to the input flavours
32911 C (diquark a-diquark string system)
32913 C input: I,J,K,L quark flavours (PDG convention)
32915 C output: AM82 mass of two octett baryons
32916 C AM102 mass of two decuplett baryons
32918 C**********************************************************************
32923 double precision AM82,AM102
32925 C input/output channels
32927 COMMON /POINOU/ LI,LO
32928 C event debugging information
32930 PARAMETER (NMAXD=100)
32931 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32932 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32933 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32934 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32935 C general particle data
32936 double precision xm_list,tau_list,gam_list,
32937 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32938 & xm_bb82_list,xm_bb102_list
32939 integer ich3_list,iba3_list,iq_list,
32940 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
32941 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32942 & xm_psm2_list(6,6),xm_vem2_list(6,6),
32943 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32944 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32945 & ich3_list(300),iba3_list(300),iq_list(3,300),
32946 & id_psm_list(6,6),id_vem_list(6,6),
32947 & id_b8_list(6,6,6),id_b10_list(6,6,6)
32950 integer ii,jj,kk,ll
32957 AM82 = xm_bb82_list(ii,jj,kk,ll)
32958 AM102 = xm_bb102_list(ii,jj,kk,ll)
32962 *$ CREATE PHO_CHECK.FOR
32964 CDECK ID>, PHO_CHECK
32965 SUBROUTINE PHO_CHECK(MD,IDEV)
32966 C**********************************************************************
32968 C check quantum numbers of entries in /POEVT1/ and /POEVT2/
32969 C (energy, momentum, charge, baryon number conservation)
32971 C input: MD -1 check overall momentum conservation
32972 C and perform detailed check only in case of
32974 C 1 test all branchings, mother-daughter
32977 C output: IDEV 0 no deviations
32978 C 1 deviations found
32980 C**********************************************************************
32981 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32984 C input/output channels
32986 COMMON /POINOU/ LI,LO
32987 C event debugging information
32989 PARAMETER (NMAXD=100)
32990 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32991 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32992 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32993 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32994 C model switches and parameters
32996 INTEGER ISWMDL,IPAMDL
32997 DOUBLE PRECISION PARMDL
32998 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
32999 C global event kinematics and particle IDs
33000 INTEGER IFPAP,IFPAB
33001 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
33002 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
33003 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
33004 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
33005 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
33006 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
33007 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
33008 C standard particle data interface
33010 PARAMETER (NMXHEP=4000)
33011 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33012 DOUBLE PRECISION PHEP,VHEP
33013 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33014 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33016 C extension to standard particle data interface (PHOJET specific)
33017 INTEGER IMPART,IPHIST,ICOLOR
33018 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33019 C color string configurations including collapsed strings and hadrons
33021 PARAMETER (MSTR=500)
33022 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33023 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33024 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33025 & NNCH(MSTR),IBHAD(MSTR),ISTR
33027 C count number of errors to avoid disk overflow
33031 C conservation check suppressed
33032 IF((IPAMDL(15).EQ.0).OR.(IDEB(20).LE.-10)) RETURN
33034 IF(IPAMDL(13).GT.0) THEN
33036 C DPMJET call with x limitations
33038 ECM1 = SQRT(XPSUB*XTSUB)*ECM
33044 C first two entries are considered as scattering particles
33045 EE1 = PHEP(4,1) + PHEP(4,2)
33046 PX1 = PHEP(1,1) + PHEP(1,2)
33047 PY1 = PHEP(2,1) + PHEP(2,2)
33048 PZ1 = PHEP(3,1) + PHEP(3,2)
33054 IF(MODE.EQ.-1) GOTO 500
33061 C recognize only decayed particles as mothers
33062 IF(ISTHEP(I).EQ.2) THEN
33063 C search for other mother particles
33066 IF(IPAMDL(178).NE.0)
33067 & WRITE(LO,'(1X,2A,I4)') 'PHO_CHECK: ',
33068 & 'entry marked as decayed but no dauther given:',I
33073 C sum over mother particles
33074 ICH1 = IPHO_CHR3(K1,2)
33075 IBA1 = IPHO_BAR3(K1,2)
33082 IF((K1.GT.I).OR.(K2.LT.I)) THEN
33083 WRITE(LO,'(/,1X,2A,3I4)') 'PHO_CHECK: ',
33084 & 'inconsistent mother/daughter relation found',I,K1,K2
33085 CALL PHO_PREVNT(-1)
33088 IF(ABS(ISTHEP(II)).LE.2) THEN
33089 ICH1 = ICH1 + IPHO_CHR3(II,2)
33090 IBA1 = IBA1 + IPHO_BAR3(II,2)
33091 EE1 = EE1 + PHEP(4,II)
33092 PX1 = PX1 + PHEP(1,II)
33093 PY1 = PY1 + PHEP(2,II)
33094 PZ1 = PZ1 + PHEP(3,II)
33097 ELSE IF((K2.GT.0).AND.(K2.NE.K1)) THEN
33098 ICH1 = ICH1 + IPHO_CHR3(K2,2)
33099 IBA1 = IBA1 + IPHO_BAR3(K2,2)
33100 EE1 = EE1 + PHEP(4,K2)
33101 PX1 = PX1 + PHEP(1,K2)
33102 PY1 = PY1 + PHEP(2,K2)
33103 PZ1 = PZ1 + PHEP(3,K2)
33106 C sum over daughter particles
33113 DO 200 II=JDAHEP(1,I),JDAHEP(2,I)
33114 IF(ABS(ISTHEP(II)).LE.2) THEN
33115 ICH2 = ICH2 + IPHO_CHR3(II,2)
33116 IBA2 = IBA2 + IPHO_BAR3(II,2)
33117 EE2 = EE2 + PHEP(4,II)
33118 PX2 = PX2 + PHEP(1,II)
33119 PY2 = PY2 + PHEP(2,II)
33120 PZ2 = PZ2 + PHEP(3,II)
33124 C conservation check
33125 ESC = MAX(MAX(EE1,EE2)*DDREL,DDABS)
33126 IF(ABS(EE1-EE2).GT.ESC) THEN
33127 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E10.3)')
33128 & 'PHO_CHECK: energy conservation violated for',
33129 & 'entry,initial,final:',I,EE1,EE2
33132 ESC = MAX(MAX(ABS(PX1),ABS(PX2))*DDREL,DDABS)
33133 IF(ABS(PX1-PX2).GT.ESC) THEN
33134 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33135 & 'PHO_CHECK: x-momentum conservation violated for',
33136 & 'entry,initial,final:',I,PX1,PX2
33139 ESC = MAX(MAX(ABS(PY1),ABS(PY2))*DDREL,DDABS)
33140 IF(ABS(PY1-PY2).GT.ESC) THEN
33141 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33142 & 'PHO_CHECK: y-momentum conservation violated for',
33143 & 'entry,initial,final:',I,PY1,PY2
33146 ESC = MAX(MAX(ABS(PZ1),ABS(PZ2))*DDREL,DDABS)
33147 IF(ABS(PZ1-PZ2).GT.ESC) THEN
33148 WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33149 & 'PHO_CHECK: z-momentum conservation violated for',
33150 & 'entry,initial,final:',I,PZ1,PZ2
33153 IF(ICH1.NE.ICH2) THEN
33154 WRITE(LO,'(1X,A,/,5X,A,I3,2X,2I5)')
33155 & 'PHO_CHECK: charge conservation violated for',
33156 & 'entry,initial,final:',I,ICH1,ICH2
33159 IF(IBA1.NE.IBA2) THEN
33160 WRITE(LO,'(1X,2A,/,5X,A,I3,2X,2I5)') 'PHO_CHECK: ',
33161 & 'baryon charge conservation violated for',
33162 & 'entry,initial,final:',I,IBA1,IBA2
33165 IF(IDEB(20).GE.35) THEN
33167 & '(/,1X,A,A,2(2X,I4,A,I4),2(/,5X,A,4E13.4),/5X,A,4I5)')
33168 & 'PHO_CHECK diagnostics:',
33169 & '(1.mother/l.mother,1.daughter/l.daughter):',
33170 & K1,'/',K2,JDAHEP(1,I),'/',JDAHEP(2,I),
33171 & 'mother momenta ',PX1,PY1,PZ1,EE1,
33172 & 'daughter momenta ',PX2,PY2,PZ2,EE2,
33173 & 'charge,baryon no ',ICH1,ICH2,IBA1,IBA2
33178 IF(I.LE.NHEP) GOTO 100
33184 C write complete event in case of deviations
33185 IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
33189 IF(ISWMDL(6).GE.0) CALL PYLIST(1)
33193 C stop after too many errors
33194 IF(IERR.GT.IPAMDL(179)) THEN
33195 WRITE(LO,'(////1X,2A,I6,////)') 'PHO_CHECK:ERROR:',
33196 & 'too many inconsistencies found, program terminated',IERR
33202 C overall check only (less time consuming)
33214 C recognize only existing particles as possible daughters
33215 IF(ABS(ISTHEP(K)).EQ.1) THEN
33216 ICH2 = ICH2 + IPHO_CHR3(K,2)
33217 IBA2 = IBA2 + IPHO_BAR3(K,2)
33218 EE2 = EE2 + PHEP(4,K)
33219 PX2 = PX2 + PHEP(1,K)
33220 PY2 = PY2 + PHEP(2,K)
33221 PZ2 = PZ2 + PHEP(3,K)
33225 C check energy-momentum conservation
33228 IF(IPAMDL(13).GT.0) THEN
33230 C DPMJET call with x limitations
33231 ECM2 = SQRT((EE2-PZ2)*(EE2+PZ2)-PX2**2-PY2**2)
33232 IF(ABS(ECM1-ECM2).GT.ESC) THEN
33233 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33234 & 'PHO_CHECK: c.m. energy conservation violated',
33235 & 'initial/final energy:',ECM1,ECM2
33242 IF(ABS(EE1-EE2).GT.ESC) THEN
33243 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33244 & 'PHO_CHECK: energy conservation violated',
33245 & 'initial/final energy:',EE1,EE2
33248 IF(ABS(PX1-PX2).GT.ESC) THEN
33249 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33250 & 'PHO_CHECK: x-momentum conservation violated',
33251 & 'initial/final x-momentum:',PX1,PX2
33254 IF(ABS(PY1-PY2).GT.ESC) THEN
33255 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33256 & 'PHO_CHECK: y-momentum conservation violated',
33257 & 'initial/final y-momentum:',PY1,PY2
33260 IF(ABS(PZ1-PZ2).GT.ESC) THEN
33261 WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33262 & 'PHO_CHECK: z-momentum conservation violated',
33263 & 'initial/final z-momentum:',PZ1,PZ2
33267 C check of quantum number conservation
33269 ICH1 = IPHO_CHR3(1,2) + IPHO_CHR3(2,2)
33270 IBA1 = IPHO_BAR3(1,2) + IPHO_BAR3(2,2)
33272 IF(ICH1.NE.ICH2) THEN
33273 WRITE(LO,'(1X,A,/,5X,A,2I5)')
33274 & 'PHO_CHECK: charge conservation violated',
33275 & 'initial/final charge sum',ICH1,ICH2
33278 IF(IBA1.NE.IBA2) THEN
33279 WRITE(LO,'(1X,2A,/,5X,A,2I5)') 'PHO_CHECK: ',
33280 & 'baryonic charge conservation violated',
33281 & 'initial/final baryonic charge sum',IBA1,IBA2
33287 C perform detailed checks in case of deviations
33288 IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
33289 IF(IPAMDL(13).GT.0) THEN
33294 WRITE(LO,'(/1X,2A,2E12.4)') 'PHO_CHECK: ',
33295 & 'increasing precision of tests to',DDREL,DDABS
33302 *$ CREATE PHO_ABORT.FOR
33304 CDECK ID>, PHO_ABORT
33305 SUBROUTINE PHO_ABORT
33306 C**********************************************************************
33308 C top MC event generation due to fatal error,
33309 C print all information of event generation and history
33311 C**********************************************************************
33312 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33315 C input/output channels
33317 COMMON /POINOU/ LI,LO
33318 C event debugging information
33320 PARAMETER (NMAXD=100)
33321 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33322 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33323 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33324 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33325 C model switches and parameters
33327 INTEGER ISWMDL,IPAMDL
33328 DOUBLE PRECISION PARMDL
33329 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33330 C standard particle data interface
33332 PARAMETER (NMXHEP=4000)
33333 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33334 DOUBLE PRECISION PHEP,VHEP
33335 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33336 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33338 C extension to standard particle data interface (PHOJET specific)
33339 INTEGER IMPART,IPHIST,ICOLOR
33340 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33341 C color string configurations including collapsed strings and hadrons
33343 PARAMETER (MSTR=500)
33344 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33345 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33346 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33347 & NNCH(MSTR),IBHAD(MSTR),ISTR
33348 C light-cone x fractions and c.m. momenta of soft cut string ends
33350 PARAMETER ( MAXSOF = 50 )
33351 INTEGER IJSI2,IJSI1
33352 DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
33353 COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
33354 & PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
33355 & IJSI1(MAXSOF),IJSI2(MAXSOF)
33356 C hard scattering data
33358 PARAMETER ( MSCAHD = 50 )
33359 INTEGER LSCAHD,LSC1HD,LSIDX,
33360 & NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
33361 DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
33362 COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
33363 & PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
33364 & Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
33365 & XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
33366 & NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
33367 & NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
33368 & NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
33370 WRITE(LO,'(//,1X,A,/,1X,A)')
33371 & 'PHO_ABORT: program execution stopped',
33372 & '===================================='
33373 WRITE(LO,'(/,1X,A,/,1X,A)') 'listing of available data follows:'
33375 CALL PHO_SETMDL(0,0,-2)
33376 CALL PHO_PREVNT(-1)
33377 CALL PHO_ACTPDF(0,-2)
33378 C print selected parton flavours
33379 WRITE(LO,'(1X,A,I4)') 'selected soft flavours: ',KSOFT
33381 WRITE(LO,'(10X,2I5)') IJSI1(I),IJSI2(I)
33383 WRITE(LO,'(1X,A,I4)') 'selected hard flavours: ',KHARD
33386 WRITE(LO,'(10X,A,I5)') 'process:',NPROHD(I)
33387 WRITE(LO,'(10X,A,2I4,7X,A,2I4)') 'initial:',NINHD(I,1),
33388 & NINHD(I,2),'final:',NOUTHD(I,1),NOUTHD(I,2)
33390 C print selected parton momenta
33391 WRITE(LO,'(1X,A,I4)') 'selected soft momenta: ',KSOFT
33393 WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PSOFT1(II,I),II=1,4)
33394 WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PSOFT2(II,I),II=1,4)
33396 WRITE(LO,'(1X,A,I4)') 'selected hard momenta: ',KHARD
33400 WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PPH(I3+II,1),II=1,4)
33401 WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PPH(I3+II,2),II=1,4)
33407 C fragmentation process
33411 IF(ISWMDL(6).GE.0) CALL PYLIST(1)
33415 WRITE(LO,'(////5X,A,///5X,A,///)')
33416 & 'PHO_ABORT: execution terminated due to fatal error',
33417 &'*** Simulating division by zero to get traceback information ***'
33418 ISTR = 100/IPAMDL(100)
33422 *$ CREATE PHO_TRACE.FOR
33424 CDECK ID>, PHO_TRACE
33425 SUBROUTINE PHO_TRACE(ISTART,ISWI,LEVEL)
33426 C**********************************************************************
33428 C trace program subroutines according to level,
33429 C original output levels will be saved
33431 C input: ISTART first event to trace
33432 C ISWI number of events to trace
33433 C 0 loop call, use old values
33434 C -1 restore original output levels
33435 C 1 store level and wait for event
33436 C LEVEL desired output level
33437 C 0 standard output
33438 C 3 internal rejections
33439 C 5 cross sections, slopes etc.
33440 C 10 parameter of subroutines and
33442 C 20 huge amount of debug output
33443 C 30 maximal possible output
33445 C**********************************************************************
33446 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33449 C input/output channels
33451 COMMON /POINOU/ LI,LO
33452 C event debugging information
33454 PARAMETER (NMAXD=100)
33455 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33456 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33457 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33458 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33460 DIMENSION IMEM(NMAXD)
33466 IF(KEVENT.LT.ION) THEN
33468 ELSE IF(KEVENT.EQ.ION) THEN
33469 WRITE(LO,'(///,1X,A,///)')
33470 & 'PHO_TRACE: trace mode switched on'
33473 IDEB(I) = MAX(ILEVEL,IMEM(I))
33475 ELSE IF(KEVENT.EQ.IOFF) THEN
33476 WRITE(LO,'(//,1X,A,///)')
33477 & 'PHO_TRACE: trace mode switched off'
33482 ELSE IF(ISW.EQ.-1) THEN
33492 C check coincidence
33501 *$ CREATE PHO_PRSTRG.FOR
33503 CDECK ID>, PHO_PRSTRG
33504 SUBROUTINE PHO_PRSTRG
33505 C**********************************************************************
33507 C print information of /POSTRG/
33509 C**********************************************************************
33510 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33513 C input/output channels
33515 COMMON /POINOU/ LI,LO
33516 C event debugging information
33518 PARAMETER (NMAXD=100)
33519 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33520 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33521 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33522 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33523 C standard particle data interface
33525 PARAMETER (NMXHEP=4000)
33526 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33527 DOUBLE PRECISION PHEP,VHEP
33528 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33529 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33531 C extension to standard particle data interface (PHOJET specific)
33532 INTEGER IMPART,IPHIST,ICOLOR
33533 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33534 C color string configurations including collapsed strings and hadrons
33536 PARAMETER (MSTR=500)
33537 INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33538 COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33539 & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33540 & NNCH(MSTR),IBHAD(MSTR),ISTR
33542 WRITE(LO,'(/,1X,A,I5)')
33543 & 'PHO_PRSTRG: number of strings soft+hard:',ISTR
33544 WRITE(LO,'(/,1X,A/,1X,A)') 'COMMON /POSTRG/:',
33545 & ' NOBAM ID1 ID2 ID3 ID4 NPO1/2/3/4 MASS'
33547 & ' ======================================================='
33549 WRITE(LO,'(1X,9I5,1P,E11.3)')
33550 & NCODE(I),IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),NPOS(1,I),
33551 & NPOS(2,I),NPOS(3,I),NPOS(4,I),PHEP(5,NPOS(1,I))
33556 *$ CREATE PHO_PREVNT.FOR
33558 CDECK ID>, PHO_PREVNT
33559 SUBROUTINE PHO_PREVNT(NPART)
33560 C**********************************************************************
33562 C print all information of event generation and history
33564 C input: NPART -1 minimal output: process IDs
33565 C 0 additional output of /POEVT1/
33566 C 1 additional output of /POSTRG/
33567 C 2 additional output of /HEPEVT/
33570 C**********************************************************************
33571 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33574 C input/output channels
33576 COMMON /POINOU/ LI,LO
33577 C event debugging information
33579 PARAMETER (NMAXD=100)
33580 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33581 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33582 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33583 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33584 C model switches and parameters
33586 INTEGER ISWMDL,IPAMDL
33587 DOUBLE PRECISION PARMDL
33588 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33589 C global event kinematics and particle IDs
33590 INTEGER IFPAP,IFPAB
33591 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
33592 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
33593 C general process information
33594 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
33595 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
33596 C standard particle data interface
33598 PARAMETER (NMXHEP=4000)
33599 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33600 DOUBLE PRECISION PHEP,VHEP
33601 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33602 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33604 C extension to standard particle data interface (PHOJET specific)
33605 INTEGER IMPART,IPHIST,ICOLOR
33606 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33607 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
33608 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
33609 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
33610 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
33611 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
33613 CHARACTER*15 PHO_PNAME
33615 IF(NPART.GE.0) WRITE(LO,'(/)')
33616 WRITE(LO,'(1X,A,1PE10.3)')
33617 & 'PHO_PREVNT: c.m. energy',ECM
33618 CALL PHO_SETPAR(-2,IH,NPART,0.D0)
33619 WRITE(LO,'(6X,A,A,/1X,I10,10I6)')
33620 & 'EV-CALL,ISPOM,IHPOM,ISREG,IHDIR,KSTRG,',
33621 & 'KHTRG,KSLOO,KHLOO,KSDPO,KHDPO',
33622 & KEVENT,KSPOM,KHPOM,KSREG,KHDIR,KSTRG,KHTRG,KSLOO,KHLOO,KSDPO,
33624 WRITE(LO,'(6X,A,I4,4I3)')
33625 & 'PROCESS-ID,IDNODF,IDIFF1,IDIFF2,IDDPOM',IPROCE,IDNODF,IDIFR1,
33628 IF(IPAMDL(13).GT.0) THEN
33629 WRITE(LO,'(1X,A)') 'PHO_PREVNT: DPMJET special settings:'
33630 WRITE(LO,'(5X,A,1P,4E11.3)') 'ECMN,PCMN,SECM,SPCM',
33631 & ECMN,PCMN,SECM,SPCM
33632 WRITE(LO,'(5X,A,1P,2E11.3)') 'XPSUB,XTSUB',XPSUB,XTSUB
33635 IF(NPART.LT.0) RETURN
33637 IF(NPART.GE.1) CALL PHO_PRSTRG
33639 WRITE(LO,'(/1X,A)') 'COMMON /POEVT1/:'
33644 WRITE(LO,'(/1X,A,A,/,1X,A,A)')
33645 & ' NO IST NAME MO-1 MO-2 DA-1 DA-2 CHA BAR',
33646 & ' IH1 IH2 CO1 CO2',
33647 & '========================================================',
33648 & '===================='
33650 CH = DBLE(IPHO_CHR3(IH,2)/3.D0)
33651 BA = DBLE(IPHO_BAR3(IH,2)/3.D0)
33652 WRITE(LO,'(1X,2I5,1X,A15,4I5,2F5.1,2I5,2I5)')
33653 & IH,ISTHEP(IH),PHO_PNAME(IH,2),
33654 & JMOHEP(1,IH),JMOHEP(2,IH),JDAHEP(1,IH),JDAHEP(2,IH),
33655 & CH,BA,IPHIST(1,IH),IPHIST(2,IH),
33656 & ICOLOR(1,IH),ICOLOR(2,IH)
33657 IF(ABS(ISTHEP(IH)).EQ.1) THEN
33658 ICHAS = ICHAS + IPHO_CHR3(IH,2)
33659 IBARFS = IBARFS + IPHO_BAR3(IH,2)
33661 IF(ABS(ISTHEP(IH)).EQ.1) THEN
33662 IF(IPHO_CHR3(IH,2).NE.0) IMULC = IMULC+1
33666 WRITE(LO,'(1X,2(3X,A,I3),2X,2(5X,A,I5))') 'sum charge:',ICHAS/3,
33667 & 'baryon:',IBARFS/3,'chr.mult:',IMULC,'tot.mult:',IMUL
33675 IF( (ABS(PHEP(3,IN)).LT.99999.D0)
33676 & .AND.(PHEP(4,IN).LT.99999.D0)) THEN
33677 WRITE(LO,8) IN,ISTHEP(IN),PHO_PNAME(IN,2),
33678 & (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
33680 WRITE(LO,11) IN,ISTHEP(IN),PHO_PNAME(IN,2),
33681 & (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
33683 IF(ABS(ISTHEP(IN)).EQ.1) THEN
33684 PXS = PXS + PHEP(1,IN)
33685 PYS = PYS + PHEP(2,IN)
33686 PZS = PZS + PHEP(3,IN)
33687 P0S = P0S + PHEP(4,IN)
33690 AMFS = P0S**2-PXS**2-PYS**2-PZS**2
33691 AMFS = SIGN(SQRT(ABS(AMFS)),AMFS)
33692 IF(P0S.LT.99999.D0) THEN
33693 WRITE(LO,10) ' sum: ',PXS,PYS,PZS,P0S,AMFS
33695 WRITE(LO,12) ' sum: ',PXS,PYS,PZS,P0S,AMFS
33699 5 FORMAT(2X,8H NUMBER ,8H STATUS ,8H IDENT. ,
33700 & 8H 1.MOTH.,8H 2.MOTH.,8H 1.DAUG.,8H L.DAUG.,
33701 & 8H CHARGE ,8H BARYON ,/)
33702 6 FORMAT(7I8,2F8.3)
33703 7 FORMAT(/,2X,' NR STAT NAME X-MOMENTA',
33704 & ' Y-MOMENTA Z-MOMENTA ENERGY MASS PT',/,
33705 & 2X,'-------------------------------',
33706 & '--------------------------------------------')
33707 8 FORMAT(I5,I4,1X,A15,2F8.3,3F10.3,F8.3)
33708 9 FORMAT(I10,14X,5F10.3)
33709 10 FORMAT(10X,A14,1X,2F8.3,3F10.3)
33710 11 FORMAT(I5,I4,1X,A15,2F8.2,2F10.1,F10.3,F8.3)
33711 12 FORMAT(10X,A14,1X,2F8.2,2F10.1,F10.3)
33713 IF(NPART.GE.2) CALL PYLIST(1)
33717 *$ CREATE PHO_LTRHEP.FOR
33719 CDECK ID>, PHO_LTRHEP
33720 SUBROUTINE PHO_LTRHEP(I1,I2,COD,SID,COF,SIF,GAM,BGX,BGY,BGZ)
33721 C*******************************************************************
33723 C Lorentz transformation of entries I1 to I2 in /POEVT1/
33725 C********************************************************************
33726 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33729 PARAMETER ( DIFF = 0.001D0,
33732 C input/output channels
33734 COMMON /POINOU/ LI,LO
33735 C event debugging information
33737 PARAMETER (NMAXD=100)
33738 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33739 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33740 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33741 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33742 C standard particle data interface
33744 PARAMETER (NMXHEP=4000)
33745 INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33746 DOUBLE PRECISION PHEP,VHEP
33747 COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33748 & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33750 C extension to standard particle data interface (PHOJET specific)
33751 INTEGER IMPART,IPHIST,ICOLOR
33752 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33754 DO 100 I=I1,MIN(I2,NHEP)
33755 IF((ABS(ISTHEP(I)).LE.10).OR.(ISTHEP(I).EQ.21)) THEN
33756 CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
33759 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
33760 & PHEP(1,I),PHEP(2,I),PHEP(3,I),PHEP(4,I))
33761 ELSE IF(ISTHEP(I).EQ.20) THEN
33762 EE=SQRT(PHEP(1,I)**2+PHEP(2,I)**2+PHEP(3,I)**2)
33763 CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
33765 CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
33766 & PHEP(1,I),PHEP(2,I),PHEP(3,I),PMASS)
33771 IF(IDEB(70).LT.1) RETURN
33772 DO 200 I=I1,MIN(NHEP,I2)
33773 IF(ABS(ISTHEP(I)).GT.10) GOTO 190
33774 PMASS = PHEP(4,I)**2-PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
33775 PMASS = SIGN(SQRT(ABS(PMASS)),PMASS)
33776 IF((ABS(PMASS-PHEP(5,I))/MAX(PHEP(5,I),1.D0)).GT.DIFF) THEN
33777 WRITE(LO,'(1X,A,I5,2E13.4)')
33778 & 'PHO_LTRHEP: inconsistent masses:',I,PMASS,PHEP(5,I)
33785 *$ CREATE PHO_PECMS.FOR
33787 CDECK ID>, PHO_PECMS
33788 SUBROUTINE PHO_PECMS(ID,PMASS1,PMASS2,ECM,PP,EE)
33789 C*******************************************************************
33791 C calculation of cms momentum and energy of massive particle
33792 C (ID= 1 using PMASS1, 2 using PMASS2)
33794 C output: PP cms momentum
33795 C EE energy in CMS of particle ID
33797 C********************************************************************
33798 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33801 C input/output channels
33803 COMMON /POINOU/ LI,LO
33804 C event debugging information
33806 PARAMETER (NMAXD=100)
33807 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33808 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33809 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33810 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33812 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
33813 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
33814 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
33817 PM1 = SIGN(PMASS1**2,PMASS1)
33818 PM2 = SIGN(PMASS2**2,PMASS2)
33819 PP = SQRT(S**2 - 2.D0*PM1*S - 2.D0*PM2*S - 2.D0*PM1*PM2
33820 & + PM1**2 + PM2**2)/(2.D0*ECM)
33823 EE = SQRT( PM1 + PP**2 )
33824 ELSE IF(ID.EQ.2) THEN
33825 EE = SQRT( PM2 + PP**2 )
33827 WRITE(LO,'(/1X,A,I3,/)')
33828 & 'PHO_PECMS:ERROR: invalid ID number:',ID
33834 *$ CREATE PHO_FRAINI.FOR
33836 CDECK ID>, PHO_FRAINI
33837 SUBROUTINE PHO_FRAINI(IDEFAU)
33838 C***********************************************************************
33840 C initialization of fragmentation packages
33841 C (currently LUND JETSET)
33843 C initialization for JETSET call in DTUNUC 1.04 (J.R. 6/93)
33844 C changed to work in PHOJET (R.E. 1/94)
33846 C input: IDEFAU 0 no hadronization at all
33847 C 1 do not touch any parameter of JETSET
33848 C 2 default parameters kept, decay length 10mm to
33849 C define stable particles
33850 C 3 load tuned parameters for JETSET 7.3
33851 C neg. value: prevent strange/charm hadrons from decaying
33853 C***********************************************************************
33854 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33857 PARAMETER (EPS=1.D-10)
33859 C input/output channels
33861 COMMON /POINOU/ LI,LO
33863 DOUBLE PRECISION P,V
33864 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
33866 DOUBLE PRECISION PARU,PARJ
33867 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33869 DOUBLE PRECISION PMAS,PARF,VCKM
33870 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33871 INTEGER MDCY,MDME,KFDP
33872 DOUBLE PRECISION BRAT
33873 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
33877 IDEFAB = ABS(IDEFAU)
33879 IF(IDEFAB.EQ.0) THEN
33880 WRITE(LO,'(/1X,A)') 'PHO_FRAINI: hadronization switched off'
33891 C declare stable particles
33892 IF(IDEFAB.GE.2) MSTJ(22) = 2
33894 C load optimized parameters
33895 IF(IDEFAB.GE.3) THEN
33903 C Lund sigma parameter in pt distribution
33908 C prevent particles decaying
33909 IF(IDEFAU.LT.0) THEN
34017 WRITE(LO,2355) IDEFAU,DEF2,PARJ(2),IDEF12,MSTJ(12),
34018 & DEF19,PARJ(19),DEF41,PARJ(41),DEF42,PARJ(42),DEF21,PARJ(21)
34019 2355 FORMAT(/' PHO_FRAINI: fragmentation initialization ISWMDL(6)',I3/,
34020 & ' --------------------------------------------------',/,
34021 & 5X,'parameter description default / current',/,
34022 & 5X,'PARJ( 2) strangeness suppression : ',2F7.3,/,
34023 & 5X,'MSTJ(12) popcorn : ',2I7,/,
34024 & 5X,'PARJ(19) popcorn : ',2F7.3,/,
34025 & 5X,'PARJ(41) Lund a : ',2F7.3,/,
34026 & 5X,'PARJ(42) Lund b : ',2F7.3,/,
34027 & 5X,'PARJ(21) sigma in pt distribution: ',2F7.3,/)
34031 *$ CREATE PHO_SETPAR.FOR
34033 CDECK ID>, PHO_SETPAR
34034 SUBROUTINE pho_setpar(Iside,IDpdg,IDcpc,Pvir)
34035 C**********************************************************************
34037 C assign a particle to either side 1 or 2
34038 C (including special treatment for remnants)
34040 C input: Iside 1,2 side selected for the particle
34041 C -2 output of current settings
34044 C 0 CPC determination in subroutine
34045 C -1 special particle remnant, IDPDG
34046 C is the particle number the remnant
34047 C corresponds to (see /POHDFL/)
34049 C**********************************************************************
34053 integer Iside,IDpdg,IDcpc
34054 double precision Pvir
34056 C input/output channels
34058 COMMON /POINOU/ LI,LO
34059 C event debugging information
34061 PARAMETER (NMAXD=100)
34062 INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
34063 & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34064 COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
34065 & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34066 C global event kinematics and particle IDs
34067 INTEGER IFPAP,IFPAB
34068 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
34069 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
34070 C nucleon-nucleus / nucleus-nucleus interface to DPMJET
34071 INTEGER IDEQP,IDEQB,IHFLD,IHFLS
34072 DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
34073 COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
34074 & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
34075 C particle ID translation table
34076 integer ID_pdg_list,ID_list,ID_pdg_max
34077 character*12 name_list
34078 COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
34080 C general particle data
34081 double precision xm_list,tau_list,gam_list,
34082 & xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
34083 & xm_bb82_list,xm_bb102_list
34084 integer ich3_list,iba3_list,iq_list,
34085 & id_psm_list,id_vem_list,id_b8_list,id_b10_list
34086 COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
34087 & xm_psm2_list(6,6),xm_vem2_list(6,6),
34088 & xm_b82_list(6,6,6),xm_b102_list(6,6,6),
34089 & xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
34090 & ich3_list(300),iba3_list(300),iq_list(3,300),
34091 & id_psm_list(6,6),id_vem_list(6,6),
34092 & id_b8_list(6,6,6),id_b10_list(6,6,6)
34093 C particle decay data
34094 double precision wg_sec_list
34095 integer idec_list,isec_list
34096 COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
34099 C external functions
34100 integer ipho_pdg2id,ipho_chr3,ipho_bar3
34101 double precision pho_pmass
34104 integer i,IDcpcN,IDcpcR,IDpdgN,IDpdgR,IDB,IFL1,IFL2,IFL3
34106 IF((Iside.EQ.1).OR.(Iside.EQ.2)) THEN
34109 IF(IDcpc.EQ.-1) THEN
34110 IF(Iside.EQ.1) THEN
34115 IDcpcR = ipho_pdg2id(IDpdgR)
34116 IDEQB(Iside) = ipho_pdg2id(IDpdg)
34117 IDEQP(Iside) = IDpdg
34118 C copy particle properties
34119 IDB = abs(IDEQB(Iside))
34120 xm_list(IDcpcR) = xm_list(IDB)
34121 tau_list(IDcpcR) = tau_list(IDB)
34122 gam_list(IDcpcR) = gam_list(IDB)
34123 IF(IHFLS(Iside).EQ.1) THEN
34124 ich3_list(IDcpcR) = ipho_chr3(IDEQB(Iside),0)
34125 iba3_list(IDcpcR) = ipho_bar3(IDEQB(Iside),0)
34127 ich3_list(IDcpcR) = 0
34128 iba3_list(IDcpcR) = 0
34131 IFL1 = IHFLD(Iside,1)
34132 IFL2 = IHFLD(Iside,2)
34134 IF(IHFLS(Iside).EQ.1) THEN
34135 IF(ABS(IHFLD(Iside,1)).GT.1000) THEN
34136 IFL1 = IHFLD(Iside,1)/1000
34137 IFL2 = MOD(IHFLD(Iside,1)/100,10)
34138 IFL3 = IHFLD(Iside,2)
34139 ELSE IF(ABS(IHFLD(Iside,2)).GT.1000) THEN
34140 IFL1 = IHFLD(Iside,1)
34141 IFL2 = IHFLD(Iside,2)/1000
34142 IFL3 = MOD(IHFLD(Iside,2)/100,10)
34145 iq_list(1,IDcpcR) = IFL1
34146 iq_list(2,IDcpcR) = IFL2
34147 iq_list(3,IDcpcR) = IFL3
34152 IF(IDEB(87).GE.5) THEN
34153 WRITE(LO,'(1X,A,I2,/5X,A,I7,4I6)')
34154 & 'pho_setpar: remnant assignment side',Iside,
34155 & 'IDPDG,IFL1,2,3,IVAL',IDPDGN,IFL1,IFL2,IFL3,IHFLS(Iside)
34157 ELSE IF(IDcpc.EQ.0) THEN
34162 IDcpcN = ipho_pdg2id(IDpdg)
34166 C initialize /POGCMS/
34167 IFPAP(Iside) = IDpdgN
34168 IFPAB(Iside) = IDcpcN
34169 PMASS(Iside) = pho_pmass(IDcpcN,0)
34170 IF(IFPAP(Iside).EQ.22) THEN
34171 PVIRT(Iside) = ABS(PVIR)
34173 PVIRT(Iside) = 0.D0
34176 ELSE IF(Iside.EQ.-2) THEN
34177 C output of current settings
34179 WRITE(LO,'(1X,A,I2,1X,A,I7,I4,1X,1P2E10.3)')
34180 & 'PHO_SETPAR: side',
34181 & I,'IDPDG,IDcpc,PMASS,PVIRT',IFPAP(I),IFPAB(I),PMASS(I),
34183 IF((IFPAP(I).EQ.81).OR.(IFPAP(I).EQ.82)) THEN
34184 WRITE(LO,'(5X,A,I7,I4,I2,3I5)')
34185 & 'remnant:IDPDG,IDcpc,IVAL,IFLA1,2',IDEQP(I),IDEQB(I),
34186 & IHFLS(I),IHFLD(I,1),IHFLD(I,2)
34190 WRITE(LO,'(/1X,A,I8)')
34191 & 'pho_setpar: invalid argument (Iside)',Iside
34196 *$ CREATE PHO_XLAM.FOR
34198 CDECK ID>, PHO_XLAM
34199 DOUBLE PRECISION FUNCTION PHO_XLAM(X,Y,Z)
34200 C**********************************************************************
34202 C auxiliary function for two/three particle decay mode
34203 C (standard LAMBDA**(1/2) function)
34205 C**********************************************************************
34206 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34210 XLAM=X*X-2.D0*X*(Y+Z)+YZ*YZ
34211 IF(XLAM.LT.0.D0) XLAM=-XLAM
34212 PHO_XLAM=SQRT(XLAM)
34215 *$ CREATE PHO_BESSJ0.FOR
34217 CDECK ID>, PHO_BESSJ0
34218 DOUBLE PRECISION FUNCTION PHO_BESSJ0(DX)
34219 C**********************************************************************
34221 C CERN (KERN) LIB function C312
34223 C modified by R. Engel (03/02/93)
34225 C**********************************************************************
34226 DOUBLE PRECISION DX
34227 DOUBLE PRECISION X,Y,V,H,ALFA,EIGHT
34228 DOUBLE PRECISION PI1,PI2,C1(0:14),C2(0:9),C3(0:10),B0,B1,B2,P,Q,R
34232 DATA PI1 /0.79788 45608 0287D0/, PI2 /0.78539 81633 9745D0/
34234 DATA C1( 0) /+0.15772 79714 7489D0/
34235 DATA C1( 1) /-0.00872 34423 5285D0/
34236 DATA C1( 2) /+0.26517 86132 0334D0/
34237 DATA C1( 3) /-0.37009 49938 7265D0/
34238 DATA C1( 4) /+0.15806 71023 3210D0/
34239 DATA C1( 5) /-0.03489 37694 1141D0/
34240 DATA C1( 6) /+0.00481 91800 6947D0/
34241 DATA C1( 7) /-0.00046 06261 6621D0/
34242 DATA C1( 8) /+0.00003 24603 2882D0/
34243 DATA C1( 9) /-0.00000 17619 4691D0/
34244 DATA C1(10) /+0.00000 00760 8164D0/
34245 DATA C1(11) /-0.00000 00026 7925D0/
34246 DATA C1(12) /+0.00000 00000 7849D0/
34247 DATA C1(13) /-0.00000 00000 0194D0/
34248 DATA C1(14) /+0.00000 00000 0004D0/
34250 DATA C2( 0) /+0.99946 03493 4752D0/
34251 DATA C2( 1) /-0.00053 65220 4681D0/
34252 DATA C2( 2) /+0.00000 30751 8479D0/
34253 DATA C2( 3) /-0.00000 00517 0595D0/
34254 DATA C2( 4) /+0.00000 00016 3065D0/
34255 DATA C2( 5) /-0.00000 00000 7864D0/
34256 DATA C2( 6) /+0.00000 00000 0517D0/
34257 DATA C2( 7) /-0.00000 00000 0043D0/
34258 DATA C2( 8) /+0.00000 00000 0004D0/
34259 DATA C2( 9) /-0.00000 00000 0001D0/
34261 DATA C3( 0) /-0.01555 58546 05337D0/
34262 DATA C3( 1) /+0.00006 83851 99426D0/
34263 DATA C3( 2) /-0.00000 07414 49841D0/
34264 DATA C3( 3) /+0.00000 00179 72457D0/
34265 DATA C3( 4) /-0.00000 00007 27192D0/
34266 DATA C3( 5) /+0.00000 00000 42201D0/
34267 DATA C3( 6) /-0.00000 00000 03207D0/
34268 DATA C3( 7) /+0.00000 00000 00301D0/
34269 DATA C3( 8) /-0.00000 00000 00033D0/
34270 DATA C3( 9) /+0.00000 00000 00004D0/
34271 DATA C3(10) /-0.00000 00000 00001D0/
34275 IF(V .LT. EIGHT) THEN
34282 B0=C1(I)-ALFA*B1-B2
34294 B0=C2(I)-ALFA*B1-B2
34301 B0=C3(I)-ALFA*B1-B2
34306 B1=PI1*SQRT(R)*(P*COS(B0)-Q*SIN(B0))
34312 *$ CREATE PHO_BESSI0.FOR
34314 CDECK ID>, PHO_BESSI0
34315 DOUBLE PRECISION FUNCTION PHO_BESSI0(X)
34316 C**********************************************************************
34318 C Bessel Function I0
34320 C**********************************************************************
34321 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34325 IF (AX .LT. 3.75D0) THEN
34328 & 1.0D0+Y*(3.5156229D0+Y*(3.0899424D0+Y*(1.2067492D0
34329 & +Y*(0.2659732D0+Y*(0.360768D-1+Y*0.45813D-2)))))
34333 & (EXP(AX)/SQRT(AX))*(0.39894228D0+Y*(0.1328592D-1
34334 & +Y*(0.225319D-2+Y*(-0.157565D-2+Y*(0.916281D-2
34335 & +Y*(-0.2057706D-1+Y*(0.2635537D-1+Y*(-0.1647633D-1
34336 & +Y*0.392377D-2))))))))
34341 *$ CREATE PHO_BESSI1.FOR
34343 CDECK ID>, PHO_BESSI1
34344 DOUBLE PRECISION FUNCTION PHO_BESSI1(X)
34345 C**********************************************************************
34347 C Bessel Function I1
34349 C**********************************************************************
34350 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34355 IF (AX .LT. 3.75D0) THEN
34358 & AX*(0.5D0+Y*(0.87890594D0+Y*(0.51498869D0+Y*(0.15084934D0
34359 & +Y*(0.2658733D-1+Y*(0.301532D-2+Y*0.32411D-3))))))
34363 & 0.2282967D-1+Y*(-0.2895312D-1+Y*(0.1787654D-1
34366 & 0.39894228D0+Y*(-0.3988024D-1+Y*(-0.362018D-2
34367 & +Y*(0.163801D-2+Y*(-0.1031555D-1+Y*BESLI1))))
34368 BESLI1 = BESLI1 * EXP(AX)/SQRT(AX)
34370 IF (X .LT. 0.D0) BESLI1 = -BESLI1
34372 PHO_BESSI1 = BESLI1
34376 *$ CREATE PHO_BESSK0.FOR
34378 CDECK ID>, PHO_BESSK0
34379 DOUBLE PRECISION FUNCTION PHO_BESSK0(X)
34380 C**********************************************************************
34382 C Modified Bessel Function K0
34384 C**********************************************************************
34385 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34388 IF (X .LT. 2.D0) THEN
34391 & (-LOG(X/2.D0)*PHO_BESSI0(X))+(-.57721566D0+Y*(0.42278420D0
34392 & +Y*(0.23069756D0+Y*(0.3488590D-1+Y*(0.262698D-2
34393 & +Y*(0.10750D-3+Y*0.740D-5))))))
34397 & (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(-0.7832358D-1
34398 & +Y*(0.2189568D-1+Y*(-0.1062446D-1+Y*(0.587872D-2
34399 & +Y*(-0.251540D-2+Y*0.53208D-3))))))
34404 *$ CREATE PHO_BESSK1.FOR
34406 CDECK ID>, PHO_BESSK1
34407 DOUBLE PRECISION FUNCTION PHO_BESSK1(X)
34408 C**********************************************************************
34410 C Modified Bessel Function K1
34412 C**********************************************************************
34413 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34416 IF (X .LT. 2.D0) THEN
34419 & (LOG(X/2.D0)*PHO_BESSI1(X))+(1.D0/X)*(1.D0+Y*(0.15443144D0
34420 & +Y*(-0.67278579D0+Y*(-0.18156897D0+Y*(-0.1919402D-1
34421 & +Y*(-0.110404D-2+Y*(-0.4686D-4)))))))
34425 & (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(0.23498619D0
34426 & +Y*(-0.3655620D-1+Y*(0.1504268D-1+Y*(-0.780353D-2
34427 & +Y*(0.325614D-2+Y*(-0.68245D-3)))))))
34432 *$ CREATE PHO_GAUSET.FOR
34434 CDECK ID>, PHO_GAUSET
34435 SUBROUTINE PHO_GAUSET(AX,BX,NX,Z,W)
34436 C********************************************************************
34438 C N-point gauss zeros and weights for the interval (AX,BX) are
34439 C stored in arrays Z and W respectively.
34441 C*********************************************************************
34442 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34445 COMMON /POGDAT/A(273),X(273),KTAB(96)
34446 DIMENSION Z(NX),W(NX)
34459 1 IF((N.LE.16).AND.(N.GT.1)) GO TO 2
34460 IF(N.EQ.20) GO TO 2
34461 IF(N.EQ.24) GO TO 2
34462 IF(N.EQ.32) GO TO 2
34463 IF(N.EQ.40) GO TO 2
34464 IF(N.EQ.48) GO TO 2
34465 IF(N.EQ.64) GO TO 2
34466 IF(N.EQ.80) GO TO 2
34467 IF(N.EQ.96) GO TO 2
34469 C the extended Gauss cases:
34470 IF((N/96)*96.EQ.N) GO TO 3
34472 C jump to center of intervall intrgration:
34475 C get Gauss point array
34478 C extract real points
34482 C extract values from big array
34486 C store them backward
34489 C store them forward
34494 C store central point (odd N)
34495 IF((N-M-M).EQ.0) RETURN
34498 W(M+1)=BETA*A(JMID)
34501 C get ND96 times chained 96 Gauss point array
34504 C print out message
34505 C -extract real points
34509 C extract values from big array
34515 DO 32 JD96=0,ND96-1
34516 ZCNTR= (ALPHA-BETA)+ BETA*FLOAT(2*JD96+1)/FLOAT(ND96)
34517 C store them backward
34518 Z(J+JD96*96)=ZCNTR-DELTA
34520 C store them forward
34522 Z(JP+JD96*96)=ZCNTR+DELTA
34523 W(JP+JD96*96)=WTEMP
34528 C the center of intervall cases:
34530 C put in constant weight and equally spaced central points
34533 WIN=(BX-AX)/FLOAT(N)
34534 Z(IN)=AX + (FLOAT(IN)-.5)*WIN
34539 *$ CREATE PHO_GAUDAT.FOR
34541 CDECK ID>, PHO_GAUDAT
34542 SUBROUTINE PHO_GAUDAT
34543 C*********************************************************************
34545 C store big arrays needed for Gauss integral, CERNLIB D106BD
34546 C (arrays A,X,ITAB copied on B,Y,LTAB)
34548 C*********************************************************************
34549 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34552 COMMON /POGDAT/ B(273),Y(273),LTAB(96)
34553 DIMENSION A(273),X(273),KTAB(96)
34555 C-----TABLE OF INITIAL SUBSCRIPTS FOR N=2(1)16(4)96
34592 C-----TABLE OF ABSCISSAE (X) AND WEIGHTS (A) FOR INTERVAL (-1,+1).
34595 DATA X(1)/0.577350269189626D0 /, A(1)/1.000000000000000D0 /
34597 DATA X(2)/0.774596669241483D0 /, A(2)/0.555555555555556D0 /
34598 DATA X(3)/0.000000000000000D0 /, A(3)/0.888888888888889D0 /
34600 DATA X(4)/0.861136311594053D0 /, A(4)/0.347854845137454D0 /
34601 DATA X(5)/0.339981043584856D0 /, A(5)/0.652145154862546D0 /
34603 DATA X(6)/0.906179845938664D0 /, A(6)/0.236926885056189D0 /
34604 DATA X(7)/0.538469310105683D0 /, A(7)/0.478628670499366D0 /
34605 DATA X(8)/0.000000000000000D0 /, A(8)/0.568888888888889D0 /
34607 DATA X(9)/0.932469514203152D0 /, A(9)/0.171324492379170D0 /
34608 DATA X(10)/0.661209386466265D0 /, A(10)/0.360761573048139D0 /
34609 DATA X(11)/0.238619186083197D0 /, A(11)/0.467913934572691D0 /
34611 DATA X(12)/0.949107912342759D0 /, A(12)/0.129484966168870D0 /
34612 DATA X(13)/0.741531185599394D0 /, A(13)/0.279705391489277D0 /
34613 DATA X(14)/0.405845151377397D0 /, A(14)/0.381830050505119D0 /
34614 DATA X(15)/0.000000000000000D0 /, A(15)/0.417959183673469D0 /
34616 DATA X(16)/0.960289856497536D0 /, A(16)/0.101228536290376D0 /
34617 DATA X(17)/0.796666477413627D0 /, A(17)/0.222381034453374D0 /
34618 DATA X(18)/0.525532409916329D0 /, A(18)/0.313706645877887D0 /
34619 DATA X(19)/0.183434642495650D0 /, A(19)/0.362683783378362D0 /
34621 DATA X(20)/0.968160239507626D0 /, A(20)/0.081274388361574D0 /
34622 DATA X(21)/0.836031107326636D0 /, A(21)/0.180648160694857D0 /
34623 DATA X(22)/0.613371432700590D0 /, A(22)/0.260610696402935D0 /
34624 DATA X(23)/0.324253423403809D0 /, A(23)/0.312347077040003D0 /
34625 DATA X(24)/0.000000000000000D0 /, A(24)/0.330239355001260D0 /
34627 DATA X(25)/0.973906528517172D0 /, A(25)/0.066671344308688D0 /
34628 DATA X(26)/0.865063366688985D0 /, A(26)/0.149451349150581D0 /
34629 DATA X(27)/0.679409568299024D0 /, A(27)/0.219086362515982D0 /
34630 DATA X(28)/0.433395394129247D0 /, A(28)/0.269266719309996D0 /
34631 DATA X(29)/0.148874338981631D0 /, A(29)/0.295524224714753D0 /
34633 DATA X(30)/0.978228658146057D0 /, A(30)/0.055668567116174D0 /
34634 DATA X(31)/0.887062599768095D0 /, A(31)/0.125580369464905D0 /
34635 DATA X(32)/0.730152005574049D0 /, A(32)/0.186290210927734D0 /
34636 DATA X(33)/0.519096129206812D0 /, A(33)/0.233193764591990D0 /
34637 DATA X(34)/0.269543155952345D0 /, A(34)/0.262804544510247D0 /
34638 DATA X(35)/0.000000000000000D0 /, A(35)/0.272925086777901D0 /
34640 DATA X(36)/0.981560634246719D0 /, A(36)/0.047175336386512D0 /
34641 DATA X(37)/0.904117256370475D0 /, A(37)/0.106939325995318D0 /
34642 DATA X(38)/0.769902674194305D0 /, A(38)/0.160078328543346D0 /
34643 DATA X(39)/0.587317954286617D0 /, A(39)/0.203167426723066D0 /
34644 DATA X(40)/0.367831498998180D0 /, A(40)/0.233492536538355D0 /
34645 DATA X(41)/0.125233408511469D0 /, A(41)/0.249147045813403D0 /
34647 DATA X(42)/0.984183054718588D0 /, A(42)/0.040484004765316D0 /
34648 DATA X(43)/0.917598399222978D0 /, A(43)/0.092121499837728D0 /
34649 DATA X(44)/0.801578090733310D0 /, A(44)/0.138873510219787D0 /
34650 DATA X(45)/0.642349339440340D0 /, A(45)/0.178145980761946D0 /
34651 DATA X(46)/0.448492751036447D0 /, A(46)/0.207816047536889D0 /
34652 DATA X(47)/0.230458315955135D0 /, A(47)/0.226283180262897D0 /
34653 DATA X(48)/0.000000000000000D0 /, A(48)/0.232551553230874D0 /
34655 DATA X(49)/0.986283808696812D0 /, A(49)/0.035119460331752D0 /
34656 DATA X(50)/0.928434883663574D0 /, A(50)/0.080158087159760D0 /
34657 DATA X(51)/0.827201315069765D0 /, A(51)/0.121518570687903D0 /
34658 DATA X(52)/0.687292904811685D0 /, A(52)/0.157203167158194D0 /
34659 DATA X(53)/0.515248636358154D0 /, A(53)/0.185538397477938D0 /
34660 DATA X(54)/0.319112368927890D0 /, A(54)/0.205198463721296D0 /
34661 DATA X(55)/0.108054948707344D0 /, A(55)/0.215263853463158D0 /
34663 DATA X(56)/0.987992518020485D0 /, A(56)/0.030753241996117D0 /
34664 DATA X(57)/0.937273392400706D0 /, A(57)/0.070366047488108D0 /
34665 DATA X(58)/0.848206583410427D0 /, A(58)/0.107159220467172D0 /
34666 DATA X(59)/0.724417731360170D0 /, A(59)/0.139570677926154D0 /
34667 DATA X(60)/0.570972172608539D0 /, A(60)/0.166269205816994D0 /
34668 DATA X(61)/0.394151347077563D0 /, A(61)/0.186161000015562D0 /
34669 DATA X(62)/0.201194093997435D0 /, A(62)/0.198431485327111D0 /
34670 DATA X(63)/0.000000000000000D0 /, A(63)/0.202578241925561D0 /
34672 DATA X(64)/0.989400934991650D0 /, A(64)/0.027152459411754D0 /
34673 DATA X(65)/0.944575023073233D0 /, A(65)/0.062253523938648D0 /
34674 DATA X(66)/0.865631202387832D0 /, A(66)/0.095158511682493D0 /
34675 DATA X(67)/0.755404408355003D0 /, A(67)/0.124628971255534D0 /
34676 DATA X(68)/0.617876244402644D0 /, A(68)/0.149595988816577D0 /
34677 DATA X(69)/0.458016777657227D0 /, A(69)/0.169156519395003D0 /
34678 DATA X(70)/0.281603550779259D0 /, A(70)/0.182603415044924D0 /
34679 DATA X(71)/0.095012509837637D0 /, A(71)/0.189450610455069D0 /
34681 DATA X(72)/0.993128599185094D0 /, A(72)/0.017614007139152D0 /
34682 DATA X(73)/0.963971927277913D0 /, A(73)/0.040601429800386D0 /
34683 DATA X(74)/0.912234428251325D0 /, A(74)/0.062672048334109D0 /
34684 DATA X(75)/0.839116971822218D0 /, A(75)/0.083276741576704D0 /
34685 DATA X(76)/0.746331906460150D0 /, A(76)/0.101930119817240D0 /
34686 DATA X(77)/0.636053680726515D0 /, A(77)/0.118194531961518D0 /
34687 DATA X(78)/0.510867001950827D0 /, A(78)/0.131688638449176D0 /
34688 DATA X(79)/0.373706088715419D0 /, A(79)/0.142096109318382D0 /
34689 DATA X(80)/0.227785851141645D0 /, A(80)/0.149172986472603D0 /
34690 DATA X(81)/0.076526521133497D0 /, A(81)/0.152753387130725D0 /
34692 DATA X(82)/0.995187219997021D0 /, A(82)/0.012341229799987D0 /
34693 DATA X(83)/0.974728555971309D0 /, A(83)/0.028531388628933D0 /
34694 DATA X(84)/0.938274552002732D0 /, A(84)/0.044277438817419D0 /
34695 DATA X(85)/0.886415527004401D0 /, A(85)/0.059298584915436D0 /
34696 DATA X(86)/0.820001985973902D0 /, A(86)/0.073346481411080D0 /
34697 DATA X(87)/0.740124191578554D0 /, A(87)/0.086190161531953D0 /
34698 DATA X(88)/0.648093651936975D0 /, A(88)/0.097618652104113D0 /
34699 DATA X(89)/0.545421471388839D0 /, A(89)/0.107444270115965D0 /
34700 DATA X(90)/0.433793507626045D0 /, A(90)/0.115505668053725D0 /
34701 DATA X(91)/0.315042679696163D0 /, A(91)/0.121670472927803D0 /
34702 DATA X(92)/0.191118867473616D0 /, A(92)/0.125837456346828D0 /
34703 DATA X(93)/0.064056892862605D0 /, A(93)/0.127938195346752D0 /
34705 DATA X(94)/0.997263861849481D0 /, A(94)/0.007018610009470D0 /
34706 DATA X(95)/0.985611511545268D0 /, A(95)/0.016274394730905D0 /
34707 DATA X(96)/0.964762255587506D0 /, A(96)/0.025392065309262D0 /
34708 DATA X(97)/0.934906075937739D0 /, A(97)/0.034273862913021D0 /
34709 DATA X(98)/0.896321155766052D0 /, A(98)/0.042835898022226D0 /
34710 DATA X(99)/0.849367613732569D0 /, A(99)/0.050998059262376D0 /
34711 DATA X(100)/0.794483795967942D0/, A(100)/0.058684093478535D0/
34712 DATA X(101)/0.732182118740289D0/, A(101)/0.065822222776361D0/
34713 DATA X(102)/0.663044266930215D0/, A(102)/0.072345794108848D0/
34714 DATA X(103)/0.587715757240762D0/, A(103)/0.078193895787070D0/
34715 DATA X(104)/0.506899908932229D0/, A(104)/0.083311924226946D0/
34716 DATA X(105)/0.421351276130635D0/, A(105)/0.087652093004403D0/
34717 DATA X(106)/0.331868602282127D0/, A(106)/0.091173878695763D0/
34718 DATA X(107)/0.239287362252137D0/, A(107)/0.093844399080804D0/
34719 DATA X(108)/0.144471961582796D0/, A(108)/0.095638720079274D0/
34720 DATA X(109)/0.048307665687738D0/, A(109)/0.096540088514727D0/
34722 DATA X(110)/0.998237709710559D0/, A(110)/0.004521277098533D0/
34723 DATA X(111)/0.990726238699457D0/, A(111)/0.010498284531152D0/
34724 DATA X(112)/0.977259949983774D0/, A(112)/0.016421058381907D0/
34725 DATA X(113)/0.957916819213791D0/, A(113)/0.022245849194166D0/
34726 DATA X(114)/0.932812808278676D0/, A(114)/0.027937006980023D0/
34727 DATA X(115)/0.902098806968874D0/, A(115)/0.033460195282547D0/
34728 DATA X(116)/0.865959503212259D0/, A(116)/0.038782167974472D0/
34729 DATA X(117)/0.824612230833311D0/, A(117)/0.043870908185673D0/
34730 DATA X(118)/0.778305651426519D0/, A(118)/0.048695807635072D0/
34731 DATA X(119)/0.727318255189927D0/, A(119)/0.053227846983936D0/
34732 DATA X(120)/0.671956684614179D0/, A(120)/0.057439769099391D0/
34733 DATA X(121)/0.612553889667980D0/, A(121)/0.061306242492928D0/
34734 DATA X(122)/0.549467125095128D0/, A(122)/0.064804013456601D0/
34735 DATA X(123)/0.483075801686178D0/, A(123)/0.067912045815233D0/
34736 DATA X(124)/0.413779204371605D0/, A(124)/0.070611647391286D0/
34737 DATA X(125)/0.341994090825758D0/, A(125)/0.072886582395804D0/
34738 DATA X(126)/0.268152185007253D0/, A(126)/0.074723169057968D0/
34739 DATA X(127)/0.192697580701371D0/, A(127)/0.076110361900626D0/
34740 DATA X(128)/0.116084070675255D0/, A(128)/0.077039818164247D0/
34741 DATA X(129)/0.038772417506050D0/, A(129)/0.077505947978424D0/
34743 DATA X(130)/0.998771007252426D0/, A(130)/0.003153346052305D0/
34744 DATA X(131)/0.993530172266350D0/, A(131)/0.007327553901276D0/
34745 DATA X(132)/0.984124583722826D0/, A(132)/0.011477234579234D0/
34746 DATA X(133)/0.970591592546247D0/, A(133)/0.015579315722943D0/
34747 DATA X(134)/0.952987703160430D0/, A(134)/0.019616160457355D0/
34748 DATA X(135)/0.931386690706554D0/, A(135)/0.023570760839324D0/
34749 DATA X(136)/0.905879136715569D0/, A(136)/0.027426509708356D0/
34750 DATA X(137)/0.876572020274247D0/, A(137)/0.031167227832798D0/
34751 DATA X(138)/0.843588261624393D0/, A(138)/0.034777222564770D0/
34752 DATA X(139)/0.807066204029442D0/, A(139)/0.038241351065830D0/
34753 DATA X(140)/0.767159032515740D0/, A(140)/0.041545082943464D0/
34754 DATA X(141)/0.724034130923814D0/, A(141)/0.044674560856694D0/
34755 DATA X(142)/0.677872379632663D0/, A(142)/0.047616658492490D0/
34756 DATA X(143)/0.628867396776513D0/, A(143)/0.050359035553854D0/
34757 DATA X(144)/0.577224726083972D0/, A(144)/0.052890189485193D0/
34758 DATA X(145)/0.523160974722233D0/, A(145)/0.055199503699984D0/
34759 DATA X(146)/0.466902904750958D0/, A(146)/0.057277292100403D0/
34760 DATA X(147)/0.408686481990716D0/, A(147)/0.059114839698395D0/
34761 DATA X(148)/0.348755886292160D0/, A(148)/0.060704439165893D0/
34762 DATA X(149)/0.287362487355455D0/, A(149)/0.062039423159892D0/
34763 DATA X(150)/0.224763790394689D0/, A(150)/0.063114192286254D0/
34764 DATA X(151)/0.161222356068891D0/, A(151)/0.063924238584648D0/
34765 DATA X(152)/0.097004699209462D0/, A(152)/0.064466164435950D0/
34766 DATA X(153)/0.032380170962869D0/, A(153)/0.064737696812683D0/
34768 DATA X(154)/0.999305041735772D0/, A(154)/0.001783280721696D0/
34769 DATA X(155)/0.996340116771955D0/, A(155)/0.004147033260562D0/
34770 DATA X(156)/0.991013371476744D0/, A(156)/0.006504457968978D0/
34771 DATA X(157)/0.983336253884625D0/, A(157)/0.008846759826363D0/
34772 DATA X(158)/0.973326827789910D0/, A(158)/0.011168139460131D0/
34773 DATA X(159)/0.961008799652053D0/, A(159)/0.013463047896718D0/
34774 DATA X(160)/0.946411374858402D0/, A(160)/0.015726030476024D0/
34775 DATA X(161)/0.929569172131939D0/, A(161)/0.017951715775697D0/
34776 DATA X(162)/0.910522137078502D0/, A(162)/0.020134823153530D0/
34777 DATA X(163)/0.889315445995114D0/, A(163)/0.022270173808383D0/
34778 DATA X(164)/0.865999398154092D0/, A(164)/0.024352702568710D0/
34779 DATA X(165)/0.840629296252580D0/, A(165)/0.026377469715054D0/
34780 DATA X(166)/0.813265315122797D0/, A(166)/0.028339672614259D0/
34781 DATA X(167)/0.783972358943341D0/, A(167)/0.030234657072402D0/
34782 DATA X(168)/0.752819907260531D0/, A(168)/0.032057928354851D0/
34783 DATA X(169)/0.719881850171610D0/, A(169)/0.033805161837141D0/
34784 DATA X(170)/0.685236313054233D0/, A(170)/0.035472213256882D0/
34785 DATA X(171)/0.648965471254657D0/, A(171)/0.037055128540240D0/
34786 DATA X(172)/0.611155355172393D0/, A(172)/0.038550153178615D0/
34787 DATA X(173)/0.571895646202634D0/, A(173)/0.039953741132720D0/
34788 DATA X(174)/0.531279464019894D0/, A(174)/0.041262563242623D0/
34789 DATA X(175)/0.489403145707052D0/, A(175)/0.042473515123653D0/
34790 DATA X(176)/0.446366017253464D0/, A(176)/0.043583724529323D0/
34791 DATA X(177)/0.402270157963991D0/, A(177)/0.044590558163756D0/
34792 DATA X(178)/0.357220158337668D0/, A(178)/0.045491627927418D0/
34793 DATA X(179)/0.311322871990210D0/, A(179)/0.046284796581314D0/
34794 DATA X(180)/0.264687162208767D0/, A(180)/0.046968182816210D0/
34795 DATA X(181)/0.217423643740007D0/, A(181)/0.047540165714830D0/
34796 DATA X(182)/0.169644420423992D0/, A(182)/0.047999388596458D0/
34797 DATA X(183)/0.121462819296120D0/, A(183)/0.048344762234802D0/
34798 DATA X(184)/0.072993121787799D0/, A(184)/0.048575467441503D0/
34799 DATA X(185)/0.024350292663424D0/, A(185)/0.048690957009139D0/
34801 DATA X(186)/0.999553822651630D0/, A(186)/0.001144950003186D0/
34802 DATA X(187)/0.997649864398237D0/, A(187)/0.002663533589512D0/
34803 DATA X(188)/0.994227540965688D0/, A(188)/0.004180313124694D0/
34804 DATA X(189)/0.989291302499755D0/, A(189)/0.005690922451403D0/
34805 DATA X(190)/0.982848572738629D0/, A(190)/0.007192904768117D0/
34806 DATA X(191)/0.974909140585727D0/, A(191)/0.008683945269260D0/
34807 DATA X(192)/0.965485089043799D0/, A(192)/0.010161766041103D0/
34808 DATA X(193)/0.954590766343634D0/, A(193)/0.011624114120797D0/
34809 DATA X(194)/0.942242761309872D0/, A(194)/0.013068761592401D0/
34810 DATA X(195)/0.928459877172445D0/, A(195)/0.014493508040509D0/
34811 DATA X(196)/0.913263102571757D0/, A(196)/0.015896183583725D0/
34812 DATA X(197)/0.896675579438770D0/, A(197)/0.017274652056269D0/
34813 DATA X(198)/0.878722567678213D0/, A(198)/0.018626814208299D0/
34814 DATA X(199)/0.859431406663111D0/, A(199)/0.019950610878141D0/
34815 DATA X(200)/0.838831473580255D0/, A(200)/0.021244026115782D0/
34816 DATA X(201)/0.816954138681463D0/, A(201)/0.022505090246332D0/
34817 DATA X(202)/0.793832717504605D0/, A(202)/0.023731882865930D0/
34818 DATA X(203)/0.769502420135041D0/, A(203)/0.024922535764115D0/
34819 DATA X(204)/0.744000297583597D0/, A(204)/0.026075235767565D0/
34820 DATA X(205)/0.717365185362099D0/, A(205)/0.027188227500486D0/
34821 DATA X(206)/0.689637644342027D0/, A(206)/0.028259816057276D0/
34822 DATA X(207)/0.660859898986119D0/, A(207)/0.029288369583267D0/
34823 DATA X(208)/0.631075773046871D0/, A(208)/0.030272321759557D0/
34824 DATA X(209)/0.600330622829751D0/, A(209)/0.031210174188114D0/
34825 DATA X(210)/0.568671268122709D0/, A(210)/0.032100498673487D0/
34826 DATA X(211)/0.536145920897131D0/, A(211)/0.032941939397645D0/
34827 DATA X(212)/0.502804111888784D0/, A(212)/0.033733214984611D0/
34828 DATA X(213)/0.468696615170544D0/, A(213)/0.034473120451753D0/
34829 DATA X(214)/0.433875370831756D0/, A(214)/0.035160529044747D0/
34830 DATA X(215)/0.398393405881969D0/, A(215)/0.035794393953416D0/
34831 DATA X(216)/0.362304753499487D0/, A(216)/0.036373749905835D0/
34832 DATA X(217)/0.325664370747701D0/, A(217)/0.036897714638276D0/
34833 DATA X(218)/0.288528054884511D0/, A(218)/0.037365490238730D0/
34834 DATA X(219)/0.250952358392272D0/, A(219)/0.037776364362001D0/
34835 DATA X(220)/0.212994502857666D0/, A(220)/0.038129711314477D0/
34836 DATA X(221)/0.174712291832646D0/, A(221)/0.038424993006959D0/
34837 DATA X(222)/0.136164022809143D0/, A(222)/0.038661759774076D0/
34838 DATA X(223)/0.097408398441584D0/, A(223)/0.038839651059051D0/
34839 DATA X(224)/0.058504437152420D0/, A(224)/0.038958395962769D0/
34840 DATA X(225)/0.019511383256793D0/, A(225)/0.039017813656306D0/
34842 DATA X(226)/0.999689503883230D0/, A(226)/0.000796792065552D0/
34843 DATA X(227)/0.998364375863181D0/, A(227)/0.001853960788946D0/
34844 DATA X(228)/0.995981842987209D0/, A(228)/0.002910731817934D0/
34845 DATA X(229)/0.992543900323762D0/, A(229)/0.003964554338444D0/
34846 DATA X(230)/0.988054126329623D0/, A(230)/0.005014202742927D0/
34847 DATA X(231)/0.982517263563014D0/, A(231)/0.006058545504235D0/
34848 DATA X(232)/0.975939174585136D0/, A(232)/0.007096470791153D0/
34849 DATA X(233)/0.968326828463264D0/, A(233)/0.008126876925698D0/
34850 DATA X(234)/0.959688291448742D0/, A(234)/0.009148671230783D0/
34851 DATA X(235)/0.950032717784437D0/, A(235)/0.010160770535008D0/
34852 DATA X(236)/0.939370339752755D0/, A(236)/0.011162102099838D0/
34853 DATA X(237)/0.927712456722308D0/, A(237)/0.012151604671088D0/
34854 DATA X(238)/0.915071423120898D0/, A(238)/0.013128229566961D0/
34855 DATA X(239)/0.901460635315852D0/, A(239)/0.014090941772314D0/
34856 DATA X(240)/0.886894517402420D0/, A(240)/0.015038721026994D0/
34857 DATA X(241)/0.871388505909296D0/, A(241)/0.015970562902562D0/
34858 DATA X(242)/0.854959033434601D0/, A(242)/0.016885479864245D0/
34859 DATA X(243)/0.837623511228187D0/, A(243)/0.017782502316045D0/
34860 DATA X(244)/0.819400310737931D0/, A(244)/0.018660679627411D0/
34861 DATA X(245)/0.800308744139140D0/, A(245)/0.019519081140145D0/
34862 DATA X(246)/0.780369043867433D0/, A(246)/0.020356797154333D0/
34863 DATA X(247)/0.759602341176647D0/, A(247)/0.021172939892191D0/
34864 DATA X(248)/0.738030643744400D0/, A(248)/0.021966644438744D0/
34865 DATA X(249)/0.715676812348967D0/, A(249)/0.022737069658329D0/
34866 DATA X(250)/0.692564536642171D0/, A(250)/0.023483399085926D0/
34867 DATA X(251)/0.668718310043916D0/, A(251)/0.024204841792364D0/
34868 DATA X(252)/0.644163403784967D0/, A(252)/0.024900633222483D0/
34869 DATA X(253)/0.618925840125468D0/, A(253)/0.025570036005349D0/
34870 DATA X(254)/0.593032364777572D0/, A(254)/0.026212340735672D0/
34871 DATA X(255)/0.566510418561397D0/, A(255)/0.026826866725591D0/
34872 DATA X(256)/0.539388108324357D0/, A(256)/0.027412962726029D0/
34873 DATA X(257)/0.511694177154667D0/, A(257)/0.027970007616848D0/
34874 DATA X(258)/0.483457973920596D0/, A(258)/0.028497411065085D0/
34875 DATA X(259)/0.454709422167743D0/, A(259)/0.028994614150555D0/
34876 DATA X(260)/0.425478988407300D0/, A(260)/0.029461089958167D0/
34877 DATA X(261)/0.395797649828908D0/, A(261)/0.029896344136328D0/
34878 DATA X(262)/0.365696861472313D0/, A(262)/0.030299915420827D0/
34879 DATA X(263)/0.335208522892625D0/, A(263)/0.030671376123669D0/
34880 DATA X(264)/0.304364944354496D0/, A(264)/0.031010332586313D0/
34881 DATA X(265)/0.273198812591049D0/, A(265)/0.031316425596861D0/
34882 DATA X(266)/0.241743156163840D0/, A(266)/0.031589330770727D0/
34883 DATA X(267)/0.210031310460567D0/, A(267)/0.031828758894411D0/
34884 DATA X(268)/0.178096882367618D0/, A(268)/0.032034456231992D0/
34885 DATA X(269)/0.145973714654896D0/, A(269)/0.032206204794030D0/
34886 DATA X(270)/0.113695850110665D0/, A(270)/0.032343822568575D0/
34887 DATA X(271)/0.081297495464425D0/, A(271)/0.032447163714064D0/
34888 DATA X(272)/0.048812985136049D0/, A(272)/0.032516118713868D0/
34889 DATA X(273)/0.016276744849602D0/, A(273)/0.032550614492363D0/
34891 IF(IBD.NE.0) RETURN
34902 *$ CREATE PHO_DZEROX.FOR
34904 CDECK ID>, PHO_DZEROX
34905 DOUBLE PRECISION FUNCTION PHO_DZEROX(A0,B0,EPS,MAXF,F,MODE)
34906 C**********************************************************************
34910 C J.C.P. Bus and T.J. Dekker, Two Efficient Algorithms with
34911 C Guaranteed Convergence for Finding a Zero of a Function,
34912 C ACM Trans. Math. Software 1 (1975) 330-345.
34914 C (MODE = 1: Algorithm M; MODE = 2: Algorithm R)
34918 C***********************************************************************
34919 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34922 C input/output channels
34924 COMMON /POINOU/ LI,LO
34927 PARAMETER (NAME = 'PHO_DZEROX')
34929 DIMENSION IM1(2),IM2(2),LMT(2)
34932 PARAMETER (Z1 = 1, HALF = Z1/2)
34934 DATA IM1 /2,3/, IM2 /-1,3/
34936 IF(MODE .NE. 1 .AND. MODE .NE. 2) THEN
34938 WRITE(LO,100) NAME,MODE
34943 IF(FA*FB .GT. 0) THEN
34956 3 IF(ABS(FC) .LT. ABS(FB)) THEN
34971 IF(ABS(HB) .GT. TOL) THEN
34972 IF(IE .GT. IM1(MODE)) THEN
34975 TOL=TOL*SIGN(Z1,HB)
34991 IF(IE .EQ. IM2(MODE)) P=P+P
34992 IF(P .EQ. 0 .OR. P .LE. Q*TOL) THEN
34994 ELSEIF(P .LT. HB*Q) THEN
35006 IF(MF .GT. MAXF) THEN
35011 IF(FB .EQ. 0 .OR. SIGN(Z1,FC) .EQ. SIGN(Z1,FB)) GO TO 1
35012 IF(W .EQ. HB) GO TO 2
35019 100 FORMAT(1X,A,': mode = ',I3,' illegal')
35020 101 FORMAT(1X,A,': F(A) and F(B) have the same sign')
35021 102 FORMAT(1X,A,': too many function calls')
35025 *$ CREATE PHO_EXPINT.FOR
35027 CDECK ID>, PHO_EXPINT
35028 DOUBLE PRECISION FUNCTION PHO_EXPINT(RXM)
35029 C***********************************************************************
35031 C function to calculate E_i(x) = -E_1(-x)
35033 C based on CERNLIB C337 (changed by R.Engel 10/1993)
35035 C***********************************************************************
35036 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35039 C input/output channels
35041 COMMON /POINOU/ LI,LO
35043 DOUBLE PRECISION P1(5),Q1(5),P2(7),Q2(7),P3(6),Q3(6),P4(8),Q4(8)
35044 DOUBLE PRECISION A1(8),B1(8),A2(8),B2(8),A3(6),B3(6),XL(6)
35045 DOUBLE PRECISION X,Y,AP,BP,DP,AQ,BQ,DQ,X0,V
35047 DATA X0 /0.37250 74107 8137D0/
35048 DATA XL /-24.0D0,-12.0D0,-6.0D0,0.0D0,1.0D0,4.0D0/
35050 1/+4.29312 52343 210D+0, +3.98941 53870 321D+1,
35051 2 +2.92525 18866 921D+2, +4.25696 82638 592D+2,
35052 3 -4.34981 43832 952D+2/
35054 1/+1.00000 00000 000D+0, +1.88992 88395 003D+1,
35055 2 +1.50950 38744 251D+2, +5.68052 52718 987D+2,
35056 3 +7.53585 64359 843D+2/
35058 1/+4.30967 83946 939D-1, +6.90522 52278 444D+0,
35059 2 +2.30192 55939 133D+1, +2.43784 08879 132D+1,
35060 3 +9.04161 55694 633D+0, +9.99979 57705 159D-1,
35061 4 +4.65627 10797 510D-7/
35063 1/+1.03400 13040 487D-1, +3.31909 21359 330D+0,
35064 2 +2.04494 78501 379D+1, +4.12807 84189 142D+1,
35065 3 +3.24264 21069 514D+1, +1.00411 64382 905D+1,
35066 4 +1.00000 00000 000D+0/
35068 1/-2.39099 64453 136D+0, -1.47982 19500 504D+2,
35069 2 -2.54376 33976 890D+2, -1.19557 61038 372D+2,
35070 3 -1.96304 08535 939D+1, -9.99999 99990 360D-1/
35072 1/+1.77600 70940 351D+2, +5.30685 09610 812D+2,
35073 2 +4.62230 27156 148D+2, +1.56818 43364 539D+2,
35074 3 +2.16304 08494 238D+1, +1.00000 00000 000D+0/
35076 1/-8.66937 33995 107D+0, -5.49142 26552 109D+2,
35077 2 -4.21001 61535 707D+3, -2.49301 39345 865D+5,
35078 3 -1.19623 66934 925D+5, -2.21744 62775 885D+7,
35079 4 +3.89280 42131 120D+6, -3.91546 07380 910D+8/
35081 1/+3.41718 75000 000D+1, -1.60708 92658 722D+3,
35082 2 +3.57300 29805 851D+4, -4.83547 43616 216D+5,
35083 3 +4.28559 62461 175D+6, -2.49033 37574 054D+7,
35084 4 +8.91925 76757 561D+7, -1.65254 29972 521D+8/
35086 1/-2.18086 38152 072D+0, -2.19010 23385 488D+1,
35087 2 +9.30816 38566 217D+0, +2.50762 81129 356D+1,
35088 3 -3.31842 53199 722D+1, +6.01217 99083 008D+1,
35089 4 -4.32531 13287 813D+1, +1.00443 10922 808D+0/
35091 1/+0.00000 00000 000D+0, +3.93707 70185 272D+0,
35092 2 +3.00892 64837 292D+2, -6.25041 16167 188D+0,
35093 3 +1.00367 43951 673D+3, +1.43256 73812 194D+1,
35094 4 +2.73624 11988 933D+3, +5.27468 85196 291D-1/
35096 1/-3.48334 65360 285D+0, -1.86545 45488 340D+1,
35097 2 -8.28561 99414 064D+0, -3.23467 33030 540D+1,
35098 3 +1.79601 68876 925D+1, +1.75656 31546 961D+0,
35099 4 -1.95022 32128 966D+0, +9.99994 29607 471D-1/
35101 1/+0.00000 00000 000D+0, +6.95000 65588 743D+1,
35102 2 +5.72837 19383 732D+1, +2.57776 38423 844D+1,
35103 3 +7.60761 14800 773D+2, +2.89516 72792 514D+1,
35104 4 -3.43942 26689 987D+0, +1.00083 86740 264D+0/
35106 1/-2.77809 28934 438D+1, -1.01047 90815 760D+1,
35107 2 -9.14830 08216 736D+0, -5.02233 17461 851D+0,
35108 3 -3.00000 77799 358D+0, +1.00000 00000 704D+0/
35110 1/+0.00000 00000 000D+0, +1.22399 93926 823D+2,
35111 2 +2.72761 00778 779D+0, -7.18975 18395 045D+0,
35112 3 -2.99901 18065 262D+0, +1.99999 99428 260D+0/
35114 C conversion to E_i function
35117 IF(X .LE. XL(1)) THEN
35120 1 AP=A3(I)-X+B3(I)/AP
35121 Y=(EXP(-X)/X)*(1.D0-(A3(6)+B3(6)/AP)/X)
35122 ELSEIF(X .LE. XL(2)) THEN
35125 2 AP=A2(I)-X+B2(I)/AP
35126 Y=(EXP(-X)/X)*(A2(8)+B2(8)/AP)
35127 ELSEIF(X .LE. XL(3)) THEN
35130 3 AP=A1(I)-X+B1(I)/AP
35131 Y=(EXP(-X)/X)*(A1(8)+B1(8)/AP)
35132 ELSEIF(X .LT. XL(4)) THEN
35133 V=-2.D0*(X/3.D0+1.D0)
35145 14 DQ=Q4(I)-AQ+V*BQ
35146 Y=-LOG(-X/X0)+(X+X0)*(DP-AP)/(DQ-AQ)
35147 ELSEIF(X .EQ. XL(4)) THEN
35148 * CALL KERMTR('C337.1',LGFILE,MFLAG,RFLAG)
35150 * IF(LGFILE .EQ. 0) THEN
35151 * WRITE(LO,100) ENAME
35153 * WRITE(LGFILE,100) ENAME
35156 * IF(.NOT.RFLAG) CALL ABEND
35159 ELSEIF(X .LT. XL(5)) THEN
35166 ELSEIF(X .LE. XL(6)) THEN
35181 Y=EXP(-X)*Y*(1.D0+Y*AP/AQ)
35183 C sign conversion to E_i
35188 *$ CREATE PHO_RNDBET.FOR
35190 CDECK ID>, PHO_RNDBET
35191 DOUBLE PRECISION FUNCTION PHO_RNDBET(GAM,ETA)
35192 C********************************************************************
35194 C RANDOM NUMBER GENERATION FROM BETA
35195 C DISTRIBUTION IN REGION 0 < X < 1.
35196 C F(X) = X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM) / (GAMM(GAM
35199 C********************************************************************
35200 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35203 Y = PHO_RNDGAM(1.D0,GAM)
35204 Z = PHO_RNDGAM(1.D0,ETA)
35206 PHO_RNDBET = Y/(Y+Z)
35210 *$ CREATE PHO_RNDGAM.FOR
35212 CDECK ID>, PHO_RNDGAM
35213 DOUBLE PRECISION FUNCTION PHO_RNDGAM(ALAM,ETA)
35214 C********************************************************************
35216 C RANDOM NUMBER SELECTION FROM GAMMA DISTRIBUTION
35217 C F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)
35219 C********************************************************************
35220 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35226 IF(F.EQ.0.D0) GOTO 20
35227 10 R = DT_RNDM(ETA)
35229 IF (NCOU.GE.11) GOTO 20
35230 IF(R.LT.F/(F+2.71828D0)) GOTO 30
35231 YYY=LOG(DT_RNDM(F)+1.0D-9)/F
35232 IF(ABS(YYY).GT.50.D0) GOTO 20
35234 IF(LOG(DT_RNDM(Y)+1.0D-9).GT.-Y) GOTO 10
35238 30 Y = 1.D0-LOG(DT_RNDM(R)+1.0D-9)
35239 IF(DT_RNDM(Y).GT.Y**(F-1.D0)) GOTO 10
35240 40 IF(N.EQ.0) GOTO 70
35243 60 Z = Z*DT_RNDM(Y)
35244 Y = Y-LOG(Z+1.0D-9)
35245 70 PHO_RNDGAM = Y/ALAM
35249 *$ CREATE PHO_SFECFE.FOR
35251 CDECK ID>, PHO_SFECFE
35252 SUBROUTINE PHO_SFECFE(SFE,CFE)
35253 C**********************************************************************
35255 C fast random SIN(X) COS(X) selection
35257 C**********************************************************************
35258 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35267 IF(XY.GT.1.D0) GOTO 1
35270 IF(DT_RNDM(XY).LT.0.5D0) THEN
35275 *$ CREATE PHO_SWAPD.FOR
35277 CDECK ID>, PHO_SWAPD
35278 SUBROUTINE PHO_SWAPD(D1,D2)
35279 C********************************************************************
35281 C exchange of argument values (double precision)
35283 C********************************************************************
35284 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35290 *$ CREATE PHO_SWAPI.FOR
35292 CDECK ID>, PHO_SWAPI
35293 SUBROUTINE PHO_SWAPI(I1,I2)
35294 C********************************************************************
35296 C exchange of argument values (integer)
35298 C********************************************************************
35299 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35305 *$ CREATE PHO_HADCSL.FOR
35307 CDECK ID>, PHO_HADCSL
35308 SUBROUTINE PHO_HADCSL(ID1,ID2,ECM,PLAB,IMODE,
35309 & SIGTOT,SIGEL,SIGDIF,SLOPE,RHO)
35310 C***********************************************************************
35312 C low-energy cross section parametrizations
35314 C input: ID1,ID2 PDG IDs of particles (meson first)
35315 C ECM c.m. energy (GeV)
35316 C PLAB lab. momentum (second particle at rest)
35317 C IMODE 1 ECM given, PLAB ignored
35318 C 2 PLAB given, ECM ignored
35320 C output: SIGTOT total cross section (mb)
35321 C SIGEL elastic cross section (mb)
35322 C SIGDIF diffracive cross section (sd-1,sd-2,dd), (mb)
35323 C SLOPE forward elastic slope (GeV**-2)
35324 C RHO real/imaginary part of elastic amplitude
35328 C - low-energy data interpolation uses PDG fits from 1992 issue
35329 C - high-energy extrapolation by Donnachie-Landshoff like fit made
35331 C - analytic extension of amplitude to calculate rho
35333 C***********************************************************************
35337 INTEGER ID1,ID2,IMODE
35338 DOUBLE PRECISION ECM,PLAB,SIGTOT,SIGEL,SIGDIF(3),SLOPE,RHO
35340 C input/output channels
35342 COMMON /POINOU/ LI,LO
35344 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
35345 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
35346 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
35347 C model switches and parameters
35349 INTEGER ISWMDL,IPAMDL
35350 DOUBLE PRECISION PARMDL
35351 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
35354 DOUBLE PRECISION SIGTO1,SIGTO2,SIGEL1,SIGEL2,
35355 & SS,PL,PLL,E1,XP,YP,YM,PHR,PHP,X1,X2
35357 DOUBLE PRECISION TPDG92(7,2,6),TPDG96(9,6),BURQ83(3,6),XMA(6)
35360 & 3.D0, 2100.D0, 48.D0, 0.D0, 1.D0, 0.522D0, -4.51D0,
35361 & 3.D0, 2100.D0, 11.9D0, 26.9D0, -1.21D0, 0.169D0, -1.85D0,
35362 & 5.D0, 2100.D0, 38.4D0, 77.6D0, -0.64D0, 0.26D0, -1.2D0,
35363 & 5.D0, 2100.D0, 10.2D0, 52.7D0, -1.16D0, 0.125D0, -1.28D0,
35364 & 4.D0, 340.D0, 16.4D0, 19.3D0, -0.42D0, 0.19D0, 0.D0,
35365 & 4.D0, 340.D0, 0.D0, 11.4D0, -0.4D0, 0.079D0, 0.D0,
35366 & 2.5D0, 370.D0, 33.D0, 14.D0, -1.36D0, 0.456D0, -4.03D0,
35367 & 2.5D0, 370.D0, 1.76D0, 11.2D0, -0.64D0, 0.043D0, 0.D0,
35368 & 2.D0, 310.D0, 18.1D0, 0.D0, 1.D0, 0.26D0, -1.D0,
35369 & 2.D0, 310.D0, 5.D0, 8.1D0, -1.8D0, 0.16D0, -1.3D0,
35370 & 3.D0, 310.D0, 32.1D0, 0.D0, 1.D0, 0.66D0, -5.6D0,
35371 & 3.D0, 310.D0, 7.3D0, 0.D0, 1.D0, 0.29D0, -2.4D0 /
35374 & 50.D0, 22.D0,0.079D0,0.25D0,0.D0,
35375 & 77.15D0,-21.05D0,0.46D0,0.9D0,
35376 & 50.D0, 22.D0,0.079D0,0.25D0,0.D0,
35377 & 77.15D0,21.05D0,0.46D0,0.9D0,
35378 & 10.D0, 13.70,0.079D0,0.25D0,0.D0,
35379 & 31.85D0,-4.05D0,0.45D0,0.9D0,
35380 & 10.D0, 13.70,0.079D0,0.25D0,0.D0,
35381 & 31.85D0,4.05D0,0.45D0,0.9D0,
35382 & 10.D0, 12.20,0.079D0,0.25D0,0.D0,
35383 & 17.35D0,-9.05D0,0.50D0,0.9D0,
35384 & 10.D0, 12.20,0.079D0,0.25D0,0.D0,
35385 & 17.35D0,9.05D0,0.50D0,0.9D0 /
35388 & 11.13D0, -6.21D0, 0.30D0,
35389 & 11.13D0, 7.23D0, 0.30D0,
35390 & 9.11D0, -0.73D0, 0.28D0,
35391 & 9.11D0, 0.65D0, 0.28D0,
35392 & 8.55D0, -5.98D0, 0.28D0,
35393 & 8.55D0, 1.60D0, 0.28D0 /
35396 & 2*0.93956563D0, 2*0.13956995D0, 2*0.493677D0 /
35399 IF(ID2.NE.2212) THEN
35401 ELSE IF(ID1.EQ.2212) THEN
35403 ELSE IF(ID1.EQ.-2212) THEN
35405 ELSE IF(ID1.EQ.211) THEN
35407 ELSE IF(ID1.EQ.-211) THEN
35409 ELSE IF(ID1.EQ.321) THEN
35411 ELSE IF(ID1.EQ.-321) THEN
35417 C calculate lab momentum
35418 IF(IMODE.EQ.1) THEN
35420 E1 = 0.5D0/XMA(1)*(SS-XMA(1)**2-XMA(K)**2)
35421 PL = SQRT(E1*E1-XMA(K)**2)
35422 ELSE IF(IMODE.EQ.2) THEN
35424 SS = XMA(1)**2+XMA(K)**2+2.D0*XMA(1)*SQRT(PL**2+XMA(K)**2)
35427 WRITE(LO,'(1X,A,I5)') 'PHO_HADCSL:ERROR: invalid IMODE: ',IMODE
35432 C check against lower limit
35433 IF(ECM.LE.XMA(1)+XMA(K)) GOTO 200
35435 XP = TPDG96(2,K)*SS**TPDG96(3,K)
35436 YP = TPDG96(6,K)/SS**TPDG96(8,K)
35437 YM = TPDG96(7,K)/SS**TPDG96(8,K)
35439 PHR = TAN(PI/2.D0*(1.-TPDG96(8,K)))
35440 PHP = TAN(PI/2.D0*(1.+TPDG96(3,K)))
35441 RHO = (-YP/PHR + YM*PHR - XP/PHP)/(YP+YM+XP)
35442 SLOPE = BURQ83(1,K)+BURQ83(2,K)/SQRT(PL)+BURQ83(3,K)*PLL
35444 C select energy range and interpolation method
35445 IF(PL.LT.TPDG96(1,K)) THEN
35446 SIGTOT = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
35447 & + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
35448 SIGEL = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
35449 & + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
35450 ELSE IF(PL.LT.TPDG92(2,1,K)) THEN
35451 SIGTO1 = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
35452 & + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
35453 SIGEL1 = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
35454 & + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
35456 SIGEL2 = SIGTO2**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
35457 X2 = LOG(PL/TPDG96(1,K))/LOG(TPDG92(2,1,K)/TPDG96(1,K))
35459 SIGTOT = SIGTO2*X2 + SIGTO1*X1
35460 SIGEL = SIGEL2*X2 + SIGEL1*X1
35463 SIGEL = SIGTOT**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
35466 C no parametrization of diffraction implemented
35474 WRITE(LO,'(1X,2A,2I7)') 'PHO_HADCSL:ERROR: ',
35475 & 'invalid particle combination: ',ID1,ID2
35479 WRITE(LO,'(1X,2A,1P,2E12.4)') 'PHO_HADCSL:ERROR: ',
35480 & 'energy too small (Ecm,Plab): ',ECM,PLAB
35484 *$ CREATE PHO_CSDIFF.FOR
35486 CDECK ID>, PHO_CSDIFF
35487 SUBROUTINE PHO_CSDIFF(Id1,Id2,SS,Xi_min,Xi_max,
35488 & sig_sd1,sig_sd2,sig_dd)
35489 C***********************************************************************
35491 C cross section for diffraction dissociation according to
35492 C Goulianos' parametrization (Ref: PL B358 (1995) 379)
35494 C in addition rescaling for different particles is applied using
35495 C internal rescaling tables (not implemented yet)
35497 C input: Id1/2 PDG ID's of incoming particles
35498 C SS squared c.m. energy (GeV**2)
35499 C Xi_min min. diff mass (squared) = Xi_min*SS
35500 C Xi_max max. diff mass (squared) = Xi_max*SS
35502 C output: sig_sd1 cross section for diss. of particle 1 (mb)
35503 C sig_sd2 cross section for diss. of particle 2 (mb)
35504 C sig_dd cross section for diss. of both particles
35506 C***********************************************************************
35511 DOUBLE PRECISION SS,Xi_min,Xi_max,sig_sd1,sig_sd2,sig_dd
35513 C input/output channels
35515 COMMON /POINOU/ LI,LO
35517 DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
35518 COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
35519 & Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
35521 DOUBLE PRECISION xpos1(96),xwgh1(96),xpos2(96),xwgh2(96)
35522 DOUBLE PRECISION delta,alphap,beta0,gpom0,xm_p,x_rad2,xm4_p2,
35523 & fac,tt,t1,t2,tl,tu,Xnorm,xi,xil,xiu,w_xi,alpha_t,f2_t,
35524 & xms_1,xms_2,CSdiff
35526 INTEGER Ngau1,Ngau2,i1,i2
35530 DATA delta / 0.104d0 /
35531 DATA alphap / 0.25d0 /
35532 DATA beta0 / 6.56d0 /
35533 DATA gpom0 / 1.21d0 /
35534 DATA xm_p / 0.938d0 /
35535 DATA x_rad2 / 0.71d0 /
35537 C integration precision
35546 IF ((ABS(id1).EQ.2212).AND.(ABS(id2).EQ.2212)) THEN
35548 xm4_p2 = 4.D0*xm_p**2
35549 fac = beta0**2/(16.D0*PI)
35553 tl = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
35554 tu = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
35556 C flux renormalization and cross section
35560 xil = log(1.5d0/SS)
35563 IF(xiu.LE.xil) goto 1000
35565 CALL PHO_GAUSET(xil,xiu,Ngau1,xpos1,xwgh1)
35566 CALL PHO_GAUSET(tl,tu,Ngau2,xpos2,xwgh2)
35570 xi = exp(xpos1(i1))
35575 tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
35577 alpha_t = 1.D0+delta+alphap*tt
35578 f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
35581 & + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
35596 TL = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
35597 TU = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
35599 C single diffraction diss. cross section
35603 IF(XIU.LE.XIL) goto 2000
35605 CALL PHO_GAUSET(XIL,XIU,NGAU1,XPOS1,XWGH1)
35606 CALL PHO_GAUSET(TL,TU,NGAU2,XPOS2,XWGH2)
35610 xi = exp(xpos1(i1))
35611 w_xi = Xwgh1(i1)*beta0*gpom0*(xi*ss)**delta
35615 tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
35617 alpha_t = 1.D0+delta+alphap*tt
35618 f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
35621 & + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
35626 CSdiff = CSdiff*fac*GEV2MB/MAX(1.d0,Xnorm)
35628 * WRITE(LO,'(1x,1p,4e14.3)')
35629 * & sqrt(SS),Xnorm,2.*CSdiff*MAX(1.d0,Xnorm),2.*CSdiff
35636 C double diffraction dissociation cross section
35640 xil = log(1.5d0/SS)
35641 xiu = log(Xi_max/1.5d0)
35643 IF(xiu.LE.xil) goto 3000
35645 fac = (beta0*gpom0*SS**delta
35646 & /(4.d0*sqrt(PI)*MAX(1.d0,Xnorm)))**2
35649 CALL PHO_GAUSET(xil,xiu,ngau1,xpos1,xwgh1)
35653 xi = exp(xpos1(i1))
35656 xiu = log(Xi_max/(xi*SS))
35658 if(xil.lt.xiu) then
35660 CALL PHO_GAUSET(xil,xiu,Ngau2,xpos2,xwgh2)
35664 xms_2 = exp(xpos2(i2))*SS
35666 & + 1.d0/((xms_1*xms_2)**delta*log(SS/(xms_1*xms_2)))
35667 & *xwgh1(i1)*xwgh2(i2)
35675 sig_dd = CSdiff*fac*GEV2MB
35681 WRITE(LO,'(1x,2a,2I8)') 'PHO_CSDIFF: ',
35682 & 'invalid particle combination (Id1/2)',Id1,Id2
35688 *$ CREATE PHO_ALLM97.FOR
35690 CDECK ID>, PHO_ALLM97
35691 DOUBLE PRECISION FUNCTION PHO_ALLM97(Q2,W)
35692 C**********************************************************************
35694 C ALLM97 parametrization for gamma*-p cross section
35695 C (for F2 see comments, code adapted from V. Shekelyan, H1)
35697 C**********************************************************************
35701 C input/output channels
35703 COMMON /POINOU/ LI,LO
35705 DOUBLE PRECISION Q2,W
35706 DOUBLE PRECISION M02,M12,LAM2,M22
35707 DOUBLE PRECISION S11,S12,S13,A11,A12,A13,B11,B12,B13
35708 DOUBLE PRECISION S21,S22,S23,A21,A22,A23,B21,B22,B23
35709 DOUBLE PRECISION ALFA,XMP2,W2,Q02,S,T,T0,Z,CIN,
35710 & AP,BP,AR,BR,XP,XR,SR,SP,F2P,F2R
35711 DATA ALFA,XMP2 /112.2D0 , .8802D0 /
35742 Q02 = 0.46017D0 +LAM2
35746 T=LOG((Q2+Q02)/LAM2)
35748 IF(Q2.GT.0.D0) S=LOG(T/T0)
35751 IF(Q2.GT.0.D0) Z=(W2-XMP2)/(Q2+W2-XMP2)
35753 IF(S.LT.0.01D0) THEN
35757 XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
35763 F2P=SP*XP**AP*Z**BP
35767 XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
35773 F2R=SR*XR**AR*Z**BR
35779 XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
35781 AP=A11+(A11-A12)*(1.D0 /(1.D0 +S**A13)-1.D0 )
35783 BP=B11**2+B12**2*S**B13
35785 SP=S11+(S11-S12)*(1.D0 /(1.D0 +S**S13)-1.D0 )
35787 F2P=SP*XP**AP*Z**BP
35791 XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
35794 BR=B21**2+B22**2*S**B23
35797 F2R=SR*XR**AR*Z**BR
35801 * F2 = (F2P+F2R)*Q2/(Q2+M02)
35803 CIN=ALFA/(Q2+M02)*(1.D0 +4.D0*XMP2*Q2/(Q2+W2-XMP2)**2)/Z
35804 PHO_ALLM97 = CIN*(F2P+F2R)
35808 *$ CREATE PHO_DOR98LO.FOR
35810 CDECK ID>, PHO_DOR98LO
35811 SUBROUTINE PHO_DOR98LO (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
35812 C***********************************************************************
35814 C GRV98 parton densities, leading order set
35816 C For a detailed explanation see
35817 C M. Glueck, E. Reya, A. Vogt :
35818 C hep-ph/9806404 = DO-TH 98/07 = WUE-ITP-98-019
35819 C (To appear in Eur. Phys. J. C)
35821 C interpolation routine based on the original GRV98PA routine,
35822 C adapted to define interpolation table as DATA statements
35827 C INPUT: X = Bjorken-x (between 1.E-9 and 1.)
35828 C Q2 = scale in GeV**2 (between 0.8 and 1.E6)
35830 C OUTPUT: UV = u - u(bar), DV = d - d(bar), US = u(bar),
35831 C DS = d(bar), SS = s = s(bar), GL = gluon.
35832 C Always x times the distribution is returned.
35834 C******************************************************i****************
35835 IMPLICIT DOUBLE PRECISION (A-H, O-Z)
35838 C input/output channels
35840 COMMON /POINOU/ LI,LO
35842 PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
35843 DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
35844 1 XSF(NX,NQ), XGF(NX,NQ),
35845 2 XT(NARG), NA(NARG), ARRF(NX+NQ)
35847 DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
35848 & XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
35850 EQUIVALENCE (XUVF(1,1),XUVF_L(1))
35851 EQUIVALENCE (XDVF(1,1),XDVF_L(1))
35852 EQUIVALENCE (XDEF(1,1),XDEF_L(1))
35853 EQUIVALENCE (XUDF(1,1),XUDF_L(1))
35854 EQUIVALENCE (XSF(1,1),XSF_L(1))
35855 EQUIVALENCE (XGF(1,1),XGF_L(1))
35857 DATA (ARRF(K),K= 1, 95) /
35858 & -2.0723E+01,-2.0135E+01,-1.9560E+01,-1.8983E+01,-1.8421E+01,
35859 & -1.7833E+01,-1.7258E+01,-1.6680E+01,-1.6118E+01,-1.5530E+01,
35860 & -1.4955E+01,-1.4378E+01,-1.3816E+01,-1.3479E+01,-1.3122E+01,
35861 & -1.2717E+01,-1.2311E+01,-1.1913E+01,-1.1513E+01,-1.1176E+01,
35862 & -1.0820E+01,-1.0414E+01,-1.0009E+01,-9.6108E+00,-9.2103E+00,
35863 & -8.8739E+00,-8.5172E+00,-8.1117E+00,-7.7063E+00,-7.3082E+00,
35864 & -6.9078E+00,-6.5713E+00,-6.2146E+00,-5.8091E+00,-5.4037E+00,
35865 & -5.0056E+00,-4.6052E+00,-4.2687E+00,-3.9120E+00,-3.5066E+00,
35866 & -3.1011E+00,-2.8134E+00,-2.5257E+00,-2.3026E+00,-2.0794E+00,
35867 & -1.8971E+00,-1.7430E+00,-1.6094E+00,-1.4917E+00,-1.3863E+00,
35868 & -1.2910E+00,-1.2040E+00,-1.1239E+00,-1.0498E+00,-9.8083E-01,
35869 & -9.1629E-01,-7.9851E-01,-6.9315E-01,-5.9784E-01,-5.1083E-01,
35870 & -4.3078E-01,-3.5667E-01,-2.8768E-01,-2.2314E-01,-1.6252E-01,
35871 & -1.0536E-01,-5.1293E-02, 0.0000E+00,-2.2314E-01, 0.0000E+00,
35872 & 2.6236E-01, 5.8779E-01, 9.9325E-01, 1.3863E+00, 1.8563E+00,
35873 & 2.3026E+00, 2.7726E+00, 3.2189E+00, 3.6889E+00, 4.1589E+00,
35874 & 4.6052E+00, 5.1930E+00, 5.7683E+00, 6.3456E+00, 6.9078E+00,
35875 & 7.4955E+00, 8.0709E+00, 8.6482E+00, 9.2103E+00, 9.9988E+00,
35876 & 1.0736E+01, 1.1513E+01, 1.2301E+01, 1.3039E+01, 1.3816E+01/
35877 DATA (XUVF_L(K),K= 1, 114) /
35878 &2.3186E+00,2.2915E+00,2.2645E+00,2.2385E+00,2.2140E+00,2.1876E+00,
35879 &2.1623E+00,2.1366E+00,2.1121E+00,2.0862E+00,2.0612E+00,2.0358E+00,
35880 &2.0110E+00,1.9963E+00,1.9806E+00,1.9624E+00,1.9446E+00,1.9263E+00,
35881 &1.9072E+00,1.8904E+00,1.8724E+00,1.8515E+00,1.8294E+00,1.8085E+00,
35882 &1.7865E+00,1.7680E+00,1.7483E+00,1.7249E+00,1.6993E+00,1.6715E+00,
35883 &1.6385E+00,1.6141E+00,1.5884E+00,1.5597E+00,1.5337E+00,1.5121E+00,
35884 &1.4985E+00,1.4980E+00,1.5116E+00,1.5555E+00,1.6432E+00,1.7434E+00,
35885 &1.8861E+00,2.0327E+00,2.2174E+00,2.4015E+00,2.5849E+00,2.7671E+00,
35886 &2.9488E+00,3.1308E+00,3.3142E+00,3.4998E+00,3.6885E+00,3.8826E+00,
35887 &4.0815E+00,4.2069E+00,4.5481E+00,4.8830E+00,5.2116E+00,5.5351E+00,
35888 &5.8553E+00,6.1665E+00,6.4745E+00,6.7767E+00,7.0735E+00,7.3628E+00,
35889 &7.6283E+00,0.0000E+00,2.3948E+00,2.3665E+00,2.3388E+00,2.3126E+00,
35890 &2.2860E+00,2.2592E+00,2.2327E+00,2.2065E+00,2.1810E+00,2.1541E+00,
35891 &2.1284E+00,2.1020E+00,2.0760E+00,2.0605E+00,2.0443E+00,2.0259E+00,
35892 &2.0068E+00,1.9873E+00,1.9676E+00,1.9500E+00,1.9312E+00,1.9081E+00,
35893 &1.8860E+00,1.8635E+00,1.8406E+00,1.8221E+00,1.8007E+00,1.7764E+00,
35894 &1.7489E+00,1.7195E+00,1.6855E+00,1.6600E+00,1.6332E+00,1.6031E+00,
35895 &1.5760E+00,1.5532E+00,1.5397E+00,1.5376E+00,1.5507E+00,1.5929E+00,
35896 &1.6784E+00,1.7759E+00,1.9129E+00,2.0531E+00,2.2292E+00,2.4032E+00/
35897 DATA (XUVF_L(K),K= 115, 228) /
35898 &2.5752E+00,2.7449E+00,2.9135E+00,3.0810E+00,3.2491E+00,3.4183E+00,
35899 &3.5898E+00,3.7650E+00,3.9437E+00,4.0443E+00,4.3402E+00,4.6262E+00,
35900 &4.9009E+00,5.1640E+00,5.4156E+00,5.6530E+00,5.8759E+00,6.0779E+00,
35901 &6.2540E+00,6.3836E+00,6.4062E+00,0.0000E+00,2.4808E+00,2.4513E+00,
35902 &2.4236E+00,2.3948E+00,2.3680E+00,2.3397E+00,2.3127E+00,2.2853E+00,
35903 &2.2585E+00,2.2307E+00,2.2026E+00,2.1762E+00,2.1490E+00,2.1332E+00,
35904 &2.1164E+00,2.0964E+00,2.0766E+00,2.0565E+00,2.0353E+00,2.0171E+00,
35905 &1.9969E+00,1.9738E+00,1.9501E+00,1.9258E+00,1.9026E+00,1.8821E+00,
35906 &1.8594E+00,1.8330E+00,1.8046E+00,1.7734E+00,1.7378E+00,1.7112E+00,
35907 &1.6829E+00,1.6514E+00,1.6228E+00,1.5994E+00,1.5840E+00,1.5808E+00,
35908 &1.5927E+00,1.6334E+00,1.7157E+00,1.8093E+00,1.9406E+00,2.0735E+00,
35909 &2.2394E+00,2.4019E+00,2.5615E+00,2.7178E+00,2.8718E+00,3.0246E+00,
35910 &3.1766E+00,3.3284E+00,3.4820E+00,3.6370E+00,3.7952E+00,3.8716E+00,
35911 &4.1225E+00,4.3580E+00,4.5798E+00,4.7847E+00,4.9730E+00,5.1395E+00,
35912 &5.2832E+00,5.3945E+00,5.4634E+00,5.4612E+00,5.2940E+00,0.0000E+00,
35913 &2.5823E+00,2.5527E+00,2.5226E+00,2.4928E+00,2.4650E+00,2.4358E+00,
35914 &2.4071E+00,2.3783E+00,2.3505E+00,2.3212E+00,2.2928E+00,2.2636E+00,
35915 &2.2360E+00,2.2185E+00,2.2005E+00,2.1801E+00,2.1591E+00,2.1376E+00,
35916 &2.1153E+00,2.0960E+00,2.0747E+00,2.0505E+00,2.0247E+00,1.9991E+00/
35917 DATA (XUVF_L(K),K= 229, 342) /
35918 &1.9746E+00,1.9523E+00,1.9287E+00,1.9000E+00,1.8693E+00,1.8361E+00,
35919 &1.7994E+00,1.7711E+00,1.7409E+00,1.7076E+00,1.6772E+00,1.6517E+00,
35920 &1.6345E+00,1.6302E+00,1.6408E+00,1.6789E+00,1.7574E+00,1.8457E+00,
35921 &1.9692E+00,2.0939E+00,2.2474E+00,2.3969E+00,2.5419E+00,2.6837E+00,
35922 &2.8216E+00,2.9573E+00,3.0915E+00,3.2246E+00,3.3583E+00,3.4917E+00,
35923 &3.6273E+00,3.6791E+00,3.8823E+00,4.0673E+00,4.2350E+00,4.3813E+00,
35924 &4.5072E+00,4.6083E+00,4.6757E+00,4.7055E+00,4.6825E+00,4.5674E+00,
35925 &4.2566E+00,0.0000E+00,2.7025E+00,2.6705E+00,2.6393E+00,2.6093E+00,
35926 &2.5790E+00,2.5484E+00,2.5184E+00,2.4880E+00,2.4590E+00,2.4277E+00,
35927 &2.3971E+00,2.3669E+00,2.3380E+00,2.3200E+00,2.3002E+00,2.2782E+00,
35928 &2.2557E+00,2.2331E+00,2.2092E+00,2.1887E+00,2.1660E+00,2.1400E+00,
35929 &2.1126E+00,2.0859E+00,2.0586E+00,2.0351E+00,2.0094E+00,1.9786E+00,
35930 &1.9453E+00,1.9096E+00,1.8707E+00,1.8406E+00,1.8084E+00,1.7728E+00,
35931 &1.7392E+00,1.7128E+00,1.6933E+00,1.6875E+00,1.6949E+00,1.7295E+00,
35932 &1.8023E+00,1.8845E+00,1.9991E+00,2.1134E+00,2.2525E+00,2.3868E+00,
35933 &2.5160E+00,2.6405E+00,2.7609E+00,2.8781E+00,2.9929E+00,3.1059E+00,
35934 &3.2180E+00,3.3292E+00,3.4407E+00,3.4675E+00,3.6225E+00,3.7573E+00,
35935 &3.8710E+00,3.9617E+00,4.0270E+00,4.0642E+00,4.0675E+00,4.0263E+00,
35936 &3.9240E+00,3.7262E+00,3.3217E+00,0.0000E+00,2.8135E+00,2.7813E+00/
35937 DATA (XUVF_L(K),K= 343, 456) /
35938 &2.7489E+00,2.7166E+00,2.6850E+00,2.6527E+00,2.6212E+00,2.5898E+00,
35939 &2.5592E+00,2.5267E+00,2.4943E+00,2.4636E+00,2.4320E+00,2.4129E+00,
35940 &2.3929E+00,2.3695E+00,2.3453E+00,2.3211E+00,2.2959E+00,2.2740E+00,
35941 &2.2496E+00,2.2221E+00,2.1931E+00,2.1653E+00,2.1356E+00,2.1112E+00,
35942 &2.0830E+00,2.0503E+00,2.0147E+00,1.9766E+00,1.9361E+00,1.9037E+00,
35943 &1.8696E+00,1.8318E+00,1.7966E+00,1.7677E+00,1.7459E+00,1.7378E+00,
35944 &1.7430E+00,1.7738E+00,1.8407E+00,1.9169E+00,2.0223E+00,2.1273E+00,
35945 &2.2537E+00,2.3742E+00,2.4892E+00,2.5990E+00,2.7043E+00,2.8056E+00,
35946 &2.9038E+00,3.0000E+00,3.0936E+00,3.1864E+00,3.2782E+00,3.2867E+00,
35947 &3.4021E+00,3.4971E+00,3.5691E+00,3.6188E+00,3.6422E+00,3.6335E+00,
35948 &3.5908E+00,3.5036E+00,3.3552E+00,3.1085E+00,2.6634E+00,0.0000E+00,
35949 &2.9406E+00,2.9062E+00,2.8726E+00,2.8385E+00,2.8060E+00,2.7720E+00,
35950 &2.7392E+00,2.7058E+00,2.6734E+00,2.6399E+00,2.6057E+00,2.5722E+00,
35951 &2.5390E+00,2.5194E+00,2.4975E+00,2.4728E+00,2.4471E+00,2.4216E+00,
35952 &2.3945E+00,2.3712E+00,2.3458E+00,2.3152E+00,2.2856E+00,2.2545E+00,
35953 &2.2237E+00,2.1966E+00,2.1672E+00,2.1312E+00,2.0926E+00,2.0521E+00,
35954 &2.0093E+00,1.9748E+00,1.9384E+00,1.8975E+00,1.8601E+00,1.8275E+00,
35955 &1.8036E+00,1.7924E+00,1.7948E+00,1.8206E+00,1.8808E+00,1.9499E+00,
35956 &2.0450E+00,2.1390E+00,2.2512E+00,2.3570E+00,2.4564E+00,2.5501E+00/
35957 DATA (XUVF_L(K),K= 457, 570) /
35958 &2.6391E+00,2.7240E+00,2.8053E+00,2.8834E+00,2.9590E+00,3.0326E+00,
35959 &3.1042E+00,3.0942E+00,3.1727E+00,3.2289E+00,3.2628E+00,3.2739E+00,
35960 &3.2574E+00,3.2103E+00,3.1297E+00,3.0047E+00,2.8211E+00,2.5467E+00,
35961 &2.0897E+00,0.0000E+00,3.0557E+00,3.0193E+00,2.9840E+00,2.9497E+00,
35962 &2.9150E+00,2.8801E+00,2.8454E+00,2.8109E+00,2.7771E+00,2.7412E+00,
35963 &2.7065E+00,2.6716E+00,2.6360E+00,2.6149E+00,2.5923E+00,2.5663E+00,
35964 &2.5395E+00,2.5120E+00,2.4834E+00,2.4589E+00,2.4330E+00,2.4011E+00,
35965 &2.3676E+00,2.3363E+00,2.3027E+00,2.2736E+00,2.2422E+00,2.2040E+00,
35966 &2.1629E+00,2.1194E+00,2.0750E+00,2.0384E+00,1.9996E+00,1.9565E+00,
35967 &1.9160E+00,1.8811E+00,1.8541E+00,1.8409E+00,1.8399E+00,1.8611E+00,
35968 &1.9143E+00,1.9764E+00,2.0622E+00,2.1459E+00,2.2457E+00,2.3385E+00,
35969 &2.4249E+00,2.5051E+00,2.5806E+00,2.6515E+00,2.7182E+00,2.7823E+00,
35970 &2.8427E+00,2.9008E+00,2.9564E+00,2.9332E+00,2.9828E+00,3.0094E+00,
35971 &3.0142E+00,2.9955E+00,2.9537E+00,2.8796E+00,2.7735E+00,2.6260E+00,
35972 &2.4242E+00,2.1388E+00,1.6900E+00,0.0000E+00,3.1718E+00,3.1348E+00,
35973 &3.0971E+00,3.0610E+00,3.0260E+00,2.9896E+00,2.9533E+00,2.9173E+00,
35974 &2.8818E+00,2.8449E+00,2.8072E+00,2.7709E+00,2.7340E+00,2.7121E+00,
35975 &2.6877E+00,2.6605E+00,2.6319E+00,2.6032E+00,2.5732E+00,2.5471E+00,
35976 &2.5180E+00,2.4851E+00,2.4511E+00,2.4170E+00,2.3817E+00,2.3505E+00/
35977 DATA (XUVF_L(K),K= 571, 684) /
35978 &2.3172E+00,2.2762E+00,2.2328E+00,2.1868E+00,2.1400E+00,2.1012E+00,
35979 &2.0601E+00,2.0136E+00,1.9704E+00,1.9335E+00,1.9035E+00,1.8868E+00,
35980 &1.8827E+00,1.8990E+00,1.9452E+00,2.0005E+00,2.0763E+00,2.1507E+00,
35981 &2.2377E+00,2.3179E+00,2.3917E+00,2.4592E+00,2.5218E+00,2.5799E+00,
35982 &2.6336E+00,2.6843E+00,2.7314E+00,2.7753E+00,2.8166E+00,2.7824E+00,
35983 &2.8054E+00,2.8081E+00,2.7893E+00,2.7474E+00,2.6818E+00,2.5888E+00,
35984 &2.4646E+00,2.3032E+00,2.0902E+00,1.8025E+00,1.3740E+00,0.0000E+00,
35985 &3.2793E+00,3.2385E+00,3.2014E+00,3.1643E+00,3.1270E+00,3.0888E+00,
35986 &3.0517E+00,3.0141E+00,2.9773E+00,2.9392E+00,2.9009E+00,2.8610E+00,
35987 &2.8230E+00,2.8000E+00,2.7754E+00,2.7459E+00,2.7163E+00,2.6858E+00,
35988 &2.6545E+00,2.6270E+00,2.5962E+00,2.5617E+00,2.5271E+00,2.4903E+00,
35989 &2.4527E+00,2.4207E+00,2.3851E+00,2.3421E+00,2.2960E+00,2.2476E+00,
35990 &2.1987E+00,2.1578E+00,2.1146E+00,2.0670E+00,2.0202E+00,1.9796E+00,
35991 &1.9468E+00,1.9282E+00,1.9203E+00,1.9319E+00,1.9712E+00,2.0197E+00,
35992 &2.0872E+00,2.1524E+00,2.2288E+00,2.2981E+00,2.3606E+00,2.4177E+00,
35993 &2.4692E+00,2.5159E+00,2.5591E+00,2.5981E+00,2.6339E+00,2.6669E+00,
35994 &2.6962E+00,2.6528E+00,2.6566E+00,2.6395E+00,2.6028E+00,2.5437E+00,
35995 &2.4622E+00,2.3555E+00,2.2200E+00,2.0488E+00,1.8335E+00,1.5506E+00,
35996 &1.1442E+00,0.0000E+00,3.3868E+00,3.3470E+00,3.3075E+00,3.2689E+00/
35997 DATA (XUVF_L(K),K= 685, 798) /
35998 &3.2300E+00,3.1909E+00,3.1517E+00,3.1129E+00,3.0747E+00,3.0335E+00,
35999 &2.9946E+00,2.9537E+00,2.9140E+00,2.8896E+00,2.8638E+00,2.8337E+00,
36000 &2.8021E+00,2.7705E+00,2.7373E+00,2.7075E+00,2.6767E+00,2.6403E+00,
36001 &2.6031E+00,2.5649E+00,2.5258E+00,2.4917E+00,2.4537E+00,2.4080E+00,
36002 &2.3597E+00,2.3091E+00,2.2580E+00,2.2150E+00,2.1692E+00,2.1186E+00,
36003 &2.0701E+00,2.0257E+00,1.9901E+00,1.9679E+00,1.9571E+00,1.9629E+00,
36004 &1.9955E+00,2.0378E+00,2.0963E+00,2.1529E+00,2.2178E+00,2.2766E+00,
36005 &2.3287E+00,2.3749E+00,2.4162E+00,2.4529E+00,2.4850E+00,2.5140E+00,
36006 &2.5392E+00,2.5617E+00,2.5798E+00,2.5298E+00,2.5151E+00,2.4811E+00,
36007 &2.4282E+00,2.3561E+00,2.2611E+00,2.1439E+00,2.0005E+00,1.8252E+00,
36008 &1.6091E+00,1.3345E+00,9.5375E-01,0.0000E+00,3.4912E+00,3.4507E+00,
36009 &3.4100E+00,3.3696E+00,3.3310E+00,3.2893E+00,3.2496E+00,3.2088E+00,
36010 &3.1686E+00,3.1278E+00,3.0865E+00,3.0438E+00,3.0020E+00,2.9766E+00,
36011 &2.9494E+00,2.9180E+00,2.8850E+00,2.8520E+00,2.8174E+00,2.7877E+00,
36012 &2.7550E+00,2.7169E+00,2.6762E+00,2.6369E+00,2.5958E+00,2.5594E+00,
36013 &2.5195E+00,2.4721E+00,2.4211E+00,2.3680E+00,2.3145E+00,2.2695E+00,
36014 &2.2214E+00,2.1684E+00,2.1154E+00,2.0706E+00,2.0303E+00,2.0058E+00,
36015 &1.9909E+00,1.9920E+00,2.0177E+00,2.0531E+00,2.1031E+00,2.1511E+00,
36016 &2.2060E+00,2.2548E+00,2.2972E+00,2.3339E+00,2.3655E+00,2.3927E+00/
36017 DATA (XUVF_L(K),K= 799, 912) /
36018 &2.4159E+00,2.4357E+00,2.4520E+00,2.4644E+00,2.4735E+00,2.4171E+00,
36019 &2.3878E+00,2.3397E+00,2.2743E+00,2.1907E+00,2.0861E+00,1.9611E+00,
36020 &1.8128E+00,1.6351E+00,1.4227E+00,1.1584E+00,8.0371E-01,0.0000E+00,
36021 &3.5892E+00,3.5473E+00,3.5055E+00,3.4637E+00,3.4230E+00,3.3809E+00,
36022 &3.3396E+00,3.2976E+00,3.2571E+00,3.2126E+00,3.1696E+00,3.1272E+00,
36023 &3.0840E+00,3.0569E+00,3.0286E+00,2.9959E+00,2.9619E+00,2.9273E+00,
36024 &2.8910E+00,2.8598E+00,2.8266E+00,2.7863E+00,2.7448E+00,2.7029E+00,
36025 &2.6598E+00,2.6219E+00,2.5804E+00,2.5305E+00,2.4773E+00,2.4214E+00,
36026 &2.3662E+00,2.3191E+00,2.2698E+00,2.2126E+00,2.1577E+00,2.1092E+00,
36027 &2.0674E+00,2.0393E+00,2.0210E+00,2.0173E+00,2.0367E+00,2.0654E+00,
36028 &2.1076E+00,2.1485E+00,2.1942E+00,2.2338E+00,2.2678E+00,2.2959E+00,
36029 &2.3193E+00,2.3386E+00,2.3539E+00,2.3660E+00,2.3738E+00,2.3789E+00,
36030 &2.3799E+00,2.3197E+00,2.2776E+00,2.2186E+00,2.1426E+00,2.0495E+00,
36031 &1.9397E+00,1.8097E+00,1.6583E+00,1.4814E+00,1.2736E+00,1.0200E+00,
36032 &6.8880E-01,0.0000E+00,3.7157E+00,3.6699E+00,3.6275E+00,3.5842E+00,
36033 &3.5420E+00,3.4972E+00,3.4542E+00,3.4107E+00,3.3678E+00,3.3234E+00,
36034 &3.2774E+00,3.2332E+00,3.1870E+00,3.1600E+00,3.1297E+00,3.0952E+00,
36035 &3.0595E+00,3.0231E+00,2.9850E+00,2.9534E+00,2.9160E+00,2.8740E+00,
36036 &2.8312E+00,2.7872E+00,2.7408E+00,2.7014E+00,2.6568E+00,2.6045E+00/
36037 DATA (XUVF_L(K),K= 913, 1026) /
36038 &2.5481E+00,2.4895E+00,2.4315E+00,2.3817E+00,2.3283E+00,2.2697E+00,
36039 &2.2106E+00,2.1591E+00,2.1128E+00,2.0807E+00,2.0578E+00,2.0477E+00,
36040 &2.0583E+00,2.0796E+00,2.1122E+00,2.1433E+00,2.1777E+00,2.2069E+00,
36041 &2.2299E+00,2.2483E+00,2.2618E+00,2.2718E+00,2.2778E+00,2.2803E+00,
36042 &2.2797E+00,2.2749E+00,2.2668E+00,2.2019E+00,2.1468E+00,2.0761E+00,
36043 &1.9902E+00,1.8883E+00,1.7711E+00,1.6370E+00,1.4847E+00,1.3103E+00,
36044 &1.1091E+00,8.7047E-01,5.6856E-01,0.0000E+00,3.8327E+00,3.7877E+00,
36045 &3.7424E+00,3.6981E+00,3.6540E+00,3.6083E+00,3.5637E+00,3.5184E+00,
36046 &3.4753E+00,3.4271E+00,3.3800E+00,3.3325E+00,3.2860E+00,3.2564E+00,
36047 &3.2258E+00,3.1893E+00,3.1519E+00,3.1135E+00,3.0738E+00,3.0389E+00,
36048 &3.0010E+00,2.9580E+00,2.9118E+00,2.8654E+00,2.8178E+00,2.7758E+00,
36049 &2.7289E+00,2.6738E+00,2.6146E+00,2.5530E+00,2.4924E+00,2.4399E+00,
36050 &2.3845E+00,2.3213E+00,2.2605E+00,2.2040E+00,2.1540E+00,2.1186E+00,
36051 &2.0908E+00,2.0749E+00,2.0772E+00,2.0914E+00,2.1145E+00,2.1368E+00,
36052 &2.1613E+00,2.1804E+00,2.1941E+00,2.2037E+00,2.2088E+00,2.2101E+00,
36053 &2.2083E+00,2.2031E+00,2.1942E+00,2.1826E+00,2.1665E+00,2.0987E+00,
36054 &2.0321E+00,1.9516E+00,1.8571E+00,1.7497E+00,1.6281E+00,1.4923E+00,
36055 &1.3406E+00,1.1697E+00,9.7635E-01,7.5209E-01,4.7638E-01,0.0000E+00,
36056 &3.9497E+00,3.9009E+00,3.8555E+00,3.8080E+00,3.7630E+00,3.7163E+00/
36057 DATA (XUVF_L(K),K= 1027, 1140) /
36058 &3.6699E+00,3.6231E+00,3.5765E+00,3.5285E+00,3.4807E+00,3.4305E+00,
36059 &3.3810E+00,3.3511E+00,3.3185E+00,3.2805E+00,3.2414E+00,3.2016E+00,
36060 &3.1598E+00,3.1244E+00,3.0837E+00,3.0383E+00,2.9908E+00,2.9424E+00,
36061 &2.8919E+00,2.8477E+00,2.7990E+00,2.7403E+00,2.6784E+00,2.6142E+00,
36062 &2.5507E+00,2.4960E+00,2.4362E+00,2.3710E+00,2.3058E+00,2.2463E+00,
36063 &2.1931E+00,2.1539E+00,2.1216E+00,2.0996E+00,2.0940E+00,2.1012E+00,
36064 &2.1154E+00,2.1294E+00,2.1444E+00,2.1543E+00,2.1597E+00,2.1610E+00,
36065 &2.1585E+00,2.1523E+00,2.1432E+00,2.1307E+00,2.1155E+00,2.0964E+00,
36066 &2.0742E+00,2.0035E+00,1.9273E+00,1.8396E+00,1.7387E+00,1.6273E+00,
36067 &1.5032E+00,1.3665E+00,1.2164E+00,1.0501E+00,8.6515E-01,6.5470E-01,
36068 &4.0284E-01,0.0000E+00,4.0572E+00,4.0093E+00,3.9616E+00,3.9140E+00,
36069 &3.8670E+00,3.8185E+00,3.7706E+00,3.7224E+00,3.6746E+00,3.6251E+00,
36070 &3.5744E+00,3.5233E+00,3.4720E+00,3.4406E+00,3.4062E+00,3.3671E+00,
36071 &3.3263E+00,3.2847E+00,3.2414E+00,3.2046E+00,3.1620E+00,3.1150E+00,
36072 &3.0653E+00,3.0145E+00,2.9619E+00,2.9153E+00,2.8641E+00,2.8032E+00,
36073 &2.7388E+00,2.6715E+00,2.6056E+00,2.5481E+00,2.4880E+00,2.4171E+00,
36074 &2.3496E+00,2.2862E+00,2.2282E+00,2.1865E+00,2.1502E+00,2.1217E+00,
36075 &2.1086E+00,2.1086E+00,2.1149E+00,2.1216E+00,2.1275E+00,2.1295E+00,
36076 &2.1273E+00,2.1212E+00,2.1119E+00,2.0992E+00,2.0837E+00,2.0653E+00/
36077 DATA (XUVF_L(K),K= 1141, 1254) /
36078 &2.0442E+00,2.0194E+00,1.9912E+00,1.9193E+00,1.8359E+00,1.7412E+00,
36079 &1.6366E+00,1.5214E+00,1.3956E+00,1.2594E+00,1.1115E+00,9.5033E-01,
36080 &7.7356E-01,5.7585E-01,3.4506E-01,0.0000E+00,4.1710E+00,4.1201E+00,
36081 &4.0712E+00,4.0213E+00,3.9730E+00,3.9228E+00,3.8734E+00,3.8233E+00,
36082 &3.7726E+00,3.7217E+00,3.6699E+00,3.6160E+00,3.5640E+00,3.5311E+00,
36083 &3.4960E+00,3.4549E+00,3.4121E+00,3.3689E+00,3.3237E+00,3.2848E+00,
36084 &3.2425E+00,3.1917E+00,3.1399E+00,3.0866E+00,3.0319E+00,2.9838E+00,
36085 &2.9306E+00,2.8668E+00,2.7992E+00,2.7291E+00,2.6605E+00,2.6007E+00,
36086 &2.5375E+00,2.4631E+00,2.3919E+00,2.3261E+00,2.2643E+00,2.2183E+00,
36087 &2.1772E+00,2.1426E+00,2.1222E+00,2.1155E+00,2.1135E+00,2.1130E+00,
36088 &2.1102E+00,2.1039E+00,2.0941E+00,2.0815E+00,2.0652E+00,2.0466E+00,
36089 &2.0251E+00,2.0014E+00,1.9746E+00,1.9450E+00,1.9116E+00,1.8381E+00,
36090 &1.7481E+00,1.6484E+00,1.5404E+00,1.4225E+00,1.2963E+00,1.1611E+00,
36091 &1.0161E+00,8.6047E-01,6.9193E-01,5.0691E-01,2.9581E-01,0.0000E+00,
36092 &4.2754E+00,4.2238E+00,4.1737E+00,4.1233E+00,4.0740E+00,4.0219E+00,
36093 &3.9713E+00,3.9196E+00,3.8675E+00,3.8160E+00,3.7618E+00,3.7060E+00,
36094 &3.6510E+00,3.6173E+00,3.5808E+00,3.5380E+00,3.4941E+00,3.4493E+00,
36095 &3.4027E+00,3.3623E+00,3.3163E+00,3.2647E+00,3.2114E+00,3.1563E+00,
36096 &3.0989E+00,3.0489E+00,2.9929E+00,2.9263E+00,2.8563E+00,2.7837E+00/
36097 DATA (XUVF_L(K),K= 1255, 1368) /
36098 &2.7122E+00,2.6501E+00,2.5825E+00,2.5073E+00,2.4327E+00,2.3623E+00,
36099 &2.2962E+00,2.2474E+00,2.2020E+00,2.1616E+00,2.1335E+00,2.1209E+00,
36100 &2.1113E+00,2.1034E+00,2.0929E+00,2.0795E+00,2.0634E+00,2.0439E+00,
36101 &2.0222E+00,1.9982E+00,1.9716E+00,1.9428E+00,1.9113E+00,1.8773E+00,
36102 &1.8394E+00,1.7649E+00,1.6692E+00,1.5658E+00,1.4547E+00,1.3360E+00,
36103 &1.2095E+00,1.0761E+00,9.3485E-01,7.8430E-01,6.2380E-01,4.5010E-01,
36104 &2.5625E-01,0.0000E+00,4.3798E+00,4.3275E+00,4.2762E+00,4.2239E+00,
36105 &4.1730E+00,4.1196E+00,4.0674E+00,4.0143E+00,3.9623E+00,3.9056E+00,
36106 &3.8502E+00,3.7935E+00,3.7370E+00,3.7018E+00,3.6642E+00,3.6200E+00,
36107 &3.5742E+00,3.5277E+00,3.4786E+00,3.4371E+00,3.3901E+00,3.3359E+00,
36108 &3.2800E+00,3.2235E+00,3.1639E+00,3.1115E+00,3.0537E+00,2.9847E+00,
36109 &2.9116E+00,2.8364E+00,2.7623E+00,2.6973E+00,2.6275E+00,2.5497E+00,
36110 &2.4705E+00,2.3972E+00,2.3281E+00,2.2747E+00,2.2253E+00,2.1793E+00,
36111 &2.1444E+00,2.1253E+00,2.1081E+00,2.0939E+00,2.0755E+00,2.0555E+00,
36112 &2.0332E+00,2.0081E+00,1.9814E+00,1.9522E+00,1.9205E+00,1.8875E+00,
36113 &1.8520E+00,1.8139E+00,1.7725E+00,1.6968E+00,1.5976E+00,1.4911E+00,
36114 &1.3772E+00,1.2577E+00,1.1320E+00,1.0005E+00,8.6242E-01,7.1750E-01,
36115 &5.6466E-01,4.0150E-01,2.2333E-01,0.0000E+00,4.4809E+00,4.4265E+00,
36116 &4.3735E+00,4.3193E+00,4.2670E+00,4.2128E+00,4.1585E+00,4.1039E+00/
36117 DATA (XUVF_L(K),K= 1369, 1482) /
36118 &4.0509E+00,3.9928E+00,3.9351E+00,3.8769E+00,3.8180E+00,3.7821E+00,
36119 &3.7434E+00,3.6974E+00,3.6501E+00,3.6019E+00,3.5513E+00,3.5093E+00,
36120 &3.4594E+00,3.4035E+00,3.3456E+00,3.2870E+00,3.2250E+00,3.1715E+00,
36121 &3.1110E+00,3.0396E+00,2.9639E+00,2.8863E+00,2.8096E+00,2.7429E+00,
36122 &2.6702E+00,2.5884E+00,2.5068E+00,2.4296E+00,2.3560E+00,2.3003E+00,
36123 &2.2464E+00,2.1951E+00,2.1530E+00,2.1283E+00,2.1045E+00,2.0843E+00,
36124 &2.0591E+00,2.0328E+00,2.0047E+00,1.9749E+00,1.9429E+00,1.9096E+00,
36125 &1.8740E+00,1.8369E+00,1.7978E+00,1.7560E+00,1.7116E+00,1.6360E+00,
36126 &1.5322E+00,1.4233E+00,1.3084E+00,1.1885E+00,1.0637E+00,9.3449E-01,
36127 &7.9961E-01,6.6020E-01,5.1453E-01,3.6103E-01,1.9641E-01,0.0000E+00,
36128 &4.6169E+00,4.5608E+00,4.5060E+00,4.4504E+00,4.3960E+00,4.3395E+00,
36129 &4.2837E+00,4.2262E+00,4.1710E+00,4.1106E+00,4.0517E+00,3.9908E+00,
36130 &3.9300E+00,3.8920E+00,3.8509E+00,3.8030E+00,3.7538E+00,3.7035E+00,
36131 &3.6494E+00,3.6055E+00,3.5556E+00,3.4966E+00,3.4351E+00,3.3738E+00,
36132 &3.3090E+00,3.2518E+00,3.1888E+00,3.1141E+00,3.0348E+00,2.9533E+00,
36133 &2.8730E+00,2.8020E+00,2.7264E+00,2.6400E+00,2.5551E+00,2.4732E+00,
36134 &2.3941E+00,2.3329E+00,2.2742E+00,2.2147E+00,2.1644E+00,2.1317E+00,
36135 &2.0986E+00,2.0700E+00,2.0363E+00,2.0021E+00,1.9668E+00,1.9299E+00,
36136 &1.8922E+00,1.8532E+00,1.8125E+00,1.7704E+00,1.7270E+00,1.6809E+00/
36137 DATA (XUVF_L(K),K= 1483, 1596) /
36138 &1.6327E+00,1.5570E+00,1.4497E+00,1.3373E+00,1.2215E+00,1.1020E+00,
36139 &9.7897E-01,8.5304E-01,7.2349E-01,5.9074E-01,4.5411E-01,3.1307E-01,
36140 &1.6547E-01,0.0000E+00,4.7403E+00,4.6834E+00,4.6262E+00,4.5696E+00,
36141 &4.5140E+00,4.4557E+00,4.3978E+00,4.3393E+00,4.2817E+00,4.2191E+00,
36142 &4.1578E+00,4.0941E+00,4.0310E+00,3.9917E+00,3.9492E+00,3.8995E+00,
36143 &3.8481E+00,3.7958E+00,3.7411E+00,3.6937E+00,3.6405E+00,3.5806E+00,
36144 &3.5171E+00,3.4520E+00,3.3840E+00,3.3254E+00,3.2596E+00,3.1812E+00,
36145 &3.0985E+00,3.0137E+00,2.9301E+00,2.8556E+00,2.7782E+00,2.6879E+00,
36146 &2.5974E+00,2.5119E+00,2.4281E+00,2.3629E+00,2.2982E+00,2.2324E+00,
36147 &2.1730E+00,2.1332E+00,2.0922E+00,2.0570E+00,2.0152E+00,1.9739E+00,
36148 &1.9323E+00,1.8902E+00,1.8474E+00,1.8039E+00,1.7589E+00,1.7129E+00,
36149 &1.6654E+00,1.6163E+00,1.5652E+00,1.4896E+00,1.3789E+00,1.2649E+00,
36150 &1.1487E+00,1.0300E+00,9.0896E-01,7.8619E-01,6.6149E-01,5.3498E-01,
36151 &4.0654E-01,2.7586E-01,1.4208E-01,0.0000E+00,4.8699E+00,4.8107E+00,
36152 &4.7518E+00,4.6928E+00,4.6350E+00,4.5750E+00,4.5152E+00,4.4524E+00,
36153 &4.3956E+00,4.3299E+00,4.2674E+00,4.2014E+00,4.1350E+00,4.0939E+00,
36154 &4.0503E+00,3.9982E+00,3.9448E+00,3.8905E+00,3.8328E+00,3.7846E+00,
36155 &3.7300E+00,3.6664E+00,3.5991E+00,3.5326E+00,3.4620E+00,3.3998E+00,
36156 &3.3311E+00,3.2494E+00,3.1632E+00,3.0752E+00,2.9881E+00,2.9120E+00/
36157 DATA (XUVF_L(K),K= 1597, 1710) /
36158 &2.8299E+00,2.7339E+00,2.6398E+00,2.5493E+00,2.4611E+00,2.3911E+00,
36159 &2.3215E+00,2.2482E+00,2.1812E+00,2.1342E+00,2.0854E+00,2.0427E+00,
36160 &1.9932E+00,1.9453E+00,1.8978E+00,1.8504E+00,1.8030E+00,1.7545E+00,
36161 &1.7059E+00,1.6565E+00,1.6056E+00,1.5535E+00,1.4989E+00,1.4245E+00,
36162 &1.3108E+00,1.1959E+00,1.0798E+00,9.6219E-01,8.4358E-01,7.2422E-01,
36163 &6.0451E-01,4.8425E-01,3.6380E-01,2.4286E-01,1.2189E-01,0.0000E+00,
36164 &4.9964E+00,4.9356E+00,4.8755E+00,4.8147E+00,4.7550E+00,4.6935E+00,
36165 &4.6315E+00,4.5697E+00,4.5062E+00,4.4406E+00,4.3752E+00,4.3061E+00,
36166 &4.2380E+00,4.1962E+00,4.1500E+00,4.0963E+00,4.0405E+00,3.9832E+00,
36167 &3.9245E+00,3.8728E+00,3.8172E+00,3.7504E+00,3.6811E+00,3.6108E+00,
36168 &3.5381E+00,3.4734E+00,3.4018E+00,3.3164E+00,3.2269E+00,3.1352E+00,
36169 &3.0446E+00,2.9657E+00,2.8794E+00,2.7800E+00,2.6821E+00,2.5867E+00,
36170 &2.4930E+00,2.4184E+00,2.3433E+00,2.2634E+00,2.1877E+00,2.1342E+00,
36171 &2.0772E+00,2.0279E+00,1.9713E+00,1.9172E+00,1.8642E+00,1.8120E+00,
36172 &1.7600E+00,1.7076E+00,1.6553E+00,1.6027E+00,1.5491E+00,1.4938E+00,
36173 &1.4374E+00,1.3637E+00,1.2481E+00,1.1325E+00,1.0166E+00,9.0047E-01,
36174 &7.8428E-01,6.6889E-01,5.5381E-01,4.3953E-01,3.2652E-01,2.1461E-01,
36175 &1.0498E-01,0.0000E+00,5.1134E+00,5.0511E+00,4.9886E+00,4.9273E+00,
36176 &4.8660E+00,4.8016E+00,4.7382E+00,4.6744E+00,4.6106E+00,4.5420E+00/
36177 DATA (XUVF_L(K),K= 1711, 1824) /
36178 &4.4742E+00,4.4028E+00,4.3320E+00,4.2892E+00,4.2413E+00,4.1858E+00,
36179 &4.1281E+00,4.0682E+00,4.0067E+00,3.9556E+00,3.8955E+00,3.8271E+00,
36180 &3.7556E+00,3.6829E+00,3.6071E+00,3.5401E+00,3.4662E+00,3.3777E+00,
36181 &3.2849E+00,3.1898E+00,3.0960E+00,3.0140E+00,2.9244E+00,2.8224E+00,
36182 &2.7183E+00,2.6191E+00,2.5219E+00,2.4431E+00,2.3628E+00,2.2767E+00,
36183 &2.1931E+00,2.1332E+00,2.0695E+00,2.0145E+00,1.9514E+00,1.8920E+00,
36184 &1.8340E+00,1.7775E+00,1.7215E+00,1.6664E+00,1.6108E+00,1.5553E+00,
36185 &1.4995E+00,1.4421E+00,1.3839E+00,1.3103E+00,1.1944E+00,1.0782E+00,
36186 &9.6271E-01,8.4822E-01,7.3481E-01,6.2240E-01,5.1184E-01,4.0291E-01,
36187 &2.9618E-01,1.9206E-01,9.1846E-02,0.0000E+00,5.2367E+00,5.1713E+00,
36188 &5.1071E+00,5.0425E+00,4.9800E+00,4.9141E+00,4.8489E+00,4.7833E+00,
36189 &4.7181E+00,4.6457E+00,4.5768E+00,4.5034E+00,4.4300E+00,4.3847E+00,
36190 &4.3353E+00,4.2782E+00,4.2182E+00,4.1570E+00,4.0921E+00,4.0385E+00,
36191 &3.9782E+00,3.9074E+00,3.8331E+00,3.7575E+00,3.6781E+00,3.6086E+00,
36192 &3.5313E+00,3.4401E+00,3.3439E+00,3.2455E+00,3.1483E+00,3.0623E+00,
36193 &2.9694E+00,2.8629E+00,2.7561E+00,2.6527E+00,2.5508E+00,2.4669E+00,
36194 &2.3816E+00,2.2887E+00,2.1979E+00,2.1317E+00,2.0613E+00,2.0002E+00,
36195 &1.9307E+00,1.8659E+00,1.8033E+00,1.7426E+00,1.6834E+00,1.6247E+00,
36196 &1.5668E+00,1.5085E+00,1.4504E+00,1.3916E+00,1.3311E+00,1.2591E+00/
36197 DATA (XUVF_L(K),K= 1825, 1836) /
36198 &1.1415E+00,1.0256E+00,9.1107E-01,7.9840E-01,6.8736E-01,5.7902E-01,
36199 &4.7260E-01,3.6895E-01,2.6838E-01,1.7161E-01,8.0264E-02,0.0000E+00/
36200 DATA (XDVF_L(K),K= 1, 114) /
36201 &1.4230E+00,1.4064E+00,1.3903E+00,1.3749E+00,1.3590E+00,1.3424E+00,
36202 &1.3271E+00,1.3114E+00,1.2962E+00,1.2803E+00,1.2647E+00,1.2492E+00,
36203 &1.2340E+00,1.2246E+00,1.2155E+00,1.2044E+00,1.1927E+00,1.1814E+00,
36204 &1.1695E+00,1.1589E+00,1.1479E+00,1.1347E+00,1.1214E+00,1.1080E+00,
36205 &1.0944E+00,1.0824E+00,1.0700E+00,1.0544E+00,1.0371E+00,1.0188E+00,
36206 &9.9884E-01,9.8287E-01,9.6563E-01,9.4645E-01,9.2847E-01,9.1313E-01,
36207 &9.0246E-01,8.9955E-01,9.0461E-01,9.2737E-01,9.7648E-01,1.0343E+00,
36208 &1.1168E+00,1.2030E+00,1.3129E+00,1.4240E+00,1.5357E+00,1.6492E+00,
36209 &1.7643E+00,1.8818E+00,2.0016E+00,2.1253E+00,2.2535E+00,2.3853E+00,
36210 &2.5225E+00,2.5620E+00,2.7906E+00,3.0230E+00,3.2574E+00,3.4983E+00,
36211 &3.7459E+00,4.0062E+00,4.2803E+00,4.5790E+00,4.9150E+00,5.3263E+00,
36212 &5.9228E+00,0.0000E+00,1.4698E+00,1.4526E+00,1.4360E+00,1.4199E+00,
36213 &1.4030E+00,1.3864E+00,1.3702E+00,1.3542E+00,1.3386E+00,1.3221E+00,
36214 &1.3059E+00,1.2896E+00,1.2740E+00,1.2644E+00,1.2544E+00,1.2425E+00,
36215 &1.2309E+00,1.2185E+00,1.2061E+00,1.1953E+00,1.1836E+00,1.1697E+00,
36216 &1.1558E+00,1.1417E+00,1.1275E+00,1.1154E+00,1.1011E+00,1.0844E+00,
36217 &1.0663E+00,1.0471E+00,1.0261E+00,1.0092E+00,9.9133E-01,9.7103E-01,
36218 &9.5184E-01,9.3560E-01,9.2380E-01,9.1922E-01,9.2378E-01,9.4563E-01,
36219 &9.9235E-01,1.0474E+00,1.1262E+00,1.2078E+00,1.3110E+00,1.4146E+00/
36220 DATA (XDVF_L(K),K= 115, 228) /
36221 &1.5192E+00,1.6241E+00,1.7298E+00,1.8375E+00,1.9471E+00,2.0592E+00,
36222 &2.1741E+00,2.2925E+00,2.4144E+00,2.4425E+00,2.6407E+00,2.8375E+00,
36223 &3.0361E+00,3.2345E+00,3.4343E+00,3.6388E+00,3.8488E+00,4.0682E+00,
36224 &4.3043E+00,4.5737E+00,4.9280E+00,0.0000E+00,1.5226E+00,1.5047E+00,
36225 &1.4874E+00,1.4702E+00,1.4530E+00,1.4363E+00,1.4193E+00,1.4023E+00,
36226 &1.3860E+00,1.3690E+00,1.3520E+00,1.3351E+00,1.3190E+00,1.3083E+00,
36227 &1.2983E+00,1.2858E+00,1.2733E+00,1.2606E+00,1.2476E+00,1.2362E+00,
36228 &1.2237E+00,1.2092E+00,1.1943E+00,1.1795E+00,1.1645E+00,1.1509E+00,
36229 &1.1365E+00,1.1185E+00,1.0994E+00,1.0784E+00,1.0566E+00,1.0388E+00,
36230 &1.0195E+00,9.9801E-01,9.7765E-01,9.6019E-01,9.4712E-01,9.4158E-01,
36231 &9.4524E-01,9.6454E-01,1.0088E+00,1.0604E+00,1.1346E+00,1.2112E+00,
36232 &1.3076E+00,1.4038E+00,1.4995E+00,1.5957E+00,1.6918E+00,1.7888E+00,
36233 &1.8877E+00,1.9877E+00,2.0896E+00,2.1940E+00,2.2999E+00,2.3168E+00,
36234 &2.4844E+00,2.6497E+00,2.8098E+00,2.9678E+00,3.1219E+00,3.2743E+00,
36235 &3.4260E+00,3.5742E+00,3.7237E+00,3.8717E+00,4.0300E+00,0.0000E+00,
36236 &1.5849E+00,1.5662E+00,1.5482E+00,1.5298E+00,1.5130E+00,1.4944E+00,
36237 &1.4769E+00,1.4593E+00,1.4423E+00,1.4243E+00,1.4066E+00,1.3894E+00,
36238 &1.3720E+00,1.3607E+00,1.3499E+00,1.3366E+00,1.3237E+00,1.3101E+00,
36239 &1.2963E+00,1.2840E+00,1.2709E+00,1.2553E+00,1.2396E+00,1.2232E+00/
36240 DATA (XDVF_L(K),K= 229, 342) /
36241 &1.2075E+00,1.1932E+00,1.1776E+00,1.1584E+00,1.1377E+00,1.1152E+00,
36242 &1.0922E+00,1.0729E+00,1.0524E+00,1.0294E+00,1.0074E+00,9.8843E-01,
36243 &9.7377E-01,9.6751E-01,9.6901E-01,9.8606E-01,1.0264E+00,1.0745E+00,
36244 &1.1435E+00,1.2136E+00,1.3018E+00,1.3894E+00,1.4758E+00,1.5619E+00,
36245 &1.6474E+00,1.7332E+00,1.8194E+00,1.9063E+00,1.9941E+00,2.0832E+00,
36246 &2.1725E+00,2.1789E+00,2.3166E+00,2.4460E+00,2.5708E+00,2.6884E+00,
36247 &2.7987E+00,2.9025E+00,2.9974E+00,3.0823E+00,3.1538E+00,3.2013E+00,
36248 &3.2043E+00,0.0000E+00,1.6586E+00,1.6391E+00,1.6202E+00,1.6014E+00,
36249 &1.5830E+00,1.5638E+00,1.5457E+00,1.5267E+00,1.5087E+00,1.4899E+00,
36250 &1.4711E+00,1.4517E+00,1.4340E+00,1.4224E+00,1.4107E+00,1.3972E+00,
36251 &1.3827E+00,1.3684E+00,1.3535E+00,1.3404E+00,1.3263E+00,1.3096E+00,
36252 &1.2927E+00,1.2758E+00,1.2575E+00,1.2422E+00,1.2250E+00,1.2046E+00,
36253 &1.1821E+00,1.1579E+00,1.1331E+00,1.1127E+00,1.0905E+00,1.0655E+00,
36254 &1.0415E+00,1.0207E+00,1.0042E+00,9.9612E-01,9.9507E-01,1.0089E+00,
36255 &1.0451E+00,1.0887E+00,1.1514E+00,1.2146E+00,1.2936E+00,1.3711E+00,
36256 &1.4469E+00,1.5220E+00,1.5960E+00,1.6694E+00,1.7428E+00,1.8159E+00,
36257 &1.8894E+00,1.9620E+00,2.0344E+00,2.0313E+00,2.1357E+00,2.2333E+00,
36258 &2.3215E+00,2.4009E+00,2.4706E+00,2.5292E+00,2.5750E+00,2.6036E+00,
36259 &2.6096E+00,2.5783E+00,2.4673E+00,0.0000E+00,1.7269E+00,1.7065E+00/
36260 DATA (XDVF_L(K),K= 343, 456) /
36261 &1.6866E+00,1.6676E+00,1.6480E+00,1.6279E+00,1.6089E+00,1.5891E+00,
36262 &1.5701E+00,1.5502E+00,1.5307E+00,1.5113E+00,1.4910E+00,1.4799E+00,
36263 &1.4673E+00,1.4526E+00,1.4373E+00,1.4221E+00,1.4060E+00,1.3922E+00,
36264 &1.3771E+00,1.3596E+00,1.3414E+00,1.3234E+00,1.3045E+00,1.2879E+00,
36265 &1.2689E+00,1.2468E+00,1.2227E+00,1.1966E+00,1.1706E+00,1.1487E+00,
36266 &1.1248E+00,1.0980E+00,1.0724E+00,1.0495E+00,1.0310E+00,1.0212E+00,
36267 &1.0181E+00,1.0291E+00,1.0609E+00,1.1002E+00,1.1563E+00,1.2136E+00,
36268 &1.2840E+00,1.3528E+00,1.4201E+00,1.4854E+00,1.5492E+00,1.6125E+00,
36269 &1.6751E+00,1.7368E+00,1.7981E+00,1.8579E+00,1.9157E+00,1.9057E+00,
36270 &1.9875E+00,2.0577E+00,2.1190E+00,2.1700E+00,2.2094E+00,2.2370E+00,
36271 &2.2484E+00,2.2403E+00,2.2047E+00,2.1261E+00,1.9567E+00,0.0000E+00,
36272 &1.8047E+00,1.7833E+00,1.7626E+00,1.7418E+00,1.7220E+00,1.7009E+00,
36273 &1.6810E+00,1.6603E+00,1.6403E+00,1.6193E+00,1.5986E+00,1.5775E+00,
36274 &1.5570E+00,1.5441E+00,1.5309E+00,1.5156E+00,1.4991E+00,1.4828E+00,
36275 &1.4658E+00,1.4510E+00,1.4350E+00,1.4160E+00,1.3966E+00,1.3772E+00,
36276 &1.3565E+00,1.3386E+00,1.3184E+00,1.2942E+00,1.2680E+00,1.2404E+00,
36277 &1.2125E+00,1.1887E+00,1.1631E+00,1.1342E+00,1.1064E+00,1.0813E+00,
36278 &1.0608E+00,1.0480E+00,1.0426E+00,1.0500E+00,1.0774E+00,1.1111E+00,
36279 &1.1608E+00,1.2107E+00,1.2719E+00,1.3315E+00,1.3886E+00,1.4445E+00/
36280 DATA (XDVF_L(K),K= 457, 570) /
36281 &1.4984E+00,1.5505E+00,1.6020E+00,1.6524E+00,1.7009E+00,1.7480E+00,
36282 &1.7926E+00,1.7763E+00,1.8327E+00,1.8794E+00,1.9154E+00,1.9405E+00,
36283 &1.9531E+00,1.9537E+00,1.9362E+00,1.8986E+00,1.8325E+00,1.7203E+00,
36284 &1.5163E+00,0.0000E+00,1.8755E+00,1.8533E+00,1.8314E+00,1.8106E+00,
36285 &1.7890E+00,1.7672E+00,1.7464E+00,1.7248E+00,1.7038E+00,1.6817E+00,
36286 &1.6601E+00,1.6385E+00,1.6160E+00,1.6033E+00,1.5889E+00,1.5721E+00,
36287 &1.5552E+00,1.5380E+00,1.5199E+00,1.5042E+00,1.4871E+00,1.4670E+00,
36288 &1.4463E+00,1.4249E+00,1.4036E+00,1.3843E+00,1.3630E+00,1.3364E+00,
36289 &1.3086E+00,1.2791E+00,1.2500E+00,1.2245E+00,1.1971E+00,1.1662E+00,
36290 &1.1361E+00,1.1090E+00,1.0858E+00,1.0721E+00,1.0641E+00,1.0676E+00,
36291 &1.0898E+00,1.1195E+00,1.1627E+00,1.2069E+00,1.2603E+00,1.3118E+00,
36292 &1.3607E+00,1.4079E+00,1.4534E+00,1.4968E+00,1.5392E+00,1.5794E+00,
36293 &1.6181E+00,1.6552E+00,1.6888E+00,1.6690E+00,1.7073E+00,1.7353E+00,
36294 &1.7530E+00,1.7595E+00,1.7531E+00,1.7338E+00,1.6988E+00,1.6428E+00,
36295 &1.5583E+00,1.4293E+00,1.2136E+00,0.0000E+00,1.9470E+00,1.9238E+00,
36296 &1.9021E+00,1.8782E+00,1.8570E+00,1.8343E+00,1.8123E+00,1.7898E+00,
36297 &1.7680E+00,1.7449E+00,1.7222E+00,1.6994E+00,1.6760E+00,1.6624E+00,
36298 &1.6469E+00,1.6299E+00,1.6118E+00,1.5933E+00,1.5742E+00,1.5574E+00,
36299 &1.5392E+00,1.5179E+00,1.4955E+00,1.4738E+00,1.4506E+00,1.4300E+00/
36300 DATA (XDVF_L(K),K= 571, 684) /
36301 &1.4069E+00,1.3792E+00,1.3492E+00,1.3178E+00,1.2868E+00,1.2597E+00,
36302 &1.2307E+00,1.1976E+00,1.1654E+00,1.1363E+00,1.1108E+00,1.0945E+00,
36303 &1.0840E+00,1.0845E+00,1.1017E+00,1.1268E+00,1.1637E+00,1.2016E+00,
36304 &1.2473E+00,1.2910E+00,1.3324E+00,1.3719E+00,1.4090E+00,1.4450E+00,
36305 &1.4784E+00,1.5109E+00,1.5404E+00,1.5681E+00,1.5925E+00,1.5689E+00,
36306 &1.5916E+00,1.6043E+00,1.6067E+00,1.5981E+00,1.5779E+00,1.5449E+00,
36307 &1.4949E+00,1.4262E+00,1.3303E+00,1.1932E+00,9.7657E-01,0.0000E+00,
36308 &2.0122E+00,1.9881E+00,1.9640E+00,1.9418E+00,1.9190E+00,1.8954E+00,
36309 &1.8721E+00,1.8492E+00,1.8262E+00,1.8024E+00,1.7784E+00,1.7550E+00,
36310 &1.7300E+00,1.7157E+00,1.6999E+00,1.6818E+00,1.6627E+00,1.6435E+00,
36311 &1.6233E+00,1.6058E+00,1.5866E+00,1.5643E+00,1.5417E+00,1.5178E+00,
36312 &1.4926E+00,1.4705E+00,1.4465E+00,1.4174E+00,1.3856E+00,1.3527E+00,
36313 &1.3198E+00,1.2914E+00,1.2605E+00,1.2257E+00,1.1915E+00,1.1601E+00,
36314 &1.1326E+00,1.1142E+00,1.1016E+00,1.0982E+00,1.1114E+00,1.1321E+00,
36315 &1.1637E+00,1.1958E+00,1.2352E+00,1.2722E+00,1.3071E+00,1.3397E+00,
36316 &1.3704E+00,1.3995E+00,1.4267E+00,1.4516E+00,1.4736E+00,1.4942E+00,
36317 &1.5100E+00,1.4848E+00,1.4955E+00,1.4964E+00,1.4873E+00,1.4675E+00,
36318 &1.4366E+00,1.3933E+00,1.3349E+00,1.2585E+00,1.1565E+00,1.0171E+00,
36319 &8.0601E-01,0.0000E+00,2.0789E+00,2.0539E+00,2.0294E+00,2.0053E+00/
36320 DATA (XDVF_L(K),K= 685, 798) /
36321 &1.9820E+00,1.9581E+00,1.9336E+00,1.9096E+00,1.8860E+00,1.8609E+00,
36322 &1.8367E+00,1.8106E+00,1.7860E+00,1.7706E+00,1.7543E+00,1.7350E+00,
36323 &1.7150E+00,1.6945E+00,1.6735E+00,1.6550E+00,1.6349E+00,1.6112E+00,
36324 &1.5864E+00,1.5617E+00,1.5356E+00,1.5128E+00,1.4868E+00,1.4555E+00,
36325 &1.4224E+00,1.3876E+00,1.3532E+00,1.3231E+00,1.2904E+00,1.2536E+00,
36326 &1.2173E+00,1.1838E+00,1.1545E+00,1.1338E+00,1.1185E+00,1.1113E+00,
36327 &1.1199E+00,1.1362E+00,1.1627E+00,1.1895E+00,1.2222E+00,1.2529E+00,
36328 &1.2813E+00,1.3080E+00,1.3324E+00,1.3546E+00,1.3756E+00,1.3938E+00,
36329 &1.4103E+00,1.4232E+00,1.4319E+00,1.4055E+00,1.4052E+00,1.3959E+00,
36330 &1.3768E+00,1.3480E+00,1.3084E+00,1.2576E+00,1.1928E+00,1.1110E+00,
36331 &1.0066E+00,8.6804E-01,6.6615E-01,0.0000E+00,2.1434E+00,2.1178E+00,
36332 &2.0930E+00,2.0676E+00,2.0440E+00,2.0184E+00,1.9935E+00,1.9686E+00,
36333 &1.9439E+00,1.9179E+00,1.8915E+00,1.8663E+00,1.8400E+00,1.8239E+00,
36334 &1.8067E+00,1.7863E+00,1.7654E+00,1.7440E+00,1.7219E+00,1.7025E+00,
36335 &1.6814E+00,1.6565E+00,1.6311E+00,1.6045E+00,1.5766E+00,1.5526E+00,
36336 &1.5250E+00,1.4925E+00,1.4574E+00,1.4213E+00,1.3849E+00,1.3532E+00,
36337 &1.3191E+00,1.2800E+00,1.2418E+00,1.2062E+00,1.1743E+00,1.1517E+00,
36338 &1.1338E+00,1.1237E+00,1.1272E+00,1.1399E+00,1.1608E+00,1.1828E+00,
36339 &1.2092E+00,1.2341E+00,1.2570E+00,1.2774E+00,1.2962E+00,1.3135E+00/
36340 DATA (XDVF_L(K),K= 799, 912) /
36341 &1.3280E+00,1.3406E+00,1.3511E+00,1.3588E+00,1.3613E+00,1.3335E+00,
36342 &1.3246E+00,1.3067E+00,1.2801E+00,1.2441E+00,1.1985E+00,1.1418E+00,
36343 &1.0724E+00,9.8806E-01,8.8293E-01,7.4746E-01,5.5665E-01,0.0000E+00,
36344 &2.2035E+00,2.1769E+00,2.1514E+00,2.1259E+00,2.1000E+00,2.0743E+00,
36345 &2.0488E+00,2.0226E+00,1.9973E+00,1.9702E+00,1.9428E+00,1.9166E+00,
36346 &1.8890E+00,1.8729E+00,1.8548E+00,1.8337E+00,1.8116E+00,1.7895E+00,
36347 &1.7662E+00,1.7461E+00,1.7239E+00,1.6980E+00,1.6714E+00,1.6436E+00,
36348 &1.6146E+00,1.5889E+00,1.5604E+00,1.5266E+00,1.4895E+00,1.4515E+00,
36349 &1.4138E+00,1.3806E+00,1.3448E+00,1.3040E+00,1.2638E+00,1.2261E+00,
36350 &1.1920E+00,1.1669E+00,1.1469E+00,1.1341E+00,1.1335E+00,1.1420E+00,
36351 &1.1583E+00,1.1760E+00,1.1971E+00,1.2168E+00,1.2343E+00,1.2501E+00,
36352 &1.2640E+00,1.2762E+00,1.2866E+00,1.2942E+00,1.2996E+00,1.3020E+00,
36353 &1.3003E+00,1.2725E+00,1.2557E+00,1.2312E+00,1.1982E+00,1.1569E+00,
36354 &1.1068E+00,1.0465E+00,9.7460E-01,8.8884E-01,7.8459E-01,6.5333E-01,
36355 &4.7359E-01,0.0000E+00,2.2800E+00,2.2524E+00,2.2256E+00,2.1987E+00,
36356 &2.1730E+00,2.1459E+00,2.1192E+00,2.0922E+00,2.0656E+00,2.0374E+00,
36357 &2.0100E+00,1.9802E+00,1.9520E+00,1.9346E+00,1.9156E+00,1.8937E+00,
36358 &1.8706E+00,1.8475E+00,1.8228E+00,1.8017E+00,1.7783E+00,1.7509E+00,
36359 &1.7221E+00,1.6937E+00,1.6627E+00,1.6354E+00,1.6050E+00,1.5688E+00/
36360 DATA (XDVF_L(K),K= 913, 1026) /
36361 &1.5301E+00,1.4898E+00,1.4503E+00,1.4150E+00,1.3772E+00,1.3339E+00,
36362 &1.2911E+00,1.2510E+00,1.2138E+00,1.1866E+00,1.1637E+00,1.1458E+00,
36363 &1.1403E+00,1.1441E+00,1.1548E+00,1.1669E+00,1.1817E+00,1.1950E+00,
36364 &1.2065E+00,1.2163E+00,1.2249E+00,1.2313E+00,1.2355E+00,1.2379E+00,
36365 &1.2379E+00,1.2348E+00,1.2275E+00,1.1987E+00,1.1744E+00,1.1427E+00,
36366 &1.1035E+00,1.0570E+00,1.0018E+00,9.3862E-01,8.6494E-01,7.7913E-01,
36367 &6.7747E-01,5.5266E-01,3.8741E-01,0.0000E+00,2.3524E+00,2.3243E+00,
36368 &2.2963E+00,2.2689E+00,2.2420E+00,2.2137E+00,2.1858E+00,2.1579E+00,
36369 &2.1301E+00,2.1011E+00,2.0718E+00,2.0424E+00,2.0120E+00,1.9937E+00,
36370 &1.9743E+00,1.9509E+00,1.9267E+00,1.9020E+00,1.8763E+00,1.8541E+00,
36371 &1.8295E+00,1.8006E+00,1.7713E+00,1.7402E+00,1.7077E+00,1.6794E+00,
36372 &1.6475E+00,1.6087E+00,1.5679E+00,1.5259E+00,1.4840E+00,1.4470E+00,
36373 &1.4072E+00,1.3615E+00,1.3163E+00,1.2738E+00,1.2336E+00,1.2045E+00,
36374 &1.1783E+00,1.1563E+00,1.1459E+00,1.1457E+00,1.1504E+00,1.1577E+00,
36375 &1.1662E+00,1.1742E+00,1.1807E+00,1.1857E+00,1.1886E+00,1.1902E+00,
36376 &1.1899E+00,1.1878E+00,1.1830E+00,1.1751E+00,1.1633E+00,1.1345E+00,
36377 &1.1039E+00,1.0667E+00,1.0230E+00,9.7228E-01,9.1417E-01,8.4905E-01,
36378 &7.7478E-01,6.9004E-01,5.9155E-01,4.7371E-01,3.2191E-01,0.0000E+00,
36379 &2.4233E+00,2.3947E+00,2.3653E+00,2.3365E+00,2.3090E+00,2.2800E+00/
36380 DATA (XDVF_L(K),K= 1027, 1140) /
36381 &2.2512E+00,2.2220E+00,2.1934E+00,2.1628E+00,2.1319E+00,2.1007E+00,
36382 &2.0700E+00,2.0512E+00,2.0301E+00,2.0057E+00,1.9809E+00,1.9549E+00,
36383 &1.9281E+00,1.9049E+00,1.8791E+00,1.8497E+00,1.8175E+00,1.7854E+00,
36384 &1.7507E+00,1.7209E+00,1.6878E+00,1.6474E+00,1.6047E+00,1.5603E+00,
36385 &1.5164E+00,1.4777E+00,1.4358E+00,1.3879E+00,1.3403E+00,1.2952E+00,
36386 &1.2523E+00,1.2206E+00,1.1913E+00,1.1661E+00,1.1505E+00,1.1462E+00,
36387 &1.1460E+00,1.1481E+00,1.1518E+00,1.1545E+00,1.1559E+00,1.1562E+00,
36388 &1.1548E+00,1.1523E+00,1.1478E+00,1.1414E+00,1.1331E+00,1.1212E+00,
36389 &1.1055E+00,1.0763E+00,1.0405E+00,9.9877E-01,9.5130E-01,8.9815E-01,
36390 &8.3813E-01,7.7188E-01,6.9792E-01,6.1492E-01,5.2020E-01,4.0920E-01,
36391 &2.7020E-01,0.0000E+00,2.4906E+00,2.4607E+00,2.4307E+00,2.4014E+00,
36392 &2.3730E+00,2.3427E+00,2.3127E+00,2.2828E+00,2.2528E+00,2.2213E+00,
36393 &2.1903E+00,2.1577E+00,2.1250E+00,2.1053E+00,2.0839E+00,2.0583E+00,
36394 &2.0318E+00,2.0051E+00,1.9771E+00,1.9527E+00,1.9259E+00,1.8935E+00,
36395 &1.8607E+00,1.8269E+00,1.7917E+00,1.7606E+00,1.7253E+00,1.6833E+00,
36396 &1.6387E+00,1.5925E+00,1.5465E+00,1.5061E+00,1.4624E+00,1.4121E+00,
36397 &1.3623E+00,1.3152E+00,1.2700E+00,1.2349E+00,1.2036E+00,1.1745E+00,
36398 &1.1544E+00,1.1457E+00,1.1410E+00,1.1389E+00,1.1378E+00,1.1357E+00,
36399 &1.1332E+00,1.1290E+00,1.1244E+00,1.1176E+00,1.1099E+00,1.0996E+00/
36400 DATA (XDVF_L(K),K= 1141, 1254) /
36401 &1.0875E+00,1.0729E+00,1.0538E+00,1.0249E+00,9.8511E-01,9.3994E-01,
36402 &8.8948E-01,8.3410E-01,7.7332E-01,7.0681E-01,6.3377E-01,5.5280E-01,
36403 &4.6214E-01,3.5755E-01,2.2965E-01,0.0000E+00,2.5589E+00,2.5291E+00,
36404 &2.4979E+00,2.4676E+00,2.4370E+00,2.4060E+00,2.3753E+00,2.3443E+00,
36405 &2.3135E+00,2.2809E+00,2.2486E+00,2.2146E+00,2.1810E+00,2.1602E+00,
36406 &2.1376E+00,2.1114E+00,2.0841E+00,2.0557E+00,2.0265E+00,2.0011E+00,
36407 &1.9730E+00,1.9392E+00,1.9055E+00,1.8697E+00,1.8327E+00,1.8003E+00,
36408 &1.7635E+00,1.7197E+00,1.6727E+00,1.6246E+00,1.5770E+00,1.5346E+00,
36409 &1.4890E+00,1.4363E+00,1.3841E+00,1.3341E+00,1.2867E+00,1.2492E+00,
36410 &1.2151E+00,1.1824E+00,1.1578E+00,1.1451E+00,1.1356E+00,1.1298E+00,
36411 &1.1233E+00,1.1169E+00,1.1105E+00,1.1027E+00,1.0940E+00,1.0840E+00,
36412 &1.0726E+00,1.0592E+00,1.0444E+00,1.0265E+00,1.0045E+00,9.7613E-01,
36413 &9.3249E-01,8.8451E-01,8.3193E-01,7.7510E-01,7.1373E-01,6.4749E-01,
36414 &5.7554E-01,4.9725E-01,4.1072E-01,3.1254E-01,1.9551E-01,0.0000E+00,
36415 &2.6244E+00,2.5927E+00,2.5615E+00,2.5299E+00,2.4990E+00,2.4671E+00,
36416 &2.4356E+00,2.4034E+00,2.3717E+00,2.3377E+00,2.3034E+00,2.2689E+00,
36417 &2.2340E+00,2.2126E+00,2.1892E+00,2.1616E+00,2.1331E+00,2.1040E+00,
36418 &2.0736E+00,2.0471E+00,2.0180E+00,1.9830E+00,1.9472E+00,1.9112E+00,
36419 &1.8717E+00,1.8375E+00,1.7996E+00,1.7538E+00,1.7053E+00,1.6548E+00/
36420 DATA (XDVF_L(K),K= 1255, 1368) /
36421 &1.6053E+00,1.5612E+00,1.5138E+00,1.4590E+00,1.4045E+00,1.3516E+00,
36422 &1.3023E+00,1.2626E+00,1.2251E+00,1.1889E+00,1.1601E+00,1.1441E+00,
36423 &1.1302E+00,1.1201E+00,1.1098E+00,1.0996E+00,1.0888E+00,1.0782E+00,
36424 &1.0659E+00,1.0531E+00,1.0388E+00,1.0228E+00,1.0047E+00,9.8480E-01,
36425 &9.6040E-01,9.3234E-01,8.8589E-01,8.3563E-01,7.8162E-01,7.2366E-01,
36426 &6.6215E-01,5.9658E-01,5.2617E-01,4.5043E-01,3.6787E-01,2.7575E-01,
36427 &1.6826E-01,0.0000E+00,2.6886E+00,2.6564E+00,2.6234E+00,2.5908E+00,
36428 &2.5600E+00,2.5268E+00,2.4943E+00,2.4612E+00,2.4283E+00,2.3924E+00,
36429 &2.3582E+00,2.3219E+00,2.2860E+00,2.2642E+00,2.2394E+00,2.2113E+00,
36430 &2.1817E+00,2.1512E+00,2.1198E+00,2.0920E+00,2.0618E+00,2.0268E+00,
36431 &1.9890E+00,1.9503E+00,1.9098E+00,1.8739E+00,1.8343E+00,1.7867E+00,
36432 &1.7365E+00,1.6843E+00,1.6329E+00,1.5870E+00,1.5377E+00,1.4807E+00,
36433 &1.4239E+00,1.3692E+00,1.3169E+00,1.2751E+00,1.2350E+00,1.1954E+00,
36434 &1.1624E+00,1.1425E+00,1.1247E+00,1.1110E+00,1.0963E+00,1.0827E+00,
36435 &1.0687E+00,1.0547E+00,1.0396E+00,1.0240E+00,1.0070E+00,9.8853E-01,
36436 &9.6834E-01,9.4569E-01,9.1962E-01,8.9220E-01,8.4321E-01,7.9105E-01,
36437 &7.3592E-01,6.7777E-01,6.1620E-01,5.5143E-01,4.8272E-01,4.0962E-01,
36438 &3.3102E-01,2.4455E-01,1.4574E-01,0.0000E+00,2.7496E+00,2.7153E+00,
36439 &2.6835E+00,2.6504E+00,2.6180E+00,2.5834E+00,2.5502E+00,2.5161E+00/
36440 DATA (XDVF_L(K),K= 1369, 1482) /
36441 &2.4824E+00,2.4466E+00,2.4095E+00,2.3736E+00,2.3360E+00,2.3124E+00,
36442 &2.2875E+00,2.2580E+00,2.2274E+00,2.1960E+00,2.1631E+00,2.1347E+00,
36443 &2.1032E+00,2.0670E+00,2.0277E+00,1.9882E+00,1.9458E+00,1.9086E+00,
36444 &1.8675E+00,1.8179E+00,1.7658E+00,1.7122E+00,1.6586E+00,1.6112E+00,
36445 &1.5600E+00,1.5010E+00,1.4420E+00,1.3855E+00,1.3294E+00,1.2858E+00,
36446 &1.2435E+00,1.2006E+00,1.1641E+00,1.1410E+00,1.1193E+00,1.1023E+00,
36447 &1.0837E+00,1.0664E+00,1.0496E+00,1.0329E+00,1.0157E+00,9.9745E-01,
36448 &9.7803E-01,9.5735E-01,9.3539E-01,9.1075E-01,8.8302E-01,8.5608E-01,
36449 &8.0509E-01,7.5168E-01,6.9580E-01,6.3743E-01,5.7619E-01,5.1233E-01,
36450 &4.4547E-01,3.7496E-01,2.9995E-01,2.1862E-01,1.2745E-01,0.0000E+00,
36451 &2.8331E+00,2.7978E+00,2.7648E+00,2.7299E+00,2.6960E+00,2.6609E+00,
36452 &2.6263E+00,2.5910E+00,2.5561E+00,2.5197E+00,2.4802E+00,2.4424E+00,
36453 &2.4030E+00,2.3791E+00,2.3526E+00,2.3216E+00,2.2897E+00,2.2570E+00,
36454 &2.2225E+00,2.1925E+00,2.1595E+00,2.1199E+00,2.0799E+00,2.0383E+00,
36455 &1.9938E+00,1.9551E+00,1.9121E+00,1.8601E+00,1.8054E+00,1.7494E+00,
36456 &1.6932E+00,1.6435E+00,1.5898E+00,1.5280E+00,1.4659E+00,1.4056E+00,
36457 &1.3471E+00,1.3010E+00,1.2550E+00,1.2078E+00,1.1652E+00,1.1383E+00,
36458 &1.1114E+00,1.0902E+00,1.0668E+00,1.0451E+00,1.0248E+00,1.0039E+00,
36459 &9.8353E-01,9.6205E-01,9.4076E-01,9.1705E-01,8.9229E-01,8.6577E-01/
36460 DATA (XDVF_L(K),K= 1483, 1596) /
36461 &8.3604E-01,8.0985E-01,7.5687E-01,7.0190E-01,6.4516E-01,5.8700E-01,
36462 &5.2660E-01,4.6452E-01,3.9995E-01,3.3310E-01,2.6289E-01,1.8826E-01,
36463 &1.0655E-01,0.0000E+00,2.9096E+00,2.8732E+00,2.8390E+00,2.8027E+00,
36464 &2.7690E+00,2.7325E+00,2.6961E+00,2.6597E+00,2.6231E+00,2.5833E+00,
36465 &2.5456E+00,2.5047E+00,2.4650E+00,2.4391E+00,2.4120E+00,2.3799E+00,
36466 &2.3462E+00,2.3123E+00,2.2763E+00,2.2451E+00,2.2108E+00,2.1692E+00,
36467 &2.1276E+00,2.0835E+00,2.0378E+00,1.9974E+00,1.9525E+00,1.8983E+00,
36468 &1.8413E+00,1.7827E+00,1.7243E+00,1.6725E+00,1.6166E+00,1.5520E+00,
36469 &1.4872E+00,1.4244E+00,1.3627E+00,1.3136E+00,1.2649E+00,1.2130E+00,
36470 &1.1663E+00,1.1352E+00,1.1040E+00,1.0787E+00,1.0514E+00,1.0264E+00,
36471 &1.0021E+00,9.7883E-01,9.5548E-01,9.3171E-01,9.0763E-01,8.8283E-01,
36472 &8.5596E-01,8.2732E-01,7.9601E-01,7.7056E-01,7.1598E-01,6.6027E-01,
36473 &6.0340E-01,5.4514E-01,4.8601E-01,4.2556E-01,3.6359E-01,2.9984E-01,
36474 &2.3396E-01,1.6486E-01,9.0844E-02,0.0000E+00,2.9880E+00,2.9510E+00,
36475 &2.9150E+00,2.8782E+00,2.8430E+00,2.8048E+00,2.7677E+00,2.7301E+00,
36476 &2.6924E+00,2.6517E+00,2.6110E+00,2.5696E+00,2.5280E+00,2.5017E+00,
36477 &2.4728E+00,2.4393E+00,2.4042E+00,2.3687E+00,2.3313E+00,2.2988E+00,
36478 &2.2631E+00,2.2204E+00,2.1768E+00,2.1312E+00,2.0828E+00,2.0405E+00,
36479 &1.9928E+00,1.9364E+00,1.8772E+00,1.8164E+00,1.7558E+00,1.7018E+00/
36480 DATA (XDVF_L(K),K= 1597, 1710) /
36481 &1.6434E+00,1.5762E+00,1.5084E+00,1.4432E+00,1.3783E+00,1.3261E+00,
36482 &1.2741E+00,1.2182E+00,1.1669E+00,1.1315E+00,1.0961E+00,1.0671E+00,
36483 &1.0360E+00,1.0071E+00,9.7992E-01,9.5371E-01,9.2801E-01,9.0200E-01,
36484 &8.7588E-01,8.4862E-01,8.2038E-01,7.9020E-01,7.5770E-01,7.3298E-01,
36485 &6.7721E-01,6.2090E-01,5.6394E-01,5.0631E-01,4.4841E-01,3.8970E-01,
36486 &3.3019E-01,2.6973E-01,2.0791E-01,1.4420E-01,7.7416E-02,0.0000E+00,
36487 &3.0661E+00,3.0288E+00,2.9911E+00,2.9537E+00,2.9160E+00,2.8778E+00,
36488 &2.8392E+00,2.8000E+00,2.7610E+00,2.7200E+00,2.6782E+00,2.6345E+00,
36489 &2.5900E+00,2.5625E+00,2.5329E+00,2.4982E+00,2.4617E+00,2.4247E+00,
36490 &2.3857E+00,2.3518E+00,2.3145E+00,2.2697E+00,2.2245E+00,2.1764E+00,
36491 &2.1269E+00,2.0819E+00,2.0331E+00,1.9746E+00,1.9126E+00,1.8497E+00,
36492 &1.7862E+00,1.7303E+00,1.6696E+00,1.5995E+00,1.5285E+00,1.4608E+00,
36493 &1.3929E+00,1.3377E+00,1.2826E+00,1.2228E+00,1.1669E+00,1.1279E+00,
36494 &1.0882E+00,1.0555E+00,1.0205E+00,9.8876E-01,9.5876E-01,9.2969E-01,
36495 &9.0171E-01,8.7356E-01,8.4551E-01,8.1668E-01,7.8701E-01,7.5564E-01,
36496 &7.2196E-01,6.9797E-01,6.4121E-01,5.8469E-01,5.2810E-01,4.7131E-01,
36497 &4.1460E-01,3.5783E-01,3.0063E-01,2.4338E-01,1.8544E-01,1.2660E-01,
36498 &6.6270E-02,0.0000E+00,3.1379E+00,3.0995E+00,3.0600E+00,3.0213E+00,
36499 &2.9840E+00,2.9442E+00,2.9047E+00,2.8641E+00,2.8239E+00,2.7813E+00/
36500 DATA (XDVF_L(K),K= 1711, 1824) /
36501 &2.7383E+00,2.6928E+00,2.6470E+00,2.6191E+00,2.5880E+00,2.5519E+00,
36502 &2.5145E+00,2.4761E+00,2.4357E+00,2.4004E+00,2.3615E+00,2.3153E+00,
36503 &2.2678E+00,2.2180E+00,2.1669E+00,2.1208E+00,2.0699E+00,2.0087E+00,
36504 &1.9447E+00,1.8795E+00,1.8139E+00,1.7558E+00,1.6930E+00,1.6205E+00,
36505 &1.5467E+00,1.4759E+00,1.4054E+00,1.3484E+00,1.2895E+00,1.2267E+00,
36506 &1.1663E+00,1.1242E+00,1.0808E+00,1.0449E+00,1.0065E+00,9.7194E-01,
36507 &9.3967E-01,9.0840E-01,8.7834E-01,8.4891E-01,8.1928E-01,7.8930E-01,
36508 &7.5803E-01,7.2562E-01,6.9124E-01,6.6796E-01,6.1058E-01,5.5392E-01,
36509 &4.9752E-01,4.4176E-01,3.8633E-01,3.3127E-01,2.7648E-01,2.2186E-01,
36510 &1.6735E-01,1.1268E-01,5.7652E-02,0.0000E+00,3.2129E+00,3.1726E+00,
36511 &3.1325E+00,3.0928E+00,3.0540E+00,3.0127E+00,2.9717E+00,2.9303E+00,
36512 &2.8887E+00,2.8449E+00,2.8001E+00,2.7537E+00,2.7060E+00,2.6766E+00,
36513 &2.6453E+00,2.6073E+00,2.5683E+00,2.5286E+00,2.4866E+00,2.4501E+00,
36514 &2.4107E+00,2.3628E+00,2.3125E+00,2.2620E+00,2.2079E+00,2.1597E+00,
36515 &2.1067E+00,2.0440E+00,1.9778E+00,1.9097E+00,1.8421E+00,1.7819E+00,
36516 &1.7169E+00,1.6416E+00,1.5664E+00,1.4922E+00,1.4189E+00,1.3583E+00,
36517 &1.2971E+00,1.2300E+00,1.1652E+00,1.1200E+00,1.0729E+00,1.0343E+00,
36518 &9.9254E-01,9.5513E-01,9.2006E-01,8.8711E-01,8.5555E-01,8.2426E-01,
36519 &7.9305E-01,7.6193E-01,7.2963E-01,6.9636E-01,6.6128E-01,6.3868E-01/
36520 DATA (XDVF_L(K),K= 1825, 1836) /
36521 &5.8093E-01,5.2428E-01,4.6858E-01,4.1372E-01,3.5972E-01,3.0648E-01,
36522 &2.5392E-01,2.0208E-01,1.5083E-01,1.0018E-01,5.0068E-02,0.0000E+00/
36523 DATA (XDEF_L(K),K= 1, 114) /
36524 &4.3007E-01,4.2474E-01,4.1967E-01,4.1458E-01,4.0970E-01,4.0443E-01,
36525 &3.9925E-01,3.9397E-01,3.8864E-01,3.8302E-01,3.7707E-01,3.7100E-01,
36526 &3.6470E-01,3.6080E-01,3.5639E-01,3.5109E-01,3.4531E-01,3.3914E-01,
36527 &3.3238E-01,3.2609E-01,3.1913E-01,3.1062E-01,3.0152E-01,2.9176E-01,
36528 &2.8100E-01,2.7114E-01,2.5952E-01,2.4467E-01,2.2784E-01,2.0937E-01,
36529 &1.9117E-01,1.7470E-01,1.5685E-01,1.3678E-01,1.1825E-01,1.0349E-01,
36530 &9.4854E-02,9.5054E-02,1.0589E-01,1.3527E-01,1.8584E-01,2.3426E-01,
36531 &2.9021E-01,3.3527E-01,3.7670E-01,4.0255E-01,4.1326E-01,4.0880E-01,
36532 &3.8831E-01,3.5045E-01,2.9287E-01,2.1298E-01,1.0773E-01,0.0000E+00,
36533 &0.0000E+00,2.0644E-01,1.5422E-01,1.0950E-01,7.3614E-02,4.6726E-02,
36534 &2.7433E-02,1.4144E-02,6.5080E-03,2.4719E-03,0.0000E+00,0.0000E+00,
36535 &0.0000E+00,0.0000E+00,4.4398E-01,4.3864E-01,4.3346E-01,4.2809E-01,
36536 &4.2290E-01,4.1747E-01,4.1205E-01,4.0650E-01,4.0098E-01,3.9480E-01,
36537 &3.8873E-01,3.8226E-01,3.7560E-01,3.7145E-01,3.6678E-01,3.6108E-01,
36538 &3.5488E-01,3.4833E-01,3.4123E-01,3.3464E-01,3.2718E-01,3.1811E-01,
36539 &3.0838E-01,2.9811E-01,2.8670E-01,2.7630E-01,2.6412E-01,2.4861E-01,
36540 &2.3110E-01,2.1209E-01,1.9355E-01,1.7681E-01,1.5878E-01,1.3870E-01,
36541 &1.2044E-01,1.0620E-01,9.8341E-02,9.9345E-02,1.1086E-01,1.4055E-01,
36542 &1.9033E-01,2.3696E-01,2.8983E-01,3.3137E-01,3.6834E-01,3.8982E-01/
36543 DATA (XDEF_L(K),K= 115, 228) /
36544 &3.9672E-01,3.8896E-01,3.6609E-01,3.2678E-01,2.6933E-01,1.9181E-01,
36545 &9.1683E-02,0.0000E+00,0.0000E+00,1.8955E-01,1.4041E-01,9.8873E-02,
36546 &6.5928E-02,4.1462E-02,2.3905E-02,1.2324E-02,5.6113E-03,2.1050E-03,
36547 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,4.5980E-01,4.5420E-01,
36548 &4.4884E-01,4.4319E-01,4.3780E-01,4.3208E-01,4.2642E-01,4.2053E-01,
36549 &4.1457E-01,4.0824E-01,4.0181E-01,3.9484E-01,3.8780E-01,3.8328E-01,
36550 &3.7831E-01,3.7223E-01,3.6559E-01,3.5853E-01,3.5072E-01,3.4400E-01,
36551 &3.3590E-01,3.2633E-01,3.1598E-01,3.0508E-01,2.9301E-01,2.8197E-01,
36552 &2.6915E-01,2.5289E-01,2.3470E-01,2.1511E-01,1.9623E-01,1.7918E-01,
36553 &1.6098E-01,1.4092E-01,1.2294E-01,1.0928E-01,1.0224E-01,1.0401E-01,
36554 &1.1623E-01,1.4620E-01,1.9488E-01,2.3948E-01,2.8894E-01,3.2681E-01,
36555 &3.5905E-01,3.7613E-01,3.7908E-01,3.6817E-01,3.4299E-01,3.0266E-01,
36556 &2.4596E-01,1.7115E-01,7.6792E-02,0.0000E+00,0.0000E+00,1.7267E-01,
36557 &1.2670E-01,8.8446E-02,5.8458E-02,3.6380E-02,2.0551E-02,1.0608E-02,
36558 &4.7732E-03,1.7670E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36559 &4.7845E-01,4.7258E-01,4.6687E-01,4.6107E-01,4.5540E-01,4.4938E-01,
36560 &4.4336E-01,4.3728E-01,4.3070E-01,4.2403E-01,4.1702E-01,4.0968E-01,
36561 &4.0210E-01,3.9723E-01,3.9181E-01,3.8522E-01,3.7808E-01,3.7047E-01,
36562 &3.6211E-01,3.5469E-01,3.4619E-01,3.3582E-01,3.2478E-01,3.1314E-01/
36563 DATA (XDEF_L(K),K= 229, 342) /
36564 &3.0021E-01,2.8848E-01,2.7488E-01,2.5781E-01,2.3886E-01,2.1865E-01,
36565 &1.9932E-01,1.8196E-01,1.6359E-01,1.4359E-01,1.2596E-01,1.1295E-01,
36566 &1.0678E-01,1.0933E-01,1.2234E-01,1.5242E-01,1.9969E-01,2.4187E-01,
36567 &2.8742E-01,3.2112E-01,3.4825E-01,3.6067E-01,3.5959E-01,3.4546E-01,
36568 &3.1813E-01,2.7719E-01,2.2151E-01,1.5037E-01,6.2862E-02,0.0000E+00,
36569 &0.0000E+00,1.5516E-01,1.1270E-01,7.7856E-02,5.0916E-02,3.1337E-02,
36570 &1.7279E-02,8.9355E-03,3.9672E-03,1.4465E-03,0.0000E+00,0.0000E+00,
36571 &0.0000E+00,0.0000E+00,5.0059E-01,4.9450E-01,4.8826E-01,4.8213E-01,
36572 &4.7610E-01,4.6972E-01,4.6326E-01,4.5655E-01,4.4999E-01,4.4265E-01,
36573 &4.3505E-01,4.2703E-01,4.1870E-01,4.1345E-01,4.0758E-01,4.0034E-01,
36574 &3.9260E-01,3.8434E-01,3.7539E-01,3.6725E-01,3.5804E-01,3.4696E-01,
36575 &3.3492E-01,3.2231E-01,3.0852E-01,2.9601E-01,2.8154E-01,2.6348E-01,
36576 &2.4363E-01,2.2272E-01,2.0295E-01,1.8526E-01,1.6669E-01,1.4678E-01,
36577 &1.2956E-01,1.1726E-01,1.1212E-01,1.1548E-01,1.2910E-01,1.5906E-01,
36578 &2.0458E-01,2.4395E-01,2.8508E-01,3.1418E-01,3.3593E-01,3.4343E-01,
36579 &3.3827E-01,3.2104E-01,2.9189E-01,2.5067E-01,1.9688E-01,1.3016E-01,
36580 &5.0498E-02,0.0000E+00,0.0000E+00,1.3742E-01,9.8602E-02,6.7357E-02,
36581 &4.3555E-02,2.6444E-02,1.4175E-02,7.3561E-03,3.2181E-03,1.1530E-03,
36582 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.2114E-01,5.1454E-01/
36583 DATA (XDEF_L(K),K= 343, 456) /
36584 &5.0806E-01,5.0160E-01,4.9520E-01,4.8843E-01,4.8165E-01,4.7456E-01,
36585 &4.6738E-01,4.5962E-01,4.5149E-01,4.4293E-01,4.3400E-01,4.2833E-01,
36586 &4.2194E-01,4.1420E-01,4.0580E-01,3.9678E-01,3.8741E-01,3.7848E-01,
36587 &3.6878E-01,3.5682E-01,3.4416E-01,3.3062E-01,3.1602E-01,3.0269E-01,
36588 &2.8749E-01,2.6857E-01,2.4798E-01,2.2641E-01,2.0626E-01,1.8828E-01,
36589 &1.6960E-01,1.4976E-01,1.3293E-01,1.2126E-01,1.1684E-01,1.2099E-01,
36590 &1.3505E-01,1.6471E-01,2.0841E-01,2.4521E-01,2.8248E-01,3.0770E-01,
36591 &3.2484E-01,3.2845E-01,3.1999E-01,3.0047E-01,2.7030E-01,2.2924E-01,
36592 &1.7739E-01,1.1482E-01,4.2174E-02,0.0000E+00,0.0000E+00,1.2330E-01,
36593 &8.7586E-02,5.9211E-02,3.7890E-02,2.2733E-02,1.1877E-02,6.1865E-03,
36594 &2.6713E-03,9.4247E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36595 &5.4423E-01,5.3740E-01,5.3068E-01,5.2385E-01,5.1700E-01,5.0982E-01,
36596 &5.0256E-01,4.9509E-01,4.8731E-01,4.7895E-01,4.7023E-01,4.6094E-01,
36597 &4.5130E-01,4.4506E-01,4.3820E-01,4.2973E-01,4.2069E-01,4.1108E-01,
36598 &4.0069E-01,3.9131E-01,3.8063E-01,3.6796E-01,3.5430E-01,3.3991E-01,
36599 &3.2433E-01,3.1014E-01,2.9407E-01,2.7418E-01,2.5281E-01,2.3056E-01,
36600 &2.0999E-01,1.9171E-01,1.7291E-01,1.5321E-01,1.3677E-01,1.2578E-01,
36601 &1.2220E-01,1.2696E-01,1.4132E-01,1.7056E-01,2.1212E-01,2.4603E-01,
36602 &2.7912E-01,3.0023E-01,3.1274E-01,3.1234E-01,3.0087E-01,2.7925E-01/
36603 DATA (XDEF_L(K),K= 457, 570) /
36604 &2.4820E-01,2.0782E-01,1.5841E-01,1.0056E-01,3.5470E-02,0.0000E+00,
36605 &0.0000E+00,1.0941E-01,7.6864E-02,5.1391E-02,3.2506E-02,1.9250E-02,
36606 &9.7741E-03,5.1192E-03,2.1775E-03,0.0000E+00,0.0000E+00,0.0000E+00,
36607 &0.0000E+00,0.0000E+00,5.6542E-01,5.5814E-01,5.5101E-01,5.4385E-01,
36608 &5.3670E-01,5.2913E-01,5.2140E-01,5.1352E-01,5.0533E-01,4.9639E-01,
36609 &4.8702E-01,4.7710E-01,4.6670E-01,4.6011E-01,4.5270E-01,4.4365E-01,
36610 &4.3394E-01,4.2383E-01,4.1271E-01,4.0253E-01,3.9137E-01,3.7783E-01,
36611 &3.6325E-01,3.4810E-01,3.3163E-01,3.1674E-01,2.9988E-01,2.7922E-01,
36612 &2.5706E-01,2.3429E-01,2.1333E-01,1.9484E-01,1.7592E-01,1.5634E-01,
36613 &1.4028E-01,1.2985E-01,1.2692E-01,1.3218E-01,1.4678E-01,1.7535E-01,
36614 &2.1492E-01,2.4628E-01,2.7582E-01,2.9349E-01,3.0215E-01,2.9865E-01,
36615 &2.8479E-01,2.6176E-01,2.3025E-01,1.9073E-01,1.4372E-01,9.0030E-02,
36616 &3.1431E-02,0.0000E+00,0.0000E+00,9.8561E-02,6.8571E-02,4.5400E-02,
36617 &2.8439E-02,1.6650E-02,8.2414E-03,4.3377E-03,1.8226E-03,0.0000E+00,
36618 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.8660E-01,5.7912E-01,
36619 &5.7170E-01,5.6412E-01,5.5660E-01,5.4858E-01,5.4040E-01,5.3194E-01,
36620 &5.2336E-01,5.1383E-01,5.0381E-01,4.9326E-01,4.8220E-01,4.7515E-01,
36621 &4.6719E-01,4.5756E-01,4.4719E-01,4.3619E-01,4.2441E-01,4.1376E-01,
36622 &4.0188E-01,3.8750E-01,3.7220E-01,3.5617E-01,3.3884E-01,3.2317E-01/
36623 DATA (XDEF_L(K),K= 571, 684) /
36624 &3.0561E-01,2.8413E-01,2.6132E-01,2.3801E-01,2.1667E-01,1.9794E-01,
36625 &1.7898E-01,1.5951E-01,1.4381E-01,1.3395E-01,1.3154E-01,1.3722E-01,
36626 &1.5183E-01,1.7978E-01,2.1726E-01,2.4615E-01,2.7227E-01,2.8668E-01,
36627 &2.9185E-01,2.8560E-01,2.6981E-01,2.4566E-01,2.1405E-01,1.7560E-01,
36628 &1.3093E-01,8.1317E-02,2.8821E-02,0.0000E+00,0.0000E+00,8.9016E-02,
36629 &6.1335E-02,4.0241E-02,2.4960E-02,1.4451E-02,6.9787E-03,3.6912E-03,
36630 &1.5320E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36631 &6.0621E-01,5.9821E-01,5.9043E-01,5.8253E-01,5.7470E-01,5.6625E-01,
36632 &5.5768E-01,5.4870E-01,5.3948E-01,5.2962E-01,5.1919E-01,5.0796E-01,
36633 &4.9620E-01,4.8867E-01,4.8027E-01,4.7003E-01,4.5907E-01,4.4740E-01,
36634 &4.3484E-01,4.2392E-01,4.1127E-01,3.9627E-01,3.8010E-01,3.6326E-01,
36635 &3.4524E-01,3.2900E-01,3.1064E-01,2.8853E-01,2.6510E-01,2.4135E-01,
36636 &2.1970E-01,2.0080E-01,1.8175E-01,1.6242E-01,1.4701E-01,1.3753E-01,
36637 &1.3572E-01,1.4160E-01,1.5623E-01,1.8343E-01,2.1902E-01,2.4571E-01,
36638 &2.6885E-01,2.8059E-01,2.8292E-01,2.7441E-01,2.5704E-01,2.3223E-01,
36639 &2.0062E-01,1.6317E-01,1.2079E-01,7.4733E-02,2.7461E-02,0.0000E+00,
36640 &0.0000E+00,8.1334E-02,5.5577E-02,3.6150E-02,2.2243E-02,1.2749E-02,
36641 &6.0264E-03,3.2009E-03,1.3143E-03,0.0000E+00,0.0000E+00,0.0000E+00,
36642 &0.0000E+00,0.0000E+00,6.2581E-01,6.1778E-01,6.0953E-01,6.0134E-01/
36643 DATA (XDEF_L(K),K= 685, 798) /
36644 &5.9310E-01,5.8428E-01,5.7523E-01,5.6587E-01,5.5625E-01,5.4565E-01,
36645 &5.3457E-01,5.2280E-01,5.1030E-01,5.0236E-01,4.9350E-01,4.8267E-01,
36646 &4.7104E-01,4.5899E-01,4.4560E-01,4.3381E-01,4.2066E-01,4.0485E-01,
36647 &3.8801E-01,3.7047E-01,3.5165E-01,3.3476E-01,3.1574E-01,2.9293E-01,
36648 &2.6889E-01,2.4469E-01,2.2279E-01,2.0369E-01,1.8458E-01,1.6537E-01,
36649 &1.5025E-01,1.4125E-01,1.3980E-01,1.4589E-01,1.6046E-01,1.8686E-01,
36650 &2.2052E-01,2.4502E-01,2.6530E-01,2.7444E-01,2.7406E-01,2.6361E-01,
36651 &2.4491E-01,2.1954E-01,1.8819E-01,1.5193E-01,1.1170E-01,6.9146E-02,
36652 &2.6829E-02,0.0000E+00,0.0000E+00,7.4387E-02,5.0398E-02,3.2529E-02,
36653 &1.9840E-02,1.1260E-02,5.2109E-03,2.7796E-03,1.1291E-03,0.0000E+00,
36654 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,6.4510E-01,6.3663E-01,
36655 &6.2809E-01,6.1948E-01,6.1090E-01,6.0165E-01,5.9256E-01,5.8263E-01,
36656 &5.7237E-01,5.6121E-01,5.4960E-01,5.3710E-01,5.2390E-01,5.1555E-01,
36657 &5.0615E-01,4.9474E-01,4.8273E-01,4.6980E-01,4.5603E-01,4.4343E-01,
36658 &4.2983E-01,4.1325E-01,3.9561E-01,3.7731E-01,3.5765E-01,3.4017E-01,
36659 &3.2063E-01,2.9709E-01,2.7258E-01,2.4795E-01,2.2572E-01,2.0647E-01,
36660 &1.8735E-01,1.6824E-01,1.5339E-01,1.4470E-01,1.4366E-01,1.4990E-01,
36661 &1.6437E-01,1.8986E-01,2.2169E-01,2.4408E-01,2.6175E-01,2.6863E-01,
36662 &2.6585E-01,2.5363E-01,2.3397E-01,2.0813E-01,1.7714E-01,1.4205E-01/
36663 DATA (XDEF_L(K),K= 799, 912) /
36664 &1.0396E-01,6.4602E-02,2.6785E-02,0.0000E+00,0.0000E+00,6.8343E-02,
36665 &4.5962E-02,2.9434E-02,1.7812E-02,1.0015E-02,4.5458E-03,2.4331E-03,
36666 &9.7866E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36667 &6.6281E-01,6.5407E-01,6.4523E-01,6.3631E-01,6.2740E-01,6.1775E-01,
36668 &6.0821E-01,5.9770E-01,5.8724E-01,5.7535E-01,5.6321E-01,5.5021E-01,
36669 &5.3640E-01,5.2763E-01,5.1775E-01,5.0583E-01,4.9310E-01,4.7946E-01,
36670 &4.6520E-01,4.5225E-01,4.3811E-01,4.2074E-01,4.0247E-01,3.8355E-01,
36671 &3.6315E-01,3.4516E-01,3.2502E-01,3.0091E-01,2.7589E-01,2.5090E-01,
36672 &2.2842E-01,2.0903E-01,1.8987E-01,1.7087E-01,1.5631E-01,1.4790E-01,
36673 &1.4709E-01,1.5345E-01,1.6771E-01,1.9243E-01,2.2253E-01,2.4307E-01,
36674 &2.5846E-01,2.6327E-01,2.5857E-01,2.4493E-01,2.2441E-01,1.9832E-01,
36675 &1.6773E-01,1.3380E-01,9.7606E-02,6.1077E-02,2.7123E-02,4.1687E-04,
36676 &0.0000E+00,6.3316E-02,4.2290E-02,2.6899E-02,1.6166E-02,9.0143E-03,
36677 &4.0214E-03,2.1587E-03,8.6042E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36678 &0.0000E+00,0.0000E+00,6.8558E-01,6.7623E-01,6.6716E-01,6.5776E-01,
36679 &6.4840E-01,6.3825E-01,6.2778E-01,6.1697E-01,6.0589E-01,5.9350E-01,
36680 &5.8071E-01,5.6677E-01,5.5220E-01,5.4293E-01,5.3246E-01,5.1980E-01,
36681 &5.0630E-01,4.9221E-01,4.7690E-01,4.6348E-01,4.4839E-01,4.3024E-01,
36682 &4.1112E-01,3.9125E-01,3.7016E-01,3.5134E-01,3.3054E-01,3.0571E-01/
36683 DATA (XDEF_L(K),K= 913, 1026) /
36684 &2.8005E-01,2.5463E-01,2.3186E-01,2.1230E-01,1.9311E-01,1.7422E-01,
36685 &1.5985E-01,1.5187E-01,1.5138E-01,1.5783E-01,1.7178E-01,1.9543E-01,
36686 &2.2331E-01,2.4162E-01,2.5415E-01,2.5666E-01,2.4964E-01,2.3438E-01,
36687 &2.1293E-01,1.8681E-01,1.5680E-01,1.2430E-01,9.0488E-02,5.7352E-02,
36688 &2.7942E-02,7.0995E-03,2.4780E-03,5.7612E-02,3.8138E-02,2.4057E-02,
36689 &1.4329E-02,7.9111E-03,3.4566E-03,1.8603E-03,7.3347E-04,0.0000E+00,
36690 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.0709E-01,6.9744E-01,
36691 &6.8784E-01,6.7803E-01,6.6830E-01,6.5763E-01,6.4678E-01,6.3540E-01,
36692 &6.2360E-01,6.1071E-01,5.9715E-01,5.8240E-01,5.6710E-01,5.5722E-01,
36693 &5.4625E-01,5.3291E-01,5.1856E-01,5.0380E-01,4.8797E-01,4.7363E-01,
36694 &4.5801E-01,4.3900E-01,4.1917E-01,3.9846E-01,3.7656E-01,3.5717E-01,
36695 &3.3564E-01,3.1017E-01,2.8397E-01,2.5816E-01,2.3508E-01,2.1538E-01,
36696 &1.9615E-01,1.7737E-01,1.6324E-01,1.5559E-01,1.5535E-01,1.6175E-01,
36697 &1.7537E-01,1.9793E-01,2.2384E-01,2.4005E-01,2.5009E-01,2.5051E-01,
36698 &2.4150E-01,2.2495E-01,2.0291E-01,1.7668E-01,1.4739E-01,1.1625E-01,
36699 &8.4583E-02,5.4470E-02,2.9013E-02,1.3147E-02,1.4553E-02,5.2777E-02,
36700 &3.4672E-02,2.1686E-02,1.2821E-02,7.0105E-03,3.0093E-03,1.6226E-03,
36701 &6.3321E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36702 &7.2796E-01,7.1795E-01,7.0799E-01,6.9776E-01,6.8760E-01,6.7649E-01/
36703 DATA (XDEF_L(K),K= 1027, 1140) /
36704 &6.6523E-01,6.5299E-01,6.4099E-01,6.2720E-01,6.1289E-01,5.9763E-01,
36705 &5.8140E-01,5.7108E-01,5.5954E-01,5.4555E-01,5.3082E-01,5.1501E-01,
36706 &4.9841E-01,4.8352E-01,4.6718E-01,4.4758E-01,4.2678E-01,4.0543E-01,
36707 &3.8267E-01,3.6267E-01,3.4052E-01,3.1445E-01,2.8771E-01,2.6154E-01,
36708 &2.3817E-01,2.1835E-01,1.9910E-01,1.8043E-01,1.6662E-01,1.5905E-01,
36709 &1.5900E-01,1.6548E-01,1.7871E-01,2.0015E-01,2.2403E-01,2.3835E-01,
36710 &2.4610E-01,2.4469E-01,2.3394E-01,2.1634E-01,1.9372E-01,1.6761E-01,
36711 &1.3910E-01,1.0920E-01,7.9530E-02,5.2165E-02,3.0250E-02,1.8723E-02,
36712 &2.5275E-02,4.8575E-02,3.1676E-02,1.9677E-02,1.1540E-02,6.2533E-03,
36713 &2.6411E-03,1.4253E-03,5.5072E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36714 &0.0000E+00,0.0000E+00,7.4788E-01,7.3751E-01,7.2708E-01,7.1644E-01,
36715 &7.0580E-01,6.9430E-01,6.8256E-01,6.6975E-01,6.5712E-01,6.4276E-01,
36716 &6.2791E-01,6.1180E-01,5.9490E-01,5.8409E-01,5.7199E-01,5.5739E-01,
36717 &5.4166E-01,5.2544E-01,5.0821E-01,4.9288E-01,4.7590E-01,4.5544E-01,
36718 &4.3393E-01,4.1178E-01,3.8837E-01,3.6775E-01,3.4513E-01,3.1844E-01,
36719 &2.9125E-01,2.6472E-01,2.4110E-01,2.2115E-01,2.0189E-01,1.8330E-01,
36720 &1.6955E-01,1.6237E-01,1.6243E-01,1.6875E-01,1.8164E-01,2.0201E-01,
36721 &2.2410E-01,2.3665E-01,2.4236E-01,2.3927E-01,2.2710E-01,2.0852E-01,
36722 &1.8563E-01,1.5962E-01,1.3170E-01,1.0314E-01,7.5292E-02,5.0347E-02/
36723 DATA (XDEF_L(K),K= 1141, 1254) /
36724 &3.1513E-02,2.3688E-02,3.4520E-02,4.4988E-02,2.9140E-02,1.7975E-02,
36725 &1.0472E-02,5.6268E-03,2.3442E-03,1.2646E-03,4.8432E-04,0.0000E+00,
36726 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.6812E-01,7.5731E-01,
36727 &7.4653E-01,7.3551E-01,7.2440E-01,7.1234E-01,6.9989E-01,6.8692E-01,
36728 &6.7357E-01,6.5855E-01,6.4312E-01,6.2624E-01,6.0850E-01,5.9719E-01,
36729 &5.8457E-01,5.6934E-01,5.5297E-01,5.3626E-01,5.1802E-01,5.0223E-01,
36730 &4.8440E-01,4.6329E-01,4.4109E-01,4.1826E-01,3.9408E-01,3.7291E-01,
36731 &3.4966E-01,3.2243E-01,2.9475E-01,2.6790E-01,2.4406E-01,2.2399E-01,
36732 &2.0470E-01,1.8621E-01,1.7262E-01,1.6558E-01,1.6576E-01,1.7201E-01,
36733 &1.8441E-01,2.0372E-01,2.2403E-01,2.3482E-01,2.3856E-01,2.3398E-01,
36734 &2.2040E-01,2.0103E-01,1.7782E-01,1.5205E-01,1.2492E-01,9.7540E-02,
36735 &7.1452E-02,4.8817E-02,3.2832E-02,2.8412E-02,4.3068E-02,4.1684E-02,
36736 &2.6819E-02,1.6431E-02,9.5049E-03,5.0674E-03,2.0840E-03,1.1231E-03,
36737 &4.2643E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36738 &7.8709E-01,7.7617E-01,7.6509E-01,7.5353E-01,7.4210E-01,7.2955E-01,
36739 &7.1666E-01,7.0326E-01,6.8906E-01,6.7364E-01,6.5743E-01,6.3988E-01,
36740 &6.2140E-01,6.0962E-01,5.9645E-01,5.8083E-01,5.6382E-01,5.4630E-01,
36741 &5.2750E-01,5.1079E-01,4.9267E-01,4.7078E-01,4.4780E-01,4.2425E-01,
36742 &3.9948E-01,3.7773E-01,3.5398E-01,3.2619E-01,2.9811E-01,2.7093E-01/
36743 DATA (XDEF_L(K),K= 1255, 1368) /
36744 &2.4686E-01,2.2668E-01,2.0735E-01,1.8888E-01,1.7555E-01,1.6865E-01,
36745 &1.6887E-01,1.7500E-01,1.8693E-01,2.0522E-01,2.2377E-01,2.3300E-01,
36746 &2.3501E-01,2.2902E-01,2.1428E-01,1.9427E-01,1.7084E-01,1.4533E-01,
36747 &1.1889E-01,9.2655E-02,6.8174E-02,4.7575E-02,3.4123E-02,3.2605E-02,
36748 &5.0454E-02,3.8820E-02,2.4822E-02,1.5113E-02,8.6857E-03,4.5962E-03,
36749 &1.8704E-03,1.0050E-03,3.7856E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36750 &0.0000E+00,0.0000E+00,8.0606E-01,7.9455E-01,7.8312E-01,7.7128E-01,
36751 &7.5940E-01,7.4610E-01,7.3287E-01,7.1917E-01,7.0456E-01,6.8825E-01,
36752 &6.7140E-01,6.5313E-01,6.3390E-01,6.2170E-01,6.0798E-01,5.9180E-01,
36753 &5.7419E-01,5.5596E-01,5.3636E-01,5.1934E-01,5.0050E-01,4.7790E-01,
36754 &4.5436E-01,4.3012E-01,4.0458E-01,3.8238E-01,3.5808E-01,3.2984E-01,
36755 &3.0133E-01,2.7388E-01,2.4957E-01,2.2930E-01,2.0996E-01,1.9168E-01,
36756 &1.7832E-01,1.7159E-01,1.7177E-01,1.7770E-01,1.8921E-01,2.0651E-01,
36757 &2.2344E-01,2.3117E-01,2.3152E-01,2.2426E-01,2.0844E-01,1.8790E-01,
36758 &1.6440E-01,1.3914E-01,1.1342E-01,8.8280E-02,6.5276E-02,4.6578E-02,
36759 &3.5360E-02,3.6411E-02,5.6986E-02,3.6256E-02,2.3040E-02,1.3948E-02,
36760 &7.9676E-03,4.1856E-03,1.6876E-03,9.0394E-04,3.3789E-04,0.0000E+00,
36761 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.2409E-01,8.1223E-01,
36762 &8.0027E-01,7.8810E-01,7.7580E-01,7.6250E-01,7.4852E-01,7.3383E-01/
36763 DATA (XDEF_L(K),K= 1369, 1482) /
36764 &7.1879E-01,7.0216E-01,6.8466E-01,6.6571E-01,6.4580E-01,6.3303E-01,
36765 &6.1887E-01,6.0161E-01,5.8362E-01,5.6485E-01,5.4490E-01,5.2736E-01,
36766 &5.0788E-01,4.8465E-01,4.6048E-01,4.3549E-01,4.0949E-01,3.8678E-01,
36767 &3.6198E-01,3.3325E-01,3.0435E-01,2.7667E-01,2.5212E-01,2.3179E-01,
36768 &2.1241E-01,1.9410E-01,1.8093E-01,1.7428E-01,1.7445E-01,1.8022E-01,
36769 &1.9133E-01,2.0758E-01,2.2299E-01,2.2941E-01,2.2823E-01,2.1990E-01,
36770 &2.0319E-01,1.8211E-01,1.5852E-01,1.3371E-01,1.0856E-01,8.4430E-02,
36771 &6.2776E-02,4.5758E-02,3.6514E-02,3.9756E-02,6.2597E-02,3.4019E-02,
36772 &2.1502E-02,1.2943E-02,7.3506E-03,3.8366E-03,1.5351E-03,8.1923E-04,
36773 &3.0383E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36774 &8.4844E-01,8.3627E-01,8.2378E-01,8.1114E-01,7.9820E-01,7.8411E-01,
36775 &7.6977E-01,7.5436E-01,7.3871E-01,7.2101E-01,7.0269E-01,6.8280E-01,
36776 &6.6180E-01,6.4849E-01,6.3365E-01,6.1605E-01,5.9682E-01,5.7721E-01,
36777 &5.5628E-01,5.3805E-01,5.1772E-01,4.9378E-01,4.6868E-01,4.4295E-01,
36778 &4.1599E-01,3.9262E-01,3.6722E-01,3.3788E-01,3.0847E-01,2.8040E-01,
36779 &2.5562E-01,2.3513E-01,2.1572E-01,1.9746E-01,1.8447E-01,1.7787E-01,
36780 &1.7810E-01,1.8358E-01,1.9394E-01,2.0894E-01,2.2227E-01,2.2689E-01,
36781 &2.2385E-01,2.1408E-01,1.9620E-01,1.7461E-01,1.5108E-01,1.2667E-01,
36782 &1.0243E-01,7.9635E-02,5.9715E-02,4.4804E-02,3.7997E-02,4.3894E-02/
36783 DATA (XDEF_L(K),K= 1483, 1596) /
36784 &6.9391E-02,3.1240E-02,1.9603E-02,1.1712E-02,6.6036E-03,3.4150E-03,
36785 &1.3549E-03,7.1812E-04,2.6373E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36786 &0.0000E+00,0.0000E+00,8.7089E-01,8.5819E-01,8.4535E-01,8.3207E-01,
36787 &8.1860E-01,8.0424E-01,7.8877E-01,7.7320E-01,7.5642E-01,7.3822E-01,
36788 &7.1895E-01,6.9816E-01,6.7640E-01,6.6244E-01,6.4701E-01,6.2817E-01,
36789 &6.0860E-01,5.8841E-01,5.6672E-01,5.4767E-01,5.2667E-01,5.0182E-01,
36790 &4.7599E-01,4.4955E-01,4.2190E-01,3.9787E-01,3.7196E-01,3.4199E-01,
36791 &3.1220E-01,2.8382E-01,2.5874E-01,2.3816E-01,2.1874E-01,2.0063E-01,
36792 &1.8770E-01,1.8107E-01,1.8121E-01,1.8638E-01,1.9622E-01,2.0994E-01,
36793 &2.2156E-01,2.2456E-01,2.1986E-01,2.0892E-01,1.9015E-01,1.6817E-01,
36794 &1.4465E-01,1.2070E-01,9.7309E-02,7.5665E-02,5.7234E-02,4.4095E-02,
36795 &3.9289E-02,4.7307E-02,7.4739E-02,2.8958E-02,1.8046E-02,1.0716E-02,
36796 &6.0010E-03,3.0801E-03,1.2145E-03,6.3833E-04,2.3251E-04,0.0000E+00,
36797 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.9366E-01,8.8058E-01,
36798 &8.6727E-01,8.5353E-01,8.3950E-01,8.2436E-01,8.0890E-01,7.9205E-01,
36799 &7.7476E-01,7.5566E-01,7.3557E-01,7.1393E-01,6.9120E-01,6.7672E-01,
36800 &6.6059E-01,6.4145E-01,6.2086E-01,5.9962E-01,5.7716E-01,5.5756E-01,
36801 &5.3584E-01,5.1022E-01,4.8344E-01,4.5615E-01,4.2780E-01,4.0320E-01,
36802 &3.7671E-01,3.4621E-01,3.1594E-01,2.8727E-01,2.6196E-01,2.4126E-01/
36803 DATA (XDEF_L(K),K= 1597, 1710) /
36804 &2.2177E-01,2.0361E-01,1.9078E-01,1.8427E-01,1.8432E-01,1.8918E-01,
36805 &1.9834E-01,2.1079E-01,2.2065E-01,2.2210E-01,2.1587E-01,2.0383E-01,
36806 &1.8424E-01,1.6197E-01,1.3849E-01,1.1505E-01,9.2463E-02,7.1949E-02,
36807 &5.4952E-02,4.3474E-02,4.0525E-02,5.0376E-02,7.9517E-02,2.6835E-02,
36808 &1.6616E-02,9.8004E-03,5.4489E-03,2.7768E-03,1.0900E-03,5.6728E-04,
36809 &2.0489E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36810 &9.1643E-01,9.0298E-01,8.8901E-01,8.7472E-01,8.6030E-01,8.4449E-01,
36811 &8.2790E-01,8.1090E-01,7.9278E-01,7.7287E-01,7.5201E-01,7.2942E-01,
36812 &7.0580E-01,6.9067E-01,6.7395E-01,6.5357E-01,6.3264E-01,6.1082E-01,
36813 &5.8728E-01,5.6718E-01,5.4478E-01,5.1825E-01,4.9075E-01,4.6263E-01,
36814 &4.3360E-01,4.0844E-01,3.8138E-01,3.5032E-01,3.1963E-01,2.9065E-01,
36815 &2.6511E-01,2.4428E-01,2.2479E-01,2.0678E-01,1.9385E-01,1.8735E-01,
36816 &1.8722E-01,1.9179E-01,2.0029E-01,2.1158E-01,2.1961E-01,2.1971E-01,
36817 &2.1194E-01,1.9894E-01,1.7862E-01,1.5609E-01,1.3279E-01,1.0972E-01,
36818 &8.8007E-02,6.8578E-02,5.2905E-02,4.2942E-02,4.1624E-02,5.3065E-02,
36819 &8.3506E-02,2.4920E-02,1.5334E-02,8.9876E-03,4.9653E-03,2.5112E-03,
36820 &9.8300E-04,5.0629E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36821 &0.0000E+00,0.0000E+00,9.3762E-01,9.2325E-01,9.0916E-01,8.9432E-01,
36822 &8.7930E-01,8.6312E-01,8.4579E-01,8.2807E-01,8.0954E-01,7.8866E-01/
36823 DATA (XDEF_L(K),K= 1711, 1824) /
36824 &7.6704E-01,7.4360E-01,7.1911E-01,7.0343E-01,6.8612E-01,6.6512E-01,
36825 &6.4349E-01,6.2048E-01,5.9676E-01,5.7574E-01,5.5261E-01,5.2556E-01,
36826 &4.9731E-01,4.6862E-01,4.3881E-01,4.1318E-01,3.8556E-01,3.5408E-01,
36827 &3.2299E-01,2.9375E-01,2.6794E-01,2.4706E-01,2.2744E-01,2.0939E-01,
36828 &1.9662E-01,1.9016E-01,1.8990E-01,1.9412E-01,2.0192E-01,2.1208E-01,
36829 &2.1863E-01,2.1745E-01,2.0845E-01,1.9458E-01,1.7365E-01,1.5094E-01,
36830 &1.2783E-01,1.0526E-01,8.4228E-02,6.5746E-02,5.1203E-02,4.2521E-02,
36831 &4.2531E-02,5.5238E-02,8.6619E-02,2.3321E-02,1.4266E-02,8.3142E-03,
36832 &4.5684E-03,2.2945E-03,8.9721E-04,4.5700E-04,0.0000E+00,0.0000E+00,
36833 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,9.5912E-01,9.4446E-01,
36834 &9.2967E-01,9.1446E-01,8.9890E-01,8.8176E-01,8.6424E-01,8.4567E-01,
36835 &8.2630E-01,8.0492E-01,7.8242E-01,7.5817E-01,7.3271E-01,7.1653E-01,
36836 &6.9849E-01,6.7725E-01,6.5433E-01,6.3091E-01,6.0625E-01,5.8456E-01,
36837 &5.6088E-01,5.3305E-01,5.0402E-01,4.7461E-01,4.4411E-01,4.1800E-01,
36838 &3.8988E-01,3.5790E-01,3.2644E-01,2.9690E-01,2.7087E-01,2.4987E-01,
36839 &2.3039E-01,2.1219E-01,1.9955E-01,1.9298E-01,1.9248E-01,1.9636E-01,
36840 &2.0355E-01,2.1258E-01,2.1752E-01,2.1512E-01,2.0490E-01,1.9021E-01,
36841 &1.6876E-01,1.4586E-01,1.2296E-01,1.0090E-01,8.0587E-02,6.3034E-02,
36842 &4.9591E-02,4.2122E-02,4.3355E-02,5.7203E-02,8.9336E-02,2.1802E-02/
36843 DATA (XDEF_L(K),K= 1825, 1836) /
36844 &1.3258E-02,7.6843E-03,4.1967E-03,2.0952E-03,8.1932E-04,4.1202E-04,
36845 &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00/
36846 DATA (XUDF_L(K),K= 1, 114) /
36847 &1.8987E-02,1.9947E-02,2.0980E-02,2.2068E-02,2.3225E-02,2.4540E-02,
36848 &2.5957E-02,2.7526E-02,2.9229E-02,3.1232E-02,3.3453E-02,3.6003E-02,
36849 &3.8855E-02,4.0763E-02,4.2980E-02,4.5778E-02,4.8895E-02,5.2320E-02,
36850 &5.6174E-02,5.9765E-02,6.3980E-02,6.9315E-02,7.5299E-02,8.1888E-02,
36851 &8.9292E-02,9.6162E-02,1.0414E-01,1.1410E-01,1.2505E-01,1.3674E-01,
36852 &1.4937E-01,1.6060E-01,1.7296E-01,1.8730E-01,2.0166E-01,2.1531E-01,
36853 &2.2821E-01,2.3833E-01,2.4848E-01,2.6049E-01,2.7586E-01,2.9166E-01,
36854 &3.1456E-01,3.3942E-01,3.7230E-01,4.0597E-01,4.3921E-01,4.7071E-01,
36855 &4.9846E-01,5.2057E-01,5.3433E-01,5.3610E-01,5.2141E-01,4.8433E-01,
36856 &4.1719E-01,6.3794E-01,6.7411E-01,7.2040E-01,7.8812E-01,8.9495E-01,
36857 &1.0702E+00,1.3629E+00,1.8763E+00,2.8399E+00,4.8968E+00,1.0506E+01,
36858 &3.7793E+01,0.0000E+00,3.1111E-02,3.2336E-02,3.3580E-02,3.4906E-02,
36859 &3.6247E-02,3.7773E-02,3.9337E-02,4.1056E-02,4.2876E-02,4.5001E-02,
36860 &4.7299E-02,4.9897E-02,5.2761E-02,5.4666E-02,5.6867E-02,5.9620E-02,
36861 &6.2679E-02,6.6018E-02,6.9775E-02,7.3275E-02,7.7353E-02,8.2522E-02,
36862 &8.8327E-02,9.4694E-02,1.0184E-01,1.0846E-01,1.1615E-01,1.2575E-01,
36863 &1.3628E-01,1.4752E-01,1.5964E-01,1.7036E-01,1.8215E-01,1.9580E-01,
36864 &2.0933E-01,2.2213E-01,2.3411E-01,2.4341E-01,2.5275E-01,2.6387E-01,
36865 &2.7831E-01,2.9333E-01,3.1510E-01,3.3876E-01,3.6995E-01,4.0170E-01/
36866 DATA (XUDF_L(K),K= 115, 228) /
36867 &4.3298E-01,4.6172E-01,4.8742E-01,5.0700E-01,5.1856E-01,5.1873E-01,
36868 &5.0352E-01,4.6746E-01,4.0418E-01,6.1801E-01,6.5339E-01,6.9923E-01,
36869 &7.6627E-01,8.7125E-01,1.0408E+00,1.3199E+00,1.8020E+00,2.6920E+00,
36870 &4.5574E+00,9.5310E+00,3.2877E+01,0.0000E+00,5.1176E-02,5.2640E-02,
36871 &5.4100E-02,5.5603E-02,5.7095E-02,5.8737E-02,6.0416E-02,6.2154E-02,
36872 &6.4016E-02,6.6046E-02,6.8273E-02,7.0765E-02,7.3444E-02,7.5182E-02,
36873 &7.7263E-02,7.9781E-02,8.2626E-02,8.5707E-02,8.9176E-02,9.2402E-02,
36874 &9.6182E-02,1.0098E-01,1.0635E-01,1.1227E-01,1.1893E-01,1.2513E-01,
36875 &1.3230E-01,1.4128E-01,1.5115E-01,1.6164E-01,1.7300E-01,1.8301E-01,
36876 &1.9397E-01,2.0660E-01,2.1907E-01,2.3072E-01,2.4154E-01,2.4985E-01,
36877 &2.5817E-01,2.6810E-01,2.8136E-01,2.9535E-01,3.1585E-01,3.3824E-01,
36878 &3.6743E-01,3.9701E-01,4.2565E-01,4.5205E-01,4.7460E-01,4.9184E-01,
36879 &5.0110E-01,4.9954E-01,4.8363E-01,4.4878E-01,3.8940E-01,5.9452E-01,
36880 &6.2820E-01,6.7181E-01,7.3612E-01,8.3598E-01,9.9560E-01,1.2543E+00,
36881 &1.6953E+00,2.4947E+00,4.1415E+00,8.4275E+00,2.7797E+01,0.0000E+00,
36882 &8.6266E-02,8.7847E-02,8.9380E-02,9.0869E-02,9.2337E-02,9.3826E-02,
36883 &9.5315E-02,9.6842E-02,9.8333E-02,1.0003E-01,1.0178E-01,1.0370E-01,
36884 &1.0575E-01,1.0710E-01,1.0872E-01,1.1075E-01,1.1295E-01,1.1538E-01,
36885 &1.1821E-01,1.2088E-01,1.2396E-01,1.2796E-01,1.3252E-01,1.3756E-01/
36886 DATA (XUDF_L(K),K= 229, 342) /
36887 &1.4331E-01,1.4870E-01,1.5500E-01,1.6291E-01,1.7166E-01,1.8100E-01,
36888 &1.9111E-01,2.0002E-01,2.0977E-01,2.2095E-01,2.3189E-01,2.4200E-01,
36889 &2.5123E-01,2.5821E-01,2.6512E-01,2.7351E-01,2.8514E-01,2.9789E-01,
36890 &3.1683E-01,3.3731E-01,3.6424E-01,3.9124E-01,4.1697E-01,4.4030E-01,
36891 &4.6002E-01,4.7419E-01,4.8085E-01,4.7740E-01,4.6086E-01,4.2728E-01,
36892 &3.7241E-01,5.6656E-01,5.9684E-01,6.3694E-01,6.9622E-01,7.8804E-01,
36893 &9.3343E-01,1.1653E+00,1.5545E+00,2.2504E+00,3.6537E+00,7.2124E+00,
36894 &2.2653E+01,0.0000E+00,1.4838E-01,1.4960E-01,1.5068E-01,1.5161E-01,
36895 &1.5242E-01,1.5316E-01,1.5373E-01,1.5426E-01,1.5470E-01,1.5511E-01,
36896 &1.5554E-01,1.5602E-01,1.5660E-01,1.5698E-01,1.5750E-01,1.5830E-01,
36897 &1.5923E-01,1.6034E-01,1.6181E-01,1.6324E-01,1.6509E-01,1.6746E-01,
36898 &1.7054E-01,1.7402E-01,1.7811E-01,1.8208E-01,1.8687E-01,1.9296E-01,
36899 &1.9986E-01,2.0734E-01,2.1554E-01,2.2281E-01,2.3075E-01,2.3983E-01,
36900 &2.4863E-01,2.5660E-01,2.6366E-01,2.6883E-01,2.7387E-01,2.8026E-01,
36901 &2.8982E-01,3.0088E-01,3.1780E-01,3.3626E-01,3.6021E-01,3.8399E-01,
36902 &4.0666E-01,4.2682E-01,4.4278E-01,4.5386E-01,4.5774E-01,4.5230E-01,
36903 &4.3509E-01,4.0314E-01,3.5321E-01,5.3325E-01,5.5916E-01,5.9448E-01,
36904 &6.4707E-01,7.2797E-01,8.5557E-01,1.0563E+00,1.3882E+00,1.9717E+00,
36905 &3.1223E+00,5.9601E+00,1.7750E+01,0.0000E+00,2.3139E-01,2.3138E-01/
36906 DATA (XUDF_L(K),K= 343, 456) /
36907 &2.3120E-01,2.3076E-01,2.3006E-01,2.2907E-01,2.2788E-01,2.2645E-01,
36908 &2.2489E-01,2.2308E-01,2.2120E-01,2.1929E-01,2.1743E-01,2.1630E-01,
36909 &2.1526E-01,2.1411E-01,2.1311E-01,2.1231E-01,2.1171E-01,2.1148E-01,
36910 &2.1150E-01,2.1182E-01,2.1271E-01,2.1412E-01,2.1601E-01,2.1822E-01,
36911 &2.2096E-01,2.2496E-01,2.2961E-01,2.3481E-01,2.4086E-01,2.4622E-01,
36912 &2.5214E-01,2.5891E-01,2.6537E-01,2.7104E-01,2.7588E-01,2.7922E-01,
36913 &2.8235E-01,2.8664E-01,2.9413E-01,3.0352E-01,3.1845E-01,3.3481E-01,
36914 &3.5617E-01,3.7737E-01,3.9689E-01,4.1403E-01,4.2736E-01,4.3558E-01,
36915 &4.3712E-01,4.3016E-01,4.1245E-01,3.8197E-01,3.3645E-01,5.0322E-01,
36916 &5.2507E-01,5.5559E-01,6.0172E-01,6.7286E-01,7.8413E-01,9.5797E-01,
36917 &1.2422E+00,1.7341E+00,2.6883E+00,4.9868E+00,1.4177E+01,0.0000E+00,
36918 &3.6389E-01,3.6098E-01,3.5780E-01,3.5400E-01,3.5016E-01,3.4553E-01,
36919 &3.4044E-01,3.3521E-01,3.2971E-01,3.2369E-01,3.1755E-01,3.1120E-01,
36920 &3.0494E-01,3.0120E-01,2.9724E-01,2.9287E-01,2.8855E-01,2.8449E-01,
36921 &2.8072E-01,2.7770E-01,2.7469E-01,2.7175E-01,2.6933E-01,2.6740E-01,
36922 &2.6613E-01,2.6556E-01,2.6563E-01,2.6631E-01,2.6763E-01,2.6975E-01,
36923 &2.7268E-01,2.7539E-01,2.7857E-01,2.8224E-01,2.8565E-01,2.8841E-01,
36924 &2.9040E-01,2.9139E-01,2.9220E-01,2.9395E-01,2.9888E-01,3.0633E-01,
36925 &3.1877E-01,3.3296E-01,3.5147E-01,3.6947E-01,3.8604E-01,3.9986E-01/
36926 DATA (XUDF_L(K),K= 457, 570) /
36927 &4.1008E-01,4.1548E-01,4.1467E-01,4.0620E-01,3.8830E-01,3.5965E-01,
36928 &3.1902E-01,4.7020E-01,4.8772E-01,5.1303E-01,5.5185E-01,6.1224E-01,
36929 &7.0699E-01,8.5323E-01,1.0903E+00,1.4950E+00,2.2640E+00,4.0723E+00,
36930 &0.0000E+00,0.0000E+00,5.2666E-01,5.1909E-01,5.1100E-01,5.0238E-01,
36931 &4.9333E-01,4.8312E-01,4.7293E-01,4.6180E-01,4.5066E-01,4.3890E-01,
36932 &4.2692E-01,4.1467E-01,4.0262E-01,3.9542E-01,3.8784E-01,3.7925E-01,
36933 &3.7080E-01,3.6267E-01,3.5482E-01,3.4841E-01,3.4190E-01,3.3492E-01,
36934 &3.2852E-01,3.2287E-01,3.1768E-01,3.1409E-01,3.1066E-01,3.0785E-01,
36935 &3.0564E-01,3.0446E-01,3.0380E-01,3.0388E-01,3.0402E-01,3.0458E-01,
36936 &3.0488E-01,3.0475E-01,3.0386E-01,3.0263E-01,3.0116E-01,3.0045E-01,
36937 &3.0296E-01,3.0852E-01,3.1888E-01,3.3085E-01,3.4677E-01,3.6222E-01,
36938 &3.7600E-01,3.8707E-01,3.9488E-01,3.9799E-01,3.9530E-01,3.8568E-01,
36939 &3.6791E-01,3.4080E-01,3.0424E-01,4.4195E-01,4.5570E-01,4.7648E-01,
36940 &5.0935E-01,5.6099E-01,6.4225E-01,7.6680E-01,9.6736E-01,1.3053E+00,
36941 &1.9393E+00,3.3976E+00,0.0000E+00,0.0000E+00,7.4015E-01,7.2498E-01,
36942 &7.0940E-01,6.9297E-01,6.7620E-01,6.5800E-01,6.3935E-01,6.2047E-01,
36943 &6.0114E-01,5.8076E-01,5.6065E-01,5.4030E-01,5.2035E-01,5.0839E-01,
36944 &4.9583E-01,4.8167E-01,4.6773E-01,4.5434E-01,4.4113E-01,4.3035E-01,
36945 &4.1922E-01,4.0719E-01,3.9582E-01,3.8536E-01,3.7557E-01,3.6805E-01/
36946 DATA (XUDF_L(K),K= 571, 684) /
36947 &3.6079E-01,3.5336E-01,3.4710E-01,3.4173E-01,3.3719E-01,3.3400E-01,
36948 &3.3124E-01,3.2819E-01,3.2494E-01,3.2158E-01,3.1765E-01,3.1400E-01,
36949 &3.1011E-01,3.0684E-01,3.0682E-01,3.1046E-01,3.1856E-01,3.2861E-01,
36950 &3.4189E-01,3.5475E-01,3.6597E-01,3.7463E-01,3.8003E-01,3.8108E-01,
36951 &3.7681E-01,3.6631E-01,3.4865E-01,3.2327E-01,2.9078E-01,4.1488E-01,
36952 &4.2529E-01,4.4193E-01,4.6945E-01,5.1322E-01,5.8236E-01,6.8846E-01,
36953 &8.5739E-01,1.1394E+00,1.6617E+00,2.8395E+00,0.0000E+00,0.0000E+00,
36954 &9.8501E-01,9.5975E-01,9.3420E-01,9.0757E-01,8.8092E-01,8.5237E-01,
36955 &8.2383E-01,7.9445E-01,7.6556E-01,7.3524E-01,7.0484E-01,6.7495E-01,
36956 &6.4547E-01,6.2798E-01,6.0969E-01,5.8904E-01,5.6882E-01,5.4932E-01,
36957 &5.3014E-01,5.1443E-01,4.9826E-01,4.8058E-01,4.6380E-01,4.4815E-01,
36958 &4.3330E-01,4.2167E-01,4.1020E-01,3.9827E-01,3.8748E-01,3.7784E-01,
36959 &3.6931E-01,3.6303E-01,3.5669E-01,3.4992E-01,3.4358E-01,3.3710E-01,
36960 &3.3025E-01,3.2429E-01,3.1817E-01,3.1242E-01,3.1001E-01,3.1195E-01,
36961 &3.1802E-01,3.2610E-01,3.3719E-01,3.4770E-01,3.5674E-01,3.6357E-01,
36962 &3.6695E-01,3.6631E-01,3.6075E-01,3.4960E-01,3.3214E-01,3.0855E-01,
36963 &2.7931E-01,3.9198E-01,3.9931E-01,4.1263E-01,4.3550E-01,4.7310E-01,
36964 &5.3259E-01,6.2375E-01,7.6876E-01,1.0087E+00,1.4464E+00,2.4185E+00,
36965 &0.0000E+00,0.0000E+00,1.2917E+00,1.2523E+00,1.2128E+00,1.1722E+00/
36966 DATA (XUDF_L(K),K= 685, 798) /
36967 &1.1321E+00,1.0894E+00,1.0473E+00,1.0044E+00,9.6262E-01,9.1838E-01,
36968 &8.7565E-01,8.3283E-01,7.9186E-01,7.6734E-01,7.4146E-01,7.1300E-01,
36969 &6.8484E-01,6.5787E-01,6.3134E-01,6.0963E-01,5.8730E-01,5.6294E-01,
36970 &5.3947E-01,5.1767E-01,4.9689E-01,4.8039E-01,4.6398E-01,4.4675E-01,
36971 &4.3087E-01,4.1650E-01,4.0371E-01,3.9342E-01,3.8361E-01,3.7293E-01,
36972 &3.6284E-01,3.5305E-01,3.4307E-01,3.3468E-01,3.2613E-01,3.1788E-01,
36973 &3.1306E-01,3.1309E-01,3.1715E-01,3.2346E-01,3.3232E-01,3.4066E-01,
36974 &3.4779E-01,3.5251E-01,3.5401E-01,3.5184E-01,3.4519E-01,3.3347E-01,
36975 &3.1650E-01,2.9433E-01,2.6872E-01,3.6968E-01,3.7446E-01,3.8477E-01,
36976 &4.0368E-01,4.3551E-01,4.8654E-01,5.6457E-01,6.8832E-01,8.9135E-01,
36977 &1.2583E+00,2.0601E+00,0.0000E+00,0.0000E+00,1.6499E+00,1.5928E+00,
36978 &1.5356E+00,1.4773E+00,1.4202E+00,1.3601E+00,1.3009E+00,1.2413E+00,
36979 &1.1836E+00,1.1235E+00,1.0650E+00,1.0076E+00,9.5212E-01,9.1919E-01,
36980 &8.8569E-01,8.4733E-01,8.1006E-01,7.7436E-01,7.3955E-01,7.1104E-01,
36981 &6.8173E-01,6.4966E-01,6.1893E-01,5.9026E-01,5.6287E-01,5.4114E-01,
36982 &5.1941E-01,4.9621E-01,4.7490E-01,4.5564E-01,4.3786E-01,4.2408E-01,
36983 &4.1024E-01,3.9562E-01,3.8175E-01,3.6853E-01,3.5541E-01,3.4455E-01,
36984 &3.3366E-01,3.2286E-01,3.1565E-01,3.1397E-01,3.1618E-01,3.2069E-01,
36985 &3.2744E-01,3.3383E-01,3.3911E-01,3.4194E-01,3.4194E-01,3.3844E-01/
36986 DATA (XUDF_L(K),K= 799, 912) /
36987 &3.3088E-01,3.1887E-01,3.0224E-01,2.8177E-01,2.5901E-01,3.4945E-01,
36988 &3.5200E-01,3.5959E-01,3.7518E-01,4.0212E-01,4.4590E-01,5.1305E-01,
36989 &6.1934E-01,7.9273E-01,1.1025E+00,1.7693E+00,0.0000E+00,0.0000E+00,
36990 &2.0413E+00,1.9626E+00,1.8840E+00,1.8053E+00,1.7284E+00,1.6480E+00,
36991 &1.5697E+00,1.4911E+00,1.4157E+00,1.3375E+00,1.2620E+00,1.1875E+00,
36992 &1.1168E+00,1.0751E+00,1.0321E+00,9.8410E-01,9.3682E-01,8.9196E-01,
36993 &8.4816E-01,8.1245E-01,7.7582E-01,7.3576E-01,6.9745E-01,6.6154E-01,
36994 &6.2742E-01,6.0036E-01,5.7319E-01,5.4409E-01,5.1721E-01,4.9291E-01,
36995 &4.7049E-01,4.5284E-01,4.3541E-01,4.1671E-01,3.9926E-01,3.8274E-01,
36996 &3.6660E-01,3.5348E-01,3.4035E-01,3.2727E-01,3.1788E-01,3.1459E-01,
36997 &3.1499E-01,3.1792E-01,3.2291E-01,3.2764E-01,3.3124E-01,3.3250E-01,
36998 &3.3120E-01,3.2663E-01,3.1834E-01,3.0608E-01,2.8998E-01,2.7085E-01,
36999 &2.5085E-01,3.3191E-01,3.3258E-01,3.3808E-01,3.5072E-01,3.7379E-01,
37000 &4.1182E-01,4.7005E-01,5.6257E-01,7.1233E-01,9.7788E-01,1.5412E+00,
37001 &0.0000E+00,0.0000E+00,2.6325E+00,2.5188E+00,2.4060E+00,2.2942E+00,
37002 &2.1863E+00,2.0740E+00,1.9650E+00,1.8571E+00,1.7537E+00,1.6473E+00,
37003 &1.5453E+00,1.4458E+00,1.3515E+00,1.2965E+00,1.2394E+00,1.1767E+00,
37004 &1.1150E+00,1.0560E+00,9.9927E-01,9.5301E-01,9.0565E-01,8.5400E-01,
37005 &8.0462E-01,7.5858E-01,7.1481E-01,6.7994E-01,6.4502E-01,6.0799E-01/
37006 DATA (XUDF_L(K),K= 913, 1026) /
37007 &5.7349E-01,5.4206E-01,5.1299E-01,4.9028E-01,4.6789E-01,4.4387E-01,
37008 &4.2168E-01,4.0096E-01,3.8070E-01,3.6457E-01,3.4857E-01,3.3249E-01,
37009 &3.2026E-01,3.1503E-01,3.1326E-01,3.1423E-01,3.1703E-01,3.1974E-01,
37010 &3.2120E-01,3.2086E-01,3.1799E-01,3.1221E-01,3.0315E-01,2.9072E-01,
37011 &2.7522E-01,2.5796E-01,2.4114E-01,3.1079E-01,3.0956E-01,3.1267E-01,
37012 &3.2223E-01,3.4089E-01,3.7246E-01,4.2134E-01,4.9853E-01,6.2305E-01,
37013 &8.4191E-01,1.2983E+00,0.0000E+00,0.0000E+00,3.2997E+00,3.1427E+00,
37014 &2.9900E+00,2.8374E+00,2.6927E+00,2.5421E+00,2.3973E+00,2.2549E+00,
37015 &2.1191E+00,1.9809E+00,1.8488E+00,1.7209E+00,1.6001E+00,1.5300E+00,
37016 &1.4576E+00,1.3771E+00,1.2999E+00,1.2268E+00,1.1551E+00,1.0975E+00,
37017 &1.0385E+00,9.7437E-01,9.1327E-01,8.5649E-01,8.0236E-01,7.5952E-01,
37018 &7.1667E-01,6.7091E-01,6.2847E-01,5.9005E-01,5.5422E-01,5.2636E-01,
37019 &4.9890E-01,4.6976E-01,4.4269E-01,4.1752E-01,3.9377E-01,3.7477E-01,
37020 &3.5594E-01,3.3710E-01,3.2226E-01,3.1511E-01,3.1131E-01,3.1067E-01,
37021 &3.1132E-01,3.1227E-01,3.1198E-01,3.1021E-01,3.0606E-01,2.9926E-01,
37022 &2.8958E-01,2.7716E-01,2.6233E-01,2.4655E-01,2.3275E-01,2.9229E-01,
37023 &2.8941E-01,2.9061E-01,2.9753E-01,3.1273E-01,3.3909E-01,3.8034E-01,
37024 &4.4548E-01,5.5028E-01,7.3256E-01,1.1074E+00,0.0000E+00,0.0000E+00,
37025 &4.0557E+00,3.8486E+00,3.6460E+00,3.4480E+00,3.2579E+00,3.0626E+00/
37026 DATA (XUDF_L(K),K= 1027, 1140) /
37027 &2.8756E+00,2.6929E+00,2.5196E+00,2.3441E+00,2.1778E+00,2.0170E+00,
37028 &1.8670E+00,1.7797E+00,1.6902E+00,1.5909E+00,1.4960E+00,1.4058E+00,
37029 &1.3191E+00,1.2484E+00,1.1764E+00,1.0991E+00,1.0253E+00,9.5689E-01,
37030 &8.9197E-01,8.4046E-01,7.8904E-01,7.3442E-01,6.8367E-01,6.3780E-01,
37031 &5.9520E-01,5.6218E-01,5.2934E-01,4.9500E-01,4.6300E-01,4.3370E-01,
37032 &4.0611E-01,3.8431E-01,3.6284E-01,3.4121E-01,3.2389E-01,3.1494E-01,
37033 &3.0926E-01,3.0697E-01,3.0594E-01,3.0501E-01,3.0330E-01,3.0019E-01,
37034 &2.9492E-01,2.8734E-01,2.7718E-01,2.6476E-01,2.5057E-01,2.3646E-01,
37035 &2.2503E-01,2.7558E-01,2.7132E-01,2.7089E-01,2.7569E-01,2.8794E-01,
37036 &3.1000E-01,3.4491E-01,4.0016E-01,4.8886E-01,6.4191E-01,9.5232E-01,
37037 &0.0000E+00,0.0000E+00,4.8799E+00,4.6116E+00,4.3560E+00,4.1035E+00,
37038 &3.8608E+00,3.6163E+00,3.3822E+00,3.1557E+00,2.9412E+00,2.7247E+00,
37039 &2.5209E+00,2.3248E+00,2.1421E+00,2.0368E+00,1.9287E+00,1.8094E+00,
37040 &1.6955E+00,1.5877E+00,1.4841E+00,1.4003E+00,1.3154E+00,1.2237E+00,
37041 &1.1368E+00,1.0563E+00,9.8015E-01,9.2005E-01,8.5978E-01,7.9615E-01,
37042 &7.3715E-01,6.8369E-01,6.3441E-01,5.9609E-01,5.5830E-01,5.1865E-01,
37043 &4.8192E-01,4.4872E-01,4.1747E-01,3.9300E-01,3.6895E-01,3.4483E-01,
37044 &3.2508E-01,3.1459E-01,3.0709E-01,3.0328E-01,3.0056E-01,2.9840E-01,
37045 &2.9543E-01,2.9107E-01,2.8485E-01,2.7655E-01,2.6610E-01,2.5368E-01/
37046 DATA (XUDF_L(K),K= 1141, 1254) /
37047 &2.4019E-01,2.2736E-01,2.1837E-01,2.6080E-01,2.5542E-01,2.5362E-01,
37048 &2.5693E-01,2.6661E-01,2.8505E-01,3.1490E-01,3.6226E-01,4.3798E-01,
37049 &5.6769E-01,8.2836E-01,0.0000E+00,0.0000E+00,5.8340E+00,5.4940E+00,
37050 &5.1700E+00,4.8532E+00,4.5515E+00,4.2463E+00,3.9559E+00,3.6752E+00,
37051 &3.4138E+00,3.1496E+00,2.9022E+00,2.6648E+00,2.4450E+00,2.3189E+00,
37052 &2.1896E+00,2.0476E+00,1.9120E+00,1.7843E+00,1.6621E+00,1.5639E+00,
37053 &1.4648E+00,1.3569E+00,1.2556E+00,1.1618E+00,1.0734E+00,1.0037E+00,
37054 &9.3416E-01,8.6065E-01,7.9257E-01,7.3145E-01,6.7463E-01,6.3082E-01,
37055 &5.8786E-01,5.4262E-01,5.0118E-01,4.6374E-01,4.2883E-01,4.0146E-01,
37056 &3.7490E-01,3.4814E-01,3.2612E-01,3.1397E-01,3.0482E-01,2.9958E-01,
37057 &2.9536E-01,2.9178E-01,2.8756E-01,2.8208E-01,2.7504E-01,2.6611E-01,
37058 &2.5539E-01,2.4319E-01,2.3031E-01,2.1877E-01,2.1195E-01,2.4673E-01,
37059 &2.4036E-01,2.3746E-01,2.3912E-01,2.4677E-01,2.6223E-01,2.8748E-01,
37060 &3.2792E-01,3.9255E-01,5.0271E-01,7.2095E-01,0.0000E+00,0.0000E+00,
37061 &6.8578E+00,6.4388E+00,6.0380E+00,5.6501E+00,5.2825E+00,4.9103E+00,
37062 &4.5613E+00,4.2230E+00,3.9070E+00,3.5911E+00,3.2966E+00,3.0156E+00,
37063 &2.7567E+00,2.6078E+00,2.4563E+00,2.2905E+00,2.1319E+00,1.9837E+00,
37064 &1.8421E+00,1.7287E+00,1.6141E+00,1.4902E+00,1.3730E+00,1.2663E+00,
37065 &1.1652E+00,1.0858E+00,1.0067E+00,9.2337E-01,8.4648E-01,7.7710E-01/
37066 DATA (XUDF_L(K),K= 1255, 1368) /
37067 &7.1333E-01,6.6392E-01,6.1566E-01,5.6531E-01,5.1904E-01,4.7761E-01,
37068 &4.3908E-01,4.0927E-01,3.8022E-01,3.5109E-01,3.2686E-01,3.1318E-01,
37069 &3.0244E-01,2.9602E-01,2.9031E-01,2.8538E-01,2.8024E-01,2.7382E-01,
37070 &2.6607E-01,2.5668E-01,2.4571E-01,2.3364E-01,2.2155E-01,2.1116E-01,
37071 &2.0617E-01,2.3421E-01,2.2704E-01,2.2320E-01,2.2366E-01,2.2952E-01,
37072 &2.4241E-01,2.6402E-01,2.9884E-01,3.5437E-01,4.4860E-01,6.3331E-01,
37073 &0.0000E+00,0.0000E+00,7.9784E+00,7.4673E+00,6.9820E+00,6.5121E+00,
37074 &6.0712E+00,5.6250E+00,5.2080E+00,4.8065E+00,4.4309E+00,4.0590E+00,
37075 &3.7131E+00,3.3843E+00,3.0816E+00,2.9094E+00,2.7332E+00,2.5420E+00,
37076 &2.3595E+00,2.1895E+00,2.0271E+00,1.8966E+00,1.7658E+00,1.6248E+00,
37077 &1.4933E+00,1.3718E+00,1.2579E+00,1.1683E+00,1.0795E+00,9.8589E-01,
37078 &8.9996E-01,8.2253E-01,7.5153E-01,6.9648E-01,6.4287E-01,5.8736E-01,
37079 &5.3655E-01,4.9109E-01,4.4891E-01,4.1655E-01,3.8518E-01,3.5367E-01,
37080 &3.2738E-01,3.1221E-01,3.0006E-01,2.9246E-01,2.8544E-01,2.7940E-01,
37081 &2.7319E-01,2.6601E-01,2.5763E-01,2.4782E-01,2.3676E-01,2.2486E-01,
37082 &2.1329E-01,2.0405E-01,2.0083E-01,2.2267E-01,2.1489E-01,2.1027E-01,
37083 &2.0967E-01,2.1409E-01,2.2473E-01,2.4320E-01,2.7316E-01,3.2113E-01,
37084 &4.0209E-01,5.5899E-01,0.0000E+00,0.0000E+00,9.1575E+00,8.5458E+00,
37085 &7.9700E+00,7.4123E+00,6.8876E+00,6.3653E+00,5.8736E+00,5.4042E+00/
37086 DATA (XUDF_L(K),K= 1369, 1482) /
37087 &4.9684E+00,4.5359E+00,4.1366E+00,3.7576E+00,3.4110E+00,3.2138E+00,
37088 &3.0122E+00,2.7943E+00,2.5871E+00,2.3944E+00,2.2102E+00,2.0646E+00,
37089 &1.9163E+00,1.7581E+00,1.6109E+00,1.4753E+00,1.3483E+00,1.2486E+00,
37090 &1.1500E+00,1.0462E+00,9.5130E-01,8.6585E-01,7.8770E-01,7.2741E-01,
37091 &6.6891E-01,6.0781E-01,5.5266E-01,5.0342E-01,4.5788E-01,4.2322E-01,
37092 &3.8960E-01,3.5594E-01,3.2768E-01,3.1125E-01,2.9779E-01,2.8890E-01,
37093 &2.8091E-01,2.7385E-01,2.6670E-01,2.5886E-01,2.4989E-01,2.3976E-01,
37094 &2.2861E-01,2.1703E-01,2.0604E-01,1.9777E-01,1.9598E-01,2.1238E-01,
37095 &2.0408E-01,1.9879E-01,1.9735E-01,2.0048E-01,2.0933E-01,2.2523E-01,
37096 &2.5120E-01,2.9296E-01,3.6305E-01,4.9711E-01,0.0000E+00,0.0000E+00,
37097 &1.0956E+01,1.0188E+01,9.4660E+00,8.7704E+00,8.1209E+00,7.4727E+00,
37098 &6.8721E+00,6.2972E+00,5.7646E+00,5.2434E+00,4.7595E+00,4.3051E+00,
37099 &3.8911E+00,3.6559E+00,3.4174E+00,3.1598E+00,2.9153E+00,2.6889E+00,
37100 &2.4732E+00,2.3031E+00,2.1311E+00,1.9475E+00,1.7771E+00,1.6202E+00,
37101 &1.4748E+00,1.3609E+00,1.2481E+00,1.1301E+00,1.0222E+00,9.2549E-01,
37102 &8.3728E-01,7.6947E-01,7.0373E-01,6.3561E-01,5.7438E-01,5.1959E-01,
37103 &4.6984E-01,4.3187E-01,3.9529E-01,3.5864E-01,3.2783E-01,3.0967E-01,
37104 &2.9444E-01,2.8428E-01,2.7469E-01,2.6638E-01,2.5813E-01,2.4942E-01,
37105 &2.3986E-01,2.2937E-01,2.1819E-01,2.0682E-01,1.9665E-01,1.8966E-01/
37106 DATA (XUDF_L(K),K= 1483, 1596) /
37107 &1.8971E-01,1.9926E-01,1.9036E-01,1.8442E-01,1.8192E-01,1.8362E-01,
37108 &1.9037E-01,2.0318E-01,2.2459E-01,2.5904E-01,3.1665E-01,4.2407E-01,
37109 &0.0000E+00,0.0000E+00,1.2798E+01,1.1861E+01,1.0986E+01,1.0144E+01,
37110 &9.3643E+00,8.5887E+00,7.8706E+00,7.1866E+00,6.5568E+00,5.9419E+00,
37111 &5.3754E+00,4.8419E+00,4.3593E+00,4.0864E+00,3.8109E+00,3.5127E+00,
37112 &3.2315E+00,2.9714E+00,2.7252E+00,2.5309E+00,2.3356E+00,2.1269E+00,
37113 &1.9338E+00,1.7578E+00,1.5939E+00,1.4656E+00,1.3394E+00,1.2075E+00,
37114 &1.0875E+00,9.8023E-01,8.8256E-01,8.0772E-01,7.3533E-01,6.6054E-01,
37115 &5.9364E-01,5.3423E-01,4.8009E-01,4.3930E-01,4.0003E-01,3.6079E-01,
37116 &3.2768E-01,3.0809E-01,2.9130E-01,2.7993E-01,2.6898E-01,2.5976E-01,
37117 &2.5062E-01,2.4123E-01,2.3116E-01,2.2040E-01,2.0917E-01,1.9814E-01,
37118 &1.8865E-01,1.8272E-01,1.8428E-01,1.8820E-01,1.7883E-01,1.7238E-01,
37119 &1.6914E-01,1.6979E-01,1.7482E-01,1.8534E-01,2.0325E-01,2.3214E-01,
37120 &2.8022E-01,3.6659E-01,0.0000E+00,0.0000E+00,1.4900E+01,1.3767E+01,
37121 &1.2708E+01,1.1700E+01,1.0766E+01,9.8403E+00,8.9832E+00,8.1757E+00,
37122 &7.4366E+00,6.7121E+00,6.0486E+00,5.4300E+00,4.8704E+00,4.5555E+00,
37123 &4.2371E+00,3.8955E+00,3.5734E+00,3.2760E+00,2.9952E+00,2.7738E+00,
37124 &2.5528E+00,2.3175E+00,2.1001E+00,1.9012E+00,1.7176E+00,1.5750E+00,
37125 &1.4344E+00,1.2880E+00,1.1547E+00,1.0364E+00,9.2859E-01,8.4652E-01/
37126 DATA (XUDF_L(K),K= 1597, 1710) /
37127 &7.6723E-01,6.8578E-01,6.1255E-01,5.4848E-01,4.9034E-01,4.4649E-01,
37128 &4.0456E-01,3.6275E-01,3.2738E-01,3.0624E-01,2.8805E-01,2.7544E-01,
37129 &2.6343E-01,2.5315E-01,2.4318E-01,2.3314E-01,2.2263E-01,2.1166E-01,
37130 &2.0051E-01,1.8983E-01,1.8102E-01,1.7610E-01,1.7901E-01,1.7764E-01,
37131 &1.6791E-01,1.6102E-01,1.5715E-01,1.5684E-01,1.6056E-01,1.6899E-01,
37132 &1.8376E-01,2.0786E-01,2.4776E-01,3.1470E-01,0.0000E+00,0.0000E+00,
37133 &1.7212E+01,1.5853E+01,1.4590E+01,1.3390E+01,1.2283E+01,1.1191E+01,
37134 &1.0185E+01,9.2395E+00,8.3762E+00,7.5315E+00,6.7670E+00,6.0503E+00,
37135 &5.4086E+00,5.0481E+00,4.6843E+00,4.2940E+00,3.9280E+00,3.5917E+00,
37136 &3.2752E+00,3.0252E+00,2.7768E+00,2.5132E+00,2.2690E+00,2.0490E+00,
37137 &1.8445E+00,1.6857E+00,1.5301E+00,1.3685E+00,1.2219E+00,1.0920E+00,
37138 &9.7438E-01,8.8478E-01,7.9825E-01,7.1007E-01,6.3111E-01,5.6196E-01,
37139 &5.0016E-01,4.5321E-01,4.0867E-01,3.6435E-01,3.2686E-01,3.0431E-01,
37140 &2.8470E-01,2.7109E-01,2.5789E-01,2.4674E-01,2.3605E-01,2.2547E-01,
37141 &2.1459E-01,2.0348E-01,1.9237E-01,1.8201E-01,1.7376E-01,1.6982E-01,
37142 &1.7398E-01,1.6789E-01,1.5795E-01,1.5065E-01,1.4630E-01,1.4521E-01,
37143 &1.4773E-01,1.5443E-01,1.6659E-01,1.8664E-01,2.1966E-01,2.6878E-01,
37144 &0.0000E+00,0.0000E+00,1.9526E+01,1.7951E+01,1.6470E+01,1.5074E+01,
37145 &1.3790E+01,1.2527E+01,1.1370E+01,1.0282E+01,9.2958E+00,8.3330E+00/
37146 DATA (XUDF_L(K),K= 1711, 1824) /
37147 &7.4603E+00,6.6536E+00,5.9285E+00,5.5219E+00,5.1141E+00,4.6768E+00,
37148 &4.2681E+00,3.8926E+00,3.5402E+00,3.2626E+00,2.9882E+00,2.6963E+00,
37149 &2.4284E+00,2.1851E+00,1.9619E+00,1.7885E+00,1.6187E+00,1.4429E+00,
37150 &1.2838E+00,1.1431E+00,1.0159E+00,9.1924E-01,8.2663E-01,7.3180E-01,
37151 &6.4793E-01,5.7429E-01,5.0828E-01,4.5904E-01,4.1215E-01,3.6558E-01,
37152 &3.2620E-01,3.0238E-01,2.8167E-01,2.6700E-01,2.5302E-01,2.4098E-01,
37153 &2.2975E-01,2.1873E-01,2.0756E-01,1.9633E-01,1.8532E-01,1.7533E-01,
37154 &1.6763E-01,1.6450E-01,1.6959E-01,1.5953E-01,1.4943E-01,1.4185E-01,
37155 &1.3716E-01,1.3545E-01,1.3705E-01,1.4238E-01,1.5258E-01,1.6945E-01,
37156 &1.9705E-01,2.3049E-01,0.0000E+00,0.0000E+00,2.2141E+01,2.0286E+01,
37157 &1.8570E+01,1.6948E+01,1.5466E+01,1.4010E+01,1.2679E+01,1.1431E+01,
37158 &1.0303E+01,9.2106E+00,8.2239E+00,7.3077E+00,6.4926E+00,6.0348E+00,
37159 &5.5765E+00,5.0879E+00,4.6321E+00,4.2138E+00,3.8233E+00,3.5162E+00,
37160 &3.2122E+00,2.8907E+00,2.5960E+00,2.3300E+00,2.0856E+00,1.8954E+00,
37161 &1.7110E+00,1.5199E+00,1.3476E+00,1.1955E+00,1.0584E+00,9.5478E-01,
37162 &8.5531E-01,7.5417E-01,6.6439E-01,5.8623E-01,5.1682E-01,4.6468E-01,
37163 &4.1541E-01,3.6662E-01,3.2538E-01,3.0035E-01,2.7843E-01,2.6291E-01,
37164 &2.4798E-01,2.3522E-01,2.2346E-01,2.1203E-01,2.0062E-01,1.8935E-01,
37165 &1.7843E-01,1.6874E-01,1.6163E-01,1.5920E-01,1.6520E-01,1.5147E-01/
37166 DATA (XUDF_L(K),K= 1825, 1836) /
37167 &1.4120E-01,1.3349E-01,1.2844E-01,1.2620E-01,1.2701E-01,1.3118E-01,
37168 &1.3954E-01,1.5369E-01,1.7631E-01,1.9416E-01,0.0000E+00,0.0000E+00/
37169 DATA (XSF_L(K),K= 1, 114) /
37170 &8.9277E-03,9.2838E-03,9.6380E-03,9.9960E-03,1.0349E-02,1.0719E-02,
37171 &1.1082E-02,1.1442E-02,1.1792E-02,1.2148E-02,1.2489E-02,1.2817E-02,
37172 &1.3124E-02,1.3295E-02,1.3474E-02,1.3661E-02,1.3835E-02,1.3985E-02,
37173 &1.4121E-02,1.4217E-02,1.4303E-02,1.4379E-02,1.4419E-02,1.4434E-02,
37174 &1.4412E-02,1.4366E-02,1.4286E-02,1.4158E-02,1.3991E-02,1.3790E-02,
37175 &1.3553E-02,1.3335E-02,1.3094E-02,1.2821E-02,1.2580E-02,1.2410E-02,
37176 &1.2357E-02,1.2459E-02,1.2790E-02,1.3571E-02,1.5018E-02,1.6665E-02,
37177 &1.9113E-02,2.1832E-02,2.5587E-02,2.9818E-02,3.4535E-02,3.9813E-02,
37178 &4.5737E-02,5.2358E-02,5.9765E-02,6.8021E-02,7.7185E-02,8.7258E-02,
37179 &9.8198E-02,1.1073E-01,1.4216E-01,1.8364E-01,2.3959E-01,3.1758E-01,
37180 &4.3050E-01,6.0203E-01,8.8214E-01,1.3845E+00,2.4294E+00,5.2463E+00,
37181 &1.8903E+01,0.0000E+00,1.4987E-02,1.5468E-02,1.5936E-02,1.6403E-02,
37182 &1.6855E-02,1.7319E-02,1.7760E-02,1.8194E-02,1.8600E-02,1.9008E-02,
37183 &1.9382E-02,1.9730E-02,2.0033E-02,2.0199E-02,2.0359E-02,2.0523E-02,
37184 &2.0654E-02,2.0760E-02,2.0831E-02,2.0870E-02,2.0886E-02,2.0858E-02,
37185 &2.0798E-02,2.0680E-02,2.0523E-02,2.0363E-02,2.0127E-02,1.9825E-02,
37186 &1.9464E-02,1.9060E-02,1.8607E-02,1.8200E-02,1.7750E-02,1.7240E-02,
37187 &1.6759E-02,1.6362E-02,1.6103E-02,1.6050E-02,1.6240E-02,1.6916E-02,
37188 &1.8336E-02,2.0030E-02,2.2586E-02,2.5447E-02,2.9418E-02,3.3874E-02/
37189 DATA (XSF_L(K),K= 115, 228) /
37190 &3.8821E-02,4.4375E-02,5.0509E-02,5.7343E-02,6.4974E-02,7.3385E-02,
37191 &8.2640E-02,9.2732E-02,1.0354E-01,1.1667E-01,1.4809E-01,1.8910E-01,
37192 &2.4387E-01,3.1940E-01,4.2764E-01,5.9054E-01,8.5228E-01,1.3150E+00,
37193 &2.2623E+00,4.7596E+00,1.6445E+01,0.0000E+00,2.5010E-02,2.5616E-02,
37194 &2.6180E-02,2.6758E-02,2.7279E-02,2.7792E-02,2.8274E-02,2.8729E-02,
37195 &2.9134E-02,2.9513E-02,2.9836E-02,3.0110E-02,3.0324E-02,3.0417E-02,
37196 &3.0492E-02,3.0537E-02,3.0551E-02,3.0517E-02,3.0432E-02,3.0326E-02,
37197 &3.0181E-02,2.9954E-02,2.9663E-02,2.9316E-02,2.8913E-02,2.8508E-02,
37198 &2.8021E-02,2.7422E-02,2.6741E-02,2.5997E-02,2.5204E-02,2.4500E-02,
37199 &2.3734E-02,2.2858E-02,2.2019E-02,2.1281E-02,2.0698E-02,2.0402E-02,
37200 &2.0365E-02,2.0844E-02,2.2137E-02,2.3807E-02,2.6404E-02,2.9338E-02,
37201 &3.3433E-02,3.8036E-02,4.3135E-02,4.8799E-02,5.5061E-02,6.1999E-02,
37202 &6.9633E-02,7.8024E-02,8.7156E-02,9.6998E-02,1.0742E-01,1.2099E-01,
37203 &1.5162E-01,1.9121E-01,2.4363E-01,3.1510E-01,4.1638E-01,5.6669E-01,
37204 &8.0557E-01,1.2216E+00,2.0572E+00,4.2084E+00,1.3911E+01,0.0000E+00,
37205 &4.2554E-02,4.3210E-02,4.3820E-02,4.4379E-02,4.4862E-02,4.5317E-02,
37206 &4.5708E-02,4.6037E-02,4.6300E-02,4.6434E-02,4.6540E-02,4.6530E-02,
37207 &4.6426E-02,4.6317E-02,4.6155E-02,4.5919E-02,4.5622E-02,4.5267E-02,
37208 &4.4833E-02,4.4425E-02,4.3932E-02,4.3298E-02,4.2582E-02,4.1785E-02/
37209 DATA (XSF_L(K),K= 229, 342) /
37210 &4.0903E-02,4.0097E-02,3.9179E-02,3.8047E-02,3.6815E-02,3.5547E-02,
37211 &3.4199E-02,3.3020E-02,3.1748E-02,3.0298E-02,2.8905E-02,2.7644E-02,
37212 &2.6563E-02,2.5882E-02,2.5485E-02,2.5614E-02,2.6651E-02,2.8199E-02,
37213 &3.0731E-02,3.3652E-02,3.7768E-02,4.2390E-02,4.7530E-02,5.3188E-02,
37214 &5.9436E-02,6.6257E-02,7.3734E-02,8.1918E-02,9.0696E-02,1.0004E-01,
37215 &1.0978E-01,1.2357E-01,1.5274E-01,1.8999E-01,2.3888E-01,3.0452E-01,
37216 &3.9656E-01,5.3136E-01,7.4246E-01,1.1043E+00,1.8158E+00,3.6023E+00,
37217 &0.0000E+00,0.0000E+00,7.3602E-02,7.4085E-02,7.4460E-02,7.4729E-02,
37218 &7.4904E-02,7.4982E-02,7.4902E-02,7.4713E-02,7.4446E-02,7.3972E-02,
37219 &7.3397E-02,7.2626E-02,7.1803E-02,7.1200E-02,7.0479E-02,6.9610E-02,
37220 &6.8654E-02,6.7624E-02,6.6495E-02,6.5467E-02,6.4313E-02,6.2898E-02,
37221 &6.1380E-02,5.9788E-02,5.8079E-02,5.6557E-02,5.4876E-02,5.2866E-02,
37222 &5.0733E-02,4.8592E-02,4.6341E-02,4.4415E-02,4.2370E-02,4.0073E-02,
37223 &3.7825E-02,3.5778E-02,3.3956E-02,3.2702E-02,3.1749E-02,3.1334E-02,
37224 &3.1922E-02,3.3216E-02,3.5534E-02,3.8322E-02,4.2321E-02,4.6830E-02,
37225 &5.1816E-02,5.7335E-02,6.3369E-02,6.9947E-02,7.7109E-02,8.4752E-02,
37226 &9.2948E-02,1.0153E-01,1.1031E-01,1.2405E-01,1.5100E-01,1.8509E-01,
37227 &2.2905E-01,2.8761E-01,3.6847E-01,4.8537E-01,6.6543E-01,9.6831E-01,
37228 &1.5524E+00,2.9766E+00,0.0000E+00,0.0000E+00,1.1509E-01,1.1500E-01/
37229 DATA (XSF_L(K),K= 343, 456) /
37230 &1.1474E-01,1.1430E-01,1.1371E-01,1.1292E-01,1.1196E-01,1.1079E-01,
37231 &1.0948E-01,1.0791E-01,1.0620E-01,1.0426E-01,1.0215E-01,1.0076E-01,
37232 &9.9224E-02,9.7466E-02,9.5472E-02,9.3507E-02,9.1346E-02,8.9460E-02,
37233 &8.7382E-02,8.4914E-02,8.2326E-02,7.9663E-02,7.6874E-02,7.4459E-02,
37234 &7.1794E-02,6.8694E-02,6.5489E-02,6.2266E-02,5.8964E-02,5.6164E-02,
37235 &5.3226E-02,4.9916E-02,4.6721E-02,4.3794E-02,4.1128E-02,3.9225E-02,
37236 &3.7654E-02,3.6613E-02,3.6666E-02,3.7626E-02,3.9655E-02,4.2227E-02,
37237 &4.6000E-02,5.0288E-02,5.5044E-02,6.0308E-02,6.6020E-02,7.2218E-02,
37238 &7.8943E-02,8.6079E-02,9.3611E-02,1.0141E-01,1.0925E-01,1.2274E-01,
37239 &1.4748E-01,1.7840E-01,2.1791E-01,2.6997E-01,3.4109E-01,4.4280E-01,
37240 &5.9706E-01,8.5325E-01,1.3371E+00,2.4909E+00,0.0000E+00,0.0000E+00,
37241 &1.8131E-01,1.7986E-01,1.7802E-01,1.7597E-01,1.7372E-01,1.7110E-01,
37242 &1.6825E-01,1.6515E-01,1.6187E-01,1.5820E-01,1.5428E-01,1.5016E-01,
37243 &1.4582E-01,1.4314E-01,1.4017E-01,1.3677E-01,1.3315E-01,1.2951E-01,
37244 &1.2571E-01,1.2248E-01,1.1891E-01,1.1472E-01,1.1045E-01,1.0615E-01,
37245 &1.0173E-01,9.7944E-02,9.3854E-02,8.9131E-02,8.4347E-02,7.9597E-02,
37246 &7.4799E-02,7.0788E-02,6.6599E-02,6.1932E-02,5.7438E-02,5.3307E-02,
37247 &4.9546E-02,4.6816E-02,4.4417E-02,4.2536E-02,4.1862E-02,4.2361E-02,
37248 &4.3960E-02,4.6198E-02,4.9612E-02,5.3553E-02,5.7974E-02,6.2830E-02/
37249 DATA (XSF_L(K),K= 457, 570) /
37250 &6.8141E-02,7.3865E-02,7.9970E-02,8.6422E-02,9.3160E-02,1.0006E-01,
37251 &1.0685E-01,1.1989E-01,1.4199E-01,1.6937E-01,2.0407E-01,2.4925E-01,
37252 &3.1029E-01,3.9635E-01,5.2529E-01,7.3579E-01,1.1263E+00,2.0347E+00,
37253 &0.0000E+00,0.0000E+00,2.6278E-01,2.5883E-01,2.5460E-01,2.5007E-01,
37254 &2.4526E-01,2.3995E-01,2.3437E-01,2.2848E-01,2.2242E-01,2.1578E-01,
37255 &2.0894E-01,2.0181E-01,1.9465E-01,1.9018E-01,1.8540E-01,1.7984E-01,
37256 &1.7415E-01,1.6846E-01,1.6261E-01,1.5768E-01,1.5234E-01,1.4615E-01,
37257 &1.3987E-01,1.3368E-01,1.2736E-01,1.2199E-01,1.1628E-01,1.0975E-01,
37258 &1.0321E-01,9.6788E-02,9.0380E-02,8.5059E-02,7.9532E-02,7.3436E-02,
37259 &6.7594E-02,6.2243E-02,5.7363E-02,5.3720E-02,5.0502E-02,4.7772E-02,
37260 &4.6346E-02,4.6358E-02,4.7497E-02,4.9377E-02,5.2401E-02,5.5965E-02,
37261 &6.0009E-02,6.4489E-02,6.9334E-02,7.4546E-02,8.0117E-02,8.5936E-02,
37262 &9.1972E-02,9.8056E-02,1.0398E-01,1.1644E-01,1.3628E-01,1.6068E-01,
37263 &1.9127E-01,2.3085E-01,2.8377E-01,3.5756E-01,4.6698E-01,6.4315E-01,
37264 &9.6485E-01,1.6969E+00,0.0000E+00,0.0000E+00,3.6944E-01,3.6187E-01,
37265 &3.5380E-01,3.4525E-01,3.3659E-01,3.2716E-01,3.1761E-01,3.0767E-01,
37266 &2.9759E-01,2.8675E-01,2.7586E-01,2.6462E-01,2.5339E-01,2.4660E-01,
37267 &2.3933E-01,2.3101E-01,2.2257E-01,2.1415E-01,2.0571E-01,1.9854E-01,
37268 &1.9083E-01,1.8216E-01,1.7338E-01,1.6480E-01,1.5613E-01,1.4885E-01/
37269 DATA (XSF_L(K),K= 571, 684) /
37270 &1.4115E-01,1.3244E-01,1.2380E-01,1.1542E-01,1.0713E-01,1.0031E-01,
37271 &9.3226E-02,8.5515E-02,7.8171E-02,7.1449E-02,6.5307E-02,6.0723E-02,
37272 &5.6523E-02,5.2878E-02,5.0622E-02,5.0109E-02,5.0720E-02,5.2187E-02,
37273 &5.4770E-02,5.7950E-02,6.1582E-02,6.5595E-02,6.9997E-02,7.4716E-02,
37274 &7.9677E-02,8.4886E-02,9.0221E-02,9.5543E-02,1.0065E-01,1.1245E-01,
37275 &1.3012E-01,1.5166E-01,1.7859E-01,2.1305E-01,2.5881E-01,3.2188E-01,
37276 &4.1454E-01,5.6186E-01,8.2718E-01,1.4188E+00,0.0000E+00,0.0000E+00,
37277 &4.9195E-01,4.7916E-01,4.6620E-01,4.5277E-01,4.3908E-01,4.2463E-01,
37278 &4.0985E-01,3.9491E-01,3.7975E-01,3.6377E-01,3.4790E-01,3.3178E-01,
37279 &3.1592E-01,3.0640E-01,2.9622E-01,2.8462E-01,2.7303E-01,2.6160E-01,
37280 &2.5012E-01,2.4047E-01,2.3023E-01,2.1867E-01,2.0717E-01,1.9597E-01,
37281 &1.8477E-01,1.7546E-01,1.6568E-01,1.5468E-01,1.4387E-01,1.3343E-01,
37282 &1.2319E-01,1.1482E-01,1.0622E-01,9.6828E-02,8.7978E-02,7.9884E-02,
37283 &7.2526E-02,6.6973E-02,6.1948E-02,5.7359E-02,5.4304E-02,5.3263E-02,
37284 &5.3381E-02,5.4456E-02,5.6601E-02,5.9380E-02,6.2613E-02,6.6252E-02,
37285 &7.0174E-02,7.4432E-02,7.8943E-02,8.3559E-02,8.8282E-02,9.2963E-02,
37286 &9.7382E-02,1.0858E-01,1.2441E-01,1.4363E-01,1.6745E-01,1.9778E-01,
37287 &2.3771E-01,2.9246E-01,3.7200E-01,4.9738E-01,7.2010E-01,1.2083E+00,
37288 &0.0000E+00,0.0000E+00,6.4521E-01,6.2534E-01,6.0540E-01,5.8499E-01/
37289 DATA (XSF_L(K),K= 685, 798) /
37290 &5.6467E-01,5.4301E-01,5.2143E-01,4.9951E-01,4.7813E-01,4.5538E-01,
37291 &4.3325E-01,4.1083E-01,3.8899E-01,3.7591E-01,3.6210E-01,3.4648E-01,
37292 &3.3091E-01,3.1578E-01,3.0062E-01,2.8797E-01,2.7469E-01,2.5979E-01,
37293 &2.4501E-01,2.3066E-01,2.1649E-01,2.0481E-01,1.9252E-01,1.7884E-01,
37294 &1.6549E-01,1.5274E-01,1.4029E-01,1.3018E-01,1.1985E-01,1.0865E-01,
37295 &9.8135E-02,8.8550E-02,7.9829E-02,7.3318E-02,6.7269E-02,6.1748E-02,
37296 &5.7838E-02,5.6250E-02,5.5826E-02,5.6474E-02,5.8181E-02,6.0533E-02,
37297 &6.3373E-02,6.6563E-02,7.0085E-02,7.3865E-02,7.7842E-02,8.1937E-02,
37298 &8.6092E-02,9.0169E-02,9.3962E-02,1.0448E-01,1.1858E-01,1.3561E-01,
37299 &1.5663E-01,1.8318E-01,2.1803E-01,2.6529E-01,3.3349E-01,4.3985E-01,
37300 &6.2661E-01,1.0291E+00,0.0000E+00,0.0000E+00,8.2462E-01,7.9558E-01,
37301 &7.6680E-01,7.3764E-01,7.0860E-01,6.7834E-01,6.4822E-01,6.1798E-01,
37302 &5.8880E-01,5.5792E-01,5.2800E-01,4.9801E-01,4.6912E-01,4.5197E-01,
37303 &4.3393E-01,4.1360E-01,3.9348E-01,3.7394E-01,3.5462E-01,3.3856E-01,
37304 &3.2180E-01,3.0303E-01,2.8460E-01,2.6681E-01,2.4932E-01,2.3502E-01,
37305 &2.2005E-01,2.0359E-01,1.8747E-01,1.7224E-01,1.5746E-01,1.4551E-01,
37306 &1.3337E-01,1.2028E-01,1.0805E-01,9.6986E-02,8.6877E-02,7.9334E-02,
37307 &7.2326E-02,6.5799E-02,6.1060E-02,5.8911E-02,5.7957E-02,5.8189E-02,
37308 &5.9441E-02,6.1387E-02,6.3834E-02,6.6632E-02,6.9732E-02,7.3070E-02/
37309 DATA (XSF_L(K),K= 799, 912) /
37310 &7.6595E-02,8.0190E-02,8.3816E-02,8.7358E-02,9.0631E-02,1.0046E-01,
37311 &1.1304E-01,1.2815E-01,1.4670E-01,1.7006E-01,2.0049E-01,2.4154E-01,
37312 &3.0039E-01,3.9121E-01,5.4894E-01,8.8378E-01,0.0000E+00,0.0000E+00,
37313 &1.0199E+00,9.8025E-01,9.4100E-01,9.0151E-01,8.6283E-01,8.2243E-01,
37314 &7.8262E-01,7.4321E-01,7.0465E-01,6.6494E-01,6.2647E-01,5.8811E-01,
37315 &5.5152E-01,5.2985E-01,5.0721E-01,4.8183E-01,4.5681E-01,4.3274E-01,
37316 &4.0883E-01,3.8916E-01,3.6878E-01,3.4589E-01,3.2366E-01,3.0238E-01,
37317 &2.8152E-01,2.6437E-01,2.4685E-01,2.2733E-01,2.0858E-01,1.9085E-01,
37318 &1.7375E-01,1.6000E-01,1.4607E-01,1.3115E-01,1.1722E-01,1.0469E-01,
37319 &9.3284E-02,8.4739E-02,7.6803E-02,6.9420E-02,6.3844E-02,6.1178E-02,
37320 &5.9720E-02,5.9561E-02,6.0398E-02,6.1984E-02,6.4051E-02,6.6494E-02,
37321 &6.9202E-02,7.2161E-02,7.5274E-02,7.8453E-02,8.1651E-02,8.4728E-02,
37322 &8.7564E-02,9.6777E-02,1.0806E-01,1.2157E-01,1.3806E-01,1.5882E-01,
37323 &1.8566E-01,2.2170E-01,2.7301E-01,3.5168E-01,4.8696E-01,7.7010E-01,
37324 &0.0000E+00,0.0000E+00,1.3158E+00,1.2585E+00,1.2024E+00,1.1462E+00,
37325 &1.0919E+00,1.0352E+00,9.8042E-01,9.2608E-01,8.7345E-01,8.1987E-01,
37326 &7.6814E-01,7.1724E-01,6.6882E-01,6.4053E-01,6.1093E-01,5.7796E-01,
37327 &5.4572E-01,5.1470E-01,4.8433E-01,4.5934E-01,4.3358E-01,4.0495E-01,
37328 &3.7717E-01,3.5082E-01,3.2513E-01,3.0408E-01,2.8258E-01,2.5918E-01/
37329 DATA (XSF_L(K),K= 913, 1026) /
37330 &2.3648E-01,2.1538E-01,1.9510E-01,1.7888E-01,1.6255E-01,1.4508E-01,
37331 &1.2895E-01,1.1443E-01,1.0131E-01,9.1507E-02,8.2387E-02,7.3778E-02,
37332 &6.7147E-02,6.3813E-02,6.1721E-02,6.1065E-02,6.1373E-02,6.2475E-02,
37333 &6.4105E-02,6.6079E-02,6.8362E-02,7.0856E-02,7.3440E-02,7.6143E-02,
37334 &7.8812E-02,8.1388E-02,8.3726E-02,9.2167E-02,1.0190E-01,1.1355E-01,
37335 &1.2780E-01,1.4554E-01,1.6841E-01,1.9900E-01,2.4223E-01,3.0775E-01,
37336 &4.1920E-01,6.4849E-01,0.0000E+00,0.0000E+00,1.6483E+00,1.5703E+00,
37337 &1.4940E+00,1.4180E+00,1.3449E+00,1.2694E+00,1.1966E+00,1.1250E+00,
37338 &1.0566E+00,9.8644E-01,9.1985E-01,8.5482E-01,7.9312E-01,7.5722E-01,
37339 &7.1986E-01,6.7849E-01,6.3821E-01,5.9972E-01,5.6214E-01,5.3143E-01,
37340 &4.9987E-01,4.6500E-01,4.3136E-01,3.9956E-01,3.6875E-01,3.4379E-01,
37341 &3.1832E-01,2.9044E-01,2.6397E-01,2.3923E-01,2.1580E-01,1.9706E-01,
37342 &1.7829E-01,1.5838E-01,1.3999E-01,1.2356E-01,1.0875E-01,9.7664E-02,
37343 &8.7392E-02,7.7645E-02,7.0035E-02,6.6062E-02,6.3365E-02,6.2239E-02,
37344 &6.2062E-02,6.2731E-02,6.3942E-02,6.5526E-02,6.7390E-02,6.9436E-02,
37345 &7.1635E-02,7.3891E-02,7.6122E-02,7.8246E-02,8.0196E-02,8.7884E-02,
37346 &9.6357E-02,1.0648E-01,1.1880E-01,1.3413E-01,1.5386E-01,1.7993E-01,
37347 &2.1655E-01,2.7189E-01,3.6486E-01,5.5332E-01,0.0000E+00,0.0000E+00,
37348 &2.0271E+00,1.9234E+00,1.8224E+00,1.7226E+00,1.6272E+00,1.5293E+00/
37349 DATA (XSF_L(K),K= 1027, 1140) /
37350 &1.4356E+00,1.3438E+00,1.2568E+00,1.1682E+00,1.0841E+00,1.0026E+00,
37351 &9.2625E-01,8.8207E-01,8.3568E-01,7.8523E-01,7.3607E-01,6.8926E-01,
37352 &6.4385E-01,6.0685E-01,5.6892E-01,5.2730E-01,4.8731E-01,4.4961E-01,
37353 &4.1331E-01,3.8417E-01,3.5441E-01,3.2210E-01,2.9168E-01,2.6323E-01,
37354 &2.3631E-01,2.1500E-01,1.9374E-01,1.7129E-01,1.5067E-01,1.3231E-01,
37355 &1.1579E-01,1.0349E-01,9.2080E-02,8.1205E-02,7.2626E-02,6.8039E-02,
37356 &6.4761E-02,6.3188E-02,6.2549E-02,6.2795E-02,6.3617E-02,6.4835E-02,
37357 &6.6329E-02,6.8017E-02,6.9809E-02,7.1667E-02,7.3520E-02,7.5270E-02,
37358 &7.6864E-02,8.3899E-02,9.1206E-02,1.0002E-01,1.1070E-01,1.2399E-01,
37359 &1.4094E-01,1.6341E-01,1.9474E-01,2.4163E-01,3.1971E-01,4.7587E-01,
37360 &0.0000E+00,0.0000E+00,2.4392E+00,2.3049E+00,2.1760E+00,2.0502E+00,
37361 &1.9296E+00,1.8065E+00,1.6895E+00,1.5750E+00,1.4674E+00,1.3585E+00,
37362 &1.2554E+00,1.1565E+00,1.0638E+00,1.0103E+00,9.5527E-01,8.9449E-01,
37363 &8.3572E-01,7.8018E-01,7.2635E-01,6.8280E-01,6.3819E-01,5.8948E-01,
37364 &5.4299E-01,4.9923E-01,4.5740E-01,4.2371E-01,3.8978E-01,3.5296E-01,
37365 &3.1832E-01,2.8629E-01,2.5599E-01,2.3212E-01,2.0840E-01,1.8346E-01,
37366 &1.6065E-01,1.4043E-01,1.2229E-01,1.0880E-01,9.6294E-02,8.4335E-02,
37367 &7.4905E-02,6.9717E-02,6.5897E-02,6.3914E-02,6.2851E-02,6.2731E-02,
37368 &6.3183E-02,6.4075E-02,6.5225E-02,6.6597E-02,6.8048E-02,6.9577E-02/
37369 DATA (XSF_L(K),K= 1141, 1254) /
37370 &7.1093E-02,7.2525E-02,7.3842E-02,8.0241E-02,8.6615E-02,9.4292E-02,
37371 &1.0360E-01,1.1517E-01,1.2992E-01,1.4936E-01,1.7633E-01,2.1652E-01,
37372 &2.8294E-01,4.1389E-01,0.0000E+00,0.0000E+00,2.9162E+00,2.7470E+00,
37373 &2.5840E+00,2.4244E+00,2.2743E+00,2.1215E+00,1.9764E+00,1.8358E+00,
37374 &1.7035E+00,1.5708E+00,1.4463E+00,1.3268E+00,1.2152E+00,1.1514E+00,
37375 &1.0857E+00,1.0132E+00,9.4449E-01,8.7867E-01,8.1556E-01,7.6453E-01,
37376 &7.1252E-01,6.5602E-01,6.0218E-01,5.5192E-01,5.0387E-01,4.6545E-01,
37377 &4.2679E-01,3.8521E-01,3.4602E-01,3.1005E-01,2.7623E-01,2.4962E-01,
37378 &2.2332E-01,1.9577E-01,1.7070E-01,1.4856E-01,1.2874E-01,1.1402E-01,
37379 &1.0040E-01,8.7343E-02,7.6984E-02,7.1254E-02,6.6892E-02,6.4508E-02,
37380 &6.3019E-02,6.2518E-02,6.2667E-02,6.3211E-02,6.4031E-02,6.5064E-02,
37381 &6.6243E-02,6.7458E-02,6.8679E-02,6.9830E-02,7.0885E-02,7.6672E-02,
37382 &8.2192E-02,8.8844E-02,9.6930E-02,1.0696E-01,1.1972E-01,1.3654E-01,
37383 &1.5978E-01,1.9411E-01,2.5048E-01,3.6023E-01,0.0000E+00,0.0000E+00,
37384 &3.4281E+00,3.2194E+00,3.0180E+00,2.8239E+00,2.6400E+00,2.4537E+00,
37385 &2.2781E+00,2.1087E+00,1.9503E+00,1.7915E+00,1.6433E+00,1.5021E+00,
37386 &1.3711E+00,1.2958E+00,1.2191E+00,1.1350E+00,1.0536E+00,9.7846E-01,
37387 &9.0526E-01,8.4668E-01,7.8697E-01,7.2243E-01,6.6110E-01,6.0402E-01,
37388 &5.4971E-01,5.0652E-01,4.6307E-01,4.1647E-01,3.7287E-01,3.3288E-01/
37389 DATA (XSF_L(K),K= 1255, 1368) /
37390 &2.9545E-01,2.6636E-01,2.3751E-01,2.0740E-01,1.8012E-01,1.5611E-01,
37391 &1.3467E-01,1.1881E-01,1.0414E-01,9.0105E-02,7.8839E-02,7.2563E-02,
37392 &6.7703E-02,6.4930E-02,6.3070E-02,6.2241E-02,6.2071E-02,6.2347E-02,
37393 &6.2882E-02,6.3645E-02,6.4526E-02,6.5473E-02,6.6427E-02,6.7333E-02,
37394 &6.8194E-02,7.3430E-02,7.8217E-02,8.3974E-02,9.1017E-02,9.9745E-02,
37395 &1.1088E-01,1.2552E-01,1.4563E-01,1.7528E-01,2.2351E-01,3.1636E-01,
37396 &0.0000E+00,0.0000E+00,3.9892E+00,3.7328E+00,3.4900E+00,3.2549E+00,
37397 &3.0344E+00,2.8108E+00,2.6014E+00,2.4001E+00,2.2123E+00,2.0253E+00,
37398 &1.8518E+00,1.6860E+00,1.5339E+00,1.4463E+00,1.3575E+00,1.2608E+00,
37399 &1.1678E+00,1.0809E+00,9.9767E-01,9.3087E-01,8.6314E-01,7.8996E-01,
37400 &7.2083E-01,6.5671E-01,5.9602E-01,5.4775E-01,4.9935E-01,4.4773E-01,
37401 &3.9951E-01,3.5571E-01,3.1467E-01,2.8272E-01,2.5135E-01,2.1871E-01,
37402 &1.8923E-01,1.6331E-01,1.4031E-01,1.2332E-01,1.0762E-01,9.2560E-02,
37403 &8.0473E-02,7.3714E-02,6.8385E-02,6.5246E-02,6.3019E-02,6.1878E-02,
37404 &6.1420E-02,6.1413E-02,6.1734E-02,6.2226E-02,6.2861E-02,6.3564E-02,
37405 &6.4288E-02,6.4985E-02,6.5657E-02,7.0367E-02,7.4522E-02,7.9506E-02,
37406 &8.5651E-02,9.3297E-02,1.0298E-01,1.1572E-01,1.3323E-01,1.5884E-01,
37407 &2.0039E-01,2.7925E-01,0.0000E+00,0.0000E+00,4.5788E+00,4.2729E+00,
37408 &3.9840E+00,3.7039E+00,3.4438E+00,3.1812E+00,2.9349E+00,2.6996E+00/
37409 DATA (XSF_L(K),K= 1369, 1482) /
37410 &2.4810E+00,2.2644E+00,2.0633E+00,1.8732E+00,1.6979E+00,1.5988E+00,
37411 &1.4974E+00,1.3865E+00,1.2812E+00,1.1834E+00,1.0891E+00,1.0143E+00,
37412 &9.3839E-01,8.5662E-01,7.7948E-01,7.0838E-01,6.4106E-01,5.8780E-01,
37413 &5.3454E-01,4.7781E-01,4.2528E-01,3.7737E-01,3.3289E-01,2.9818E-01,
37414 &2.6446E-01,2.2932E-01,1.9770E-01,1.7005E-01,1.4552E-01,1.2746E-01,
37415 &1.1078E-01,9.4770E-02,8.1957E-02,7.4689E-02,6.8915E-02,6.5457E-02,
37416 &6.2902E-02,6.1493E-02,6.0768E-02,6.0515E-02,6.0585E-02,6.0863E-02,
37417 &6.1298E-02,6.1789E-02,6.2311E-02,6.2835E-02,6.3340E-02,6.7601E-02,
37418 &7.1162E-02,7.5516E-02,8.0878E-02,8.7566E-02,9.6095E-02,1.0725E-01,
37419 &1.2258E-01,1.4495E-01,1.8090E-01,2.4841E-01,0.0000E+00,0.0000E+00,
37420 &5.4774E+00,5.0929E+00,4.7320E+00,4.3841E+00,4.0592E+00,3.7350E+00,
37421 &3.4329E+00,3.1454E+00,2.8799E+00,2.6172E+00,2.3747E+00,2.1466E+00,
37422 &1.9383E+00,1.8195E+00,1.6996E+00,1.5689E+00,1.4457E+00,1.3301E+00,
37423 &1.2211E+00,1.1339E+00,1.0456E+00,9.5119E-01,8.6259E-01,7.8097E-01,
37424 &7.0419E-01,6.4380E-01,5.8358E-01,5.1955E-01,4.6051E-01,4.0719E-01,
37425 &3.5768E-01,3.1962E-01,2.8220E-01,2.4360E-01,2.0909E-01,1.7895E-01,
37426 &1.5240E-01,1.3282E-01,1.1484E-01,9.7655E-02,8.3739E-02,7.5857E-02,
37427 &6.9509E-02,6.5616E-02,6.2633E-02,6.0853E-02,5.9819E-02,5.9271E-02,
37428 &5.9038E-02,5.9046E-02,5.9192E-02,5.9432E-02,5.9709E-02,6.0008E-02/
37429 DATA (XSF_L(K),K= 1483, 1596) /
37430 &6.0340E-02,6.4032E-02,6.6851E-02,7.0446E-02,7.4870E-02,8.0457E-02,
37431 &8.7554E-02,9.6862E-02,1.0964E-01,1.2821E-01,1.5779E-01,2.1189E-01,
37432 &0.0000E+00,0.0000E+00,6.3982E+00,5.9307E+00,5.4920E+00,5.0710E+00,
37433 &4.6822E+00,4.2915E+00,3.9337E+00,3.5898E+00,3.2756E+00,2.9660E+00,
37434 &2.6817E+00,2.4150E+00,2.1724E+00,2.0348E+00,1.8961E+00,1.7457E+00,
37435 &1.6034E+00,1.4714E+00,1.3471E+00,1.2473E+00,1.1476E+00,1.0408E+00,
37436 &9.4083E-01,8.4932E-01,7.6350E-01,6.9606E-01,6.2897E-01,5.5833E-01,
37437 &4.9315E-01,4.3444E-01,3.8044E-01,3.3861E-01,2.9817E-01,2.5642E-01,
37438 &2.1917E-01,1.8685E-01,1.5838E-01,1.3752E-01,1.1831E-01,9.9987E-02,
37439 &8.5224E-02,7.6762E-02,6.9910E-02,6.5655E-02,6.2297E-02,6.0213E-02,
37440 &5.8897E-02,5.8096E-02,5.7624E-02,5.7400E-02,5.7322E-02,5.7351E-02,
37441 &5.7432E-02,5.7560E-02,5.7758E-02,6.0939E-02,6.3212E-02,6.6167E-02,
37442 &6.9884E-02,7.4560E-02,8.0552E-02,8.8432E-02,9.9242E-02,1.1491E-01,
37443 &1.3966E-01,1.8320E-01,0.0000E+00,0.0000E+00,7.4490E+00,6.8826E+00,
37444 &6.3540E+00,5.8477E+00,5.3805E+00,4.9187E+00,4.4884E+00,4.0843E+00,
37445 &3.7147E+00,3.3516E+00,3.0193E+00,2.7088E+00,2.4279E+00,2.2696E+00,
37446 &2.1091E+00,1.9368E+00,1.7739E+00,1.6237E+00,1.4821E+00,1.3692E+00,
37447 &1.2557E+00,1.1358E+00,1.0238E+00,9.2133E-01,8.2567E-01,7.5070E-01,
37448 &6.7656E-01,5.9850E-01,5.2688E-01,4.6263E-01,4.0371E-01,3.5842E-01/
37449 DATA (XSF_L(K),K= 1597, 1710) /
37450 &3.1427E-01,2.6933E-01,2.2930E-01,1.9466E-01,1.6427E-01,1.4208E-01,
37451 &1.2168E-01,1.0226E-01,8.6560E-02,7.7553E-02,7.0202E-02,6.5576E-02,
37452 &6.1860E-02,5.9487E-02,5.7920E-02,5.6852E-02,5.6166E-02,5.5736E-02,
37453 &5.5458E-02,5.5289E-02,5.5193E-02,5.5163E-02,5.5243E-02,5.7935E-02,
37454 &5.9740E-02,6.2111E-02,6.5158E-02,6.9050E-02,7.4078E-02,8.0683E-02,
37455 &8.9776E-02,1.0288E-01,1.2351E-01,1.5725E-01,0.0000E+00,0.0000E+00,
37456 &8.6044E+00,7.9255E+00,7.2940E+00,6.6940E+00,6.1391E+00,5.5940E+00,
37457 &5.0907E+00,4.6180E+00,4.1841E+00,3.7622E+00,3.3775E+00,3.0195E+00,
37458 &2.6967E+00,2.5153E+00,2.3331E+00,2.1364E+00,1.9521E+00,1.7815E+00,
37459 &1.6211E+00,1.4944E+00,1.3683E+00,1.2334E+00,1.1084E+00,9.9465E-01,
37460 &8.8864E-01,8.0585E-01,7.2432E-01,6.3866E-01,5.6038E-01,4.9058E-01,
37461 &4.2648E-01,3.7768E-01,3.3036E-01,2.8189E-01,2.3907E-01,2.0214E-01,
37462 &1.6987E-01,1.4635E-01,1.2479E-01,1.0428E-01,8.7748E-02,7.8203E-02,
37463 &7.0386E-02,6.5431E-02,6.1373E-02,5.8719E-02,5.6916E-02,5.5642E-02,
37464 &5.4751E-02,5.4118E-02,5.3653E-02,5.3314E-02,5.3067E-02,5.2897E-02,
37465 &5.2861E-02,5.5140E-02,5.6493E-02,5.8378E-02,6.0860E-02,6.4090E-02,
37466 &6.8261E-02,7.3828E-02,8.1439E-02,9.2423E-02,1.0952E-01,1.3424E-01,
37467 &0.0000E+00,0.0000E+00,9.7645E+00,8.9701E+00,8.2340E+00,7.5357E+00,
37468 &6.8926E+00,6.2607E+00,5.6834E+00,5.1374E+00,4.6459E+00,4.1625E+00/
37469 DATA (XSF_L(K),K= 1711, 1824) /
37470 &3.7261E+00,3.3206E+00,2.9567E+00,2.7529E+00,2.5476E+00,2.3274E+00,
37471 &2.1217E+00,1.9320E+00,1.7541E+00,1.6131E+00,1.4740E+00,1.3257E+00,
37472 &1.1879E+00,1.0631E+00,9.4732E-01,8.5726E-01,7.6844E-01,6.7586E-01,
37473 &5.9131E-01,5.1597E-01,4.4748E-01,3.9504E-01,3.4470E-01,2.9317E-01,
37474 &2.4779E-01,2.0880E-01,1.7478E-01,1.5007E-01,1.2748E-01,1.0600E-01,
37475 &8.8713E-02,7.8704E-02,7.0472E-02,6.5220E-02,6.0885E-02,5.7993E-02,
37476 &5.5967E-02,5.4536E-02,5.3470E-02,5.2665E-02,5.2054E-02,5.1577E-02,
37477 &5.1203E-02,5.0930E-02,5.0809E-02,5.2731E-02,5.3716E-02,5.5192E-02,
37478 &5.7203E-02,5.9902E-02,6.3412E-02,6.8123E-02,7.4602E-02,8.3905E-02,
37479 &9.8185E-02,1.1515E-01,0.0000E+00,0.0000E+00,1.1069E+01,1.0141E+01,
37480 &9.2840E+00,8.4741E+00,7.7316E+00,7.0038E+00,6.3364E+00,5.7137E+00,
37481 &5.1475E+00,4.6031E+00,4.1059E+00,3.6477E+00,3.2381E+00,3.0086E+00,
37482 &2.7788E+00,2.5333E+00,2.3033E+00,2.0926E+00,1.8951E+00,1.7404E+00,
37483 &1.5854E+00,1.4229E+00,1.2715E+00,1.1352E+00,1.0089E+00,9.1089E-01,
37484 &8.1457E-01,7.1424E-01,6.2332E-01,5.4229E-01,4.6872E-01,4.1295E-01,
37485 &3.5903E-01,3.0454E-01,2.5654E-01,2.1539E-01,1.7965E-01,1.5373E-01,
37486 &1.3011E-01,1.0766E-01,8.9530E-02,7.9108E-02,7.0483E-02,6.4943E-02,
37487 &6.0331E-02,5.7203E-02,5.4990E-02,5.3395E-02,5.2144E-02,5.1206E-02,
37488 &5.0454E-02,4.9840E-02,4.9351E-02,4.8978E-02,4.8801E-02,5.0351E-02/
37489 DATA (XSF_L(K),K= 1825, 1836) /
37490 &5.1017E-02,5.2127E-02,5.3737E-02,5.5934E-02,5.8835E-02,6.2800E-02,
37491 &6.8260E-02,7.6135E-02,8.7873E-02,0.0000E+00,0.0000E+00,0.0000E+00/
37492 DATA (XGF_L(K),K= 1, 114) /
37493 &1.0646E+00,1.0934E+00,1.1214E+00,1.1484E+00,1.1741E+00,1.1999E+00,
37494 &1.2242E+00,1.2466E+00,1.2676E+00,1.2873E+00,1.3042E+00,1.3194E+00,
37495 &1.3313E+00,1.3376E+00,1.3430E+00,1.3472E+00,1.3502E+00,1.3504E+00,
37496 &1.3501E+00,1.3478E+00,1.3430E+00,1.3356E+00,1.3267E+00,1.3149E+00,
37497 &1.3003E+00,1.2857E+00,1.2680E+00,1.2451E+00,1.2189E+00,1.1899E+00,
37498 &1.1575E+00,1.1282E+00,1.0947E+00,1.0543E+00,1.0121E+00,9.6983E-01,
37499 &9.2809E-01,8.9556E-01,8.6663E-01,8.4606E-01,8.4971E-01,8.7714E-01,
37500 &9.3569E-01,1.0140E+00,1.1325E+00,1.2706E+00,1.4268E+00,1.6005E+00,
37501 &1.7918E+00,2.0014E+00,2.2301E+00,2.4791E+00,2.7490E+00,3.0404E+00,
37502 &3.3541E+00,3.5718E+00,4.2579E+00,5.0478E+00,5.9674E+00,7.0458E+00,
37503 &8.3375E+00,9.9284E+00,1.1949E+01,1.4650E+01,1.8560E+01,2.5096E+01,
37504 &4.0067E+01,0.0000E+00,1.6404E+00,1.6723E+00,1.7014E+00,1.7287E+00,
37505 &1.7533E+00,1.7768E+00,1.7973E+00,1.8152E+00,1.8297E+00,1.8417E+00,
37506 &1.8498E+00,1.8540E+00,1.8544E+00,1.8526E+00,1.8489E+00,1.8424E+00,
37507 &1.8335E+00,1.8221E+00,1.8091E+00,1.7949E+00,1.7784E+00,1.7555E+00,
37508 &1.7310E+00,1.7034E+00,1.6713E+00,1.6428E+00,1.6093E+00,1.5680E+00,
37509 &1.5230E+00,1.4754E+00,1.4241E+00,1.3785E+00,1.3278E+00,1.2681E+00,
37510 &1.2068E+00,1.1462E+00,1.0867E+00,1.0400E+00,9.9665E-01,9.6041E-01,
37511 &9.4923E-01,9.6563E-01,1.0117E+00,1.0781E+00,1.1816E+00,1.3028E+00/
37512 DATA (XGF_L(K),K= 115, 228) /
37513 &1.4397E+00,1.5912E+00,1.7573E+00,1.9376E+00,2.1326E+00,2.3425E+00,
37514 &2.5677E+00,2.8078E+00,3.0611E+00,3.2398E+00,3.7904E+00,4.4126E+00,
37515 &5.1162E+00,5.9322E+00,6.8841E+00,8.0278E+00,9.4403E+00,1.1276E+01,
37516 &1.3844E+01,1.7948E+01,2.6821E+01,0.0000E+00,2.5295E+00,2.5563E+00,
37517 &2.5800E+00,2.5995E+00,2.6174E+00,2.6286E+00,2.6363E+00,2.6395E+00,
37518 &2.6379E+00,2.6306E+00,2.6184E+00,2.6000E+00,2.5768E+00,2.5598E+00,
37519 &2.5397E+00,2.5137E+00,2.4839E+00,2.4516E+00,2.4161E+00,2.3833E+00,
37520 &2.3459E+00,2.3000E+00,2.2499E+00,2.1966E+00,2.1407E+00,2.0900E+00,
37521 &2.0320E+00,1.9647E+00,1.8929E+00,1.8190E+00,1.7411E+00,1.6734E+00,
37522 &1.5997E+00,1.5142E+00,1.4279E+00,1.3438E+00,1.2617E+00,1.1967E+00,
37523 &1.1353E+00,1.0800E+00,1.0501E+00,1.0526E+00,1.0849E+00,1.1369E+00,
37524 &1.2228E+00,1.3250E+00,1.4410E+00,1.5691E+00,1.7085E+00,1.8587E+00,
37525 &2.0200E+00,2.1915E+00,2.3728E+00,2.5633E+00,2.7603E+00,2.9047E+00,
37526 &3.3315E+00,3.8026E+00,4.3243E+00,4.9121E+00,5.5828E+00,6.3648E+00,
37527 &7.3038E+00,8.4817E+00,1.0068E+01,1.2484E+01,1.7398E+01,0.0000E+00,
37528 &3.9781E+00,3.9859E+00,3.9880E+00,3.9845E+00,3.9763E+00,3.9582E+00,
37529 &3.9337E+00,3.9028E+00,3.8636E+00,3.8159E+00,3.7613E+00,3.6984E+00,
37530 &3.6287E+00,3.5836E+00,3.5326E+00,3.4703E+00,3.4046E+00,3.3350E+00,
37531 &3.2612E+00,3.1962E+00,3.1248E+00,3.0388E+00,2.9485E+00,2.8565E+00/
37532 DATA (XGF_L(K),K= 229, 342) /
37533 &2.7591E+00,2.6752E+00,2.5823E+00,2.4756E+00,2.3627E+00,2.2510E+00,
37534 &2.1352E+00,2.0365E+00,1.9308E+00,1.8097E+00,1.6896E+00,1.5737E+00,
37535 &1.4618E+00,1.3735E+00,1.2886E+00,1.2087E+00,1.1551E+00,1.1411E+00,
37536 &1.1545E+00,1.1903E+00,1.2550E+00,1.3356E+00,1.4282E+00,1.5306E+00,
37537 &1.6419E+00,1.7606E+00,1.8869E+00,2.0194E+00,2.1574E+00,2.2992E+00,
37538 &2.4432E+00,2.5568E+00,2.8674E+00,3.2008E+00,3.5626E+00,3.9572E+00,
37539 &4.3932E+00,4.8857E+00,5.4544E+00,6.1386E+00,7.0188E+00,8.2895E+00,
37540 &1.0709E+01,0.0000E+00,6.3697E+00,6.3265E+00,6.2740E+00,6.2091E+00,
37541 &6.1391E+00,6.0517E+00,5.9560E+00,5.8525E+00,5.7367E+00,5.6106E+00,
37542 &5.4709E+00,5.3235E+00,5.1695E+00,5.0724E+00,4.9662E+00,4.8411E+00,
37543 &4.7105E+00,4.5784E+00,4.4412E+00,4.3226E+00,4.1943E+00,4.0442E+00,
37544 &3.8903E+00,3.7360E+00,3.5773E+00,3.4420E+00,3.2967E+00,3.1301E+00,
37545 &2.9593E+00,2.7916E+00,2.6229E+00,2.4802E+00,2.3301E+00,2.1613E+00,
37546 &1.9957E+00,1.8382E+00,1.6875E+00,1.5691E+00,1.4545E+00,1.3433E+00,
37547 &1.2614E+00,1.2264E+00,1.2177E+00,1.2342E+00,1.2749E+00,1.3313E+00,
37548 &1.3987E+00,1.4740E+00,1.5559E+00,1.6431E+00,1.7346E+00,1.8295E+00,
37549 &1.9260E+00,2.0232E+00,2.1174E+00,2.2034E+00,2.4118E+00,2.6289E+00,
37550 &2.8563E+00,3.0948E+00,3.3486E+00,3.6231E+00,3.9250E+00,4.2677E+00,
37551 &4.6847E+00,5.2492E+00,6.2650E+00,0.0000E+00,9.3778E+00,9.2428E+00/
37552 DATA (XGF_L(K),K= 343, 456) /
37553 &9.0960E+00,8.9365E+00,8.7665E+00,8.5746E+00,8.3714E+00,8.1544E+00,
37554 &7.9343E+00,7.6882E+00,7.4352E+00,7.1724E+00,6.9027E+00,6.7360E+00,
37555 &6.5571E+00,6.3494E+00,6.1374E+00,5.9260E+00,5.7093E+00,5.5249E+00,
37556 &5.3270E+00,5.0995E+00,4.8700E+00,4.6419E+00,4.4114E+00,4.2173E+00,
37557 &4.0129E+00,3.7786E+00,3.5451E+00,3.3173E+00,3.0900E+00,2.9004E+00,
37558 &2.7040E+00,2.4853E+00,2.2734E+00,2.0742E+00,1.8851E+00,1.7372E+00,
37559 &1.5941E+00,1.4536E+00,1.3433E+00,1.2893E+00,1.2607E+00,1.2587E+00,
37560 &1.2792E+00,1.3153E+00,1.3616E+00,1.4149E+00,1.4736E+00,1.5361E+00,
37561 &1.6012E+00,1.6677E+00,1.7344E+00,1.7990E+00,1.8589E+00,1.9261E+00,
37562 &2.0646E+00,2.2044E+00,2.3456E+00,2.4882E+00,2.6342E+00,2.7823E+00,
37563 &2.9370E+00,3.1022E+00,3.2902E+00,3.5288E+00,3.9528E+00,0.0000E+00,
37564 &1.3926E+01,1.3617E+01,1.3298E+01,1.2959E+01,1.2612E+01,1.2230E+01,
37565 &1.1845E+01,1.1442E+01,1.1036E+01,1.0599E+01,1.0158E+01,9.7041E+00,
37566 &9.2562E+00,8.9827E+00,8.6974E+00,8.3632E+00,8.0255E+00,7.6946E+00,
37567 &7.3614E+00,7.0802E+00,6.7814E+00,6.4439E+00,6.1064E+00,5.7775E+00,
37568 &5.4468E+00,5.1723E+00,4.8858E+00,4.5617E+00,4.2425E+00,3.9361E+00,
37569 &3.6353E+00,3.3874E+00,3.1301E+00,2.8506E+00,2.5816E+00,2.3318E+00,
37570 &2.0965E+00,1.9136E+00,1.7368E+00,1.5622E+00,1.4211E+00,1.3452E+00,
37571 &1.2937E+00,1.2737E+00,1.2719E+00,1.2868E+00,1.3119E+00,1.3437E+00/
37572 DATA (XGF_L(K),K= 457, 570) /
37573 &1.3799E+00,1.4189E+00,1.4596E+00,1.5003E+00,1.5401E+00,1.5761E+00,
37574 &1.6073E+00,1.6574E+00,1.7377E+00,1.8158E+00,1.8902E+00,1.9601E+00,
37575 &2.0263E+00,2.0884E+00,2.1452E+00,2.1990E+00,2.2512E+00,2.3118E+00,
37576 &2.4354E+00,0.0000E+00,1.9256E+01,1.8699E+01,1.8142E+01,1.7563E+01,
37577 &1.6980E+01,1.6355E+01,1.5725E+01,1.5081E+01,1.4443E+01,1.3769E+01,
37578 &1.3097E+01,1.2422E+01,1.1755E+01,1.1358E+01,1.0937E+01,1.0454E+01,
37579 &9.9818E+00,9.5167E+00,9.0465E+00,8.6570E+00,8.2473E+00,7.7870E+00,
37580 &7.3320E+00,6.8911E+00,6.4569E+00,6.0969E+00,5.7223E+00,5.3051E+00,
37581 &4.8992E+00,4.5131E+00,4.1351E+00,3.8285E+00,3.5148E+00,3.1749E+00,
37582 &2.8517E+00,2.5534E+00,2.2748E+00,2.0598E+00,1.8527E+00,1.6465E+00,
37583 &1.4780E+00,1.3832E+00,1.3129E+00,1.2758E+00,1.2566E+00,1.2544E+00,
37584 &1.2628E+00,1.2778E+00,1.2971E+00,1.3186E+00,1.3412E+00,1.3637E+00,
37585 &1.3845E+00,1.4021E+00,1.4142E+00,1.4518E+00,1.4945E+00,1.5327E+00,
37586 &1.5661E+00,1.5941E+00,1.6160E+00,1.6309E+00,1.6386E+00,1.6381E+00,
37587 &1.6291E+00,1.6176E+00,1.6271E+00,0.0000E+00,2.5945E+01,2.5063E+01,
37588 &2.4160E+01,2.3234E+01,2.2336E+01,2.1370E+01,2.0417E+01,1.9450E+01,
37589 &1.8508E+01,1.7517E+01,1.6548E+01,1.5580E+01,1.4645E+01,1.4085E+01,
37590 &1.3496E+01,1.2836E+01,1.2181E+01,1.1547E+01,1.0921E+01,1.0404E+01,
37591 &9.8614E+00,9.2547E+00,8.6616E+00,8.0926E+00,7.5352E+00,7.0774E+00/
37592 DATA (XGF_L(K),K= 571, 684) /
37593 &6.6043E+00,6.0842E+00,5.5816E+00,5.1040E+00,4.6450E+00,4.2749E+00,
37594 &3.8995E+00,3.4941E+00,3.1134E+00,2.7651E+00,2.4423E+00,2.1941E+00,
37595 &1.9564E+00,1.7198E+00,1.5241E+00,1.4112E+00,1.3220E+00,1.2705E+00,
37596 &1.2348E+00,1.2175E+00,1.2113E+00,1.2119E+00,1.2167E+00,1.2238E+00,
37597 &1.2321E+00,1.2398E+00,1.2460E+00,1.2491E+00,1.2470E+00,1.2752E+00,
37598 &1.2894E+00,1.2998E+00,1.3055E+00,1.3049E+00,1.2991E+00,1.2860E+00,
37599 &1.2655E+00,1.2370E+00,1.1998E+00,1.1564E+00,1.1181E+00,0.0000E+00,
37600 &3.3362E+01,3.2051E+01,3.0740E+01,2.9429E+01,2.8133E+01,2.6758E+01,
37601 &2.5422E+01,2.4082E+01,2.2784E+01,2.1435E+01,2.0130E+01,1.8839E+01,
37602 &1.7597E+01,1.6865E+01,1.6098E+01,1.5241E+01,1.4397E+01,1.3587E+01,
37603 &1.2791E+01,1.2130E+01,1.1444E+01,1.0687E+01,9.9507E+00,9.2501E+00,
37604 &8.5659E+00,8.0104E+00,7.4390E+00,6.8118E+00,6.2125E+00,5.6506E+00,
37605 &5.1096E+00,4.6780E+00,4.2434E+00,3.7769E+00,3.3424E+00,2.9475E+00,
37606 &2.5842E+00,2.3061E+00,2.0409E+00,1.7770E+00,1.5572E+00,1.4290E+00,
37607 &1.3248E+00,1.2609E+00,1.2112E+00,1.1814E+00,1.1636E+00,1.1530E+00,
37608 &1.1469E+00,1.1433E+00,1.1407E+00,1.1378E+00,1.1337E+00,1.1269E+00,
37609 &1.1152E+00,1.1360E+00,1.1320E+00,1.1243E+00,1.1127E+00,1.0960E+00,
37610 &1.0739E+00,1.0461E+00,1.0122E+00,9.7100E-01,9.2292E-01,8.6909E-01,
37611 &8.1432E-01,0.0000E+00,4.2364E+01,4.0483E+01,3.8640E+01,3.6792E+01/
37612 DATA (XGF_L(K),K= 685, 798) /
37613 &3.4991E+01,3.3112E+01,3.1295E+01,2.9487E+01,2.7748E+01,2.5953E+01,
37614 &2.4235E+01,2.2543E+01,2.0935E+01,1.9990E+01,1.9011E+01,1.7921E+01,
37615 &1.6852E+01,1.5830E+01,1.4831E+01,1.4013E+01,1.3165E+01,1.2236E+01,
37616 &1.1337E+01,1.0485E+01,9.6616E+00,8.9943E+00,8.3137E+00,7.5711E+00,
37617 &6.8670E+00,6.2090E+00,5.5842E+00,5.0866E+00,4.5873E+00,4.0564E+00,
37618 &3.5646E+00,3.1234E+00,2.7185E+00,2.4107E+00,2.1172E+00,1.8273E+00,
37619 &1.5836E+00,1.4407E+00,1.3211E+00,1.2459E+00,1.1839E+00,1.1433E+00,
37620 &1.1153E+00,1.0949E+00,1.0794E+00,1.0667E+00,1.0555E+00,1.0443E+00,
37621 &1.0317E+00,1.0172E+00,9.9883E-01,1.0131E+00,9.9503E-01,9.7446E-01,
37622 &9.5064E-01,9.2316E-01,8.9156E-01,8.5528E-01,8.1439E-01,7.6837E-01,
37623 &7.1718E-01,6.6210E-01,6.0243E-01,0.0000E+00,5.2603E+01,5.0038E+01,
37624 &4.7540E+01,4.5053E+01,4.2652E+01,4.0175E+01,3.7784E+01,3.5407E+01,
37625 &3.3154E+01,3.0851E+01,2.8651E+01,2.6507E+01,2.4488E+01,2.3310E+01,
37626 &2.2084E+01,2.0735E+01,1.9418E+01,1.8166E+01,1.6951E+01,1.5960E+01,
37627 &1.4935E+01,1.3817E+01,1.2742E+01,1.1732E+01,1.0759E+01,9.9749E+00,
37628 &9.1794E+00,8.3186E+00,7.5044E+00,6.7510E+00,6.0386E+00,5.4762E+00,
37629 &4.9137E+00,4.3200E+00,3.7728E+00,3.2842E+00,2.8391E+00,2.5026E+00,
37630 &2.1835E+00,1.8677E+00,1.6033E+00,1.4461E+00,1.3138E+00,1.2277E+00,
37631 &1.1557E+00,1.1057E+00,1.0689E+00,1.0407E+00,1.0176E+00,9.9768E-01/
37632 DATA (XGF_L(K),K= 799, 912) /
37633 &9.7951E-01,9.6199E-01,9.4331E-01,9.2359E-01,9.0058E-01,9.0921E-01,
37634 &8.8156E-01,8.5244E-01,8.2081E-01,7.8702E-01,7.5025E-01,7.1005E-01,
37635 &6.6667E-01,6.1984E-01,5.6969E-01,5.1748E-01,4.5895E-01,0.0000E+00,
37636 &6.3459E+01,6.0127E+01,5.6900E+01,5.3695E+01,5.0615E+01,4.7464E+01,
37637 &4.4440E+01,4.1483E+01,3.8684E+01,3.5826E+01,3.3122E+01,3.0500E+01,
37638 &2.8040E+01,2.6617E+01,2.5143E+01,2.3518E+01,2.1950E+01,2.0455E+01,
37639 &1.9011E+01,1.7842E+01,1.6646E+01,1.5337E+01,1.4094E+01,1.2920E+01,
37640 &1.1799E+01,1.0903E+01,9.9940E+00,9.0166E+00,8.0967E+00,7.2512E+00,
37641 &6.4551E+00,5.8279E+00,5.2081E+00,4.5519E+00,3.9568E+00,3.4237E+00,
37642 &2.9425E+00,2.5798E+00,2.2371E+00,1.8995E+00,1.6161E+00,1.4477E+00,
37643 &1.3046E+00,1.2096E+00,1.1285E+00,1.0709E+00,1.0274E+00,9.9290E-01,
37644 &9.6399E-01,9.3860E-01,9.1550E-01,8.9324E-01,8.7036E-01,8.4674E-01,
37645 &8.2129E-01,8.2506E-01,7.9094E-01,7.5633E-01,7.2031E-01,6.8307E-01,
37646 &6.4387E-01,6.0237E-01,5.5907E-01,5.1344E-01,4.6618E-01,4.1810E-01,
37647 &3.6329E-01,0.0000E+00,7.9498E+01,7.4941E+01,7.0580E+01,6.6266E+01,
37648 &6.2169E+01,5.8002E+01,5.4045E+01,5.0164E+01,4.6539E+01,4.2847E+01,
37649 &3.9386E+01,3.6065E+01,3.2968E+01,3.1180E+01,2.9347E+01,2.7330E+01,
37650 &2.5394E+01,2.3566E+01,2.1811E+01,2.0388E+01,1.8944E+01,1.7368E+01,
37651 &1.5877E+01,1.4488E+01,1.3164E+01,1.2111E+01,1.1051E+01,9.9162E+00/
37652 DATA (XGF_L(K),K= 913, 1026) /
37653 &8.8542E+00,7.8839E+00,6.9777E+00,6.2689E+00,5.5695E+00,4.8410E+00,
37654 &4.1789E+00,3.5909E+00,3.0635E+00,2.6689E+00,2.2973E+00,1.9324E+00,
37655 &1.6270E+00,1.4446E+00,1.2882E+00,1.1839E+00,1.0926E+00,1.0266E+00,
37656 &9.7585E-01,9.3473E-01,8.9976E-01,8.6898E-01,8.4068E-01,8.1374E-01,
37657 &7.8714E-01,7.6011E-01,7.3262E-01,7.3148E-01,6.9170E-01,6.5270E-01,
37658 &6.1357E-01,5.7426E-01,5.3417E-01,4.9316E-01,4.5166E-01,4.0914E-01,
37659 &3.6649E-01,3.2429E-01,2.7651E-01,0.0000E+00,9.7091E+01,9.1127E+01,
37660 &8.5440E+01,7.9869E+01,7.4603E+01,6.9275E+01,6.4220E+01,5.9343E+01,
37661 &5.4780E+01,5.0195E+01,4.5912E+01,4.1816E+01,3.8028E+01,3.5857E+01,
37662 &3.3637E+01,3.1205E+01,2.8880E+01,2.6695E+01,2.4601E+01,2.2923E+01,
37663 &2.1219E+01,1.9374E+01,1.7634E+01,1.6009E+01,1.4488E+01,1.3276E+01,
37664 &1.2064E+01,1.0772E+01,9.5709E+00,8.4795E+00,7.4649E+00,6.6775E+00,
37665 &5.9046E+00,5.1015E+00,4.3733E+00,3.7372E+00,3.1677E+00,2.7434E+00,
37666 &2.3459E+00,1.9566E+00,1.6317E+00,1.4368E+00,1.2699E+00,1.1572E+00,
37667 &1.0581E+00,9.8558E-01,9.2913E-01,8.8297E-01,8.4349E-01,8.0862E-01,
37668 &7.7667E-01,7.4686E-01,7.1760E-01,6.8906E-01,6.6005E-01,6.5493E-01,
37669 &6.1209E-01,5.7080E-01,5.3038E-01,4.9085E-01,4.5137E-01,4.1231E-01,
37670 &3.7316E-01,3.3442E-01,2.9613E-01,2.5928E-01,2.1912E-01,0.0000E+00,
37671 &1.1660E+02,1.0899E+02,1.0178E+02,9.4752E+01,8.8142E+01,8.1480E+01/
37672 DATA (XGF_L(K),K= 1027, 1140) /
37673 &7.5219E+01,6.9198E+01,6.3578E+01,5.7986E+01,5.2800E+01,4.7867E+01,
37674 &4.3328E+01,4.0736E+01,3.8088E+01,3.5213E+01,3.2469E+01,2.9907E+01,
37675 &2.7451E+01,2.5501E+01,2.3516E+01,2.1392E+01,1.9391E+01,1.7546E+01,
37676 &1.5800E+01,1.4426E+01,1.3057E+01,1.1607E+01,1.0266E+01,9.0517E+00,
37677 &7.9294E+00,7.0617E+00,6.2165E+00,5.3397E+00,4.5572E+00,3.8687E+00,
37678 &3.2598E+00,2.8078E+00,2.3859E+00,1.9745E+00,1.6317E+00,1.4267E+00,
37679 &1.2497E+00,1.1305E+00,1.0247E+00,9.4657E-01,8.8556E-01,8.3542E-01,
37680 &7.9253E-01,7.5465E-01,7.2037E-01,6.8840E-01,6.5775E-01,6.2793E-01,
37681 &5.9852E-01,5.9015E-01,5.4553E-01,5.0339E-01,4.6306E-01,4.2411E-01,
37682 &3.8622E-01,3.4909E-01,3.1294E-01,2.7773E-01,2.4373E-01,2.1150E-01,
37683 &1.7848E-01,0.0000E+00,1.3738E+02,1.2796E+02,1.1904E+02,1.1042E+02,
37684 &1.0233E+02,9.4222E+01,8.6662E+01,7.9409E+01,7.2655E+01,6.6001E+01,
37685 &5.9833E+01,5.4007E+01,4.8672E+01,4.5642E+01,4.2552E+01,3.9214E+01,
37686 &3.6040E+01,3.3082E+01,3.0272E+01,2.8026E+01,2.5779E+01,2.3361E+01,
37687 &2.1093E+01,1.9009E+01,1.7062E+01,1.5526E+01,1.4003E+01,1.2396E+01,
37688 &1.0916E+01,9.5845E+00,8.3611E+00,7.4188E+00,6.5021E+00,5.5589E+00,
37689 &4.7169E+00,3.9865E+00,3.3389E+00,2.8617E+00,2.4178E+00,1.9872E+00,
37690 &1.6283E+00,1.4143E+00,1.2296E+00,1.1049E+00,9.9315E-01,9.1079E-01,
37691 &8.4623E-01,7.9317E-01,7.4768E-01,7.0802E-01,6.7178E-01,6.3836E-01/
37692 DATA (XGF_L(K),K= 1141, 1254) /
37693 &6.0703E-01,5.7658E-01,5.4733E-01,5.3630E-01,4.9100E-01,4.4879E-01,
37694 &4.0920E-01,3.7138E-01,3.3521E-01,3.0054E-01,2.6721E-01,2.3523E-01,
37695 &2.0485E-01,1.7634E-01,1.4852E-01,0.0000E+00,1.6103E+02,1.4938E+02,
37696 &1.3848E+02,1.2798E+02,1.1818E+02,1.0840E+02,9.9309E+01,9.0651E+01,
37697 &8.2647E+01,7.4733E+01,6.7469E+01,6.0672E+01,5.4433E+01,5.0913E+01,
37698 &4.7343E+01,4.3482E+01,3.9833E+01,3.6452E+01,3.3242E+01,3.0689E+01,
37699 &2.8134E+01,2.5404E+01,2.2863E+01,2.0531E+01,1.8362E+01,1.6652E+01,
37700 &1.4967E+01,1.3197E+01,1.1573E+01,1.0120E+01,8.7877E+00,7.7679E+00,
37701 &6.7819E+00,5.7685E+00,4.8731E+00,4.0967E+00,3.4122E+00,2.9097E+00,
37702 &2.4451E+00,1.9953E+00,1.6222E+00,1.3995E+00,1.2076E+00,1.0771E+00,
37703 &9.6151E-01,8.7563E-01,8.0819E-01,7.5269E-01,7.0548E-01,6.6395E-01,
37704 &6.2666E-01,5.9253E-01,5.6034E-01,5.3005E-01,5.0122E-01,4.8790E-01,
37705 &4.4273E-01,4.0115E-01,3.6251E-01,3.2632E-01,2.9224E-01,2.5988E-01,
37706 &2.2931E-01,2.0039E-01,1.7324E-01,1.4805E-01,1.2201E-01,0.0000E+00,
37707 &1.8591E+02,1.7193E+02,1.5886E+02,1.4632E+02,1.3469E+02,1.2310E+02,
37708 &1.1237E+02,1.0218E+02,9.2839E+01,8.3643E+01,7.5256E+01,6.7382E+01,
37709 &6.0231E+01,5.6204E+01,5.2127E+01,4.7743E+01,4.3601E+01,3.9784E+01,
37710 &3.6172E+01,3.3310E+01,3.0455E+01,2.7410E+01,2.4579E+01,2.2009E+01,
37711 &1.9599E+01,1.7727E+01,1.5886E+01,1.3956E+01,1.2193E+01,1.0620E+01/
37712 DATA (XGF_L(K),K= 1255, 1368) /
37713 &9.1866E+00,8.0925E+00,7.0383E+00,5.9623E+00,5.0119E+00,4.1917E+00,
37714 &3.4750E+00,2.9503E+00,2.4663E+00,1.9999E+00,1.6141E+00,1.3840E+00,
37715 &1.1856E+00,1.0518E+00,9.3192E-01,8.4324E-01,7.7348E-01,7.1642E-01,
37716 &6.6779E-01,6.2531E-01,5.8732E-01,5.5231E-01,5.2039E-01,4.9037E-01,
37717 &4.6218E-01,4.4711E-01,4.0225E-01,3.6159E-01,3.2438E-01,2.8982E-01,
37718 &2.5765E-01,2.2765E-01,1.9954E-01,1.7331E-01,1.4889E-01,1.2621E-01,
37719 &9.6984E-02,0.0000E+00,2.1269E+02,1.9609E+02,1.8060E+02,1.6582E+02,
37720 &1.5214E+02,1.3863E+02,1.2613E+02,1.1431E+02,1.0351E+02,9.2957E+01,
37721 &8.3294E+01,7.4318E+01,6.6188E+01,6.1617E+01,5.7019E+01,5.2073E+01,
37722 &4.7428E+01,4.3153E+01,3.9122E+01,3.5941E+01,3.2764E+01,2.9404E+01,
37723 &2.6282E+01,2.3458E+01,2.0836E+01,1.8796E+01,1.6786E+01,1.4693E+01,
37724 &1.2792E+01,1.1101E+01,9.5678E+00,8.4010E+00,7.2773E+00,6.1402E+00,
37725 &5.1403E+00,4.2791E+00,3.5311E+00,2.9851E+00,2.4835E+00,2.0017E+00,
37726 &1.6039E+00,1.3677E+00,1.1646E+00,1.0265E+00,9.0375E-01,8.1271E-01,
37727 &7.4135E-01,6.8280E-01,6.3328E-01,5.9018E-01,5.5184E-01,5.1677E-01,
37728 &4.8494E-01,4.5537E-01,4.2797E-01,4.1146E-01,3.6736E-01,3.2788E-01,
37729 &2.9207E-01,2.5923E-01,2.2901E-01,2.0110E-01,1.7527E-01,1.5131E-01,
37730 &1.2926E-01,1.0839E-01,6.9776E-02,0.0000E+00,2.4043E+02,2.2104E+02,
37731 &2.0300E+02,1.8582E+02,1.7003E+02,1.5443E+02,1.4007E+02,1.2658E+02/
37732 DATA (XGF_L(K),K= 1369, 1482) /
37733 &1.1426E+02,1.0227E+02,9.1332E+01,8.1197E+01,7.2119E+01,6.6989E+01,
37734 &6.1846E+01,5.6342E+01,5.1188E+01,4.6448E+01,4.2002E+01,3.8498E+01,
37735 &3.5016E+01,3.1335E+01,2.7931E+01,2.4848E+01,2.2009E+01,1.9797E+01,
37736 &1.7637E+01,1.5389E+01,1.3354E+01,1.1550E+01,9.9187E+00,8.6824E+00,
37737 &7.4988E+00,6.3022E+00,5.2549E+00,4.3589E+00,3.5788E+00,3.0139E+00,
37738 &2.4962E+00,2.0005E+00,1.5931E+00,1.3514E+00,1.1435E+00,1.0028E+00,
37739 &8.7751E-01,7.8479E-01,7.1218E-01,6.5272E-01,6.0250E-01,5.5920E-01,
37740 &5.2061E-01,4.8590E-01,4.5422E-01,4.2519E-01,3.9858E-01,3.8094E-01,
37741 &3.3789E-01,2.9975E-01,2.6524E-01,2.3401E-01,2.0560E-01,1.7956E-01,
37742 &1.5565E-01,1.3374E-01,1.1354E-01,9.4096E-02,3.9275E-02,0.0000E+00,
37743 &2.8195E+02,2.5830E+02,2.3640E+02,2.1554E+02,1.9645E+02,1.7774E+02,
37744 &1.6058E+02,1.4448E+02,1.2990E+02,1.1575E+02,1.0299E+02,9.1121E+01,
37745 &8.0574E+01,7.4642E+01,6.8724E+01,6.2402E+01,5.6498E+01,5.1101E+01,
37746 &4.6042E+01,4.2081E+01,3.8152E+01,3.4014E+01,3.0201E+01,2.6780E+01,
37747 &2.3611E+01,2.1171E+01,1.8789E+01,1.6329E+01,1.4107E+01,1.2148E+01,
37748 &1.0386E+01,9.0557E+00,7.7874E+00,6.5118E+00,5.4006E+00,4.4539E+00,
37749 &3.6370E+00,3.0467E+00,2.5088E+00,1.9959E+00,1.5762E+00,1.3274E+00,
37750 &1.1142E+00,9.7065E-01,8.4265E-01,7.4825E-01,6.7451E-01,6.1445E-01,
37751 &5.6374E-01,5.2024E-01,4.8166E-01,4.4741E-01,4.1643E-01,3.8830E-01/
37752 DATA (XGF_L(K),K= 1483, 1596) /
37753 &3.6282E-01,3.4411E-01,3.0249E-01,2.6607E-01,2.3369E-01,2.0474E-01,
37754 &1.7852E-01,1.5489E-01,1.3341E-01,1.1384E-01,9.5862E-02,7.7509E-02,
37755 &0.0000E+00,0.0000E+00,3.2379E+02,2.9556E+02,2.6960E+02,2.4513E+02,
37756 &2.2265E+02,2.0073E+02,1.8071E+02,1.6202E+02,1.4515E+02,1.2887E+02,
37757 &1.1419E+02,1.0071E+02,8.8650E+01,8.1931E+01,7.5233E+01,6.8140E+01,
37758 &6.1510E+01,5.5467E+01,4.9832E+01,4.5419E+01,4.1070E+01,3.6493E+01,
37759 &3.2295E+01,2.8536E+01,2.5086E+01,2.2426E+01,1.9846E+01,1.7175E+01,
37760 &1.4781E+01,1.2681E+01,1.0797E+01,9.3831E+00,8.0380E+00,6.6897E+00,
37761 &5.5221E+00,4.5337E+00,3.6831E+00,3.0714E+00,2.5159E+00,1.9884E+00,
37762 &1.5586E+00,1.3048E+00,1.0886E+00,9.4191E-01,8.1217E-01,7.1679E-01,
37763 &6.4238E-01,5.8194E-01,5.3136E-01,4.8766E-01,4.4965E-01,4.1594E-01,
37764 &3.8570E-01,3.5847E-01,3.3403E-01,3.1456E-01,2.7454E-01,2.3977E-01,
37765 &2.0922E-01,1.8216E-01,1.5795E-01,1.3622E-01,1.1669E-01,9.9012E-02,
37766 &8.2668E-02,6.4604E-02,0.0000E+00,0.0000E+00,3.7071E+02,3.3727E+02,
37767 &3.0660E+02,2.7790E+02,2.5169E+02,2.2608E+02,2.0283E+02,1.8123E+02,
37768 &1.6179E+02,1.4311E+02,1.2635E+02,1.1097E+02,9.7357E+01,8.9759E+01,
37769 &8.2263E+01,7.4239E+01,6.6821E+01,6.0073E+01,5.3813E+01,4.8927E+01,
37770 &4.4114E+01,3.9072E+01,3.4471E+01,3.0351E+01,2.6592E+01,2.3699E+01,
37771 &2.0903E+01,1.8031E+01,1.5459E+01,1.3211E+01,1.1204E+01,9.7024E+00/
37772 DATA (XGF_L(K),K= 1597, 1710) /
37773 &8.2828E+00,6.8644E+00,5.6367E+00,4.6059E+00,3.7241E+00,3.0915E+00,
37774 &2.5189E+00,1.9786E+00,1.5396E+00,1.2816E+00,1.0611E+00,9.1306E-01,
37775 &7.8207E-01,6.8594E-01,6.1118E-01,5.5075E-01,5.0031E-01,4.5732E-01,
37776 &4.1996E-01,3.8671E-01,3.5732E-01,3.3101E-01,3.0775E-01,2.8769E-01,
37777 &2.4931E-01,2.1637E-01,1.8763E-01,1.6241E-01,1.4002E-01,1.2013E-01,
37778 &1.0238E-01,8.6311E-02,7.1348E-02,5.2982E-02,0.0000E+00,0.0000E+00,
37779 &4.2142E+02,3.8237E+02,3.4660E+02,3.1292E+02,2.8259E+02,2.5300E+02,
37780 &2.2626E+02,2.0148E+02,1.7927E+02,1.5797E+02,1.3896E+02,1.2163E+02,
37781 &1.0632E+02,9.7858E+01,8.9366E+01,8.0488E+01,7.2234E+01,6.4771E+01,
37782 &5.7843E+01,5.2468E+01,4.7182E+01,4.1663E+01,3.6633E+01,3.2165E+01,
37783 &2.8082E+01,2.4971E+01,2.1960E+01,1.8866E+01,1.6118E+01,1.3723E+01,
37784 &1.1595E+01,1.0008E+01,8.5101E+00,7.0232E+00,5.7443E+00,4.6705E+00,
37785 &3.7584E+00,3.1066E+00,2.5189E+00,1.9659E+00,1.5193E+00,1.2575E+00,
37786 &1.0346E+00,8.8517E-01,7.5338E-01,6.5695E-01,5.8219E-01,5.2200E-01,
37787 &4.7218E-01,4.2954E-01,3.9258E-01,3.6043E-01,3.3190E-01,3.0663E-01,
37788 &2.8431E-01,2.6413E-01,2.2746E-01,1.9612E-01,1.6912E-01,1.4557E-01,
37789 &1.2488E-01,1.0660E-01,9.0362E-02,7.5731E-02,6.1890E-02,4.2720E-02,
37790 &0.0000E+00,0.0000E+00,4.7166E+02,4.2676E+02,3.8580E+02,3.4749E+02,
37791 &3.1273E+02,2.7927E+02,2.4899E+02,2.2108E+02,1.9611E+02,1.7230E+02/
37792 DATA (XGF_L(K),K= 1711, 1824) /
37793 &1.5107E+02,1.3178E+02,1.1483E+02,1.0548E+02,9.6179E+01,8.6383E+01,
37794 &7.7331E+01,6.9156E+01,6.1613E+01,5.5763E+01,5.0019E+01,4.4056E+01,
37795 &3.8633E+01,3.3819E+01,2.9446E+01,2.6108E+01,2.2889E+01,1.9617E+01,
37796 &1.6706E+01,1.4179E+01,1.1938E+01,1.0276E+01,8.7112E+00,7.1630E+00,
37797 &5.8345E+00,4.7275E+00,3.7856E+00,3.1171E+00,2.5164E+00,1.9532E+00,
37798 &1.4997E+00,1.2350E+00,1.0108E+00,8.6027E-01,7.2804E-01,6.3166E-01,
37799 &5.5726E-01,4.9745E-01,4.4802E-01,4.0623E-01,3.7002E-01,3.3850E-01,
37800 &3.1081E-01,2.8644E-01,2.6509E-01,2.4476E-01,2.0951E-01,1.7979E-01,
37801 &1.5426E-01,1.3217E-01,1.1290E-01,9.5951E-02,8.0975E-02,6.7483E-02,
37802 &5.4483E-02,3.4309E-02,0.0000E+00,0.0000E+00,5.2745E+02,4.7595E+02,
37803 &4.2900E+02,3.8543E+02,3.4589E+02,3.0795E+02,2.7377E+02,2.4235E+02,
37804 &2.1434E+02,1.8771E+02,1.6408E+02,1.4266E+02,1.2392E+02,1.1358E+02,
37805 &1.0335E+02,9.2593E+01,8.2702E+01,7.3780E+01,6.5553E+01,5.9207E+01,
37806 &5.2983E+01,4.6535E+01,4.0700E+01,3.5531E+01,3.0842E+01,2.7278E+01,
37807 &2.3855E+01,2.0386E+01,1.7301E+01,1.4635E+01,1.2282E+01,1.0538E+01,
37808 &8.9065E+00,7.2932E+00,5.9178E+00,4.7769E+00,3.8086E+00,3.1240E+00,
37809 &2.5114E+00,1.9387E+00,1.4794E+00,1.2125E+00,9.8604E-01,8.3538E-01,
37810 &7.0309E-01,6.0683E-01,5.3289E-01,4.7378E-01,4.2493E-01,3.8387E-01,
37811 &3.4846E-01,3.1778E-01,2.9097E-01,2.6744E-01,2.4699E-01,2.2688E-01/
37812 DATA (XGF_L(K),K= 1825, 1836) /
37813 &1.9308E-01,1.6489E-01,1.4079E-01,1.2009E-01,1.0214E-01,8.6447E-02,
37814 &7.2603E-02,6.0131E-02,4.7893E-02,2.6613E-02,0.0000E+00,0.0000E+00/
37818 *...CHECK OF X AND Q2 VALUES :
37819 IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
37821 91 FORMAT (2X,'GRV98: x out of range',1p,E12.4)
37827 IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
37829 92 FORMAT (2X,'GRV98: Q2 out of range',1p,E12.4)
37835 *...INTERPOLATION :
37843 UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
37844 DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
37845 DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
37846 UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
37847 US = 0.5 * (UD - DE)
37848 DS = 0.5 * (UD + DE)
37849 SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF) * X1**7 * XS
37850 GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF) * X1**5 * XS
37854 *$ CREATE PHO_DOR98SC.FOR
37856 CDECK ID>, PHO_DOR98SC
37857 SUBROUTINE PHO_DOR98SC (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
37858 C***********************************************************************
37860 C GRV98 parton densities, leading order set
37862 C For a detailed explanation see
37863 C M. Glueck, E. Reya, A. Vogt :
37864 C hep-ph/9806404 = DO-TH 98/07 = WUE-ITP-98-019
37865 C (To appear in Eur. Phys. J. C)
37867 C interpolation routine based on the original GRV98PA routine,
37868 C adapted to define interpolation table as DATA statements
37872 C CAUTION: this is a version with gluon shadowing corrections
37876 C INPUT: X = Bjorken-x (between 1.E-9 and 1.)
37877 C Q2 = scale in GeV**2 (between 0.8 and 1.E6)
37879 C OUTPUT: UV = u - u(bar), DV = d - d(bar), US = u(bar),
37880 C DS = d(bar), SS = s = s(bar), GL = gluon.
37881 C Always x times the distribution is returned.
37883 C******************************************************i****************
37884 IMPLICIT DOUBLE PRECISION (A-H, O-Z)
37887 C input/output channels
37889 COMMON /POINOU/ LI,LO
37891 PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
37892 DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
37893 1 XSF(NX,NQ), XGF(NX,NQ),
37894 2 XT(NARG), NA(NARG), ARRF(NX+NQ)
37896 DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
37897 & XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
37899 EQUIVALENCE (XUVF(1,1),XUVF_L(1))
37900 EQUIVALENCE (XDVF(1,1),XDVF_L(1))
37901 EQUIVALENCE (XDEF(1,1),XDEF_L(1))
37902 EQUIVALENCE (XUDF(1,1),XUDF_L(1))
37903 EQUIVALENCE (XSF(1,1),XSF_L(1))
37904 EQUIVALENCE (XGF(1,1),XGF_L(1))
37906 *#################### data statements for shadowed LO PDF ##############
37908 *#######################################################################
37911 *...CHECK OF X AND Q2 VALUES :
37912 IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
37914 91 FORMAT (2X,'GRV98_SC: x out of range',1p,E12.4)
37920 IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
37922 92 FORMAT (2X,'GRV98_SC: Q2 out of range',1p,E12.4)
37928 *...INTERPOLATION :
37936 UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
37937 DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
37938 DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
37939 UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
37940 US = 0.5 * (UD - DE)
37941 DS = 0.5 * (UD + DE)
37942 SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF) * X1**7 * XS
37943 GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF) * X1**5 * XS
37947 *$ CREATE PHO_DOR94LO.FOR
37949 CDECK ID>, PHO_DOR94LO
37950 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
37952 * 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 *
37956 * FOR A DETAILED EXPLANATION SEE *
37957 * M. GLUECK, E.REYA, A.VOGT : *
37958 * DO-TH 94/24 = DESY 94-206 *
37959 * (TO APPEAR IN Z. PHYS. C) *
37961 * THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR *
37962 * Q**2 / GEV**2 BETWEEN 0.4 AND 1.E6 *
37963 * X BETWEEN 1.E-5 AND 1. *
37964 * LARGE-X REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION *
37965 * IS NEGLIGIBLY SMALL, WERE EXCLUDED FROM THE FIT. *
37967 * HEAVY QUARK THRESHOLDS Q(H) = M(H) IN THE BETA FUNCTION : *
37968 * M(C) = 1.5, M(B) = 4.5 *
37969 * CORRESPONDING LAMBDA(F) VALUES IN GEV FOR Q**2 > M(H)**2 : *
37970 * LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
37971 * LAMBDA(5) = 0.153, *
37972 * NLO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
37973 * LAMBDA(5) = 0.131. *
37974 * THE NUMBER OF ACTIVE QUARK FLAVOURS IS NF = 3 EVERYWHERE *
37975 * EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,... *
37976 * ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION. *
37977 * IF NEEDED, HEAVY QUARK DENSITIES CAN BE TAKEN FROM THE 1991 *
37978 * GRV PARAMETRIZATION. *
37980 * NLO DISTRIBUTIONS ARE GIVEN IN MS-BAR FACTORIZATION SCHEME *
37981 * (SUBROUTINE GRV94HO) AS WELL AS IN THE DIS SCHEME (GRV94DI), *
37982 * THE LEADING ORDER PARAMETRIZATION IS PROVIDED BY "GRV94LO". *
37984 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
37986 *...INPUT PARAMETERS :
37988 * X = MOMENTUM FRACTION
37989 * Q2 = SCALE Q**2 IN GEV**2
37991 *...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION) :
37993 * UV = U(VAL) = U - U(BAR)
37994 * DV = D(VAL) = D - D(BAR)
37995 * DEL = D(BAR) - U(BAR)
37996 * UDB = U(BAR) + D(BAR)
38000 *...LO PARAMETRIZATION :
38002 SUBROUTINE PHO_DOR94LO (X, Q2, UV, DV, DEL, UDB, SB, GL)
38003 IMPLICIT DOUBLE PRECISION (A - Z)
38007 LAM2 = 0.2322 * 0.2322
38008 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38013 NU = 2.284 + 0.802 * S + 0.055 * S2
38014 AKU = 0.590 - 0.024 * S
38015 BKU = 0.131 + 0.063 * S
38016 AU = -0.449 - 0.138 * S - 0.076 * S2
38017 BU = 0.213 + 2.669 * S - 0.728 * S2
38018 CU = 8.854 - 9.135 * S + 1.979 * S2
38019 DU = 2.997 + 0.753 * S - 0.076 * S2
38020 UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38022 ND = 0.371 + 0.083 * S + 0.039 * S2
38024 BKD = 0.486 + 0.062 * S
38025 AD = -0.509 + 3.310 * S - 1.248 * S2
38026 BD = 12.41 - 10.52 * S + 2.267 * S2
38027 CD = 6.373 - 6.208 * S + 1.418 * S2
38028 DD = 3.691 + 0.799 * S - 0.071 * S2
38029 DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38031 NE = 0.082 + 0.014 * S + 0.008 * S2
38032 AKE = 0.409 - 0.005 * S
38033 BKE = 0.799 + 0.071 * S
38034 AE = -38.07 + 36.13 * S - 0.656 * S2
38035 BE = 90.31 - 74.15 * S + 7.645 * S2
38037 DE = 7.486 + 1.217 * S - 0.159 * S2
38038 DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38042 AKX = 0.410 - 0.232 * S
38043 BKX = 0.534 - 0.457 * S
38044 AGX = 0.890 - 0.140 * S
38046 CX = 0.320 + 0.683 * S
38047 DX = 4.752 + 1.164 * S + 0.286 * S2
38048 EX = 4.119 + 1.713 * S
38049 ESX = 0.682 + 2.978 * S
38050 UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38054 AKS = 1.798 - 0.596 * S
38055 AS = -5.548 + 3.669 * DS - 0.616 * S
38056 BS = 18.92 - 16.73 * DS + 5.168 * S
38057 DST = 6.379 - 0.350 * S + 0.142 * S2
38058 EST = 3.981 + 1.638 * S
38060 SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38064 AKG = 1.742 - 0.930 * S
38066 AG = 7.486 - 2.185 * S
38067 BG = 16.69 - 22.74 * S + 5.779 * S2
38068 CG = -25.59 + 29.71 * S - 7.296 * S2
38069 DG = 2.792 + 2.215 * S + 0.422 * S2 - 0.104 * S3
38070 EG = 0.807 + 2.005 * S
38071 ESG = 3.841 + 0.316 * S
38072 GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38077 *...NLO PARAMETRIZATION (MS(BAR)) :
38079 *$ CREATE PHO_DOR94HO.FOR
38081 CDECK ID>, PHO_DOR94HO
38082 SUBROUTINE PHO_DOR94HO (X, Q2, UV, DV, DEL, UDB, SB, GL)
38083 IMPLICIT DOUBLE PRECISION (A - Z)
38087 LAM2 = 0.248 * 0.248
38088 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38093 NU = 1.304 + 0.863 * S
38094 AKU = 0.558 - 0.020 * S
38096 AU = -0.113 + 0.283 * S - 0.321 * S2
38097 BU = 6.843 - 5.089 * S + 2.647 * S2 - 0.527 * S3
38098 CU = 7.771 - 10.09 * S + 2.630 * S2
38099 DU = 3.315 + 1.145 * S - 0.583 * S2 + 0.154 * S3
38100 UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38102 ND = 0.102 - 0.017 * S + 0.005 * S2
38103 AKD = 0.270 - 0.019 * S
38105 AD = 2.393 + 6.228 * S - 0.881 * S2
38106 BD = 46.06 + 4.673 * S - 14.98 * S2 + 1.331 * S3
38107 CD = 17.83 - 53.47 * S + 21.24 * S2
38108 DD = 4.081 + 0.976 * S - 0.485 * S2 + 0.152 * S3
38109 DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38111 NE = 0.070 + 0.042 * S - 0.011 * S2 + 0.004 * S3
38112 AKE = 0.409 - 0.007 * S
38113 BKE = 0.782 + 0.082 * S
38114 AE = -29.65 + 26.49 * S + 5.429 * S2
38115 BE = 90.20 - 74.97 * S + 4.526 * S2
38117 DE = 8.122 + 2.120 * S - 1.088 * S2 + 0.231 * S3
38118 DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38125 BGX = 3.210 - 1.866 * S
38127 DX = 9.010 + 0.896 * DS + 0.222 * S2
38128 EX = 3.077 + 1.446 * S
38129 ESX = 3.173 - 2.445 * DS + 2.207 * S
38130 UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38134 AKS = 1.690 + 0.650 * DS - 0.922 * S
38135 AS = -4.329 + 1.131 * S
38136 BS = 9.568 - 1.744 * S
38137 DST = 9.377 + 1.088 * DS - 1.320 * S + 0.130 * S2
38138 EST = 3.031 + 1.639 * S
38139 ESS = 5.837 + 0.815 * S
38140 SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38144 AKG = 1.724 + 0.157 * S
38145 BKG = 0.800 + 1.016 * S
38146 AG = 7.517 - 2.547 * S
38147 BG = 34.09 - 52.21 * DS + 17.47 * S
38148 CG = 4.039 + 1.491 * S
38149 DG = 3.404 + 0.830 * S
38150 EG = -1.112 + 3.438 * S - 0.302 * S2
38151 ESG = 3.256 - 0.436 * S
38152 GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38156 *$ CREATE PHO_DOR94DI.FOR
38158 CDECK ID>, PHO_DOR94DI
38160 *...NLO PARAMETRIZATION (DIS) :
38162 SUBROUTINE PHO_DOR94DI (X, Q2, UV, DV, DEL, UDB, SB, GL)
38163 IMPLICIT DOUBLE PRECISION (A - Z)
38167 LAM2 = 0.248 * 0.248
38168 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38173 NU = 2.484 + 0.116 * S + 0.093 * S2
38174 AKU = 0.563 - 0.025 * S
38175 BKU = 0.054 + 0.154 * S
38176 AU = -0.326 - 0.058 * S - 0.135 * S2
38177 BU = -3.322 + 8.259 * S - 3.119 * S2 + 0.291 * S3
38178 CU = 11.52 - 12.99 * S + 3.161 * S2
38179 DU = 2.808 + 1.400 * S - 0.557 * S2 + 0.119 * S3
38180 UV = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38182 ND = 0.156 - 0.017 * S
38183 AKD = 0.299 - 0.022 * S
38184 BKD = 0.259 - 0.015 * S
38185 AD = 3.445 + 1.278 * S + 0.326 * S2
38186 BD = -6.934 + 37.45 * S - 18.95 * S2 + 1.463 * S3
38187 CD = 55.45 - 69.92 * S + 20.78 * S2
38188 DD = 3.577 + 1.441 * S - 0.683 * S2 + 0.179 * S3
38189 DV = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38191 NE = 0.099 + 0.019 * S + 0.002 * S2
38192 AKE = 0.419 - 0.013 * S
38193 BKE = 1.064 - 0.038 * S
38194 AE = -44.00 + 98.70 * S - 14.79 * S2
38195 BE = 28.59 - 40.94 * S - 13.66 * S2 + 2.523 * S3
38196 CE = 84.57 - 108.8 * S + 31.52 * S2
38197 DE = 7.469 + 2.480 * S - 0.866 * S2
38198 DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38202 AKX = 0.326 + 0.150 * S
38203 BKX = 0.956 + 0.405 * S
38205 BGX = 3.794 - 2.359 * DS
38207 DX = 7.941 + 0.534 * DS - 0.940 * S + 0.410 * S2
38208 EX = 3.049 + 1.597 * S
38209 ESX = 4.396 - 4.594 * DS + 3.268 * S
38210 UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38214 AKS = 1.415 - 0.641 * DS
38215 AS = 0.580 - 9.763 * DS + 6.795 * S - 0.558 * S2
38216 BS = 5.617 + 5.709 * DS - 3.972 * S
38217 DST = 13.78 - 9.581 * S + 5.370 * S2 - 0.996 * S3
38218 EST = 4.546 + 0.372 * S2
38219 ESS = 5.053 - 1.070 * S + 0.805 * S2
38220 SB = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38225 BKG = 2.427 + 1.311 * S - 0.153 * S2
38226 AG = 25.09 - 7.935 * S
38227 BG = -14.84 - 124.3 * DS + 72.18 * S
38228 CG = 590.3 - 173.8 * S
38229 DG = 5.196 + 1.857 * S
38230 EG = -1.648 + 3.988 * S - 0.432 * S2
38231 ESG = 3.232 - 0.542 * S
38232 GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38237 *...FUNCTIONAL FORMS OF THE PARAMETRIZATIONS :
38239 *$ CREATE PHO_DOR94FV.FOR
38241 CDECK ID>, PHO_DOR94FV
38242 DOUBLE PRECISION FUNCTION PHO_DOR94FV (X,N,AK,BK,A,B,C,D)
38243 IMPLICIT DOUBLE PRECISION (A - Z)
38247 PHO_DOR94FV = N*X**AK*(1.D0+A*X**BK+X*(B+C*DX))*(1.D0-X)**D
38251 *$ CREATE PHO_DOR94FW.FOR
38253 CDECK ID>, PHO_DOR94FW
38254 DOUBLE PRECISION FUNCTION PHO_DOR94FW(X,S,AL,BE,AK,BK,
38256 IMPLICIT DOUBLE PRECISION (A - Z)
38260 PHO_DOR94FW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
38261 1 * DEXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38265 *$ CREATE PHO_DOR94FS.FOR
38267 CDECK ID>, PHO_DOR94FS
38268 DOUBLE PRECISION FUNCTION PHO_DOR94FS (X,S,AL,BE,AK,AG,B,D,E,ES)
38269 IMPLICIT DOUBLE PRECISION (A - Z)
38274 PHO_DOR94FS = S**AL / LX**AK * (1.+ AG*DX + B*X) * (1.- X)**D
38275 1 * DEXP (-E + SQRT (ES * S**BE * LX))
38279 *$ CREATE PHO_DOR92LO.FOR
38281 CDECK ID>, PHO_DOR92LO
38284 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38286 * 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 *
38288 * FOR A DETAILED EXPLANATION SEE : *
38289 * M. GLUECK, E.REYA, A.VOGT: DO-TH 91/07 *
38291 * THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
38292 * FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
38293 * / HO) AND 1.E8 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
38294 * REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG- *
38295 * LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT. *
38297 * HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
38298 * M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
38300 * CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
38301 * LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
38302 * LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
38303 * HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
38304 * LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
38306 * HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL. *
38308 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38310 SUBROUTINE PHO_DOR92LO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
38311 IMPLICIT DOUBLE PRECISION (A - Z)
38315 LAM2 = 0.232 * 0.232
38316 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38319 C...X * (UV + DV) :
38320 NUD = 0.663 + 0.191 * S - 0.041 * S2 + 0.031 * S3
38322 AGUD = -1.97 + 6.74 * S - 1.96 * S2
38323 BUD = 24.4 - 20.7 * S + 4.08 * S2
38324 DUD = 2.86 + 0.70 * S - 0.02 * S2
38325 UDV = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
38327 ND = 0.579 + 0.283 * S + 0.047 * S2
38328 AKD = 0.523 - 0.015 * S
38329 AGD = 2.22 - 0.59 * S - 0.27 * S2
38330 BD = 5.95 - 6.19 * S + 1.55 * S2
38331 DD = 3.57 + 0.94 * S - 0.16 * S2
38332 DV = PHO_DOR92FV (X,ND,AKD,AGD,BD,DD)
38336 AKG = 1.00 - 0.17 * S
38338 AGG = 0.0 + 4.879 * S - 1.383 * S2
38339 BGG = 25.92 - 28.97 * S + 5.596 * S2
38340 CG = -25.69 + 23.68 * S - 1.975 * S2
38341 DG = 2.537 + 1.718 * S + 0.353 * S2
38342 EG = 0.595 + 2.138 * S
38344 GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38345 C...X * UBAR = X * DBAR :
38348 AKU = 0.412 - 0.171 * S
38349 BKU = 0.566 - 0.496 * S
38352 CU = 1.029 + 1.785 * S - 0.459 * S2
38353 DU = 4.696 + 2.109 * S
38354 EU = 3.838 + 1.944 * S
38356 UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
38357 C...X * SBAR = X * S :
38361 AKS = 2.082 - 0.577 * S
38362 AGS = -3.055 + 1.024 * S ** 0.67
38363 BS = 27.4 - 20.0 * S ** 0.154
38365 EST = 4.33 + 1.408 * S
38366 ESS = 8.27 - 0.437 * S
38367 SB = PHO_DOR92FS(X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38368 C...X * CBAR = X * C :
38374 BC = 4.24 - 0.804 * S
38375 DC = 3.46 + 1.076 * S
38376 EC = 4.61 + 1.490 * S
38377 ESC = 2.555 + 1.961 * S
38378 CB = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38379 C...X * BBAR = X * B :
38386 DB = 2.929 + 1.396 * S
38387 EB = 4.71 + 1.514 * S
38388 ESB = 4.02 + 1.239 * S
38389 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38393 *$ CREATE PHO_DOR92HO.FOR
38395 CDECK ID>, PHO_DOR92HO
38396 SUBROUTINE PHO_DOR92HO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
38397 IMPLICIT DOUBLE PRECISION (A - Z)
38401 LAM2 = 0.248 * 0.248
38402 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38406 C...X * (UV + DV) :
38407 NUD = 0.330 + 0.151 * S - 0.059 * S2 + 0.027 * S3
38409 AGUD = -2.28 + 15.73 * S - 4.58 * S2
38410 BUD = 56.7 - 53.6 * S + 11.21 * S2
38411 DUD = 3.17 + 1.17 * S - 0.47 * S2 + 0.09 * S3
38412 UDV = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
38414 ND = 0.459 + 0.315 * DS + 0.515 * S
38415 AKD = 0.624 - 0.031 * S
38416 AGD = 8.13 - 6.77 * DS + 0.46 * S
38417 BD = 6.59 - 12.83 * DS + 5.65 * S
38418 DD = 3.98 + 1.04 * S - 0.34 * S2
38419 DV = PHO_DOR92FV (X, ND, AKD, AGD, BD, DD)
38423 AKG = 0.323 + 1.653 * S
38424 BKG = 0.811 + 2.044 * S
38425 AGG = 0.0 + 1.963 * S - 0.519 * S2
38426 BGG = 0.078 + 6.24 * S
38427 CG = 30.77 - 24.19 * S
38428 DG = 3.188 + 0.720 * S
38429 EG = -0.881 + 2.687 * S
38431 GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38432 C...X * UBAR = X * DBAR :
38435 AKU = 0.636 - 0.084 * S
38437 AGU = 1.121 - 0.193 * S
38438 BGU = 0.751 - 0.785 * S
38439 CU = 8.57 - 1.763 * S
38440 DU = 10.22 + 0.668 * S
38441 EU = 3.784 + 1.280 * S
38442 ESU = 1.808 + 0.980 * S
38443 UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
38444 C...X * SBAR = X * S :
38448 AKS = 2.942 - 1.016 * S
38449 AGS = -4.60 + 1.167 * S
38450 BS = 9.31 - 1.324 * S
38451 DS = 11.49 - 1.198 * S + 0.053 * S2
38452 EST = 2.630 + 1.729 * S
38454 SB = PHO_DOR92FS (X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38455 C...X * CBAR = X * C :
38459 AKC = -0.625 - 0.523 * S
38461 BC = 1.896 + 1.616 * S
38462 DC = 4.12 + 0.683 * S
38463 EC = 4.36 + 1.328 * S
38464 ESC = 0.677 + 0.679 * S
38465 CB = PHO_DOR92FS (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38466 C...X * BBAR = X * B :
38470 AKB = 0.0 - 0.193 * S
38473 DB = 3.447 + 0.927 * S
38474 EB = 4.68 + 1.259 * S
38475 ESB = 1.892 + 2.199 * S
38476 BB = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38480 *$ CREATE PHO_DOR92FV.FOR
38482 CDECK ID>, PHO_DOR92FV
38483 DOUBLE PRECISION FUNCTION PHO_DOR92FV(X,N,AK,AG,B,D)
38484 IMPLICIT DOUBLE PRECISION (A - Z)
38487 PHO_DOR92FV = N * X**AK * (1.+ AG*DX + B*X) * (1.- X)**D
38491 *$ CREATE PHO_DOR92FW.FOR
38493 CDECK ID>, PHO_DOR92FW
38494 DOUBLE PRECISION FUNCTION PHO_DOR92FW(X,S,
38495 & AL,BE,AK,BK,AG,BG,C,D,E,ES)
38496 IMPLICIT DOUBLE PRECISION (A - Z)
38499 PHO_DOR92FW = (X**AK * (AG + X * (BG + X*C)) * LX**BK + S**AL
38500 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38504 *$ CREATE PHO_DOR92FS.FOR
38506 CDECK ID>, PHO_DOR92FS
38507 DOUBLE PRECISION FUNCTION PHO_DOR92FS(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
38508 IMPLICIT DOUBLE PRECISION (A - Z)
38513 IF (S .LE. ST) THEN
38516 PHO_DOR92FS = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
38517 1 * EXP (-E + SQRT (ES * S**BE * LX))
38522 *$ CREATE PHO_DORPLO.FOR
38524 CDECK ID>, PHO_DORPLO
38526 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38528 * G R V - P I O N - P A R A M E T R I Z A T I O N S *
38530 * FOR A DETAILED EXPLANATION SEE : *
38531 * M. GLUECK, E.REYA, A.VOGT: DO-TH 91/16 *
38533 * THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
38534 * FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
38535 * / HO) AND 1.E8 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
38536 * REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG- *
38537 * LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT. *
38539 * HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
38540 * M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
38542 * CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
38543 * LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
38544 * LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
38545 * HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
38546 * LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
38548 * HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL. *
38550 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38552 SUBROUTINE PHO_DORPLO (X, Q2, VAP, GLP, QBP, CBP, BBP)
38553 IMPLICIT DOUBLE PRECISION (A - Z)
38557 LAM2 = 0.232 * 0.232
38558 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38562 NV = 0.519 + 0.180 * S - 0.011 * S2
38563 AKV = 0.499 - 0.027 * S
38564 AGV = 0.381 - 0.419 * S
38565 DV = 0.367 + 0.563 * S
38566 VAP = PHO_DORFVP (X, NV, AKV, AGV, DV)
38570 AKG = 0.482 + 0.341 * DS
38572 AGG = 0.678 + 0.877 * S - 0.175 * S2
38573 BGG = 0.338 - 1.597 * S
38574 CG = 0.0 - 0.233 * S + 0.406 * S2
38575 DG = 0.390 + 1.053 * S
38576 EG = 0.618 + 2.070 * S
38578 GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38579 C...X * QBAR (SU(3)-SYMMETRIC SEA) :
38583 AKS = 2.538 - 0.763 * S
38585 BS = 0.313 + 0.935 * S
38587 EST = 4.433 + 1.301 * S
38588 ESS = 9.30 - 0.887 * S
38589 QBP = PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38590 C...X * CBAR = X * C :
38597 DC = 1.208 + 0.771 * S
38598 EC = 4.40 + 1.493 * S
38599 ESC = 2.032 + 1.901 * S
38600 CBP = PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38601 C...X * BBAR = X * B :
38608 DB = 0.697 + 0.855 * S
38609 EB = 4.51 + 1.490 * S
38610 ESB = 3.056 + 1.694 * S
38611 BBP = PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38615 *$ CREATE PHO_DORPHO.FOR
38617 CDECK ID>, PHO_DORPHO
38618 SUBROUTINE PHO_DORPHO (X, Q2, VAP, GLP, QBP, CBP, BBP)
38619 IMPLICIT DOUBLE PRECISION (A - Z)
38623 LAM2 = 0.248 * 0.248
38624 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38628 NV = 0.456 + 0.150 * DS + 0.112 * S - 0.019 * S2
38629 AKV = 0.505 - 0.033 * S
38630 AGV = 0.748 - 0.669 * DS - 0.133 * S
38631 DV = 0.365 + 0.197 * DS + 0.394 * S
38632 VAP = PHO_DORFVP (X, NV, AKV, AGV, DV)
38636 AKG = 0.437 - 0.689 * DS
38638 AGG = 1.324 - 0.441 * DS - 0.130 * S
38639 BGG = -0.955 + 0.259 * S
38640 CG = 1.075 - 0.302 * S
38641 DG = 1.158 + 1.229 * S
38642 EG = 0.0 + 2.510 * S
38643 ESG = 2.604 + 0.165 * S
38644 GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38645 C...X * QBAR (SU(3)-SYMMETRIC SEA) :
38649 AKS = -0.350 + 0.806 * S
38652 DS = 2.273 + 1.438 * S
38653 EST = 3.214 + 1.545 * S
38654 ESS = 1.341 + 1.938 * S
38655 QBP = PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38656 C...X * CBAR = X * C :
38660 AKC = 0.0 - 0.457 * S
38662 BC = -1.00 + 1.40 * S
38663 DC = 1.318 + 0.584 * S
38664 EC = 4.45 + 1.235 * S
38665 ESC = 1.496 + 1.010 * S
38666 CBP = PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38667 C...X * BBAR = X * B :
38671 AKB = 0.0 - 0.172 * S
38674 DB = 1.447 + 0.485 * S
38675 EB = 4.79 + 1.164 * S
38676 ESB = 1.724 + 2.121 * S
38677 BBP = PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38681 *$ CREATE PHO_DORFVP.FOR
38683 CDECK ID>, PHO_DORFVP
38684 DOUBLE PRECISION FUNCTION PHO_DORFVP(X,N,AK,AG,D)
38685 IMPLICIT DOUBLE PRECISION (A - Z)
38689 PHO_DORFVP = N * X**AK * (1.+ AG*DX) * (1.- X)**D
38693 *$ CREATE PHO_DORFGP.FOR
38695 CDECK ID>, PHO_DORFGP
38696 DOUBLE PRECISION FUNCTION PHO_DORFGP(X,S,AL,BE,AK,BK,AG,
38698 IMPLICIT DOUBLE PRECISION (A - Z)
38703 PHO_DORFGP = (X**AK * (AG + BG*DX + C*X) * LX**BK + S**AL
38704 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38708 *$ CREATE PHO_DORFQP.FOR
38710 CDECK ID>, PHO_DORFQP
38711 DOUBLE PRECISION FUNCTION PHO_DORFQP(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
38712 IMPLICIT DOUBLE PRECISION (A - Z)
38717 IF (S .LE. ST) THEN
38720 PHO_DORFQP = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
38721 1 * EXP (-E + SQRT (ES * S**BE * LX))
38726 *$ CREATE PHO_DORGLO.FOR
38728 CDECK ID>, PHO_DORGLO
38729 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38731 * 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 *
38733 * FOR A DETAILED EXPLANATION SEE : *
38734 * M. GLUECK, E.REYA, A.VOGT: DO-TH 91/31 *
38736 * THE OUTPUT IS ALWAYS 1./ ALPHA(EM) * X * PARTON DENSITY *
38738 * THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS *
38739 * FOR Q ** 2 BETWEEN MU ** 2 (= 0.25 / 0.30 GEV ** 2 IN LO *
38740 * / HO) AND 1.E6 GEV ** 2 AND FOR X BETWEEN 1.E-5 AND 1. *
38742 * HEAVY QUARK THRESHOLDS Q(H) = M(H) : *
38743 * M(C) = 1.5, M(B) = 4.5, M(T) = 100 GEV *
38745 * CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS : *
38746 * LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
38747 * LAMBDA(5) = 0.153, LAMBDA(6) = 0.082 GEV *
38748 * HO : LAMBDA(3) = 0.248, LAMBDA(4) = 0.200, *
38749 * LAMBDA(5) = 0.131, LAMBDA(6) = 0.053 GEV *
38751 * HO DISTRIBUTIONS REFER TO THE DIS(GAMMA) SCHEME, SEE : *
38752 * M. GLUECK, E.REYA, A.VOGT: DO-TH 91/26 *
38754 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38756 SUBROUTINE PHO_DORGLO (X, Q2, UL, DL, SL, CL, BL, GL)
38757 IMPLICIT DOUBLE PRECISION (A - Z)
38761 LAM2 = 0.232 * 0.232
38762 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38765 C...X * U = X * UBAR :
38768 AK = 0.500 - 0.176 * S
38769 BK = 15.00 - 5.687 * SS - 0.552 * S2
38770 AG = 0.235 + 0.046 * SS
38771 BG = 0.082 - 0.051 * S + 0.168 * S2
38772 C = 0.0 + 0.459 * S
38773 D = 0.354 - 0.061 * S
38774 E = 4.899 + 1.678 * S
38775 ES = 2.046 + 1.389 * S
38776 UL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38777 C...X * D = X * DBAR :
38780 AK = 0.496 + 0.026 * S
38781 BK = 0.685 - 0.580 * SS + 0.608 * S2
38782 AG = 0.233 + 0.302 * S
38783 BG = 0.0 - 0.818 * S + 0.198 * S2
38784 C = 0.114 + 0.154 * S
38785 D = 0.405 - 0.195 * S + 0.046 * S2
38786 E = 4.807 + 1.226 * S
38787 ES = 2.166 + 0.664 * S
38788 DL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38792 AK = 0.462 - 0.524 * SS
38793 BK = 5.451 - 0.804 * S2
38794 AG = 0.535 - 0.504 * SS + 0.288 * S2
38795 BG = 0.364 - 0.520 * S
38796 C = -0.323 + 0.115 * S2
38797 D = 0.233 + 0.790 * S - 0.139 * S2
38798 E = 0.893 + 1.968 * S
38799 ES = 3.432 + 0.392 * S
38800 GL = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38801 C...X * S = X * SBAR :
38805 AK = 0.470 - 0.099 * S2
38807 AG = 0.121 - 0.068 * SS
38808 BG = -0.090 + 0.074 * S
38809 C = 0.062 + 0.034 * S
38810 D = 0.0 + 0.226 * S - 0.060 * S2
38811 E = 4.288 + 1.707 * S
38812 ES = 2.122 + 0.656 * S
38813 SL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38814 C...X * C = X * CBAR :
38818 AK = 1.254 - 0.251 * S
38819 BK = 3.932 - 0.327 * S2
38820 AG = 0.658 + 0.202 * S
38823 D = 0.0 + 0.141 * S - 0.027 * S2
38824 E = 4.911 + 0.969 * S
38825 ES = 2.796 + 0.952 * S
38826 CL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38827 C...X * B = X * BBAR :
38831 AK = 1.961 - 0.370 * S
38832 BK = 0.923 + 0.119 * S
38833 AG = 0.815 + 0.207 * S
38836 D = -0.223 + 0.173 * S
38837 E = 5.426 + 0.623 * S
38838 ES = 3.819 + 0.901 * S
38839 BL = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38843 *$ CREATE PHO_DORGHO.FOR
38845 CDECK ID>, PHO_DORGHO
38846 SUBROUTINE PHO_DORGHO (X, Q2, UH, DH, SH, CH, BH, GH)
38847 IMPLICIT DOUBLE PRECISION (A - Z)
38851 LAM2 = 0.248 * 0.248
38852 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38855 C...X * U = X * UBAR :
38858 AK = 0.449 - 0.025 * S - 0.071 * S2
38859 BK = 5.060 - 1.116 * SS
38861 BG = 0.319 + 0.422 * S
38862 C = 1.508 + 4.792 * S - 1.963 * S2
38863 D = 1.075 + 0.222 * SS - 0.193 * S2
38864 E = 4.147 + 1.131 * S
38865 ES = 1.661 + 0.874 * S
38866 UH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38867 C...X * D = X * DBAR :
38870 AK = 0.442 - 0.132 * S - 0.058 * S2
38871 BK = 5.437 - 1.916 * SS
38873 BG = 0.311 - 0.059 * S
38874 C = 0.800 + 0.078 * S - 0.100 * S2
38875 D = 0.862 + 0.294 * SS - 0.184 * S2
38876 E = 4.202 + 1.352 * S
38877 ES = 1.841 + 0.990 * S
38878 DH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38882 AK = 0.530 - 0.742 * SS + 0.025 * S2
38884 AG = 0.533 - 0.281 * SS + 0.218 * S2
38885 BG = 0.025 - 0.518 * S + 0.156 * S2
38886 C = -0.282 + 0.209 * S2
38887 D = 0.107 + 1.058 * S - 0.218 * S2
38888 E = 0.0 + 2.704 * S
38889 ES = 3.071 - 0.378 * S
38890 GH = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38891 C...X * S = X * SBAR :
38895 AK = 1.770 - 0.735 * SS - 0.079 * S2
38897 AG = 0.084 - 0.023 * S
38899 C = 2.119 - 0.942 * S + 0.063 * S2
38900 D = 1.271 + 0.076 * S - 0.190 * S2
38901 E = 4.604 + 0.737 * S
38902 ES = 1.641 + 0.976 * S
38903 SH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38904 C...X * C = X * CBAR :
38908 AK = 1.142 - 0.175 * S
38910 AG = 0.504 + 0.317 * S
38913 D = 0.398 + 0.326 * S - 0.107 * S2
38914 E = 5.493 + 0.408 * S
38915 ES = 2.426 + 1.277 * S
38916 CH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38917 C...X * B = X * BBAR :
38921 AK = 1.953 - 0.391 * S
38922 BK = 1.657 - 0.161 * S
38923 AG = 1.076 + 0.034 * S
38926 D = 0.353 + 0.016 * S
38927 E = 5.713 + 0.249 * S
38928 ES = 3.456 + 0.673 * S
38929 BH = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38933 *$ CREATE PHO_DORGH0.FOR
38935 CDECK ID>, PHO_DORGH0
38936 SUBROUTINE PHO_DORGH0 (X, Q2, U0, D0, S0, C0, B0, G0)
38937 IMPLICIT DOUBLE PRECISION (A - Z)
38941 LAM2 = 0.248 * 0.248
38942 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38945 C...X * U = X * UBAR :
38948 AK = 0.527 + 0.200 * S - 0.107 * S2
38949 BK = 7.106 - 0.310 * SS - 0.786 * S2
38950 AG = 0.197 + 0.533 * S
38951 BG = 0.062 - 0.398 * S + 0.109 * S2
38952 C = 0.755 * S - 0.112 * S2
38953 D = 0.318 - 0.059 * S
38954 E = 4.225 + 1.708 * S
38955 ES = 1.752 + 0.866 * S
38956 U0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38957 C...X * D = X * DBAR :
38960 AK = 0.500 + 0.067 * SS - 0.055 * S2
38961 BK = 0.376 - 0.453 * SS + 0.405 * S2
38962 AG = 0.156 + 0.184 * S
38963 BG = 0.0 - 0.528 * S + 0.146 * S2
38964 C = 0.121 + 0.092 * S
38965 D = 0.379 - 0.301 * S + 0.081 * S2
38966 E = 4.346 + 1.638 * S
38967 ES = 1.645 + 1.016 * S
38968 D0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38972 AK = 0.537 - 0.600 * SS
38973 BK = 6.389 - 0.953 * S2
38974 AG = 0.558 - 0.383 * SS + 0.261 * S2
38975 BG = 0.0 - 0.305 * S
38976 C = -0.222 + 0.078 * S2
38977 D = 0.153 + 0.978 * S - 0.209 * S2
38978 E = 1.429 + 1.772 * S
38979 ES = 3.331 + 0.806 * S
38980 G0 = PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38981 C...X * S = X * SBAR :
38985 AK = 0.622 + 0.332 * S - 0.300 * S2
38987 AG = 0.211 - 0.064 * SS - 0.018 * S2
38988 BG = -0.215 + 0.122 * S
38990 D = 0.0 + 0.253 * S - 0.081 * S2
38991 E = 3.990 + 2.014 * S
38992 ES = 1.720 + 0.986 * S
38993 S0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38994 C...X * C = X * CBAR :
38998 AK = 1.228 - 0.231 * S
38999 BK = 3.806 - 0.337 * S2
39000 AG = 0.932 + 0.150 * S
39003 D = 0.0 + 0.138 * S - 0.028 * S2
39004 E = 5.588 + 0.628 * S
39005 ES = 2.665 + 1.054 * S
39006 C0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39007 C...X * B = X * BBAR :
39011 AK = 1.719 - 0.292 * S
39012 BK = 0.928 + 0.096 * S
39013 AG = 0.845 + 0.178 * S
39016 D = -0.191 + 0.151 * S
39017 E = 6.089 + 0.282 * S
39018 ES = 3.379 + 1.062 * S
39019 B0 = PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39023 *$ CREATE PHO_DORGF.FOR
39025 CDECK ID>, PHO_DORGF
39026 DOUBLE PRECISION FUNCTION PHO_DORGF(X,S,AL,BE,AK,BK,
39028 IMPLICIT DOUBLE PRECISION (A - Z)
39033 PHO_DORGF = (X**AK * (AG + BG * SX + C * X**BK) + S**AL
39034 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
39038 *$ CREATE PHO_DORGFS.FOR
39040 CDECK ID>, PHO_DORGFS
39041 DOUBLE PRECISION FUNCTION PHO_DORGFS(X,S,SF,AL,BE,AK,BK,AG,BG,
39043 IMPLICIT DOUBLE PRECISION (A - Z)
39046 IF (S .LE. SF) THEN
39052 PHO_DORGFS = (DS * X**AK * (AG + BG * SX + C * X**BK) + DS**AL
39053 1 * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
39058 *$ CREATE PHO_DORGLV.FOR
39060 CDECK ID>, PHO_DORGLV
39061 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39063 * G R S - LO - VIRTUAL PHOTON PARAMETRIZATIONS *
39065 * FOR A DETAILED EXPLANATION SEE *
39066 * M. GLUECK, E.REYA, M. STRATMANN : *
39067 * PHYS. REV. D51 (1995) 3220 *
39069 * THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR *
39070 * Q**2 / GEV**2 BETWEEN 0.6 AND 5.E4 *
39071 * AND (!) Q**2 > 5 P**2 *
39072 * P**2 / GEV**2 BETWEEN 0.0 AND 10. *
39073 * P**2 = 0 <=> REAL PHOTON *
39074 * X BETWEEN 1.E-4 AND 1. *
39076 * HEAVY QUARK THRESHOLDS Q(H) = M(H) IN THE BETA FUNCTION : *
39077 * M(C) = 1.5, M(B) = 4.5 *
39078 * CORRESPONDING LAMBDA(F) VALUES IN GEV FOR Q**2 > M(H)**2 : *
39079 * LO : LAMBDA(3) = 0.232, LAMBDA(4) = 0.200, *
39080 * LAMBDA(5) = 0.153, *
39081 * THE NUMBER OF ACTIVE QUARK FLAVOURS IS NF = 3 EVERYWHERE *
39082 * EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,... *
39083 * ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION. *
39085 * PLEASE REPORT ANY STRANGE BEHAVIOUR TO : *
39086 * Marco.Stratmann@durham.ac.uk *
39087 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39089 *...INPUT PARAMETERS :
39091 * X = MOMENTUM FRACTION
39092 * Q2 = SCALE Q**2 IN GEV**2
39093 * P2 = VIRTUALITY OF THE PHOTON IN GEV**2
39095 *...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION DIVIDED BY ALPHA_EM) :
39097 ********************************************************
39098 * subroutine grspar(x,q2,p2,ugam,dgam,sgam,ggam)
39099 subroutine PHO_DORGLV(x,q2,p2,ugam,dgam,sgam,ggam)
39100 implicit double precision (a-z)
39103 C input/output channels
39105 COMMON /POINOU/ LI,LO
39112 if(x.lt.0.0001d0) check=1
39113 if((q2.lt.0.6d0).or.(q2.gt.50000.d0)) check=1
39114 if(q2.lt.5.d0*p2) check=1
39116 c calculate distributions
39118 if(check.eq.0) then
39119 call PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
39121 WRITE(LO,*) 'GRS PDF parametrization: x/q2/p2 limits exceeded'
39122 WRITE(LO,'(1X,A,1P,3E12.3)') 'current X, Q2, P2:',x,q2,p2
39127 *$ CREATE PHO_grscalc.FOR
39129 CDECK ID>, PHO_grscalc
39130 subroutine PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
39131 implicit double precision (a-z)
39134 dimension u1(40),ds1(40),g1(40)
39135 dimension ud2(20),s2(20),g2(20)
39136 dimension up0(20),dsp0(20),gp0(20)
39137 CPH save u1,ds1,g1,ud2,s2,g2,up0,dsp0,gp0
39139 data u1/-0.139d0,0.783d0,0.132d0,0.087d0,0.003d0,-0.0134d0,
39140 & 0.009d0,-0.017d0,0.092d0,-0.516d0,-0.085d0,0.439d0,
39141 & 0.013d0,0.108d0,-0.019d0,-0.272d0,-0.167d0,0.138d0,
39142 & 0.076d0,0.026d0,-0.013d0,0.27d0,0.107d0,-0.097d0,0.04d0,
39143 & 0.064d0,0.011d0,0.002d0,0.057d0,-0.057d0,0.162d0,
39144 & -0.172d0,0.124d0,-0.016d0,-0.065d0,0.044d0,-1.009d0,
39145 & 0.622d0,0.227d0,-0.184d0/
39146 data ds1/0.033d0,0.007d0,-0.0516d0,0.12d0,0.001d0,-0.013d0,
39147 & 0.018d0,-0.028d0,0.102d0,-0.595d0,-0.114d0,0.669d0,
39148 & 0.022d0,0.001d0,-0.003d0,-0.0583d0,-0.041d0,0.035d0,
39149 & 0.009d0,0.009d0,0.004d0,0.054d0,0.025d0,-0.02d0,
39150 & 0.007d0,0.021d0,0.01d0,0.004d0,-0.067d0,0.06d0,-0.148d0,
39151 & 0.13d0,0.032d0,-0.009d0,-0.06d0,0.036d0,-0.39d0,0.033d0,
39152 & 0.245d0,-0.171d0/
39153 data g1/0.025d0,0.d0,-0.018d0,0.112d0,-0.025d0,0.177d0,
39154 & -0.022d0,0.024d0,0.001d0,-0.0104d0,0.d0,0.d0,-1.082d0,
39155 & -1.666d0,0.d0,0.086d0,0.d0,0.053d0,0.005d0,-0.058d0,
39156 & 0.034d0,0.073d0,1.08d0,1.63d0,-0.0256d0,-0.088d0,0.d0,
39157 & 0.d0,-0.004d0,0.016d0,0.007d0,-0.012d0,0.01d0,-0.673d0,
39158 & 0.126d0,-0.167d0,0.032d0,-0.227d0,0.086d0,-0.159d0/
39159 data ud2/0.756d0,0.187d0,0.109d0,-0.163d0,0.002d0,0.004d0,
39160 & 0.054d0,-0.039d0,22.53d0,-21.02d0,5.608d0,0.332d0,
39161 & -0.008d0,-0.021d0,0.381d0,0.572d0,4.774d0,1.436d0,
39162 & -0.614d0,3.548d0/
39163 data s2/0.902d0,0.182d0,0.271d0,-0.346d0,0.017d0,-0.01d0,
39164 & -0.011d0,0.0065d0,17.1d0,-13.29d0,6.519d0,0.031d0,
39165 & -0.0176d0,0.003d0,1.243d0,0.804d0,4.709d0,1.499d0,
39167 data g2/0.364d0,1.31d0,0.86d0,-0.254d0,0.611d0,0.008d0,
39168 & -0.097d0,-2.412d0,-0.843d0,2.248d0,-0.201d0,1.33d0,
39169 & 0.572d0,0.44d0,1.233d0,0.009d0,0.954d0,1.862d0,3.791d0,
39171 data up0/1.551d0,0.105d0,1.089d0,-0.172d0,3.822d0,-2.162d0,
39172 & 0.533d0,-0.467d0,-0.412d0,0.2d0,0.377d0,0.299d0,0.487d0,
39173 & 0.0766d0,0.119d0,0.063d0,7.605d0,0.234d0,-0.567d0,
39175 data dsp0/2.484d0,1.214d0,1.088d0,-0.1735d0,4.293d0,
39176 & -2.802d0,0.5975d0,-0.1193d0,-0.0872d0,0.0418d0,0.128d0,
39177 & 0.0337d0,0.127d0,0.0135d0,0.14d0,0.0423d0,6.946d0,
39178 & 0.814d0,1.531d0,0.124d0/
39179 data gp0/1.682d0,1.1d0,0.5888d0,-0.4714d0,0.5362d0,0.0127d0,
39180 & -2.438d0,0.03399d0,0.07825d0,0.05842d0,0.08393d0,2.348d0,
39181 & -0.07182d0,1.084d0,0.3098d0,-0.07514d0,3.327d0,1.1d0,
39182 & 2.264d0,0.2675d0/
39185 lam2=0.232d0*0.232d0
39187 if(p2.le.0.25d0) then
39188 s=log(log(q2/lam2)/log(mu2/lam2))
39192 s=log(log(q2/lam2)/log(p2/lam2))
39193 lp1=log(p2/mu2)*log(p2/mu2)
39194 lp2=log(p2/mu2+log(p2/mu2))
39197 alp=up0(1)+lp1*u1(1)+lp2*u1(2)
39198 bet=up0(2)+lp1*u1(3)+lp2*u1(4)
39199 a=up0(3)+lp1*u1(5)+lp2*u1(6)+
39200 & (up0(4)+lp1*u1(7)+lp2*u1(8))*s
39201 b=up0(5)+lp1*u1(9)+lp2*u1(10)+
39202 & (up0(6)+lp1*u1(11)+lp2*u1(12))*s**0.5+
39203 & (up0(7)+lp1*u1(13)+lp2*u1(14))*s**2
39204 gb=up0(8)+lp1*u1(15)+lp2*u1(16)+
39205 & (up0(9)+lp1*u1(17)+lp2*u1(18))*s+
39206 & (up0(10)+lp1*u1(19)+lp2*u1(20))*s**2
39207 ga=up0(11)+lp1*u1(21)+lp2*u1(22)+
39208 & (up0(12)+lp1*u1(23)+lp2*u1(24))*s**0.5
39209 gc=up0(13)+lp1*u1(25)+lp2*u1(33)+
39210 & (up0(14)+lp1*u1(26)+lp2*u1(34))*s
39211 gd=up0(15)+lp1*u1(27)+lp2*u1(35)+
39212 & (up0(16)+lp1*u1(28)+lp2*u1(36))*s
39213 ge=up0(17)+lp1*u1(29)+lp2*u1(37)+
39214 & (up0(18)+lp1*u1(30)+lp2*u1(38))*s
39215 gep=up0(19)+lp1*u1(31)+lp2*u1(39)+
39216 & (up0(20)+lp1*u1(32)+lp2*u1(40))*s
39217 upart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39219 alp=dsp0(1)+lp1*ds1(1)+lp2*ds1(2)
39220 bet=dsp0(2)+lp1*ds1(3)+lp2*ds1(4)
39221 a=dsp0(3)+lp1*ds1(5)+lp2*ds1(6)+
39222 & (dsp0(4)+lp1*ds1(7)+lp2*ds1(8))*s
39223 b=dsp0(5)+lp1*ds1(9)+lp2*ds1(10)+
39224 & (dsp0(6)+lp1*ds1(11)+lp2*ds1(12))*s**0.5+
39225 & (dsp0(7)+lp1*ds1(13)+lp2*ds1(14))*s**2
39226 gb=dsp0(8)+lp1*ds1(15)+lp2*ds1(16)+
39227 & (dsp0(9)+lp1*ds1(17)+lp2*ds1(18))*s+
39228 & (dsp0(10)+lp1*ds1(19)+lp2*ds1(20))*s**2
39229 ga=dsp0(11)+lp1*ds1(21)+lp2*ds1(22)+
39230 & (dsp0(12)+lp1*ds1(23)+lp2*ds1(24))*s
39231 gc=dsp0(13)+lp1*ds1(25)+lp2*ds1(33)+
39232 & (dsp0(14)+lp1*ds1(26)+lp2*ds1(34))*s
39233 gd=dsp0(15)+lp1*ds1(27)+lp2*ds1(35)+
39234 & (dsp0(16)+lp1*ds1(28)+lp2*ds1(36))*s
39235 ge=dsp0(17)+lp1*ds1(29)+lp2*ds1(37)+
39236 & (dsp0(18)+lp1*ds1(30)+lp2*ds1(38))*s
39237 gep=dsp0(19)+lp1*ds1(31)+lp2*ds1(39)+
39238 & (dsp0(20)+lp1*ds1(32)+lp2*ds1(40))*s
39239 dspart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39241 alp=gp0(1)+lp1*g1(1)+lp2*g1(2)
39242 bet=gp0(2)+lp1*g1(3)+lp2*g1(4)
39243 a=gp0(3)+lp1*g1(5)+lp2*g1(6)+
39244 & (gp0(4)+lp1*g1(7)+lp2*g1(8))*s**0.5
39245 b=gp0(5)+lp1*g1(9)+lp2*g1(10)+
39246 & (gp0(6)+lp1*g1(11)+lp2*g1(12))*s**2
39247 gb=gp0(7)+lp1*g1(13)+lp2*g1(14)+
39248 & (gp0(8)+lp1*g1(15)+lp2*g1(16))*s
39249 ga=gp0(9)+lp1*g1(17)+lp2*g1(18)+
39250 & (gp0(10)+lp1*g1(19)+lp2*g1(20))*s**0.5+
39251 & (gp0(11)+lp1*g1(21)+lp2*g1(22))*s**2
39252 gc=gp0(12)+lp1*g1(23)+lp2*g1(24)+
39253 & (gp0(13)+lp1*g1(25)+lp2*g1(26))*s**2
39254 gd=gp0(14)+lp1*g1(27)+lp2*g1(28)+
39255 & (gp0(15)+lp1*g1(29)+lp2*g1(30))*s+
39256 & (gp0(16)+lp1*g1(31)+lp2*g1(32))*s**2
39257 ge=gp0(17)+lp1*g1(33)+lp2*g1(34)+
39258 & (gp0(18)+lp1*g1(35)+lp2*g1(36))*s
39259 gep=gp0(19)+lp1*g1(37)+lp2*g1(38)+
39260 & (gp0(20)+lp1*g1(39)+lp2*g1(40))*s
39261 gpart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39263 s=log(log(q2/lam2)/log(mu2/lam2))
39264 suppr=1.d0/(1.d0+p2/0.59d0)**2
39269 ga=ud2(5)+ud2(6)*s**0.5
39271 b=ud2(9)+ud2(10)*s+ud2(11)*s**2
39272 gb=ud2(12)+ud2(13)*s+ud2(14)*s**2
39273 gd=ud2(15)+ud2(16)*s
39274 ge=ud2(17)+ud2(18)*s
39275 gep=ud2(19)+ud2(20)*s
39276 udpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39281 ga=s2(5)+s2(6)*s**0.5
39283 b=s2(9)+s2(10)*s+s2(11)*s**2
39284 gb=s2(12)+s2(13)*s+s2(14)*s**2
39287 gep=s2(19)+s2(20)*s
39288 spart2=suppr*PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39292 a=g2(3)+g2(4)*s**0.5
39295 ga=g2(9)+g2(10)*s**0.5+g2(11)*s**2
39296 gc=g2(12)+g2(13)*s**2
39297 gd=g2(14)+g2(15)*s+g2(16)*s**2
39299 gep=g2(19)+g2(20)*s
39300 gpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39302 ugam=upart1+udpart2
39303 dgam=dspart1+udpart2
39304 sgam=dspart1+spart2
39309 *$ CREATE PHO_grsf1.FOR
39311 CDECK ID>, PHO_grsf1
39312 DOUBLE PRECISION FUNCTION PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,
39314 implicit double precision (a-z)
39317 PHO_grsf1=(x**a*(ga+gb*sqrt(x)+gc*x**b)+
39318 & s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
39323 *$ CREATE PHO_grsf2.FOR
39325 CDECK ID>, PHO_grsf2
39326 DOUBLE PRECISION FUNCTION PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,
39328 implicit double precision (a-z)
39331 PHO_grsf2=(s*x**a*(ga+gb*sqrt(x)+gc*x**b)+
39332 & s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
39337 *$ CREATE PHO_CKMTPA.FOR
39339 CDECK ID>, PHO_CKMTPA
39340 SUBROUTINE PHO_CKMTPA(IPA,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
39341 C**********************************************************************
39343 C PDF based on Regge theory, evolved with .... by ....
39345 C input: IPAR 2212 proton (not installed)
39348 C output: parameters of parametrization
39350 C**********************************************************************
39351 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39356 C input/output channels
39358 COMMON /POINOU/ LI,LO
39360 REAL PROP(40),POMP(40)
39362 & .230000E+00, .200000E+01, .150200E+00, .120000E+01, .263100E+00,
39363 & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
39364 & .100000E+00, .330000E-01, .352102E-01, .200000E+01, .200000E+01,
39365 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39366 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39367 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39368 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39369 & .000000E+00, .000000E+00, .100000E+00, .200000E+01, .100000E+09/
39371 & .230000E+00, .500000E+01, .150200E+00, .120000E+01, .263100E+00,
39372 & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
39373 & .700000E-01, .700000E-01, .137161E+00, .300000E+01, .200000E+01,
39374 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39375 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39376 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39377 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39378 & .000000E+00, .000000E+00, .100000E+00, .500000E+01, .100000E+09/
39380 IF(IPA.EQ.2212) THEN
39385 ELSE IF(IPA.EQ.990) THEN
39391 WRITE(LO,'(1X,A,I7)')
39392 & 'PHO_CKMTPA:ERROR: invalid particle code',IPA
39399 *$ CREATE PHO_CKMTPD.FOR
39401 CDECK ID>, PHO_CKMTPD
39402 SUBROUTINE PHO_CKMTPD(IPAR,X,SCALE2,PD)
39403 C**********************************************************************
39405 C PDF based on Regge theory, evolved with .... by ....
39407 C input: IPAR 2212 proton (not installed)
39410 C output: PD(-6:6) x*f(x) parton distribution functions
39411 C (PDFLIB convention: d = PD(1), u = PD(2) )
39413 C**********************************************************************
39416 C input/output channels
39418 COMMON /POINOU/ LI,LO
39420 DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP
39426 C QCD lambda for evolution
39429 C Q0**2 for evolution
39433 C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
39434 C q(6)=x*charm, q(7)=x*gluon
39438 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
39440 IF(IPAR.EQ.2212) THEN
39441 * CALL PHO_CKMTPR(XX,SB,QQ
39442 WRITE(LO,'(/1X,A,I6)') 'PHO_CKMTPD:ERROR: invalid particle',IPAR
39445 CALL PHO_CKMTPO(XX,SB,QQ)
39450 PD(-4) = DBLE(QQ(6))
39451 PD(-3) = DBLE(QQ(3))
39452 PD(-2) = DBLE(QQ(4))
39453 PD(-1) = DBLE(QQ(5))
39454 PD(0) = DBLE(QQ(7))
39455 PD(1) = DBLE(QQ(2))
39456 PD(2) = DBLE(QQ(1))
39457 PD(3) = DBLE(QQ(3))
39458 PD(4) = DBLE(QQ(6))
39461 IF(IPAR.EQ.990) THEN
39462 CDN = (PD(1)-PD(-1))/2.D0
39463 CUP = (PD(2)-PD(-2))/2.D0
39464 PD(-1) = PD(-1) + CDN
39465 PD(-2) = PD(-2) + CUP
39471 *$ CREATE PHO_CKMTPO.FOR
39473 CDECK ID>, PHO_CKMTPO
39474 SUBROUTINE PHO_CKMTPO(X,S,QQ)
39475 C**********************************************************************
39477 C calculation partons in Pomeron
39479 C**********************************************************************
39484 C input/output channels
39486 COMMON /POINOU/ LI,LO
39488 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
39489 EQUIVALENCE (GF(1,1,1),DL(1))
39493 C DEU.NORM. QUARKS,GLUONS,NEW NORM .6223E+00 .2754E+00 .1372E+01
39494 C POM.NORM. QUARKS,GLUONS,ALL .132E+00 .275E+00 .407E+00
39495 DATA (DL(K),K= 1, 85) /
39496 & .324159E-01, .324159E-01, .298895E-01, .298895E-01, .298895E-01,
39497 & .298895E-01, .486150E+00,-.867362E-18, .362035E-01, .362035E-01,
39498 & .335142E-01, .335151E-01, .335151E-01, .335142E-01, .745381E+00,
39499 & .399157E-02, .417146E-01, .417146E-01, .388545E-01, .388564E-01,
39500 & .388564E-01, .388545E-01, .107588E+01, .969559E-02, .493208E-01,
39501 & .493208E-01, .462819E-01, .462849E-01, .462849E-01, .462819E-01,
39502 & .148168E+01, .174837E-01, .593251E-01, .593251E-01, .560991E-01,
39503 & .561035E-01, .561035E-01, .560991E-01, .196422E+01, .276588E-01,
39504 & .720220E-01, .720220E-01, .686007E-01, .686065E-01, .686065E-01,
39505 & .686007E-01, .252331E+01, .405154E-01, .876695E-01, .876695E-01,
39506 & .840445E-01, .840520E-01, .840520E-01, .840445E-01, .315730E+01,
39507 & .563115E-01, .106489E+00, .106489E+00, .102652E+00, .102662E+00,
39508 & .102662E+00, .102652E+00, .386313E+01, .752690E-01, .128662E+00,
39509 & .128662E+00, .124605E+00, .124616E+00, .124616E+00, .124605E+00,
39510 & .463661E+01, .975686E-01, .154326E+00, .154326E+00, .150039E+00,
39511 & .150053E+00, .150053E+00, .150039E+00, .547247E+01, .123348E+00,
39512 & .183571E+00, .183571E+00, .179048E+00, .179063E+00, .179063E+00/
39513 DATA (DL(K),K= 86, 170) /
39514 & .179048E+00, .636464E+01, .152698E+00, .216445E+00, .216445E+00,
39515 & .211676E+00, .211694E+00, .211694E+00, .211676E+00, .730631E+01,
39516 & .185666E+00, .252948E+00, .252948E+00, .247925E+00, .247946E+00,
39517 & .247946E+00, .247925E+00, .829017E+01, .222252E+00, .293037E+00,
39518 & .293037E+00, .287752E+00, .287776E+00, .287776E+00, .287752E+00,
39519 & .930850E+01, .262414E+00, .336625E+00, .336625E+00, .331070E+00,
39520 & .331097E+00, .331097E+00, .331070E+00, .103534E+02, .306065E+00,
39521 & .383587E+00, .383587E+00, .377754E+00, .377785E+00, .377785E+00,
39522 & .377754E+00, .114166E+02, .353079E+00, .433760E+00, .433760E+00,
39523 & .427641E+00, .427675E+00, .427675E+00, .427641E+00, .124903E+02,
39524 & .403294E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39525 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39526 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39527 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39528 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39529 & .296507E-01, .296507E-01, .258624E-01, .258624E-01, .258624E-01,
39530 & .258624E-01, .422709E+00,-.173472E-17, .330029E-01, .330029E-01/
39531 DATA (DL(K),K= 171, 255) /
39532 & .289773E-01, .289787E-01, .289787E-01, .289773E-01, .642996E+00,
39533 & .344499E-02, .377610E-01, .377610E-01, .334880E-01, .334910E-01,
39534 & .334910E-01, .334880E-01, .914159E+00, .828363E-02, .441590E-01,
39535 & .441590E-01, .396285E-01, .396333E-01, .396333E-01, .396285E-01,
39536 & .123635E+01, .147501E-01, .523710E-01, .523710E-01, .475730E-01,
39537 & .475798E-01, .475798E-01, .475730E-01, .160820E+01, .230185E-01,
39538 & .625514E-01, .625514E-01, .574758E-01, .574848E-01, .574848E-01,
39539 & .574758E-01, .202705E+01, .332433E-01, .748195E-01, .748195E-01,
39540 & .694563E-01, .694678E-01, .694678E-01, .694563E-01, .248945E+01,
39541 & .455440E-01, .892611E-01, .892611E-01, .836006E-01, .836147E-01,
39542 & .836147E-01, .836006E-01, .299114E+01, .600067E-01, .105928E+00,
39543 & .105928E+00, .999607E-01, .999776E-01, .999776E-01, .999607E-01,
39544 & .352735E+01, .766833E-01, .124839E+00, .124839E+00, .118555E+00,
39545 & .118575E+00, .118575E+00, .118555E+00, .409288E+01, .955921E-01,
39546 & .145978E+00, .145978E+00, .139368E+00, .139391E+00, .139391E+00,
39547 & .139368E+00, .468226E+01, .116719E+00, .169300E+00, .169300E+00,
39548 & .162355E+00, .162382E+00, .162382E+00, .162355E+00, .528987E+01/
39549 DATA (DL(K),K= 256, 340) /
39550 & .140017E+00, .194730E+00, .194730E+00, .187441E+00, .187471E+00,
39551 & .187471E+00, .187441E+00, .591007E+01, .165413E+00, .222167E+00,
39552 & .222167E+00, .214525E+00, .214559E+00, .214559E+00, .214525E+00,
39553 & .653724E+01, .192806E+00, .251486E+00, .251486E+00, .243482E+00,
39554 & .243521E+00, .243521E+00, .243482E+00, .716591E+01, .222070E+00,
39555 & .282539E+00, .282539E+00, .274165E+00, .274208E+00, .274208E+00,
39556 & .274165E+00, .779082E+01, .253058E+00, .315161E+00, .315161E+00,
39557 & .306410E+00, .306458E+00, .306458E+00, .306410E+00, .840695E+01,
39558 & .285608E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39559 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39560 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39561 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39562 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39563 & .279581E-01, .279581E-01, .222797E-01, .222797E-01, .222797E-01,
39564 & .222797E-01, .367732E+00, .867362E-18, .309604E-01, .309604E-01,
39565 & .249419E-01, .249441E-01, .249441E-01, .249419E-01, .552053E+00,
39566 & .296633E-02, .350831E-01, .350831E-01, .287126E-01, .287173E-01/
39567 DATA (DL(K),K= 341, 425) /
39568 & .287173E-01, .287126E-01, .770476E+00, .704001E-02, .404554E-01,
39569 & .404554E-01, .337212E-01, .337286E-01, .337286E-01, .337212E-01,
39570 & .102096E+01, .123504E-01, .471588E-01, .471588E-01, .400495E-01,
39571 & .400599E-01, .400599E-01, .400495E-01, .130079E+01, .189795E-01,
39572 & .552518E-01, .552518E-01, .477564E-01, .477700E-01, .477700E-01,
39573 & .477564E-01, .160637E+01, .269860E-01, .647649E-01, .647649E-01,
39574 & .568725E-01, .568897E-01, .568897E-01, .568725E-01, .193388E+01,
39575 & .364007E-01, .757021E-01, .757021E-01, .674022E-01, .674232E-01,
39576 & .674232E-01, .674022E-01, .227916E+01, .472280E-01, .880430E-01,
39577 & .880430E-01, .793257E-01, .793507E-01, .793507E-01, .793257E-01,
39578 & .263802E+01, .594481E-01, .101745E+00, .101745E+00, .926005E-01,
39579 & .926297E-01, .926297E-01, .926005E-01, .300628E+01, .730184E-01,
39580 & .116745E+00, .116745E+00, .107164E+00, .107198E+00, .107198E+00,
39581 & .107164E+00, .337982E+01, .878765E-01, .132961E+00, .132961E+00,
39582 & .122936E+00, .122974E+00, .122974E+00, .122936E+00, .375469E+01,
39583 & .103942E+00, .150298E+00, .150298E+00, .139820E+00, .139863E+00,
39584 & .139863E+00, .139820E+00, .412714E+01, .121118E+00, .168645E+00/
39585 DATA (DL(K),K= 426, 510) /
39586 & .168645E+00, .157706E+00, .157754E+00, .157754E+00, .157706E+00,
39587 & .449366E+01, .139296E+00, .187883E+00, .187883E+00, .176476E+00,
39588 & .176529E+00, .176529E+00, .176476E+00, .485100E+01, .158356E+00,
39589 & .207882E+00, .207882E+00, .196000E+00, .196059E+00, .196059E+00,
39590 & .196000E+00, .519622E+01, .178170E+00, .228506E+00, .228506E+00,
39591 & .216145E+00, .216209E+00, .216209E+00, .216145E+00, .552665E+01,
39592 & .198603E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39593 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39594 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39595 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39596 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39597 & .275294E-01, .275294E-01, .190245E-01, .190245E-01, .190245E-01,
39598 & .190245E-01, .320228E+00, .000000E+00, .302671E-01, .302671E-01,
39599 & .212851E-01, .212884E-01, .212884E-01, .212851E-01, .470861E+00,
39600 & .255059E-02, .338703E-01, .338703E-01, .243988E-01, .244059E-01,
39601 & .244059E-01, .243988E-01, .642452E+00, .595399E-02, .383922E-01,
39602 & .383922E-01, .284195E-01, .284305E-01, .284305E-01, .284195E-01/
39603 DATA (DL(K),K= 511, 595) /
39604 & .831913E+00, .102638E-01, .438519E-01, .438519E-01, .333669E-01,
39605 & .333821E-01, .333821E-01, .333669E-01, .103618E+01, .155000E-01,
39606 & .502475E-01, .502475E-01, .392399E-01, .392595E-01, .392595E-01,
39607 & .392399E-01, .125172E+01, .216612E-01, .575580E-01, .575580E-01,
39608 & .460181E-01, .460425E-01, .460425E-01, .460181E-01, .147519E+01,
39609 & .287272E-01, .657445E-01, .657445E-01, .536635E-01, .536929E-01,
39610 & .536929E-01, .536635E-01, .170330E+01, .366597E-01, .747539E-01,
39611 & .747539E-01, .621238E-01, .621582E-01, .621582E-01, .621238E-01,
39612 & .193297E+01, .454066E-01, .845205E-01, .845205E-01, .713340E-01,
39613 & .713738E-01, .713738E-01, .713340E-01, .216133E+01, .549027E-01,
39614 & .949687E-01, .949687E-01, .812194E-01, .812646E-01, .812646E-01,
39615 & .812194E-01, .238578E+01, .650733E-01, .106015E+00, .106015E+00,
39616 & .916972E-01, .917480E-01, .917480E-01, .916972E-01, .260395E+01,
39617 & .758355E-01, .117569E+00, .117569E+00, .102678E+00, .102735E+00,
39618 & .102735E+00, .102678E+00, .281373E+01, .871004E-01, .129537E+00,
39619 & .129537E+00, .114070E+00, .114133E+00, .114133E+00, .114070E+00,
39620 & .301327E+01, .987750E-01, .141824E+00, .141824E+00, .125777E+00/
39621 DATA (DL(K),K= 596, 680) /
39622 & .125846E+00, .125846E+00, .125777E+00, .320098E+01, .110764E+00,
39623 & .154331E+00, .154331E+00, .137703E+00, .137778E+00, .137778E+00,
39624 & .137703E+00, .337553E+01, .122970E+00, .166962E+00, .166962E+00,
39625 & .149753E+00, .149833E+00, .149833E+00, .149753E+00, .353582E+01,
39626 & .135299E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39627 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39628 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39629 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39630 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39631 & .286766E-01, .286766E-01, .159579E-01, .159579E-01, .159579E-01,
39632 & .159579E-01, .279430E+00,-.867362E-18, .312327E-01, .312327E-01,
39633 & .178644E-01, .178691E-01, .178691E-01, .178644E-01, .399186E+00,
39634 & .219459E-02, .344289E-01, .344289E-01, .204015E-01, .204111E-01,
39635 & .204111E-01, .204015E-01, .529978E+00, .501953E-02, .382657E-01,
39636 & .382657E-01, .235713E-01, .235860E-01, .235860E-01, .235713E-01,
39637 & .668515E+00, .847682E-02, .427243E-01, .427243E-01, .273559E-01,
39638 & .273758E-01, .273758E-01, .273559E-01, .812075E+00, .125486E-01/
39639 DATA (DL(K),K= 681, 765) /
39640 & .477691E-01, .477691E-01, .317212E-01, .317465E-01, .317465E-01,
39641 & .317212E-01, .957801E+00, .172006E-01, .533547E-01, .533547E-01,
39642 & .366231E-01, .366539E-01, .366539E-01, .366231E-01, .110327E+01,
39643 & .223886E-01, .594259E-01, .594259E-01, .420076E-01, .420441E-01,
39644 & .420441E-01, .420076E-01, .124628E+01, .280584E-01, .659213E-01,
39645 & .659213E-01, .478149E-01, .478570E-01, .478570E-01, .478149E-01,
39646 & .138496E+01, .341502E-01, .727749E-01, .727749E-01, .539803E-01,
39647 & .540280E-01, .540280E-01, .539803E-01, .151767E+01, .405990E-01,
39648 & .799178E-01, .799178E-01, .604361E-01, .604895E-01, .604895E-01,
39649 & .604361E-01, .164304E+01, .473372E-01, .872796E-01, .872796E-01,
39650 & .671134E-01, .671724E-01, .671724E-01, .671134E-01, .175992E+01,
39651 & .542955E-01, .947896E-01, .947896E-01, .739429E-01, .740075E-01,
39652 & .740075E-01, .739429E-01, .186739E+01, .614047E-01, .102378E+00,
39653 & .102378E+00, .808565E-01, .809266E-01, .809266E-01, .808565E-01,
39654 & .196473E+01, .685965E-01, .109978E+00, .109978E+00, .877881E-01,
39655 & .878637E-01, .878637E-01, .877881E-01, .205141E+01, .758045E-01,
39656 & .117525E+00, .117525E+00, .946745E-01, .947553E-01, .947553E-01/
39657 DATA (DL(K),K= 766, 850) /
39658 & .946745E-01, .212709E+01, .829655E-01, .124958E+00, .124958E+00,
39659 & .101456E+00, .101542E+00, .101542E+00, .101456E+00, .219159E+01,
39660 & .900196E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39661 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39662 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39663 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39664 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39665 & .318691E-01, .318691E-01, .129081E-01, .129081E-01, .129081E-01,
39666 & .129081E-01, .244842E+00,-.867362E-18, .343104E-01, .343104E-01,
39667 & .145076E-01, .145124E-01, .145124E-01, .145076E-01, .337040E+00,
39668 & .189443E-02, .371900E-01, .371900E-01, .165461E-01, .165557E-01,
39669 & .165557E-01, .165461E-01, .433081E+00, .422691E-02, .404763E-01,
39670 & .404763E-01, .189941E-01, .190085E-01, .190085E-01, .189941E-01,
39671 & .530109E+00, .696769E-02, .441304E-01, .441304E-01, .218150E-01,
39672 & .218342E-01, .218342E-01, .218150E-01, .626129E+00, .100799E-01,
39673 & .481031E-01, .481031E-01, .249615E-01, .249853E-01, .249853E-01,
39674 & .249615E-01, .719221E+00, .135159E-01, .523426E-01, .523426E-01/
39675 DATA (DL(K),K= 851, 935) /
39676 & .283837E-01, .284122E-01, .284122E-01, .283837E-01, .807951E+00,
39677 & .172259E-01, .567940E-01, .567940E-01, .320288E-01, .320619E-01,
39678 & .320619E-01, .320288E-01, .891154E+00, .211568E-01, .614022E-01,
39679 & .614022E-01, .358436E-01, .358811E-01, .358811E-01, .358436E-01,
39680 & .967928E+00, .252549E-01, .661122E-01, .661122E-01, .397750E-01,
39681 & .398169E-01, .398169E-01, .397750E-01, .103759E+01, .294673E-01,
39682 & .708708E-01, .708708E-01, .437716E-01, .438176E-01, .438176E-01,
39683 & .437716E-01, .109966E+01, .337422E-01, .756269E-01, .756269E-01,
39684 & .477840E-01, .478342E-01, .478342E-01, .477840E-01, .115380E+01,
39685 & .380302E-01, .803322E-01, .803322E-01, .517659E-01, .518200E-01,
39686 & .518200E-01, .517659E-01, .119986E+01, .422846E-01, .849423E-01,
39687 & .849423E-01, .556743E-01, .557322E-01, .557322E-01, .556743E-01,
39688 & .123782E+01, .464624E-01, .894164E-01, .894164E-01, .594701E-01,
39689 & .595315E-01, .595315E-01, .594701E-01, .126777E+01, .505242E-01,
39690 & .937178E-01, .937178E-01, .631181E-01, .631829E-01, .631829E-01,
39691 & .631181E-01, .128993E+01, .544348E-01, .978144E-01, .978144E-01,
39692 & .665876E-01, .666556E-01, .666556E-01, .665876E-01, .130457E+01/
39693 DATA (DL(K),K= 936, 1020) /
39694 & .581632E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39695 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39696 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39697 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39698 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39699 & .377668E-01, .377668E-01, .968304E-02, .968304E-02, .968304E-02,
39700 & .968304E-02, .216392E+00,-.130104E-17, .401066E-01, .401066E-01,
39701 & .110266E-01, .110291E-01, .110291E-01, .110266E-01, .284113E+00,
39702 & .164283E-02, .426983E-01, .426983E-01, .126461E-01, .126510E-01,
39703 & .126510E-01, .126461E-01, .350879E+00, .355790E-02, .454940E-01,
39704 & .454940E-01, .144965E-01, .145039E-01, .145039E-01, .144965E-01,
39705 & .414611E+00, .570002E-02, .484493E-01, .484493E-01, .165364E-01,
39706 & .165462E-01, .165462E-01, .165364E-01, .474149E+00, .802739E-02,
39707 & .515153E-01, .515153E-01, .187191E-01, .187313E-01, .187313E-01,
39708 & .187191E-01, .528511E+00, .104932E-01, .546458E-01, .546458E-01,
39709 & .210009E-01, .210154E-01, .210154E-01, .210009E-01, .577107E+00,
39710 & .130535E-01, .577962E-01, .577962E-01, .233395E-01, .233563E-01/
39711 DATA (DL(K),K= 1021, 1105) /
39712 & .233563E-01, .233395E-01, .619574E+00, .156658E-01, .609249E-01,
39713 & .609249E-01, .256954E-01, .257143E-01, .257143E-01, .256954E-01,
39714 & .655725E+00, .182905E-01, .639938E-01, .639938E-01, .280322E-01,
39715 & .280532E-01, .280532E-01, .280322E-01, .685523E+00, .208909E-01,
39716 & .669681E-01, .669681E-01, .303170E-01, .303399E-01, .303399E-01,
39717 & .303170E-01, .709053E+00, .234341E-01, .698172E-01, .698172E-01,
39718 & .325206E-01, .325454E-01, .325454E-01, .325206E-01, .726501E+00,
39719 & .258907E-01, .725141E-01, .725141E-01, .346176E-01, .346442E-01,
39720 & .346442E-01, .346176E-01, .738139E+00, .282352E-01, .750364E-01,
39721 & .750364E-01, .365866E-01, .366148E-01, .366148E-01, .365866E-01,
39722 & .744304E+00, .304461E-01, .773653E-01, .773653E-01, .384099E-01,
39723 & .384396E-01, .384396E-01, .384099E-01, .745388E+00, .325056E-01,
39724 & .794860E-01, .794860E-01, .400736E-01, .401046E-01, .401046E-01,
39725 & .400736E-01, .741819E+00, .343996E-01, .813873E-01, .813873E-01,
39726 & .415670E-01, .415993E-01, .415993E-01, .415670E-01, .734051E+00,
39727 & .361177E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39728 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
39729 DATA (DL(K),K= 1106, 1190) /
39730 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39731 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39732 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39733 & .433773E-01, .433773E-01, .745094E-02, .745094E-02, .745094E-02,
39734 & .745094E-02, .201612E+00,-.130104E-17, .455998E-01, .455998E-01,
39735 & .866239E-02, .866443E-02, .866443E-02, .866239E-02, .255046E+00,
39736 & .149977E-02, .479569E-01, .479569E-01, .100584E-01, .100624E-01,
39737 & .100624E-01, .100584E-01, .305549E+00, .317779E-02, .503976E-01,
39738 & .503976E-01, .115911E-01, .115970E-01, .115970E-01, .115911E-01,
39739 & .351606E+00, .498612E-02, .528804E-01, .528804E-01, .132216E-01,
39740 & .132293E-01, .132293E-01, .132216E-01, .392560E+00, .688553E-02,
39741 & .553621E-01, .553621E-01, .149087E-01, .149181E-01, .149181E-01,
39742 & .149087E-01, .427948E+00, .883486E-02, .578049E-01, .578049E-01,
39743 & .166165E-01, .166276E-01, .166276E-01, .166165E-01, .457612E+00,
39744 & .107980E-01, .601739E-01, .601739E-01, .183120E-01, .183246E-01,
39745 & .183246E-01, .183120E-01, .481565E+00, .127419E-01, .624390E-01,
39746 & .624390E-01, .199661E-01, .199801E-01, .199801E-01, .199661E-01/
39747 DATA (DL(K),K= 1191, 1275) /
39748 & .499943E+00, .146375E-01, .645736E-01, .645736E-01, .215535E-01,
39749 & .215688E-01, .215688E-01, .215535E-01, .512983E+00, .164593E-01,
39750 & .665556E-01, .665556E-01, .230528E-01, .230693E-01, .230693E-01,
39751 & .230528E-01, .520995E+00, .181859E-01, .683669E-01, .683669E-01,
39752 & .244463E-01, .244639E-01, .244639E-01, .244463E-01, .524347E+00,
39753 & .197998E-01, .699932E-01, .699932E-01, .257201E-01, .257387E-01,
39754 & .257387E-01, .257201E-01, .523447E+00, .212869E-01, .714240E-01,
39755 & .714240E-01, .268637E-01, .268832E-01, .268832E-01, .268637E-01,
39756 & .518729E+00, .226367E-01, .726523E-01, .726523E-01, .278697E-01,
39757 & .278900E-01, .278900E-01, .278697E-01, .510641E+00, .238420E-01,
39758 & .736741E-01, .736741E-01, .287338E-01, .287547E-01, .287547E-01,
39759 & .287338E-01, .499630E+00, .248984E-01, .744886E-01, .744886E-01,
39760 & .294542E-01, .294757E-01, .294757E-01, .294542E-01, .486140E+00,
39761 & .258043E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39762 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39763 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39764 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
39765 DATA (DL(K),K= 1276, 1360) /
39766 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39767 & .499162E-01, .499162E-01, .534441E-02, .534441E-02, .534441E-02,
39768 & .534441E-02, .191108E+00,-.151788E-17, .519197E-01, .519197E-01,
39769 & .646285E-02, .646402E-02, .646402E-02, .646285E-02, .232539E+00,
39770 & .137669E-02, .539504E-01, .539504E-01, .769150E-02, .769377E-02,
39771 & .769377E-02, .769150E-02, .269907E+00, .285489E-02, .559598E-01,
39772 & .559598E-01, .898389E-02, .898721E-02, .898721E-02, .898389E-02,
39773 & .302186E+00, .438814E-02, .579130E-01, .579130E-01, .103061E-01,
39774 & .103104E-01, .103104E-01, .103061E-01, .329124E+00, .594258E-02,
39775 & .597754E-01, .597754E-01, .116245E-01, .116297E-01, .116297E-01,
39776 & .116245E-01, .350643E+00, .748452E-02, .615191E-01, .615191E-01,
39777 & .129113E-01, .129174E-01, .129174E-01, .129113E-01, .366890E+00,
39778 & .898645E-02, .631204E-01, .631204E-01, .141428E-01, .141497E-01,
39779 & .141497E-01, .141428E-01, .378134E+00, .104247E-01, .645601E-01,
39780 & .645601E-01, .152995E-01, .153071E-01, .153071E-01, .152995E-01,
39781 & .384719E+00, .117798E-01, .658236E-01, .658236E-01, .163657E-01,
39782 & .163739E-01, .163739E-01, .163657E-01, .387045E+00, .130362E-01/
39783 DATA (DL(K),K= 1361, 1445) /
39784 & .669000E-01, .669000E-01, .173294E-01, .173381E-01, .173381E-01,
39785 & .173294E-01, .385547E+00, .141821E-01, .677824E-01, .677824E-01,
39786 & .181820E-01, .181912E-01, .181912E-01, .181820E-01, .380677E+00,
39787 & .152091E-01, .684672E-01, .684672E-01, .189180E-01, .189277E-01,
39788 & .189277E-01, .189180E-01, .372894E+00, .161119E-01, .689539E-01,
39789 & .689539E-01, .195349E-01, .195449E-01, .195449E-01, .195349E-01,
39790 & .362650E+00, .168880E-01, .692447E-01, .692447E-01, .200324E-01,
39791 & .200427E-01, .200427E-01, .200324E-01, .350383E+00, .175374E-01,
39792 & .693442E-01, .693442E-01, .204123E-01, .204229E-01, .204229E-01,
39793 & .204123E-01, .336505E+00, .180622E-01, .692590E-01, .692590E-01,
39794 & .206783E-01, .206891E-01, .206891E-01, .206783E-01, .321403E+00,
39795 & .184661E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39796 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39797 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39798 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39799 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39800 & .554152E-01, .554152E-01, .386683E-02, .386683E-02, .386683E-02/
39801 DATA (DL(K),K= 1446, 1530) /
39802 & .386683E-02, .185844E+00,-.151788E-17, .571372E-01, .571372E-01,
39803 & .493623E-02, .493704E-02, .493704E-02, .493623E-02, .219342E+00,
39804 & .129037E-02, .588098E-01, .588098E-01, .606768E-02, .606924E-02,
39805 & .606924E-02, .606768E-02, .248288E+00, .263296E-02, .603896E-01,
39806 & .603896E-01, .721747E-02, .721973E-02, .721973E-02, .721747E-02,
39807 & .271974E+00, .398431E-02, .618484E-01, .618484E-01, .835658E-02,
39808 & .835949E-02, .835949E-02, .835658E-02, .290397E+00, .531560E-02,
39809 & .631600E-01, .631600E-01, .945726E-02, .946074E-02, .946074E-02,
39810 & .945726E-02, .303702E+00, .659930E-02, .643051E-01, .643051E-01,
39811 & .104983E-01, .105023E-01, .105023E-01, .104983E-01, .312209E+00,
39812 & .781443E-02, .652691E-01, .652691E-01, .114624E-01, .114669E-01,
39813 & .114669E-01, .114624E-01, .316328E+00, .894407E-02, .660416E-01,
39814 & .660416E-01, .123367E-01, .123416E-01, .123416E-01, .123367E-01,
39815 & .316509E+00, .997546E-02, .666169E-01, .666169E-01, .131119E-01,
39816 & .131171E-01, .131171E-01, .131119E-01, .313229E+00, .108996E-01,
39817 & .669925E-01, .669925E-01, .137818E-01, .137874E-01, .137874E-01,
39818 & .137818E-01, .306974E+00, .117107E-01, .671695E-01, .671695E-01/
39819 DATA (DL(K),K= 1531, 1615) /
39820 & .143437E-01, .143495E-01, .143495E-01, .143437E-01, .298224E+00,
39821 & .124061E-01, .671517E-01, .671517E-01, .147970E-01, .148031E-01,
39822 & .148031E-01, .147970E-01, .287441E+00, .129858E-01, .669454E-01,
39823 & .669454E-01, .151437E-01, .151499E-01, .151499E-01, .151437E-01,
39824 & .275064E+00, .134517E-01, .665590E-01, .665590E-01, .153872E-01,
39825 & .153935E-01, .153935E-01, .153872E-01, .261497E+00, .138078E-01,
39826 & .660023E-01, .660023E-01, .155327E-01, .155391E-01, .155391E-01,
39827 & .155327E-01, .247105E+00, .140595E-01, .652865E-01, .652865E-01,
39828 & .155864E-01, .155929E-01, .155929E-01, .155864E-01, .232218E+00,
39829 & .142131E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39830 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39831 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39832 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39833 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39834 & .601098E-01, .601098E-01, .278641E-02, .278641E-02, .278641E-02,
39835 & .278641E-02, .183460E+00, .130104E-17, .614949E-01, .614949E-01,
39836 & .382710E-02, .382771E-02, .382771E-02, .382710E-02, .211150E+00/
39837 DATA (DL(K),K= 1616, 1700) /
39838 & .122320E-02, .627722E-01, .627722E-01, .489465E-02, .489580E-02,
39839 & .489580E-02, .489465E-02, .234040E+00, .246333E-02, .639042E-01,
39840 & .639042E-01, .594825E-02, .594990E-02, .594990E-02, .594825E-02,
39841 & .251649E+00, .367998E-02, .648697E-01, .648697E-01, .696315E-02,
39842 & .696526E-02, .696526E-02, .696315E-02, .264143E+00, .484875E-02,
39843 & .656502E-01, .656502E-01, .791658E-02, .791907E-02, .791907E-02,
39844 & .791658E-02, .271822E+00, .594722E-02, .662343E-01, .662343E-01,
39845 & .879236E-02, .879520E-02, .879520E-02, .879236E-02, .275124E+00,
39846 & .695957E-02, .666152E-01, .666152E-01, .957846E-02, .958160E-02,
39847 & .958160E-02, .957846E-02, .274549E+00, .787413E-02, .667905E-01,
39848 & .667905E-01, .102668E-01, .102702E-01, .102702E-01, .102668E-01,
39849 & .270615E+00, .868318E-02, .667616E-01, .667616E-01, .108528E-01,
39850 & .108564E-01, .108564E-01, .108528E-01, .263847E+00, .938250E-02,
39851 & .665331E-01, .665331E-01, .113349E-01, .113387E-01, .113387E-01,
39852 & .113349E-01, .254756E+00, .997082E-02, .661123E-01, .661123E-01,
39853 & .117139E-01, .117179E-01, .117179E-01, .117139E-01, .243828E+00,
39854 & .104494E-01, .655090E-01, .655090E-01, .119931E-01, .119971E-01/
39855 DATA (DL(K),K= 1701, 1785) /
39856 & .119971E-01, .119931E-01, .231518E+00, .108217E-01, .647345E-01,
39857 & .647345E-01, .121770E-01, .121811E-01, .121811E-01, .121770E-01,
39858 & .218237E+00, .110927E-01, .638017E-01, .638017E-01, .122717E-01,
39859 & .122759E-01, .122759E-01, .122717E-01, .204353E+00, .112689E-01,
39860 & .627241E-01, .627241E-01, .122842E-01, .122884E-01, .122884E-01,
39861 & .122842E-01, .190187E+00, .113573E-01, .615161E-01, .615161E-01,
39862 & .122221E-01, .122262E-01, .122262E-01, .122221E-01, .176012E+00,
39863 & .113659E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39864 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39865 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39866 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39867 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39868 & .641221E-01, .641221E-01, .198544E-02, .198544E-02, .198544E-02,
39869 & .198544E-02, .183018E+00, .184314E-17, .651208E-01, .651208E-01,
39870 & .300778E-02, .300823E-02, .300823E-02, .300778E-02, .206180E+00,
39871 & .116844E-02, .659664E-01, .659664E-01, .402903E-02, .402989E-02,
39872 & .402989E-02, .402903E-02, .224390E+00, .232648E-02, .666277E-01/
39873 DATA (DL(K),K= 1786, 1870) /
39874 & .666277E-01, .501117E-02, .501238E-02, .501238E-02, .501117E-02,
39875 & .237332E+00, .343657E-02, .670904E-01, .670904E-01, .593321E-02,
39876 & .593473E-02, .593473E-02, .593321E-02, .245310E+00, .447818E-02,
39877 & .673435E-01, .673435E-01, .677663E-02, .677843E-02, .677843E-02,
39878 & .677663E-02, .248743E+00, .543320E-02, .673832E-01, .673832E-01,
39879 & .752958E-02, .753161E-02, .753161E-02, .752958E-02, .248162E+00,
39880 & .629021E-02, .672099E-01, .672099E-01, .818432E-02, .818655E-02,
39881 & .818655E-02, .818432E-02, .244140E+00, .704188E-02, .668281E-01,
39882 & .668281E-01, .873688E-02, .873927E-02, .873927E-02, .873688E-02,
39883 & .237247E+00, .768463E-02, .662457E-01, .662457E-01, .918650E-02,
39884 & .918903E-02, .918903E-02, .918650E-02, .228043E+00, .821808E-02,
39885 & .654734E-01, .654734E-01, .953502E-02, .953766E-02, .953766E-02,
39886 & .953502E-02, .217054E+00, .864446E-02, .645238E-01, .645238E-01,
39887 & .978645E-02, .978915E-02, .978915E-02, .978645E-02, .204766E+00,
39888 & .896811E-02, .634114E-01, .634114E-01, .994639E-02, .994915E-02,
39889 & .994915E-02, .994639E-02, .191614E+00, .919500E-02, .621515E-01,
39890 & .621515E-01, .100217E-01, .100245E-01, .100245E-01, .100217E-01/
39891 DATA (DL(K),K= 1871, 1955) /
39892 & .177983E+00, .933229E-02, .607602E-01, .607602E-01, .100200E-01,
39893 & .100228E-01, .100228E-01, .100200E-01, .164201E+00, .938793E-02,
39894 & .592539E-01, .592539E-01, .994938E-02, .995217E-02, .995217E-02,
39895 & .994938E-02, .150544E+00, .937032E-02, .576488E-01, .576488E-01,
39896 & .981814E-02, .982091E-02, .982091E-02, .981814E-02, .137234E+00,
39897 & .928803E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39898 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39899 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39900 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39901 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39902 & .675167E-01, .675167E-01, .139130E-02, .139130E-02, .139130E-02,
39903 & .139130E-02, .184090E+00, .113841E-17, .680840E-01, .680840E-01,
39904 & .240061E-02, .240097E-02, .240097E-02, .240061E-02, .203559E+00,
39905 & .112278E-02, .684634E-01, .684634E-01, .338513E-02, .338580E-02,
39906 & .338580E-02, .338513E-02, .217944E+00, .221249E-02, .686304E-01,
39907 & .686304E-01, .430938E-02, .431032E-02, .431032E-02, .430938E-02,
39908 & .227068E+00, .323420E-02, .685779E-01, .685779E-01, .515589E-02/
39909 DATA (DL(K),K= 1956, 2040) /
39910 & .515707E-02, .515707E-02, .515589E-02, .231353E+00, .417091E-02,
39911 & .683023E-01, .683023E-01, .591002E-02, .591140E-02, .591140E-02,
39912 & .591002E-02, .231327E+00, .500843E-02, .678068E-01, .678068E-01,
39913 & .656383E-02, .656537E-02, .656537E-02, .656383E-02, .227606E+00,
39914 & .573925E-02, .670989E-01, .670989E-01, .711344E-02, .711513E-02,
39915 & .711513E-02, .711344E-02, .220833E+00, .635992E-02, .661895E-01,
39916 & .661895E-01, .755852E-02, .756031E-02, .756031E-02, .755852E-02,
39917 & .211624E+00, .687048E-02, .650923E-01, .650923E-01, .790162E-02,
39918 & .790350E-02, .790350E-02, .790162E-02, .200567E+00, .727387E-02,
39919 & .638232E-01, .638232E-01, .814753E-02, .814946E-02, .814946E-02,
39920 & .814753E-02, .188197E+00, .757524E-02, .623994E-01, .623994E-01,
39921 & .830271E-02, .830469E-02, .830469E-02, .830271E-02, .174994E+00,
39922 & .778139E-02, .608390E-01, .608390E-01, .837482E-02, .837682E-02,
39923 & .837682E-02, .837482E-02, .161373E+00, .790029E-02, .591605E-01,
39924 & .591605E-01, .837226E-02, .837426E-02, .837426E-02, .837226E-02,
39925 & .147685E+00, .794065E-02, .573824E-01, .573824E-01, .830376E-02,
39926 & .830575E-02, .830575E-02, .830376E-02, .134218E+00, .791148E-02/
39927 DATA (DL(K),K= 2041, 2125) /
39928 & .555224E-01, .555224E-01, .817811E-02, .818008E-02, .818008E-02,
39929 & .817811E-02, .121200E+00, .782185E-02, .535980E-01, .535980E-01,
39930 & .800390E-02, .800584E-02, .800584E-02, .800390E-02, .108803E+00,
39931 & .768059E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39932 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39933 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39934 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39935 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39936 & .703249E-01, .703249E-01, .953926E-03, .953926E-03, .953926E-03,
39937 & .953926E-03, .186497E+00, .108420E-18, .704188E-01, .704188E-01,
39938 & .195267E-02, .195297E-02, .195297E-02, .195267E-02, .202831E+00,
39939 & .108414E-02, .702995E-01, .702995E-01, .290528E-02, .290582E-02,
39940 & .290582E-02, .290528E-02, .213933E+00, .211514E-02, .699499E-01,
39941 & .699499E-01, .377873E-02, .377950E-02, .377950E-02, .377873E-02,
39942 & .219748E+00, .306054E-02, .693699E-01, .693699E-01, .455903E-02,
39943 & .455997E-02, .455997E-02, .455903E-02, .220821E+00, .390679E-02,
39944 & .685634E-01, .685634E-01, .523531E-02, .523640E-02, .523640E-02/
39945 DATA (DL(K),K= 2126, 2210) /
39946 & .523531E-02, .217787E+00, .464347E-02, .675406E-01, .675406E-01,
39947 & .580340E-02, .580462E-02, .580462E-02, .580340E-02, .211353E+00,
39948 & .526681E-02, .663155E-01, .663155E-01, .626315E-02, .626446E-02,
39949 & .626446E-02, .626315E-02, .202230E+00, .577705E-02, .649052E-01,
39950 & .649052E-01, .661759E-02, .661897E-02, .661897E-02, .661759E-02,
39951 & .191081E+00, .617758E-02, .633285E-01, .633285E-01, .687230E-02,
39952 & .687373E-02, .687373E-02, .687230E-02, .178518E+00, .647434E-02,
39953 & .616058E-01, .616058E-01, .703464E-02, .703611E-02, .703611E-02,
39954 & .703464E-02, .165082E+00, .667499E-02, .597580E-01, .597580E-01,
39955 & .711320E-02, .711468E-02, .711468E-02, .711320E-02, .151241E+00,
39956 & .678842E-02, .578059E-01, .578059E-01, .711723E-02, .711872E-02,
39957 & .711872E-02, .711723E-02, .137382E+00, .682417E-02, .557702E-01,
39958 & .557702E-01, .705628E-02, .705776E-02, .705776E-02, .705628E-02,
39959 & .123821E+00, .679205E-02, .536704E-01, .536704E-01, .693979E-02,
39960 & .694125E-02, .694125E-02, .693979E-02, .110798E+00, .670173E-02,
39961 & .515252E-01, .515252E-01, .677689E-02, .677832E-02, .677832E-02,
39962 & .677689E-02, .984933E-01, .656256E-02, .493519E-01, .493519E-01/
39963 DATA (DL(K),K= 2211, 2295) /
39964 & .657614E-02, .657753E-02, .657753E-02, .657614E-02, .870270E-01,
39965 & .638332E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39966 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39967 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39968 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39969 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39970 & .725555E-01, .725555E-01, .636424E-03, .636424E-03, .636424E-03,
39971 & .636424E-03, .190200E+00,-.271051E-17, .721364E-01, .721364E-01,
39972 & .162522E-02, .162546E-02, .162546E-02, .162522E-02, .203770E+00,
39973 & .105090E-02, .714881E-01, .714881E-01, .254763E-02, .254807E-02,
39974 & .254807E-02, .254763E-02, .211914E+00, .202976E-02, .706012E-01,
39975 & .706012E-01, .337323E-02, .337384E-02, .337384E-02, .337323E-02,
39976 & .214704E+00, .290668E-02, .694832E-01, .694832E-01, .409164E-02,
39977 & .409240E-02, .409240E-02, .409164E-02, .212817E+00, .367169E-02,
39978 & .681454E-01, .681454E-01, .469593E-02, .469679E-02, .469679E-02,
39979 & .469593E-02, .207013E+00, .431823E-02, .666048E-01, .666048E-01,
39980 & .518578E-02, .518673E-02, .518673E-02, .518578E-02, .198095E+00/
39981 DATA (DL(K),K= 2296, 2380) /
39982 & .484637E-02, .648819E-01, .648819E-01, .556473E-02, .556575E-02,
39983 & .556575E-02, .556473E-02, .186850E+00, .525997E-02, .629989E-01,
39984 & .629989E-01, .583908E-02, .584014E-02, .584014E-02, .583908E-02,
39985 & .173986E+00, .556566E-02, .609795E-01, .609795E-01, .601725E-02,
39986 & .601834E-02, .601834E-02, .601725E-02, .160140E+00, .577215E-02,
39987 & .588474E-01, .588474E-01, .610889E-02, .611000E-02, .611000E-02,
39988 & .610889E-02, .145850E+00, .588934E-02, .566261E-01, .566261E-01,
39989 & .612435E-02, .612547E-02, .612547E-02, .612435E-02, .131564E+00,
39990 & .592785E-02, .543385E-01, .543385E-01, .607415E-02, .607526E-02,
39991 & .607526E-02, .607415E-02, .117636E+00, .589841E-02, .520060E-01,
39992 & .520060E-01, .596861E-02, .596970E-02, .596970E-02, .596861E-02,
39993 & .104336E+00, .581156E-02, .496485E-01, .496485E-01, .581753E-02,
39994 & .581860E-02, .581860E-02, .581753E-02, .918563E-01, .567728E-02,
39995 & .472842E-01, .472842E-01, .563002E-02, .563105E-02, .563105E-02,
39996 & .563002E-02, .803205E-01, .550487E-02, .449295E-01, .449295E-01,
39997 & .541435E-02, .541535E-02, .541535E-02, .541435E-02, .697975E-01,
39998 & .530276E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
39999 DATA (DL(K),K= 2381, 2465) /
40000 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40001 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40002 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40003 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40004 & .742000E-01, .742000E-01, .410482E-03, .410482E-03, .410482E-03,
40005 & .410482E-03, .195273E+00,-.143657E-17, .732296E-01, .732296E-01,
40006 & .138854E-02, .138874E-02, .138874E-02, .138854E-02, .206298E+00,
40007 & .102151E-02, .720241E-01, .720241E-01, .228017E-02, .228054E-02,
40008 & .228054E-02, .228017E-02, .211639E+00, .195225E-02, .705820E-01,
40009 & .705820E-01, .305794E-02, .305844E-02, .305844E-02, .305794E-02,
40010 & .211509E+00, .276522E-02, .689187E-01, .689187E-01, .371549E-02,
40011 & .371609E-02, .371609E-02, .371549E-02, .206745E+00, .345441E-02,
40012 & .670527E-01, .670527E-01, .425016E-02, .425084E-02, .425084E-02,
40013 & .425016E-02, .198254E+00, .401749E-02, .650080E-01, .650080E-01,
40014 & .466572E-02, .466647E-02, .466647E-02, .466572E-02, .186950E+00,
40015 & .445856E-02, .628107E-01, .628107E-01, .496948E-02, .497027E-02,
40016 & .497027E-02, .496948E-02, .173701E+00, .478517E-02, .604878E-01/
40017 DATA (DL(K),K= 2466, 2550) /
40018 & .604878E-01, .517094E-02, .517175E-02, .517175E-02, .517094E-02,
40019 & .159263E+00, .500709E-02, .580665E-01, .580665E-01, .528116E-02,
40020 & .528199E-02, .528199E-02, .528116E-02, .144287E+00, .513562E-02,
40021 & .555730E-01, .555730E-01, .531181E-02, .531265E-02, .531265E-02,
40022 & .531181E-02, .129304E+00, .518264E-02, .530325E-01, .530325E-01,
40023 & .527468E-02, .527550E-02, .527550E-02, .527468E-02, .114731E+00,
40024 & .516012E-02, .504682E-01, .504682E-01, .518116E-02, .518198E-02,
40025 & .518198E-02, .518116E-02, .100877E+00, .507964E-02, .479014E-01,
40026 & .479014E-01, .504198E-02, .504278E-02, .504278E-02, .504198E-02,
40027 & .879578E-01, .495209E-02, .453511E-01, .453511E-01, .486695E-02,
40028 & .486772E-02, .486772E-02, .486695E-02, .761077E-01, .478741E-02,
40029 & .428340E-01, .428340E-01, .466486E-02, .466560E-02, .466560E-02,
40030 & .466486E-02, .653932E-01, .459453E-02, .403645E-01, .403645E-01,
40031 & .444342E-02, .444413E-02, .444413E-02, .444342E-02, .558281E-01,
40032 & .438128E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40033 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40034 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40035 DATA (DL(K),K= 2551, 2635) /
40036 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40037 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40038 & .752337E-01, .752337E-01, .253875E-03, .253875E-03, .253875E-03,
40039 & .253875E-03, .201902E+00,-.159920E-17, .736752E-01, .736752E-01,
40040 & .121909E-02, .121925E-02, .121925E-02, .121909E-02, .210465E+00,
40041 & .994282E-03, .718865E-01, .718865E-01, .207747E-02, .207776E-02,
40042 & .207776E-02, .207747E-02, .212997E+00, .187854E-02, .698746E-01,
40043 & .698746E-01, .280521E-02, .280560E-02, .280560E-02, .280521E-02,
40044 & .209895E+00, .262933E-02, .676629E-01, .676629E-01, .340063E-02,
40045 & .340109E-02, .340109E-02, .340063E-02, .202191E+00, .324527E-02,
40046 & .652775E-01, .652775E-01, .386588E-02, .386641E-02, .386641E-02,
40047 & .386588E-02, .190971E+00, .372876E-02, .627483E-01, .627483E-01,
40048 & .420910E-02, .420967E-02, .420967E-02, .420910E-02, .177278E+00,
40049 & .408818E-02, .601066E-01, .601066E-01, .444148E-02, .444208E-02,
40050 & .444208E-02, .444148E-02, .162071E+00, .433493E-02, .573831E-01,
40051 & .573831E-01, .457564E-02, .457625E-02, .457625E-02, .457564E-02,
40052 & .146148E+00, .448183E-02, .546072E-01, .546072E-01, .462506E-02/
40053 DATA (DL(K),K= 2636, 2720) /
40054 & .462567E-02, .462567E-02, .462506E-02, .130166E+00, .454252E-02,
40055 & .518065E-01, .518065E-01, .460307E-02, .460368E-02, .460368E-02,
40056 & .460307E-02, .114632E+00, .453052E-02, .490062E-01, .490062E-01,
40057 & .452252E-02, .452312E-02, .452312E-02, .452252E-02, .999175E-01,
40058 & .445880E-02, .462287E-01, .462287E-01, .439529E-02, .439588E-02,
40059 & .439588E-02, .439529E-02, .862750E-01, .433936E-02, .434937E-01,
40060 & .434937E-01, .423211E-02, .423268E-02, .423268E-02, .423211E-02,
40061 & .738542E-01, .418306E-02, .408180E-01, .408180E-01, .404245E-02,
40062 & .404299E-02, .404299E-02, .404245E-02, .627228E-01, .399946E-02,
40063 & .382157E-01, .382157E-01, .383446E-02, .383498E-02, .383498E-02,
40064 & .383446E-02, .528847E-01, .379682E-02, .356980E-01, .356980E-01,
40065 & .361508E-02, .361557E-02, .361557E-02, .361508E-02, .442963E-01,
40066 & .358213E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40067 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40068 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40069 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40070 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40071 DATA (DL(K),K= 2721, 2805) /
40072 & .756149E-01, .756149E-01, .148956E-03, .148956E-03, .148956E-03,
40073 & .148956E-03, .210410E+00,-.149078E-18, .734321E-01, .734321E-01,
40074 & .109779E-02, .109791E-02, .109791E-02, .109779E-02, .216444E+00,
40075 & .967243E-03, .710369E-01, .710369E-01, .191860E-02, .191882E-02,
40076 & .191882E-02, .191860E-02, .215992E+00, .180426E-02, .684452E-01,
40077 & .684452E-01, .259230E-02, .259259E-02, .259259E-02, .259230E-02,
40078 & .209697E+00, .249224E-02, .656884E-01, .656884E-01, .312270E-02,
40079 & .312305E-02, .312305E-02, .312270E-02, .198844E+00, .303522E-02,
40080 & .627994E-01, .627994E-01, .351747E-02, .351786E-02, .351786E-02,
40081 & .351747E-02, .184740E+00, .344105E-02, .598138E-01, .598138E-01,
40082 & .378940E-02, .378981E-02, .378981E-02, .378940E-02, .168578E+00,
40083 & .372269E-02, .567666E-01, .567666E-01, .395362E-02, .395405E-02,
40084 & .395405E-02, .395362E-02, .151409E+00, .389544E-02, .536907E-01,
40085 & .536907E-01, .402569E-02, .402613E-02, .402613E-02, .402569E-02,
40086 & .134065E+00, .397499E-02, .506163E-01, .506163E-01, .402117E-02,
40087 & .402161E-02, .402161E-02, .402117E-02, .117191E+00, .397702E-02,
40088 & .475706E-01, .475706E-01, .395467E-02, .395511E-02, .395511E-02/
40089 DATA (DL(K),K= 2806, 2890) /
40090 & .395467E-02, .101250E+00, .391626E-02, .445771E-01, .445771E-01,
40091 & .383961E-02, .384003E-02, .384003E-02, .383961E-02, .865500E-01,
40092 & .380621E-02, .416559E-01, .416559E-01, .368789E-02, .368830E-02,
40093 & .368830E-02, .368789E-02, .732657E-01, .365888E-02, .388235E-01,
40094 & .388235E-01, .350985E-02, .351025E-02, .351025E-02, .350985E-02,
40095 & .614686E-01, .348466E-02, .360931E-01, .360931E-01, .331425E-02,
40096 & .331462E-02, .331462E-02, .331425E-02, .511511E-01, .329240E-02,
40097 & .334751E-01, .334751E-01, .310835E-02, .310870E-02, .310870E-02,
40098 & .310835E-02, .422485E-01, .308941E-02, .309768E-01, .309768E-01,
40099 & .289805E-02, .289838E-02, .289838E-02, .289805E-02, .346590E-01,
40100 & .288164E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40101 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40102 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40103 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40104 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40105 & .752796E-01, .752796E-01, .816906E-04, .816906E-04, .816906E-04,
40106 & .816906E-04, .221322E+00, .298156E-18, .724376E-01, .724376E-01/
40107 DATA (DL(K),K= 2891, 2975) /
40108 & .100884E-02, .100894E-02, .100894E-02, .100884E-02, .224569E+00,
40109 & .938046E-03, .694166E-01, .694166E-01, .178592E-02, .178609E-02,
40110 & .178609E-02, .178592E-02, .220745E+00, .172460E-02, .662414E-01,
40111 & .662414E-01, .240001E-02, .240024E-02, .240024E-02, .240001E-02,
40112 & .210839E+00, .234694E-02, .629511E-01, .629511E-01, .286144E-02,
40113 & .286171E-02, .286171E-02, .286144E-02, .196463E+00, .281556E-02,
40114 & .595849E-01, .595849E-01, .318412E-02, .318441E-02, .318441E-02,
40115 & .318412E-02, .179204E+00, .314448E-02, .561822E-01, .561822E-01,
40116 & .338573E-02, .338605E-02, .338605E-02, .338573E-02, .160420E+00,
40117 & .335151E-02, .527801E-01, .527801E-01, .348530E-02, .348562E-02,
40118 & .348562E-02, .348530E-02, .141254E+00, .345578E-02, .494117E-01,
40119 & .494117E-01, .350098E-02, .350131E-02, .350131E-02, .350098E-02,
40120 & .122547E+00, .347555E-02, .461061E-01, .461061E-01, .344994E-02,
40121 & .345026E-02, .345026E-02, .344994E-02, .104908E+00, .342804E-02,
40122 & .428876E-01, .428876E-01, .334753E-02, .334784E-02, .334784E-02,
40123 & .334753E-02, .887264E-01, .332868E-02, .397764E-01, .397764E-01,
40124 & .320718E-02, .320748E-02, .320748E-02, .320718E-02, .742160E-01/
40125 DATA (DL(K),K= 2976, 3060) /
40126 & .319097E-02, .367882E-01, .367882E-01, .304033E-02, .304062E-02,
40127 & .304062E-02, .304033E-02, .614556E-01, .302641E-02, .339348E-01,
40128 & .339348E-01, .285650E-02, .285677E-02, .285677E-02, .285650E-02,
40129 & .504214E-01, .284454E-02, .312247E-01, .312247E-01, .266337E-02,
40130 & .266363E-02, .266363E-02, .266337E-02, .410205E-01, .265311E-02,
40131 & .286629E-01, .286629E-01, .246705E-02, .246730E-02, .246730E-02,
40132 & .246705E-02, .331166E-01, .245826E-02, .262521E-01, .262521E-01,
40133 & .227226E-02, .227248E-02, .227248E-02, .227226E-02, .265498E-01,
40134 & .226473E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40135 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40136 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40137 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40138 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40139 & .741335E-01, .741335E-01, .409835E-04, .409835E-04, .409835E-04,
40140 & .409835E-04, .235495E+00,-.158395E-17, .705990E-01, .705990E-01,
40141 & .938808E-03, .938883E-03, .938883E-03, .938808E-03, .235413E+00,
40142 & .903728E-03, .669383E-01, .669383E-01, .166382E-02, .166395E-02/
40143 DATA (DL(K),K= 3061, 3145) /
40144 & .166395E-02, .166382E-02, .227523E+00, .163381E-02, .631853E-01,
40145 & .631853E-01, .221128E-02, .221145E-02, .221145E-02, .221128E-02,
40146 & .213316E+00, .218562E-02, .593855E-01, .593855E-01, .259911E-02,
40147 & .259931E-02, .259931E-02, .259911E-02, .194833E+00, .257720E-02,
40148 & .555825E-01, .555825E-01, .284819E-02, .284841E-02, .284841E-02,
40149 & .284819E-02, .174012E+00, .282950E-02, .518174E-01, .518174E-01,
40150 & .298117E-02, .298140E-02, .298140E-02, .298117E-02, .152385E+00,
40151 & .296523E-02, .481268E-01, .481268E-01, .302067E-02, .302090E-02,
40152 & .302090E-02, .302067E-02, .131168E+00, .300708E-02, .445413E-01,
40153 & .445413E-01, .298689E-02, .298712E-02, .298712E-02, .298689E-02,
40154 & .111177E+00, .297532E-02, .410859E-01, .410859E-01, .289793E-02,
40155 & .289815E-02, .289815E-02, .289793E-02, .929352E-01, .288809E-02,
40156 & .377798E-01, .377798E-01, .276920E-02, .276941E-02, .276941E-02,
40157 & .276920E-02, .767178E-01, .276084E-02, .346372E-01, .346372E-01,
40158 & .261353E-02, .261373E-02, .261373E-02, .261353E-02, .626102E-01,
40159 & .260643E-02, .316676E-01, .316676E-01, .244134E-02, .244154E-02,
40160 & .244154E-02, .244134E-02, .505665E-01, .243531E-02, .288765E-01/
40161 DATA (DL(K),K= 3146, 3230) /
40162 & .288765E-01, .226087E-02, .226105E-02, .226105E-02, .226087E-02,
40163 & .404527E-01, .225576E-02, .262660E-01, .262660E-01, .207845E-02,
40164 & .207862E-02, .207862E-02, .207845E-02, .320820E-01, .207412E-02,
40165 & .238351E-01, .238351E-01, .189881E-02, .189897E-02, .189897E-02,
40166 & .189881E-02, .252422E-01, .189514E-02, .215808E-01, .215808E-01,
40167 & .172536E-02, .172551E-02, .172551E-02, .172536E-02, .197186E-01,
40168 & .172225E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40169 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40170 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40171 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40172 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40173 & .720339E-01, .720339E-01, .181946E-04, .181946E-04, .181946E-04,
40174 & .181946E-04, .254393E+00, .469256E-18, .677768E-01, .677768E-01,
40175 & .875835E-03, .875888E-03, .875888E-03, .875835E-03, .249966E+00,
40176 & .860480E-03, .634725E-01, .634725E-01, .153792E-02, .153801E-02,
40177 & .153801E-02, .153792E-02, .236824E+00, .152496E-02, .591619E-01,
40178 & .591619E-01, .201036E-02, .201048E-02, .201048E-02, .201036E-02/
40179 DATA (DL(K),K= 3231, 3315) /
40180 & .217211E+00, .199944E-02, .548948E-01, .548948E-01, .231978E-02,
40181 & .231992E-02, .231992E-02, .231978E-02, .193739E+00, .231058E-02,
40182 & .507162E-01, .507162E-01, .249460E-02, .249475E-02, .249475E-02,
40183 & .249460E-02, .168773E+00, .248686E-02, .466653E-01, .466653E-01,
40184 & .256217E-02, .256232E-02, .256232E-02, .256217E-02, .144012E+00,
40185 & .255566E-02, .427744E-01, .427744E-01, .254804E-02, .254820E-02,
40186 & .254820E-02, .254804E-02, .120695E+00, .254258E-02, .390676E-01,
40187 & .390676E-01, .247365E-02, .247380E-02, .247380E-02, .247365E-02,
40188 & .995452E-01, .246906E-02, .355626E-01, .355626E-01, .235710E-02,
40189 & .235725E-02, .235725E-02, .235710E-02, .809281E-01, .235325E-02,
40190 & .322703E-01, .322703E-01, .221303E-02, .221317E-02, .221317E-02,
40191 & .221303E-02, .649429E-01, .220980E-02, .291963E-01, .291963E-01,
40192 & .205294E-02, .205307E-02, .205307E-02, .205294E-02, .515039E-01,
40193 & .205024E-02, .263419E-01, .263419E-01, .188569E-02, .188581E-02,
40194 & .188581E-02, .188569E-02, .404102E-01, .188343E-02, .237044E-01,
40195 & .237044E-01, .171783E-02, .171795E-02, .171795E-02, .171783E-02,
40196 & .313959E-01, .171594E-02, .212782E-01, .212782E-01, .155409E-02/
40197 DATA (DL(K),K= 3316, 3400) /
40198 & .155419E-02, .155419E-02, .155409E-02, .241750E-01, .155251E-02,
40199 & .190555E-01, .190555E-01, .139767E-02, .139777E-02, .139777E-02,
40200 & .139767E-02, .184646E-01, .139635E-02, .170270E-01, .170270E-01,
40201 & .125065E-02, .125074E-02, .125074E-02, .125065E-02, .139996E-01,
40202 & .124955E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40203 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40204 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40205 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40206 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40207 & .687547E-01, .687547E-01, .676181E-05, .676181E-05, .676181E-05,
40208 & .676181E-05, .280728E+00,-.145838E-17, .637529E-01, .637529E-01,
40209 & .808781E-03, .808818E-03, .808818E-03, .808781E-03, .270033E+00,
40210 & .803169E-03, .588180E-01, .588180E-01, .139388E-02, .139394E-02,
40211 & .139394E-02, .139388E-02, .249568E+00, .138922E-02, .539945E-01,
40212 & .539945E-01, .178168E-02, .178176E-02, .178176E-02, .178168E-02,
40213 & .222743E+00, .177782E-02, .493317E-01, .493317E-01, .200838E-02,
40214 & .200848E-02, .200848E-02, .200838E-02, .192919E+00, .200519E-02/
40215 DATA (DL(K),K= 3401, 3485) /
40216 & .448709E-01, .448709E-01, .211009E-02, .211019E-02, .211019E-02,
40217 & .211009E-02, .162975E+00, .210745E-02, .406433E-01, .406433E-01,
40218 & .211805E-02, .211815E-02, .211815E-02, .211805E-02, .134716E+00,
40219 & .211586E-02, .366716E-01, .366716E-01, .205957E-02, .205968E-02,
40220 & .205968E-02, .205957E-02, .109289E+00, .205776E-02, .329687E-01,
40221 & .329687E-01, .195606E-02, .195616E-02, .195616E-02, .195606E-02,
40222 & .871955E-01, .195457E-02, .295400E-01, .295400E-01, .182447E-02,
40223 & .182456E-02, .182456E-02, .182447E-02, .685399E-01, .182323E-02,
40224 & .263849E-01, .263849E-01, .167765E-02, .167774E-02, .167774E-02,
40225 & .167765E-02, .531615E-01, .167663E-02, .234975E-01, .234975E-01,
40226 & .152505E-02, .152514E-02, .152514E-02, .152505E-02, .407334E-01,
40227 & .152421E-02, .208683E-01, .208683E-01, .137342E-02, .137350E-02,
40228 & .137350E-02, .137342E-02, .308674E-01, .137273E-02, .184852E-01,
40229 & .184852E-01, .122732E-02, .122739E-02, .122739E-02, .122732E-02,
40230 & .231578E-01, .122675E-02, .163340E-01, .163340E-01, .108968E-02,
40231 & .108975E-02, .108975E-02, .108968E-02, .172149E-01, .108921E-02,
40232 & .143996E-01, .143996E-01, .962198E-03, .962260E-03, .962260E-03/
40233 DATA (DL(K),K= 3486, 3570) /
40234 & .962198E-03, .126908E-01, .961815E-03, .126661E-01, .126661E-01,
40235 & .845675E-03, .845732E-03, .845732E-03, .845675E-03, .928555E-02,
40236 & .845361E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40237 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40238 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40239 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40240 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40241 & .639050E-01, .639050E-01, .189600E-05, .189600E-05, .189600E-05,
40242 & .189600E-05, .320203E+00, .545701E-18, .581555E-01, .581555E-01,
40243 & .725861E-03, .725886E-03, .725886E-03, .725861E-03, .299305E+00,
40244 & .724320E-03, .526376E-01, .526376E-01, .121568E-02, .121572E-02,
40245 & .121572E-02, .121568E-02, .267591E+00, .121442E-02, .473911E-01,
40246 & .473911E-01, .150820E-02, .150825E-02, .150825E-02, .150820E-02,
40247 & .230364E+00, .150718E-02, .424558E-01, .424558E-01, .164949E-02,
40248 & .164955E-02, .164955E-02, .164949E-02, .191972E+00, .164867E-02,
40249 & .378600E-01, .378600E-01, .168256E-02, .168262E-02, .168262E-02,
40250 & .168256E-02, .155818E+00, .168189E-02, .336181E-01, .336181E-01/
40251 DATA (DL(K),K= 3571, 3655) /
40252 & .164080E-02, .164086E-02, .164086E-02, .164080E-02, .123609E+00,
40253 & .164026E-02, .297349E-01, .297349E-01, .155136E-02, .155142E-02,
40254 & .155142E-02, .155136E-02, .961680E-01, .155092E-02, .262052E-01,
40255 & .262052E-01, .143382E-02, .143388E-02, .143388E-02, .143382E-02,
40256 & .735522E-01, .143346E-02, .230171E-01, .230171E-01, .130247E-02,
40257 & .130253E-02, .130253E-02, .130247E-02, .553916E-01, .130218E-02,
40258 & .201539E-01, .201539E-01, .116733E-02, .116739E-02, .116739E-02,
40259 & .116733E-02, .411453E-01, .116710E-02, .175955E-01, .175955E-01,
40260 & .103505E-02, .103510E-02, .103510E-02, .103505E-02, .301858E-01,
40261 & .103486E-02, .153199E-01, .153199E-01, .909828E-03, .909880E-03,
40262 & .909880E-03, .909828E-03, .218957E-01, .909677E-03, .133043E-01,
40263 & .133043E-01, .794097E-03, .794146E-03, .794146E-03, .794097E-03,
40264 & .157204E-01, .793976E-03, .115259E-01, .115259E-01, .689012E-03,
40265 & .689057E-03, .689057E-03, .689012E-03, .111816E-01, .688913E-03,
40266 & .996208E-02, .996208E-02, .594880E-03, .594922E-03, .594922E-03,
40267 & .594880E-03, .788559E-02, .594801E-03, .859151E-02, .859151E-02,
40268 & .511455E-03, .511493E-03, .511493E-03, .511455E-03, .551865E-02/
40269 DATA (DL(K),K= 3656, 3740) /
40270 & .511392E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40271 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40272 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40273 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40274 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40275 & .567030E-01, .567030E-01, .317692E-06, .317692E-06, .317692E-06,
40276 & .317692E-06, .387655E+00,-.196551E-18, .502560E-01, .502560E-01,
40277 & .611827E-03, .611838E-03, .611838E-03, .611827E-03, .346975E+00,
40278 & .611576E-03, .442838E-01, .442838E-01, .981907E-03, .981929E-03,
40279 & .981929E-03, .981907E-03, .295290E+00, .981708E-03, .388018E-01,
40280 & .388018E-01, .116826E-02, .116829E-02, .116829E-02, .116826E-02,
40281 & .241157E+00, .116810E-02, .338227E-01, .338227E-01, .122537E-02,
40282 & .122541E-02, .122541E-02, .122537E-02, .190062E+00, .122525E-02,
40283 & .293442E-01, .293442E-01, .120047E-02, .120052E-02, .120052E-02,
40284 & .120047E-02, .145706E+00, .120037E-02, .253494E-01, .253494E-01,
40285 & .112580E-02, .112585E-02, .112585E-02, .112580E-02, .109110E+00,
40286 & .112572E-02, .218132E-01, .218132E-01, .102498E-02, .102503E-02/
40287 DATA (DL(K),K= 3741, 3825) /
40288 & .102503E-02, .102498E-02, .800661E-01, .102492E-02, .187030E-01,
40289 & .187030E-01, .913395E-03, .913450E-03, .913450E-03, .913395E-03,
40290 & .577342E-01, .913348E-03, .159833E-01, .159833E-01, .800935E-03,
40291 & .800990E-03, .800990E-03, .800935E-03, .409782E-01, .800898E-03,
40292 & .136172E-01, .136172E-01, .693698E-03, .693751E-03, .693751E-03,
40293 & .693698E-03, .286780E-01, .693669E-03, .115681E-01, .115681E-01,
40294 & .595013E-03, .595064E-03, .595064E-03, .595013E-03, .198197E-01,
40295 & .594990E-03, .980105E-02, .980105E-02, .506423E-03, .506471E-03,
40296 & .506471E-03, .506423E-03, .135410E-01, .506405E-03, .828286E-02,
40297 & .828286E-02, .428323E-03, .428368E-03, .428368E-03, .428323E-03,
40298 & .915498E-02, .428309E-03, .698303E-02, .698303E-02, .360397E-03,
40299 & .360439E-03, .360439E-03, .360397E-03, .613133E-02, .360386E-03,
40300 & .587373E-02, .587373E-02, .301934E-03, .301973E-03, .301973E-03,
40301 & .301934E-03, .407092E-02, .301925E-03, .492985E-02, .492985E-02,
40302 & .252029E-03, .252064E-03, .252064E-03, .252029E-03, .268179E-02,
40303 & .252022E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40304 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40305 DATA (DL(K),K= 3826, 3910) /
40306 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40307 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40308 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40309 & .450567E-01, .450567E-01, .151200E-07, .151200E-07, .151200E-07,
40310 & .151200E-07, .542258E+00,-.767310E-18, .381624E-01, .381624E-01,
40311 & .438685E-03, .438751E-03, .438751E-03, .438685E-03, .447480E+00,
40312 & .438674E-03, .321250E-01, .321250E-01, .653465E-03, .653574E-03,
40313 & .653574E-03, .653465E-03, .347952E+00, .653456E-03, .268827E-01,
40314 & .268827E-01, .724735E-03, .724868E-03, .724868E-03, .724735E-03,
40315 & .258636E+00, .724728E-03, .223751E-01, .223751E-01, .709421E-03,
40316 & .709567E-03, .709567E-03, .709421E-03, .185088E+00, .709417E-03,
40317 & .185359E-01, .185359E-01, .650478E-03, .650626E-03, .650626E-03,
40318 & .650478E-03, .128686E+00, .650474E-03, .152906E-01, .152906E-01,
40319 & .572423E-03, .572567E-03, .572567E-03, .572423E-03, .873875E-01,
40320 & .572420E-03, .125654E-01, .125654E-01, .490165E-03, .490302E-03,
40321 & .490302E-03, .490165E-03, .581141E-01, .490163E-03, .102901E-01,
40322 & .102901E-01, .411740E-03, .411866E-03, .411866E-03, .411740E-03/
40323 DATA (DL(K),K= 3911, 3995) /
40324 & .379596E-01, .411738E-03, .839975E-02, .839975E-02, .340986E-03,
40325 & .341101E-03, .341101E-03, .340986E-03, .244073E-01, .340985E-03,
40326 & .683634E-02, .683634E-02, .279417E-03, .279520E-03, .279520E-03,
40327 & .279417E-03, .154717E-01, .279416E-03, .554846E-02, .554846E-02,
40328 & .227114E-03, .227204E-03, .227204E-03, .227114E-03, .968450E-02,
40329 & .227113E-03, .449143E-02, .449143E-02, .183425E-03, .183504E-03,
40330 & .183504E-03, .183425E-03, .599306E-02, .183425E-03, .362676E-02,
40331 & .362676E-02, .147387E-03, .147455E-03, .147455E-03, .147387E-03,
40332 & .366977E-02, .147387E-03, .292164E-02, .292164E-02, .117936E-03,
40333 & .117995E-03, .117995E-03, .117936E-03, .222583E-02, .117936E-03,
40334 & .234830E-02, .234830E-02, .940414E-04, .940914E-04, .940914E-04,
40335 & .940414E-04, .133844E-02, .940412E-04, .188339E-02, .188339E-02,
40336 & .747651E-04, .748074E-04, .748074E-04, .747651E-04, .798451E-03,
40337 & .747649E-04, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40338 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40339 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40340 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40341 DATA (DL(K),K= 3996, 4000) /
40342 & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40347 IF(X.GT.0.9985) RETURN
40353 IF(I.EQ.3.AND.X.GT.0.95) GOTO 19
40354 IF(I.EQ.8.AND.X.GT.0.95) GOTO 19
40361 A1 = PHO_CKMTFV(X,F1)
40362 A2 = PHO_CKMTFV(X,F2)
40363 QQ(I)=A1*(S2-S)/DELTA+A2*(S-S1)/DELTA
40369 *$ CREATE PHO_CKMTFV.FOR
40371 CDECK ID>, PHO_CKMTFV
40372 REAL FUNCTION PHO_CKMTFV(X,FVL)
40373 C**********************************************************************
40375 C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
40376 C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
40377 C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
40380 C**********************************************************************
40383 DIMENSION FVL(25),XGRID(25)
40385 C input/output channels
40387 COMMON /POINOU/ LI,LO
40389 DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
40390 *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
40394 IF(X.LT.XGRID(I)) GO TO 2
40399 ELSE IF(I.GT.23) THEN
40405 BXI=LOG(1.-XGRID(I))
40407 BXJ=LOG(1.-XGRID(J))
40409 BXK=LOG(1.-XGRID(K))
40410 FI=LOG(ABS(FVL(I)) +1.E-15)
40411 FJ=LOG(ABS(FVL(J)) +1.E-16)
40412 FK=LOG(ABS(FVL(K)) +1.E-17)
40413 DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
40414 ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
40416 ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
40417 BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
40418 IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
40420 C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
40421 C WRITE(LO,2001) X,FVL
40422 C 2001 FORMAT(8E12.4)
40423 C WRITE(LO,2001) ALPHA,BETA,ALOGA,DET
40425 PHO_CKMTFV=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
40429 *$ CREATE PHO_SASGAM.FOR
40431 CDECK ID>, PHO_SASGAM
40432 C***********************************************************************
40433 C...SaSgam version 2 - parton distributions of the photon
40434 C...by Gerhard A. Schuler and Torbjorn Sjostrand
40435 C...For further information see Z. Phys. C68 (1995) 607
40436 C...and Phys. Lett. B376 (1996) 193.
40438 C...18 January 1996: original code.
40439 C...22 July 1996: calculation of BETA moved in SASBEH.
40441 C!!!Note that one further call parameter - IP2 - has been added
40442 C!!!to the SASGAM argument list compared with version 1.
40444 C...The user should only need to call the SASGAM routine,
40445 C...which in turn calls the auxiliary routines SASVMD, SASANO,
40446 C...SASBEH and SASDIR. The package is self-contained.
40448 C...One particular aspect of these parametrizations is that F2 for
40449 C...the photon is not obtained just as the charge-squared-weighted
40450 C...sum of quark distributions, but differ in the treatment of
40451 C...heavy flavours (in F2 the DIS relation W2 = Q2*(1-x)/x restricts
40452 C...the kinematics range of heavy-flavour production, but the same
40453 C...kinematics is not relevant e.g. for jet production) and, for the
40454 C...'MSbar' fits, in the addition of a Cgamma term related to the
40455 C...separation of direct processes. Schematically:
40456 C...PDF = VMD (rho, omega, phi) + anomalous (d, u, s, c, b).
40457 C...F2 = VMD (rho, omega, phi) + anomalous (d, u, s) +
40458 C... Bethe-Heitler (c, b) (+ Cgamma (d, u, s)).
40459 C...The J/psi and Upsilon states have not been included in the VMD sum,
40460 C...but low c and b masses in the other components should compensate
40461 C...for this in a duality sense.
40463 C...The calling sequence is the following:
40464 C CALL SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40465 C...with the following declaration statement:
40466 C DIMENSION XPDFGM(-6:6)
40467 C...and, optionally, further information in:
40468 C COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
40470 C COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
40471 C...Input: ISET = 1 : SaS set 1D ('DIS', Q0 = 0.6 GeV)
40472 C = 2 : SaS set 1M ('MSbar', Q0 = 0.6 GeV)
40473 C = 3 : SaS set 2D ('DIS', Q0 = 2 GeV)
40474 C = 4 : SaS set 2M ('MSbar', Q0 = 2 GeV)
40477 C P2 : P2 value; should be = 0. for an on-shell photon.
40478 C IP2 : scheme used to evaluate off-shell anomalous component.
40479 C = 0 : recommended default, see = 7.
40480 C = 1 : dipole dampening by integration; very time-consuming.
40481 C = 2 : P_0^2 = max( Q_0^2, P^2 )
40482 C = 3 : P_0^2 = Q_0^2 + P^2.
40483 C = 4 : P_{eff} that preserves momentum sum.
40484 C = 5 : P_{int} that preserves momentum and average
40486 C = 6 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
40487 C = 7 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
40488 C...Output: F2GM : F2 value of the photon (including factors of alpha_em).
40489 C XPFDGM : x times parton distribution functions of the photon,
40490 C with elements 0 = g, 1 = d, 2 = u, 3 = s, 4 = c, 5 = b,
40491 C 6 = t (always empty!), - for antiquarks (result is same).
40492 C...The breakdown by component is stored in the commonblock SASCOM,
40493 C with elements as above.
40494 C XPVMD : rho, omega, phi VMD part only of output.
40495 C XPANL : d, u, s anomalous part only of output.
40496 C XPANH : c, b anomalous part only of output.
40497 C XPBEH : c, b Bethe-Heitler part only of output.
40498 C XPDIR : Cgamma (direct contribution) part only of output.
40499 C...The above arrays do not distinguish valence and sea contributions,
40500 C...although this information is available internally. The additional
40501 C...commonblock SASVAL provides the valence part only of the above
40502 C...distributions. Array names VXPVMD, VXPANL and VXPANH correspond
40503 C...to XPVMD, XPANL and XPANH, while XPBEH and XPDIR are valence only
40504 C...and therefore not given doubly. VXPDGM gives the sum of valence
40505 C...parts, and so matches XPDFGM. The difference, i.e. XPVMD-VXPVMD
40506 C...and so on, gives the sea part only.
40507 C***********************************************************************
40509 SUBROUTINE PHO_SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40510 C...Purpose: to construct the F2 and parton distributions of the photon
40511 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
40512 C...For F2, c and b are included by the Bethe-Heitler formula;
40513 C...in the 'MSbar' scheme additionally a Cgamma term is added.
40515 DIMENSION XPDFGM(-6:6)
40517 C input/output channels
40519 COMMON /POINOU/ LI,LO
40521 COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
40523 COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
40524 CPH SAVE /SASCOM/,/SASVAL/
40526 C...Temporary array.
40527 DIMENSION XPGA(-6:6), VXPGA(-6:6)
40528 C...Charm and bottom masses (low to compensate for J/psi etc.).
40529 DATA PMC/1.3/, PMB/4.6/
40530 C...alpha_em and alpha_em/(2*pi).
40531 DATA AEM/0.007297/, AEM2PI/0.0011614/
40532 C...Lambda value for 4 flavours.
40534 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
40536 C...VMD couplings f_V**2/(4*pi).
40537 DATA FRHO/2.20/, FOMEGA/23.6/, FPHI/18.4/
40538 C...Masses for rho (=omega) and phi.
40539 DATA PMRHO/0.770/, PMPHI/1.020/
40540 C...Number of points in integration for IP2=1.
40558 C...Check that input sensible.
40559 IF(ISET.LE.0.OR.ISET.GE.5) THEN
40560 WRITE(LO,*) ' FATAL ERROR: SaSgam called for unknown set'
40561 WRITE(LO,*) ' ISET = ',ISET
40564 IF(X.LE.0..OR.X.GT.1.) THEN
40565 WRITE(LO,*) ' FATAL ERROR: SaSgam called for unphysical x'
40566 WRITE(LO,*) ' X = ',X
40570 C...Set Q0 cut-off parameter as function of set used.
40578 C...Scale choice for off-shell photon; common factors.
40583 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
40584 FACNOR=LOG(Q2/Q02)/NSTEP
40585 ELSEIF(IP2.EQ.2) THEN
40587 ELSEIF(IP2.EQ.3) THEN
40589 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
40590 ELSEIF(IP2.EQ.4) THEN
40591 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40592 & ((Q2+P2)*(Q02+P2)))
40593 ELSEIF(IP2.EQ.5) THEN
40594 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40595 & ((Q2+P2)*(Q02+P2)))
40596 P2MX=Q0*SQRT(P2MXA)
40597 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
40598 ELSEIF(IP2.EQ.6) THEN
40599 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40600 & ((Q2+P2)*(Q02+P2)))
40601 P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
40603 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40604 & ((Q2+P2)*(Q02+P2)))
40605 P2MX=Q0*SQRT(P2MXA)
40607 P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
40608 P2MXB=MAX(0.,1.-P2/Q2)*P2MXB+MIN(1.,P2/Q2)*P2MXA
40609 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
40612 C...Call VMD parametrization for d quark and use to give rho, omega,
40613 C...phi. Note dipole dampening for off-shell photon.
40614 CALL PHO_SASVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40618 FACUD=AEM*(1./FRHO+1./FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
40619 FACS=AEM*(1./FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
40621 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
40623 XPVMD(1)=XPVMD(1)+(1.-FRACU)*FACUD*XFVAL
40624 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
40625 XPVMD(3)=XPVMD(3)+FACS*XFVAL
40626 XPVMD(-1)=XPVMD(-1)+(1.-FRACU)*FACUD*XFVAL
40627 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
40628 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
40629 VXPVMD(1)=(1.-FRACU)*FACUD*XFVAL
40630 VXPVMD(2)=FRACU*FACUD*XFVAL
40631 VXPVMD(3)=FACS*XFVAL
40632 VXPVMD(-1)=(1.-FRACU)*FACUD*XFVAL
40633 VXPVMD(-2)=FRACU*FACUD*XFVAL
40634 VXPVMD(-3)=FACS*XFVAL
40637 C...Anomalous parametrizations for different strategies
40638 C...for off-shell photons; except full integration.
40640 C...Call anomalous parametrization for d + u + s.
40641 CALL PHO_SASANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40643 XPANL(KFL)=FACNOR*XPGA(KFL)
40644 VXPANL(KFL)=FACNOR*VXPGA(KFL)
40647 C...Call anomalous parametrization for c and b.
40648 CALL PHO_SASANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40650 XPANH(KFL)=FACNOR*XPGA(KFL)
40651 VXPANH(KFL)=FACNOR*VXPGA(KFL)
40653 CALL PHO_SASANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40655 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
40656 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
40660 C...Special option: loop over flavours and integrate over k2.
40662 DO 160 ISTEP=1,NSTEP
40663 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5)/NSTEP)
40664 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
40665 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
40666 CALL PHO_SASVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
40667 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
40668 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8./9.)
40669 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2./9.)
40671 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
40672 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
40673 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
40674 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
40680 C...Call Bethe-Heitler term expression for charm and bottom.
40681 CALL PHO_SASBEH(4,X,Q2,P2,PMC**2,XPBH)
40684 CALL PHO_SASBEH(5,X,Q2,P2,PMB**2,XPBH)
40688 C...For MSbar subtraction call C^gamma term expression for d, u, s.
40689 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
40690 CALL PHO_SASDIR(X,Q2,P2,Q02,XPGA)
40692 XPDIR(KFL)=XPGA(KFL)
40696 C...Store result in output array.
40699 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4./9.
40700 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
40701 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
40702 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
40703 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
40709 C*********************************************************************
40711 *$ CREATE PHO_SASVMD.FOR
40713 CDECK ID>, PHO_SASVMD
40714 SUBROUTINE PHO_SASVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40715 C...Purpose: to evaluate the VMD parton distributions of a photon,
40716 C...evolved homogeneously from an initial scale P2 to Q2.
40717 C...Does not include dipole suppression factor.
40718 C...ISET is parton distribution set, see above;
40719 C...additionally ISET=0 is used for the evolution of an anomalous photon
40720 C...which branched at a scale P2 and then evolved homogeneously to Q2.
40721 C...ALAM is the 4-flavour Lambda, which is automatically converted
40722 C...to 3- and 5-flavour equivalents as needed.
40724 DIMENSION XPGA(-6:6), VXPGA(-6:6)
40726 C input/output channels
40728 COMMON /POINOU/ LI,LO
40730 DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
40739 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
40740 ALAM3=ALAM*(PMC/ALAM)**(2./27.)
40741 ALAM5=ALAM*(ALAM/PMB)**(2./23.)
40742 P2EFF=MAX(P2,1.2*ALAM3**2)
40743 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
40744 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
40745 Q2EFF=MAX(Q2,P2EFF)
40747 C...Find number of flavours at lower and upper scale.
40749 IF(P2EFF.LT.PMC**2) NFP=3
40750 IF(P2EFF.GT.PMB**2) NFP=5
40752 IF(Q2EFF.LT.PMC**2) NFQ=3
40753 IF(Q2EFF.GT.PMB**2) NFQ=5
40755 C...Find s as sum of 3-, 4- and 5-flavour parts.
40759 IF(NFQ.EQ.3) Q2DIV=Q2EFF
40760 S=S+(6./27.)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
40762 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
40764 IF(NFP.EQ.3) P2DIV=PMC**2
40766 IF(NFQ.EQ.5) Q2DIV=PMB**2
40767 S=S+(6./25.)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
40771 IF(NFP.EQ.5) P2DIV=P2EFF
40772 S=S+(6./23.)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
40775 C...Calculate frequent combinations of x and s.
40782 C...Evaluate homogeneous anomalous parton distributions below or
40783 C...above threshold.
40785 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40786 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40787 XVAL = X * 1.5 * (X**2+X1**2)
40791 XVAL = (1.5/(1.-0.197*S+4.33*S2)*X**2 + (1.5+2.10*S)/
40792 & (1.+3.29*S)*X1**2 + 5.23*S/(1.+1.17*S+19.9*S3)*X*X1) *
40793 & X**(1./(1.+1.5*S)) * (1.-X**2)**(2.667*S)
40794 XGLU = 4.*S/(1.+4.76*S+15.2*S2+29.3*S4) *
40795 & X**(-2.03*S/(1.+2.44*S)) * (X1*XL)**(1.333*S) *
40796 & ((4.*X**2+7.*X+4.)*X1/3. - 2.*X*(1.+X)*XL)
40797 XSEA = S2/(1.+4.54*S+8.19*S2+8.05*S3) *
40798 & X**(-1.54*S/(1.+1.29*S)) * X1**(2.667*S) *
40799 & ((8.-73.*X+62.*X**2)*X1/9. + (3.-8.*X**2/3.)*X*XL +
40800 & (2.*X-1.)*X*XL**2)
40803 C...Evaluate set 1D parton distributions below or above threshold.
40804 ELSEIF(ISET.EQ.1) THEN
40805 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40806 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40807 XVAL = 1.294 * X**0.80 * X1**0.76
40808 XGLU = 1.273 * X**0.40 * X1**1.76
40809 XSEA = 0.100 * X1**3.76
40811 XVAL = 1.294/(1.+0.252*S+3.079*S2) * X**(0.80-0.13*S) *
40812 & X1**(0.76+0.667*S) * XL**(2.*S)
40813 XGLU = 7.90*S/(1.+5.50*S) * EXP(-5.16*S) *
40814 & X**(-1.90*S/(1.+3.60*S)) * X1**1.30 * XL**(0.50+3.*S) +
40815 & 1.273 * EXP(-10.*S) * X**0.40 * X1**(1.76+3.*S)
40816 XSEA = (0.1-0.397*S2+1.121*S3)/(1.+5.61*S2+5.26*S3) *
40817 & X**(-7.32*S2/(1.+10.3*S2)) *
40818 & X1**((3.76+15.*S+12.*S2)/(1.+4.*S))
40819 XSEA0 = 0.100 * X1**3.76
40822 C...Evaluate set 1M parton distributions below or above threshold.
40823 ELSEIF(ISET.EQ.2) THEN
40824 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40825 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40826 XVAL = 0.8477 * X**0.51 * X1**1.37
40827 XGLU = 3.42 * X**0.255 * X1**2.37
40830 XVAL = 0.8477/(1.+1.37*S+2.18*S2+3.73*S3) * X**(0.51+0.21*S)
40831 & * X1**1.37 * XL**(2.667*S)
40832 XGLU = 24.*S/(1.+9.6*S+0.92*S2+14.34*S3) * EXP(-5.94*S) *
40833 & X**((-0.013-1.80*S)/(1.+3.14*S)) * X1**(2.37+0.4*S) *
40834 & XL**(0.32+3.6*S) + 3.42 * EXP(-12.*S) * X**0.255 *
40836 XSEA = 0.842*S/(1.+21.3*S-33.2*S2+229.*S3) *
40837 & X**((0.13-2.90*S)/(1.+5.44*S)) * X1**(3.45+0.5*S) *
40842 C...Evaluate set 2D parton distributions below or above threshold.
40843 ELSEIF(ISET.EQ.3) THEN
40844 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40845 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40846 XVAL = X**0.46 * X1**0.64 + 0.76 * X
40847 XGLU = 1.925 * X1**2
40848 XSEA = 0.242 * X1**4
40850 XVAL = (1.+0.186*S)/(1.-0.209*S+1.495*S2) * X**(0.46+0.25*S)
40851 & * X1**((0.64+0.14*S+5.*S2)/(1.+S)) * XL**(1.9*S) +
40852 & (0.76+0.4*S) * X * X1**(2.667*S)
40853 XGLU = (1.925+5.55*S+147.*S2)/(1.-3.59*S+3.32*S2) *
40854 & EXP(-18.67*S) * X**((-5.81*S-5.34*S2)/(1.+29.*S-4.26*S2))
40855 & * X1**((2.-5.9*S)/(1.+1.7*S)) * XL**(9.3*S/(1.+1.7*S))
40856 XSEA = (0.242-0.252*S+1.19*S2)/(1.-0.607*S+21.95*S2) *
40857 & X**(-12.1*S2/(1.+2.62*S+16.7*S2)) * X1**4 * XL**S
40858 XSEA0 = 0.242 * X1**4
40861 C...Evaluate set 2M parton distributions below or above threshold.
40862 ELSEIF(ISET.EQ.4) THEN
40863 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40864 &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40865 XVAL = 1.168 * X**0.50 * X1**2.60 + 0.965 * X
40866 XGLU = 1.808 * X1**2
40867 XSEA = 0.209 * X1**4
40869 XVAL = (1.168+1.771*S+29.35*S2) * EXP(-5.776*S) *
40870 & X**((0.5+0.208*S)/(1.-0.794*S+1.516*S2)) *
40871 & X1**((2.6+7.6*S)/(1.+5.*S)) * XL**(5.15*S/(1.+2.*S)) +
40872 & (0.965+22.35*S)/(1.+18.4*S) * X * X1**(2.667*S)
40873 XGLU = (1.808+29.9*S)/(1.+26.4*S) * EXP(-5.28*S) *
40874 & X**((-5.35*S-10.11*S2)/(1.+31.71*S)) *
40875 & X1**((2.-7.3*S+4.*S2)/(1.+2.5*S)) *
40876 & XL**(10.9*S/(1.+2.5*S))
40877 XSEA = (0.209+0.644*S2)/(1.+0.319*S+17.6*S2) *
40878 & X**((-0.373*S-7.71*S2)/(1.+0.815*S+11.0*S2)) *
40879 & X1**(4.+S) * XL**(0.45*S)
40880 XSEA0 = 0.209 * X1**4
40884 C...Threshold factors for c and b sea.
40885 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
40887 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
40888 SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40890 XCHM=XSEA*(1.-(SCH/SLL)**2)
40892 XCHM=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SCH/SLL)
40896 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
40897 SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40899 XBOT=XSEA*(1.-(SBT/SLL)**2)
40901 XBOT=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SBT/SLL)
40905 C...Fill parton distributions.
40912 XPGA(KFA)=XPGA(KFA)+XVAL
40914 XPGA(-KFL)=XPGA(KFL)
40922 C*********************************************************************
40924 *$ CREATE PHO_SASANO.FOR
40926 CDECK ID>, PHO_SASANO
40927 SUBROUTINE PHO_SASANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40928 C...Purpose: to evaluate the parton distributions of the anomalous
40929 C...photon, inhomogeneously evolved from a scale P2 (where it vanishes)
40931 C...KF=0 gives the sum over (up to) 5 flavours,
40932 C...KF<0 limits to flavours up to abs(KF),
40933 C...KF>0 is for flavour KF only.
40934 C...ALAM is the 4-flavour Lambda, which is automatically converted
40935 C...to 3- and 5-flavour equivalents as needed.
40938 C input/output channels
40940 COMMON /POINOU/ LI,LO
40942 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
40943 DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
40950 IF(Q2.LE.P2) RETURN
40953 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
40954 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2./27.))**2
40956 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2./23.))**2
40957 P2EFF=MAX(P2,1.2*ALAMSQ(3))
40958 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
40959 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
40960 Q2EFF=MAX(Q2,P2EFF)
40963 C...Find number of flavours at lower and upper scale.
40965 IF(P2EFF.LT.PMC**2) NFP=3
40966 IF(P2EFF.GT.PMB**2) NFP=5
40968 IF(Q2EFF.LT.PMC**2) NFQ=3
40969 IF(Q2EFF.GT.PMB**2) NFQ=5
40971 C...Define range of flavour loop.
40975 ELSEIF(KF.LT.0) THEN
40983 C...Loop over flavours the photon can branch into.
40984 DO 110 KFL=KFLMN,KFLMX
40986 C...Light flavours: calculate t range and (approximate) s range.
40987 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
40988 TDIFF=LOG(Q2EFF/P2EFF)
40989 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
40990 & LOG(P2EFF/ALAMSQ(NFQ)))
40991 IF(NFQ.GT.NFP) THEN
40993 IF(NFQ.EQ.4) Q2DIV=PMC**2
40994 SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
40995 & LOG(P2EFF/ALAMSQ(NFQ)))
40996 SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
40997 & LOG(P2EFF/ALAMSQ(NFQ-1)))
40998 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
41000 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
41002 SNF4=(6./(33.-2.*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
41003 & LOG(P2EFF/ALAMSQ(4)))
41004 SNF3=(6./(33.-2.*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
41005 & LOG(P2EFF/ALAMSQ(3)))
41006 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
41009 C...u and s quark do not need a separate treatment when d has been done.
41010 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
41012 C...Charm: as above, but only include range above c threshold.
41013 ELSEIF(KFL.EQ.4) THEN
41014 IF(Q2.LE.PMC**2) GOTO 110
41015 P2EFF=MAX(P2EFF,PMC**2)
41016 Q2EFF=MAX(Q2EFF,P2EFF)
41017 TDIFF=LOG(Q2EFF/P2EFF)
41018 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41019 & LOG(P2EFF/ALAMSQ(NFQ)))
41020 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
41022 SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
41023 & LOG(P2EFF/ALAMSQ(NFQ)))
41024 SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
41025 & LOG(P2EFF/ALAMSQ(NFQ-1)))
41026 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
41029 C...Bottom: as above, but only include range above b threshold.
41030 ELSEIF(KFL.EQ.5) THEN
41031 IF(Q2.LE.PMB**2) GOTO 110
41032 P2EFF=MAX(P2EFF,PMB**2)
41033 Q2EFF=MAX(Q2,P2EFF)
41034 TDIFF=LOG(Q2EFF/P2EFF)
41035 S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41036 & LOG(P2EFF/ALAMSQ(NFQ)))
41039 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
41041 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4./9.
41042 FAC=AEM2PI*2.*CHSQ*TDIFF
41044 C...Evaluate parton distributions (normalized to unit momentum sum).
41045 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
41046 XVAL= ((1.5+2.49*S+26.9*S**2)/(1.+32.3*S**2)*X**2 +
41047 & (1.5-0.49*S+7.83*S**2)/(1.+7.68*S**2)*(1.-X)**2 +
41048 & 1.5*S/(1.-3.2*S+7.*S**2)*X*(1.-X)) *
41049 & X**(1./(1.+0.58*S)) * (1.-X**2)**(2.5*S/(1.+10.*S))
41050 XGLU= 2.*S/(1.+4.*S+7.*S**2) *
41051 & X**(-1.67*S/(1.+2.*S)) * (1.-X**2)**(1.2*S) *
41052 & ((4.*X**2+7.*X+4.)*(1.-X)/3. - 2.*X*(1.+X)*XL)
41053 XSEA= 0.333*S**2/(1.+4.90*S+4.69*S**2+21.4*S**3) *
41054 & X**(-1.18*S/(1.+1.22*S)) * (1.-X)**(1.2*S) *
41055 & ((8.-73.*X+62.*X**2)*(1.-X)/9. + (3.-8.*X**2/3.)*X*XL +
41056 & (2.*X-1.)*X*XL**2)
41058 C...Threshold factors for c and b sea.
41059 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
41061 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
41062 SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41063 XCHM=XSEA*(1.-(SCH/SLL)**3)
41066 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
41067 SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41068 XBOT=XSEA*(1.-(SBT/SLL)**3)
41072 C...Add contribution of each valence flavour.
41073 XPGA(0)=XPGA(0)+FAC*XGLU
41074 XPGA(1)=XPGA(1)+FAC*XSEA
41075 XPGA(2)=XPGA(2)+FAC*XSEA
41076 XPGA(3)=XPGA(3)+FAC*XSEA
41077 XPGA(4)=XPGA(4)+FAC*XCHM
41078 XPGA(5)=XPGA(5)+FAC*XBOT
41079 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
41080 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
41083 XPGA(-KFL)=XPGA(KFL)
41084 VXPGA(-KFL)=VXPGA(KFL)
41089 C*********************************************************************
41091 *$ CREATE PHO_SASBEH.FOR
41093 CDECK ID>, PHO_SASBEH
41094 SUBROUTINE PHO_SASBEH(KF,X,Q2,P2,PM2,XPBH)
41095 C...Purpose: to evaluate the Bethe-Heitler cross section for
41096 C...heavy flavour production.
41098 DATA AEM2PI/0.0011614/
41104 C...Check kinematics limits.
41105 IF(X.GE.Q2/(4.*PM2+Q2+P2)) RETURN
41108 IF(BETA2.LT.1E-10) RETURN
41112 C...Simple case: P2 = 0.
41113 IF(P2.LT.1E-4) THEN
41114 IF(BETA.LT.0.99) THEN
41115 XBL=LOG((1.+BETA)/(1.-BETA))
41117 XBL=LOG((1.+BETA)**2*W2/(4.*PM2))
41119 SIGBH=BETA*(8.*X*(1.-X)-1.-RMQ*X*(1.-X))+
41120 & XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)
41122 C...Complicated case: P2 > 0, based on approximation of
41123 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
41125 RPQ=1.-4.*X**2*P2/Q2
41126 IF(RPQ.GT.1E-10) THEN
41127 RPBE=SQRT(RPQ*BETA2)
41128 IF(RPBE.LT.0.99) THEN
41129 XBL=LOG((1.+RPBE)/(1.-RPBE))
41130 XBI=2.*RPBE/(1.-RPBE**2)
41132 RPBESN=4.*PM2/W2+(4.*X**2*P2/Q2)*BETA2
41133 XBL=LOG((1.+RPBE)**2/RPBESN)
41136 SIGBH=BETA*(6.*X*(1.-X)-1.)+
41137 & XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)+
41138 & XBI*(2.*X/Q2)*(PM2*X*(2.-RMQ)-P2*X)
41142 C...Multiply by charge-squared etc. to get parton distribution.
41144 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4./9.
41145 XPBH=3.*CHSQ*AEM2PI*X*SIGBH
41149 C*********************************************************************
41151 *$ CREATE PHO_SASDIR.FOR
41153 CDECK ID>, PHO_SASDIR
41154 SUBROUTINE PHO_SASDIR(X,Q2,P2,Q02,XPGA)
41155 C...Purpose: to evaluate the direct contribution, i.e. the C^gamma term,
41156 C...as needed in MSbar parametrizations.
41158 DIMENSION XPGA(-6:6)
41159 DATA PMC/1.3/, PMB/4.6/, AEM2PI/0.0011614/
41166 C...Evaluate common x-dependent expression.
41167 XTMP = (X**2+(1.-X)**2) * (-LOG(X)) - 1.
41168 CGAM = 3.*AEM2PI*X * (XTMP*(1.+P2/(P2+Q02)) + 6.*X*(1.-X))
41170 C...d, u, s part by simple charge factor.
41171 XPGA(1)=(1./9.)*CGAM
41172 XPGA(2)=(4./9.)*CGAM
41173 XPGA(3)=(1./9.)*CGAM
41175 C...Also fill for antiquarks.
41182 *$ CREATE PHO_PHGAL.FOR
41184 CDECK ID>, PHO_PHGAL
41185 SUBROUTINE PHO_PHGAL(X,Q2,XPDF)
41186 C***********************************************************************
41188 C photon parton densities with built-in momentum sum rule and
41189 C Regge-based low-x behaviour
41191 C H. Abramowicz, E. Gurvich, A. Levy: Phys.Lett.B420:104-108,1998
41192 C e-Print Archive: hep-ph/9711355
41194 C code submitted by E.Gurvich, slightly modified (R.Engel, 09/1998)
41196 C***********************************************************************
41197 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
41200 PARAMETER(IX=100,IQ=7,NARG=2,NFUN=4)
41202 & XT(IX),Q2T(IQ),ARG(NARG),ENT(IX+IQ),
41203 & XPV(IX,IQ,0:NFUN),XPDF(-6:6)
41209 C...100 x values; in (D-4,.77) log spaced (78 points)
41210 C... in (.78,.995) lineary spaced (22 points)
41211 DATA Q2T/4.D0,10.D0,50.D0,1.D2,1.D3,1.D4,1.D5/
41213 &0.1000D-03,0.1123D-03,0.1262D-03,0.1417D-03,0.1592D-03,0.1789D-03,
41214 &0.2009D-03,0.2257D-03,0.2535D-03,0.2848D-03,0.3199D-03,0.3593D-03,
41215 &0.4037D-03,0.4534D-03,0.5093D-03,0.5722D-03,0.6427D-03,0.7220D-03,
41216 &0.8110D-03,0.9110D-03,0.1023D-02,0.1150D-02,0.1291D-02,0.1451D-02,
41217 &0.1629D-02,0.1830D-02,0.2056D-02,0.2310D-02,0.2594D-02,0.2914D-02,
41218 &0.3274D-02,0.3677D-02,0.4131D-02,0.4640D-02,0.5212D-02,0.5855D-02,
41219 &0.6577D-02,0.7388D-02,0.8299D-02,0.9323D-02,0.1047D-01,0.1176D-01,
41220 &0.1321D-01,0.1484D-01,0.1667D-01,0.1873D-01,0.2104D-01,0.2363D-01,
41221 &0.2655D-01,0.2982D-01,0.3350D-01,0.3763D-01,0.4227D-01,0.4748D-01,
41222 &0.5334D-01,0.5992D-01,0.6731D-01,0.7560D-01,0.8493D-01,0.9540D-01,
41223 &0.1072D+00,0.1204D+00,0.1352D+00,0.1519D+00,0.1706D+00,0.1917D+00,
41224 &0.2153D+00,0.2419D+00,0.2717D+00,0.3052D+00,0.3428D+00,0.3851D+00,
41225 &0.4326D+00,0.4859D+00,0.5458D+00,0.6131D+00,0.6887D+00,0.7737D+00,
41226 &0.7837D+00,0.7937D+00,0.8037D+00,0.8137D+00,0.8237D+00,0.8337D+00,
41227 &0.8437D+00,0.8537D+00,0.8637D+00,0.8737D+00,0.8837D+00,0.8937D+00,
41228 &0.9037D+00,0.9137D+00,0.9237D+00,0.9337D+00,0.9437D+00,0.9537D+00,
41229 &0.9637D+00,0.9737D+00,0.9837D+00,0.9937D+00/
41231 C...place for DATA blocks
41232 DATA (XPV(I,1,0),I=1,100)/
41233 &0.6632D-01,0.6536D-01,0.6390D-01,0.6196D-01,0.5952D-01,0.5663D-01,
41234 &0.5339D-01,0.5124D-01,0.5029D-01,0.4893D-01,0.4718D-01,0.4505D-01,
41235 &0.4259D-01,0.4038D-01,0.3966D-01,0.3860D-01,0.3721D-01,0.3551D-01,
41236 &0.3354D-01,0.3206D-01,0.3134D-01,0.3031D-01,0.2902D-01,0.2747D-01,
41237 &0.2608D-01,0.2543D-01,0.2451D-01,0.2335D-01,0.2202D-01,0.2132D-01,
41238 &0.2051D-01,0.1950D-01,0.1851D-01,0.1783D-01,0.1696D-01,0.1609D-01,
41239 &0.1539D-01,0.1454D-01,0.1386D-01,0.1310D-01,0.1242D-01,0.1169D-01,
41240 &0.1104D-01,0.1036D-01,0.9694D-02,0.9046D-02,0.8400D-02,0.7792D-02,
41241 &0.7173D-02,0.6573D-02,0.5978D-02,0.5411D-02,0.4853D-02,0.4307D-02,
41242 &0.3791D-02,0.3292D-02,0.2818D-02,0.2382D-02,0.1976D-02,0.1606D-02,
41243 &0.1275D-02,0.9866D-03,0.7403D-03,0.5351D-03,0.3713D-03,0.2450D-03,
41244 &0.1524D-03,0.8849D-04,0.4730D-04,0.2278D-04,0.9707D-05,0.3518D-05,
41245 &0.1041D-05,0.2356D-06,0.3682D-07,0.3365D-08,0.1333D-09,0.1188D-11,
41246 &0.6095D-12,0.3031D-12,0.1457D-12,0.6733D-13,0.2986D-13,0.1262D-13,
41247 &0.5060D-14,0.1912D-14,0.6734D-15,0.2199D-15,0.6498D-16,0.1729D-16,
41248 &0.4059D-17,0.8091D-18,0.1324D-18,0.1691D-19,0.1518D-20,0.8785D-22,
41249 &0.2519D-23,0.2197D-25,0.2840D-28,0.1908D-33/
41250 DATA (XPV(I,1,1),I=1,100)/
41251 &0.5848D-03,0.5838D-03,0.5793D-03,0.5713D-03,0.5597D-03,0.5447D-03,
41252 &0.5270D-03,0.5167D-03,0.5143D-03,0.5087D-03,0.4998D-03,0.4879D-03,
41253 &0.4731D-03,0.4599D-03,0.4584D-03,0.4538D-03,0.4461D-03,0.4355D-03,
41254 &0.4223D-03,0.4133D-03,0.4109D-03,0.4053D-03,0.3970D-03,0.3859D-03,
41255 &0.3763D-03,0.3739D-03,0.3686D-03,0.3605D-03,0.3504D-03,0.3473D-03,
41256 &0.3426D-03,0.3355D-03,0.3286D-03,0.3253D-03,0.3196D-03,0.3138D-03,
41257 &0.3102D-03,0.3047D-03,0.3014D-03,0.2971D-03,0.2939D-03,0.2901D-03,
41258 &0.2875D-03,0.2849D-03,0.2824D-03,0.2805D-03,0.2787D-03,0.2780D-03,
41259 &0.2772D-03,0.2771D-03,0.2773D-03,0.2784D-03,0.2799D-03,0.2820D-03,
41260 &0.2850D-03,0.2886D-03,0.2930D-03,0.2985D-03,0.3050D-03,0.3126D-03,
41261 &0.3215D-03,0.3316D-03,0.3432D-03,0.3564D-03,0.3714D-03,0.3883D-03,
41262 &0.4073D-03,0.4287D-03,0.4526D-03,0.4794D-03,0.5092D-03,0.5425D-03,
41263 &0.5796D-03,0.6207D-03,0.6664D-03,0.7171D-03,0.7733D-03,0.8356D-03,
41264 &0.8429D-03,0.8502D-03,0.8574D-03,0.8647D-03,0.8719D-03,0.8791D-03,
41265 &0.8863D-03,0.8935D-03,0.9007D-03,0.9079D-03,0.9151D-03,0.9222D-03,
41266 &0.9294D-03,0.9365D-03,0.9436D-03,0.9508D-03,0.9579D-03,0.9650D-03,
41267 &0.9720D-03,0.9791D-03,0.9862D-03,0.9932D-03/
41268 DATA (XPV(I,1,2),I=1,100)/
41269 &0.2339D-02,0.2335D-02,0.2317D-02,0.2285D-02,0.2239D-02,0.2179D-02,
41270 &0.2108D-02,0.2067D-02,0.2057D-02,0.2035D-02,0.1999D-02,0.1951D-02,
41271 &0.1892D-02,0.1840D-02,0.1833D-02,0.1815D-02,0.1784D-02,0.1742D-02,
41272 &0.1689D-02,0.1653D-02,0.1643D-02,0.1621D-02,0.1588D-02,0.1544D-02,
41273 &0.1505D-02,0.1496D-02,0.1474D-02,0.1442D-02,0.1402D-02,0.1389D-02,
41274 &0.1370D-02,0.1342D-02,0.1314D-02,0.1301D-02,0.1278D-02,0.1255D-02,
41275 &0.1241D-02,0.1219D-02,0.1205D-02,0.1188D-02,0.1176D-02,0.1160D-02,
41276 &0.1150D-02,0.1139D-02,0.1130D-02,0.1122D-02,0.1115D-02,0.1112D-02,
41277 &0.1109D-02,0.1108D-02,0.1109D-02,0.1114D-02,0.1120D-02,0.1128D-02,
41278 &0.1140D-02,0.1154D-02,0.1172D-02,0.1194D-02,0.1220D-02,0.1251D-02,
41279 &0.1286D-02,0.1326D-02,0.1373D-02,0.1426D-02,0.1485D-02,0.1553D-02,
41280 &0.1629D-02,0.1715D-02,0.1811D-02,0.1917D-02,0.2037D-02,0.2170D-02,
41281 &0.2318D-02,0.2483D-02,0.2666D-02,0.2868D-02,0.3093D-02,0.3342D-02,
41282 &0.3372D-02,0.3401D-02,0.3430D-02,0.3459D-02,0.3488D-02,0.3517D-02,
41283 &0.3545D-02,0.3574D-02,0.3603D-02,0.3632D-02,0.3660D-02,0.3689D-02,
41284 &0.3717D-02,0.3746D-02,0.3775D-02,0.3803D-02,0.3831D-02,0.3860D-02,
41285 &0.3888D-02,0.3916D-02,0.3945D-02,0.3973D-02/
41286 DATA (XPV(I,1,3),I=1,100)/
41287 &0.1755D-03,0.1751D-03,0.1738D-03,0.1714D-03,0.1679D-03,0.1634D-03,
41288 &0.1581D-03,0.1550D-03,0.1543D-03,0.1526D-03,0.1499D-03,0.1464D-03,
41289 &0.1419D-03,0.1380D-03,0.1375D-03,0.1361D-03,0.1338D-03,0.1306D-03,
41290 &0.1267D-03,0.1240D-03,0.1233D-03,0.1216D-03,0.1191D-03,0.1158D-03,
41291 &0.1129D-03,0.1122D-03,0.1106D-03,0.1082D-03,0.1051D-03,0.1042D-03,
41292 &0.1028D-03,0.1006D-03,0.9857D-04,0.9759D-04,0.9587D-04,0.9414D-04,
41293 &0.9305D-04,0.9140D-04,0.9041D-04,0.8912D-04,0.8817D-04,0.8702D-04,
41294 &0.8626D-04,0.8546D-04,0.8472D-04,0.8415D-04,0.8362D-04,0.8339D-04,
41295 &0.8317D-04,0.8312D-04,0.8318D-04,0.8352D-04,0.8398D-04,0.8459D-04,
41296 &0.8550D-04,0.8658D-04,0.8789D-04,0.8956D-04,0.9151D-04,0.9379D-04,
41297 &0.9644D-04,0.9948D-04,0.1030D-03,0.1069D-03,0.1114D-03,0.1165D-03,
41298 &0.1222D-03,0.1286D-03,0.1358D-03,0.1438D-03,0.1528D-03,0.1628D-03,
41299 &0.1739D-03,0.1862D-03,0.1999D-03,0.2151D-03,0.2320D-03,0.2507D-03,
41300 &0.2529D-03,0.2551D-03,0.2572D-03,0.2594D-03,0.2616D-03,0.2637D-03,
41301 &0.2659D-03,0.2681D-03,0.2702D-03,0.2724D-03,0.2745D-03,0.2767D-03,
41302 &0.2788D-03,0.2810D-03,0.2831D-03,0.2852D-03,0.2874D-03,0.2895D-03,
41303 &0.2916D-03,0.2937D-03,0.2959D-03,0.2980D-03/
41304 DATA (XPV(I,1,4),I=1,100)/
41305 &0.7018D-03,0.7006D-03,0.6951D-03,0.6855D-03,0.6716D-03,0.6537D-03,
41306 &0.6324D-03,0.6200D-03,0.6172D-03,0.6104D-03,0.5998D-03,0.5854D-03,
41307 &0.5677D-03,0.5519D-03,0.5500D-03,0.5445D-03,0.5353D-03,0.5226D-03,
41308 &0.5068D-03,0.4960D-03,0.4930D-03,0.4864D-03,0.4764D-03,0.4631D-03,
41309 &0.4516D-03,0.4487D-03,0.4423D-03,0.4326D-03,0.4205D-03,0.4167D-03,
41310 &0.4111D-03,0.4026D-03,0.3943D-03,0.3903D-03,0.3835D-03,0.3765D-03,
41311 &0.3722D-03,0.3656D-03,0.3616D-03,0.3565D-03,0.3527D-03,0.3481D-03,
41312 &0.3450D-03,0.3418D-03,0.3389D-03,0.3366D-03,0.3345D-03,0.3336D-03,
41313 &0.3327D-03,0.3325D-03,0.3327D-03,0.3341D-03,0.3359D-03,0.3383D-03,
41314 &0.3420D-03,0.3463D-03,0.3516D-03,0.3582D-03,0.3660D-03,0.3752D-03,
41315 &0.3858D-03,0.3979D-03,0.4118D-03,0.4277D-03,0.4456D-03,0.4660D-03,
41316 &0.4887D-03,0.5145D-03,0.5432D-03,0.5752D-03,0.6111D-03,0.6510D-03,
41317 &0.6955D-03,0.7448D-03,0.7997D-03,0.8605D-03,0.9280D-03,0.1003D-02,
41318 &0.1011D-02,0.1020D-02,0.1029D-02,0.1038D-02,0.1046D-02,0.1055D-02,
41319 &0.1064D-02,0.1072D-02,0.1081D-02,0.1089D-02,0.1098D-02,0.1107D-02,
41320 &0.1115D-02,0.1124D-02,0.1132D-02,0.1141D-02,0.1149D-02,0.1158D-02,
41321 &0.1166D-02,0.1175D-02,0.1183D-02,0.1192D-02/
41322 DATA (XPV(I,2,0),I=1,100)/
41323 &0.1024D+00,0.1007D+00,0.9821D-01,0.9497D-01,0.9093D-01,0.8617D-01,
41324 &0.8086D-01,0.7731D-01,0.7566D-01,0.7338D-01,0.7048D-01,0.6700D-01,
41325 &0.6300D-01,0.5939D-01,0.5814D-01,0.5638D-01,0.5410D-01,0.5135D-01,
41326 &0.4819D-01,0.4580D-01,0.4460D-01,0.4293D-01,0.4087D-01,0.3843D-01,
41327 &0.3624D-01,0.3517D-01,0.3372D-01,0.3192D-01,0.2988D-01,0.2879D-01,
41328 &0.2755D-01,0.2602D-01,0.2454D-01,0.2352D-01,0.2224D-01,0.2097D-01,
41329 &0.1995D-01,0.1875D-01,0.1779D-01,0.1673D-01,0.1580D-01,0.1480D-01,
41330 &0.1393D-01,0.1305D-01,0.1218D-01,0.1136D-01,0.1055D-01,0.9801D-02,
41331 &0.9052D-02,0.8337D-02,0.7641D-02,0.6989D-02,0.6357D-02,0.5747D-02,
41332 &0.5179D-02,0.4637D-02,0.4127D-02,0.3663D-02,0.3232D-02,0.2840D-02,
41333 &0.2487D-02,0.2174D-02,0.1901D-02,0.1662D-02,0.1459D-02,0.1285D-02,
41334 &0.1137D-02,0.1010D-02,0.9006D-03,0.8023D-03,0.7126D-03,0.6276D-03,
41335 &0.5458D-03,0.4661D-03,0.3876D-03,0.3101D-03,0.2334D-03,0.1570D-03,
41336 &0.1486D-03,0.1404D-03,0.1322D-03,0.1242D-03,0.1162D-03,0.1084D-03,
41337 &0.1007D-03,0.9304D-04,0.8554D-04,0.7817D-04,0.7086D-04,0.6372D-04,
41338 &0.5670D-04,0.4982D-04,0.4307D-04,0.3647D-04,0.3005D-04,0.2382D-04,
41339 &0.1781D-04,0.1208D-04,0.6720D-05,0.1928D-05/
41340 DATA (XPV(I,2,1),I=1,100)/
41341 &0.1449D-02,0.1433D-02,0.1407D-02,0.1370D-02,0.1324D-02,0.1268D-02,
41342 &0.1204D-02,0.1163D-02,0.1147D-02,0.1123D-02,0.1089D-02,0.1048D-02,
41343 &0.1000D-02,0.9567D-03,0.9446D-03,0.9250D-03,0.8981D-03,0.8642D-03,
41344 &0.8244D-03,0.7951D-03,0.7821D-03,0.7623D-03,0.7362D-03,0.7043D-03,
41345 &0.6759D-03,0.6640D-03,0.6459D-03,0.6223D-03,0.5945D-03,0.5817D-03,
41346 &0.5660D-03,0.5455D-03,0.5256D-03,0.5132D-03,0.4963D-03,0.4794D-03,
41347 &0.4669D-03,0.4510D-03,0.4394D-03,0.4261D-03,0.4151D-03,0.4031D-03,
41348 &0.3934D-03,0.3838D-03,0.3747D-03,0.3666D-03,0.3591D-03,0.3533D-03,
41349 &0.3477D-03,0.3433D-03,0.3397D-03,0.3376D-03,0.3364D-03,0.3361D-03,
41350 &0.3375D-03,0.3399D-03,0.3437D-03,0.3492D-03,0.3562D-03,0.3648D-03,
41351 &0.3751D-03,0.3871D-03,0.4009D-03,0.4167D-03,0.4344D-03,0.4543D-03,
41352 &0.4760D-03,0.5003D-03,0.5268D-03,0.5558D-03,0.5876D-03,0.6226D-03,
41353 &0.6610D-03,0.7035D-03,0.7509D-03,0.8041D-03,0.8638D-03,0.9294D-03,
41354 &0.9367D-03,0.9440D-03,0.9511D-03,0.9581D-03,0.9648D-03,0.9714D-03,
41355 &0.9776D-03,0.9836D-03,0.9891D-03,0.9942D-03,0.9987D-03,0.1003D-02,
41356 &0.1006D-02,0.1008D-02,0.1008D-02,0.1007D-02,0.1004D-02,0.9977D-03,
41357 &0.9868D-03,0.9681D-03,0.9347D-03,0.8678D-03/
41358 DATA (XPV(I,2,2),I=1,100)/
41359 &0.3175D-02,0.3156D-02,0.3117D-02,0.3057D-02,0.2976D-02,0.2876D-02,
41360 &0.2760D-02,0.2689D-02,0.2666D-02,0.2625D-02,0.2566D-02,0.2489D-02,
41361 &0.2398D-02,0.2316D-02,0.2299D-02,0.2266D-02,0.2217D-02,0.2152D-02,
41362 &0.2073D-02,0.2018D-02,0.1998D-02,0.1962D-02,0.1911D-02,0.1847D-02,
41363 &0.1791D-02,0.1773D-02,0.1739D-02,0.1692D-02,0.1636D-02,0.1614D-02,
41364 &0.1586D-02,0.1545D-02,0.1506D-02,0.1485D-02,0.1452D-02,0.1420D-02,
41365 &0.1398D-02,0.1368D-02,0.1348D-02,0.1324D-02,0.1306D-02,0.1285D-02,
41366 &0.1271D-02,0.1256D-02,0.1243D-02,0.1233D-02,0.1224D-02,0.1220D-02,
41367 &0.1217D-02,0.1217D-02,0.1220D-02,0.1227D-02,0.1237D-02,0.1249D-02,
41368 &0.1267D-02,0.1288D-02,0.1313D-02,0.1345D-02,0.1381D-02,0.1422D-02,
41369 &0.1469D-02,0.1522D-02,0.1582D-02,0.1648D-02,0.1722D-02,0.1804D-02,
41370 &0.1893D-02,0.1992D-02,0.2099D-02,0.2216D-02,0.2345D-02,0.2486D-02,
41371 &0.2641D-02,0.2812D-02,0.3002D-02,0.3216D-02,0.3455D-02,0.3718D-02,
41372 &0.3748D-02,0.3777D-02,0.3806D-02,0.3833D-02,0.3861D-02,0.3887D-02,
41373 &0.3912D-02,0.3936D-02,0.3958D-02,0.3978D-02,0.3996D-02,0.4012D-02,
41374 &0.4024D-02,0.4032D-02,0.4035D-02,0.4031D-02,0.4018D-02,0.3993D-02,
41375 &0.3949D-02,0.3875D-02,0.3741D-02,0.3474D-02/
41376 DATA (XPV(I,2,3),I=1,100)/
41377 &0.1046D-02,0.1031D-02,0.1008D-02,0.9768D-03,0.9381D-03,0.8923D-03,
41378 &0.8410D-03,0.8074D-03,0.7928D-03,0.7720D-03,0.7450D-03,0.7121D-03,
41379 &0.6741D-03,0.6398D-03,0.6287D-03,0.6123D-03,0.5906D-03,0.5640D-03,
41380 &0.5332D-03,0.5101D-03,0.4988D-03,0.4827D-03,0.4624D-03,0.4380D-03,
41381 &0.4161D-03,0.4059D-03,0.3914D-03,0.3732D-03,0.3524D-03,0.3416D-03,
41382 &0.3290D-03,0.3133D-03,0.2981D-03,0.2878D-03,0.2747D-03,0.2616D-03,
41383 &0.2515D-03,0.2392D-03,0.2296D-03,0.2191D-03,0.2100D-03,0.2004D-03,
41384 &0.1923D-03,0.1842D-03,0.1764D-03,0.1694D-03,0.1627D-03,0.1571D-03,
41385 &0.1517D-03,0.1469D-03,0.1427D-03,0.1394D-03,0.1367D-03,0.1345D-03,
41386 &0.1333D-03,0.1327D-03,0.1329D-03,0.1340D-03,0.1360D-03,0.1387D-03,
41387 &0.1424D-03,0.1469D-03,0.1522D-03,0.1584D-03,0.1654D-03,0.1733D-03,
41388 &0.1819D-03,0.1915D-03,0.2019D-03,0.2132D-03,0.2257D-03,0.2396D-03,
41389 &0.2553D-03,0.2737D-03,0.2956D-03,0.3227D-03,0.3570D-03,0.4009D-03,
41390 &0.4064D-03,0.4119D-03,0.4175D-03,0.4231D-03,0.4287D-03,0.4344D-03,
41391 &0.4400D-03,0.4457D-03,0.4512D-03,0.4567D-03,0.4621D-03,0.4673D-03,
41392 &0.4723D-03,0.4769D-03,0.4811D-03,0.4848D-03,0.4875D-03,0.4891D-03,
41393 &0.4888D-03,0.4853D-03,0.4756D-03,0.4518D-03/
41394 DATA (XPV(I,2,4),I=1,100)/
41395 &0.1564D-02,0.1548D-02,0.1521D-02,0.1483D-02,0.1434D-02,0.1375D-02,
41396 &0.1308D-02,0.1265D-02,0.1249D-02,0.1223D-02,0.1188D-02,0.1145D-02,
41397 &0.1094D-02,0.1048D-02,0.1035D-02,0.1015D-02,0.9868D-03,0.9509D-03,
41398 &0.9086D-03,0.8776D-03,0.8644D-03,0.8436D-03,0.8161D-03,0.7822D-03,
41399 &0.7521D-03,0.7400D-03,0.7212D-03,0.6963D-03,0.6669D-03,0.6538D-03,
41400 &0.6377D-03,0.6163D-03,0.5956D-03,0.5832D-03,0.5658D-03,0.5486D-03,
41401 &0.5363D-03,0.5203D-03,0.5091D-03,0.4962D-03,0.4859D-03,0.4746D-03,
41402 &0.4661D-03,0.4578D-03,0.4502D-03,0.4441D-03,0.4387D-03,0.4355D-03,
41403 &0.4329D-03,0.4318D-03,0.4320D-03,0.4342D-03,0.4379D-03,0.4429D-03,
41404 &0.4503D-03,0.4594D-03,0.4704D-03,0.4839D-03,0.4996D-03,0.5177D-03,
41405 &0.5383D-03,0.5613D-03,0.5869D-03,0.6152D-03,0.6462D-03,0.6802D-03,
41406 &0.7167D-03,0.7565D-03,0.7995D-03,0.8461D-03,0.8972D-03,0.9538D-03,
41407 &0.1018D-02,0.1092D-02,0.1181D-02,0.1290D-02,0.1428D-02,0.1604D-02,
41408 &0.1626D-02,0.1649D-02,0.1671D-02,0.1694D-02,0.1716D-02,0.1739D-02,
41409 &0.1762D-02,0.1784D-02,0.1806D-02,0.1828D-02,0.1850D-02,0.1871D-02,
41410 &0.1891D-02,0.1909D-02,0.1926D-02,0.1941D-02,0.1952D-02,0.1958D-02,
41411 &0.1957D-02,0.1943D-02,0.1905D-02,0.1811D-02/
41412 DATA (XPV(I,3,0),I=1,100)/
41413 &0.1761D+00,0.1728D+00,0.1680D+00,0.1619D+00,0.1544D+00,0.1456D+00,
41414 &0.1358D+00,0.1292D+00,0.1260D+00,0.1218D+00,0.1165D+00,0.1101D+00,
41415 &0.1029D+00,0.9643D-01,0.9409D-01,0.9087D-01,0.8680D-01,0.8192D-01,
41416 &0.7638D-01,0.7217D-01,0.7000D-01,0.6708D-01,0.6352D-01,0.5934D-01,
41417 &0.5561D-01,0.5375D-01,0.5129D-01,0.4829D-01,0.4491D-01,0.4309D-01,
41418 &0.4104D-01,0.3857D-01,0.3618D-01,0.3454D-01,0.3252D-01,0.3053D-01,
41419 &0.2896D-01,0.2712D-01,0.2565D-01,0.2407D-01,0.2268D-01,0.2123D-01,
41420 &0.1997D-01,0.1870D-01,0.1748D-01,0.1634D-01,0.1523D-01,0.1422D-01,
41421 &0.1321D-01,0.1227D-01,0.1137D-01,0.1053D-01,0.9723D-02,0.8952D-02,
41422 &0.8241D-02,0.7563D-02,0.6926D-02,0.6345D-02,0.5801D-02,0.5298D-02,
41423 &0.4833D-02,0.4407D-02,0.4017D-02,0.3657D-02,0.3327D-02,0.3021D-02,
41424 &0.2735D-02,0.2469D-02,0.2217D-02,0.1976D-02,0.1746D-02,0.1522D-02,
41425 &0.1307D-02,0.1098D-02,0.8959D-03,0.7002D-03,0.5112D-03,0.3292D-03,
41426 &0.3097D-03,0.2906D-03,0.2718D-03,0.2534D-03,0.2354D-03,0.2178D-03,
41427 &0.2005D-03,0.1836D-03,0.1672D-03,0.1511D-03,0.1354D-03,0.1203D-03,
41428 &0.1055D-03,0.9128D-04,0.7756D-04,0.6440D-04,0.5185D-04,0.3998D-04,
41429 &0.2891D-04,0.1876D-04,0.9776D-05,0.2464D-05/
41430 DATA (XPV(I,3,1),I=1,100)/
41431 &0.3351D-02,0.3297D-02,0.3217D-02,0.3112D-02,0.2981D-02,0.2828D-02,
41432 &0.2656D-02,0.2543D-02,0.2493D-02,0.2422D-02,0.2332D-02,0.2223D-02,
41433 &0.2097D-02,0.1984D-02,0.1946D-02,0.1892D-02,0.1821D-02,0.1734D-02,
41434 &0.1635D-02,0.1560D-02,0.1523D-02,0.1471D-02,0.1406D-02,0.1329D-02,
41435 &0.1260D-02,0.1228D-02,0.1182D-02,0.1126D-02,0.1061D-02,0.1028D-02,
41436 &0.9902D-03,0.9426D-03,0.8967D-03,0.8664D-03,0.8274D-03,0.7890D-03,
41437 &0.7596D-03,0.7240D-03,0.6969D-03,0.6671D-03,0.6417D-03,0.6149D-03,
41438 &0.5928D-03,0.5708D-03,0.5502D-03,0.5317D-03,0.5144D-03,0.5002D-03,
41439 &0.4867D-03,0.4753D-03,0.4655D-03,0.4582D-03,0.4526D-03,0.4487D-03,
41440 &0.4475D-03,0.4480D-03,0.4506D-03,0.4559D-03,0.4632D-03,0.4729D-03,
41441 &0.4849D-03,0.4991D-03,0.5155D-03,0.5343D-03,0.5552D-03,0.5783D-03,
41442 &0.6033D-03,0.6307D-03,0.6600D-03,0.6915D-03,0.7256D-03,0.7626D-03,
41443 &0.8031D-03,0.8482D-03,0.8993D-03,0.9582D-03,0.1026D-02,0.1099D-02,
41444 &0.1107D-02,0.1115D-02,0.1122D-02,0.1129D-02,0.1136D-02,0.1142D-02,
41445 &0.1148D-02,0.1152D-02,0.1156D-02,0.1159D-02,0.1161D-02,0.1161D-02,
41446 &0.1160D-02,0.1156D-02,0.1150D-02,0.1141D-02,0.1127D-02,0.1107D-02,
41447 &0.1078D-02,0.1036D-02,0.9685D-03,0.8413D-03/
41448 DATA (XPV(I,3,2),I=1,100)/
41449 &0.5039D-02,0.4982D-02,0.4889D-02,0.4761D-02,0.4597D-02,0.4401D-02,
41450 &0.4179D-02,0.4036D-02,0.3979D-02,0.3893D-02,0.3777D-02,0.3634D-02,
41451 &0.3466D-02,0.3315D-02,0.3273D-02,0.3206D-02,0.3114D-02,0.2997D-02,
41452 &0.2860D-02,0.2760D-02,0.2717D-02,0.2650D-02,0.2562D-02,0.2454D-02,
41453 &0.2359D-02,0.2321D-02,0.2262D-02,0.2184D-02,0.2092D-02,0.2052D-02,
41454 &0.2003D-02,0.1938D-02,0.1875D-02,0.1839D-02,0.1787D-02,0.1736D-02,
41455 &0.1700D-02,0.1653D-02,0.1622D-02,0.1585D-02,0.1557D-02,0.1526D-02,
41456 &0.1504D-02,0.1483D-02,0.1464D-02,0.1450D-02,0.1438D-02,0.1433D-02,
41457 &0.1430D-02,0.1432D-02,0.1438D-02,0.1450D-02,0.1466D-02,0.1487D-02,
41458 &0.1515D-02,0.1547D-02,0.1585D-02,0.1631D-02,0.1683D-02,0.1742D-02,
41459 &0.1808D-02,0.1880D-02,0.1960D-02,0.2048D-02,0.2142D-02,0.2245D-02,
41460 &0.2354D-02,0.2471D-02,0.2596D-02,0.2729D-02,0.2872D-02,0.3025D-02,
41461 &0.3193D-02,0.3378D-02,0.3587D-02,0.3827D-02,0.4100D-02,0.4397D-02,
41462 &0.4429D-02,0.4461D-02,0.4490D-02,0.4519D-02,0.4545D-02,0.4570D-02,
41463 &0.4592D-02,0.4611D-02,0.4627D-02,0.4639D-02,0.4646D-02,0.4647D-02,
41464 &0.4642D-02,0.4628D-02,0.4604D-02,0.4566D-02,0.4510D-02,0.4431D-02,
41465 &0.4317D-02,0.4147D-02,0.3877D-02,0.3370D-02/
41466 DATA (XPV(I,3,3),I=1,100)/
41467 &0.2958D-02,0.2904D-02,0.2827D-02,0.2727D-02,0.2604D-02,0.2461D-02,
41468 &0.2301D-02,0.2195D-02,0.2146D-02,0.2079D-02,0.1995D-02,0.1894D-02,
41469 &0.1778D-02,0.1674D-02,0.1637D-02,0.1586D-02,0.1520D-02,0.1440D-02,
41470 &0.1349D-02,0.1280D-02,0.1245D-02,0.1197D-02,0.1138D-02,0.1068D-02,
41471 &0.1005D-02,0.9742D-03,0.9325D-03,0.8812D-03,0.8233D-03,0.7922D-03,
41472 &0.7568D-03,0.7138D-03,0.6722D-03,0.6438D-03,0.6084D-03,0.5735D-03,
41473 &0.5460D-03,0.5138D-03,0.4883D-03,0.4609D-03,0.4371D-03,0.4123D-03,
41474 &0.3912D-03,0.3704D-03,0.3507D-03,0.3327D-03,0.3158D-03,0.3012D-03,
41475 &0.2873D-03,0.2751D-03,0.2641D-03,0.2551D-03,0.2474D-03,0.2410D-03,
41476 &0.2365D-03,0.2334D-03,0.2318D-03,0.2321D-03,0.2339D-03,0.2372D-03,
41477 &0.2421D-03,0.2485D-03,0.2562D-03,0.2652D-03,0.2755D-03,0.2870D-03,
41478 &0.2995D-03,0.3131D-03,0.3278D-03,0.3438D-03,0.3615D-03,0.3814D-03,
41479 &0.4046D-03,0.4328D-03,0.4682D-03,0.5142D-03,0.5747D-03,0.6529D-03,
41480 &0.6625D-03,0.6722D-03,0.6819D-03,0.6916D-03,0.7012D-03,0.7107D-03,
41481 &0.7200D-03,0.7292D-03,0.7380D-03,0.7464D-03,0.7544D-03,0.7617D-03,
41482 &0.7681D-03,0.7735D-03,0.7776D-03,0.7798D-03,0.7796D-03,0.7761D-03,
41483 &0.7676D-03,0.7510D-03,0.7195D-03,0.6522D-03/
41484 DATA (XPV(I,3,4),I=1,100)/
41485 &0.3464D-02,0.3410D-02,0.3329D-02,0.3222D-02,0.3090D-02,0.2933D-02,
41486 &0.2758D-02,0.2643D-02,0.2593D-02,0.2521D-02,0.2430D-02,0.2318D-02,
41487 &0.2190D-02,0.2075D-02,0.2037D-02,0.1982D-02,0.1910D-02,0.1821D-02,
41488 &0.1720D-02,0.1643D-02,0.1607D-02,0.1554D-02,0.1489D-02,0.1410D-02,
41489 &0.1340D-02,0.1308D-02,0.1262D-02,0.1205D-02,0.1140D-02,0.1108D-02,
41490 &0.1070D-02,0.1023D-02,0.9772D-03,0.9482D-03,0.9103D-03,0.8732D-03,
41491 &0.8458D-03,0.8121D-03,0.7877D-03,0.7607D-03,0.7388D-03,0.7157D-03,
41492 &0.6981D-03,0.6812D-03,0.6662D-03,0.6540D-03,0.6438D-03,0.6377D-03,
41493 &0.6331D-03,0.6316D-03,0.6326D-03,0.6376D-03,0.6453D-03,0.6560D-03,
41494 &0.6708D-03,0.6887D-03,0.7102D-03,0.7361D-03,0.7656D-03,0.7991D-03,
41495 &0.8365D-03,0.8777D-03,0.9226D-03,0.9714D-03,0.1024D-02,0.1080D-02,
41496 &0.1138D-02,0.1201D-02,0.1267D-02,0.1338D-02,0.1415D-02,0.1501D-02,
41497 &0.1599D-02,0.1717D-02,0.1863D-02,0.2051D-02,0.2296D-02,0.2612D-02,
41498 &0.2650D-02,0.2689D-02,0.2729D-02,0.2767D-02,0.2806D-02,0.2844D-02,
41499 &0.2882D-02,0.2919D-02,0.2954D-02,0.2988D-02,0.3020D-02,0.3049D-02,
41500 &0.3075D-02,0.3097D-02,0.3114D-02,0.3123D-02,0.3122D-02,0.3108D-02,
41501 &0.3074D-02,0.3008D-02,0.2881D-02,0.2614D-02/
41502 DATA (XPV(I,4,0),I=1,100)/
41503 &0.2113D+00,0.2071D+00,0.2012D+00,0.1936D+00,0.1844D+00,0.1736D+00,
41504 &0.1616D+00,0.1536D+00,0.1497D+00,0.1445D+00,0.1380D+00,0.1303D+00,
41505 &0.1215D+00,0.1136D+00,0.1108D+00,0.1069D+00,0.1019D+00,0.9605D-01,
41506 &0.8939D-01,0.8432D-01,0.8171D-01,0.7821D-01,0.7395D-01,0.6897D-01,
41507 &0.6452D-01,0.6231D-01,0.5938D-01,0.5583D-01,0.5185D-01,0.4969D-01,
41508 &0.4728D-01,0.4438D-01,0.4158D-01,0.3967D-01,0.3731D-01,0.3500D-01,
41509 &0.3318D-01,0.3105D-01,0.2936D-01,0.2754D-01,0.2595D-01,0.2429D-01,
41510 &0.2285D-01,0.2141D-01,0.2003D-01,0.1874D-01,0.1749D-01,0.1635D-01,
41511 &0.1523D-01,0.1418D-01,0.1317D-01,0.1223D-01,0.1134D-01,0.1048D-01,
41512 &0.9692D-02,0.8938D-02,0.8227D-02,0.7578D-02,0.6967D-02,0.6398D-02,
41513 &0.5867D-02,0.5377D-02,0.4922D-02,0.4497D-02,0.4101D-02,0.3730D-02,
41514 &0.3379D-02,0.3048D-02,0.2732D-02,0.2429D-02,0.2139D-02,0.1858D-02,
41515 &0.1588D-02,0.1328D-02,0.1077D-02,0.8361D-03,0.6052D-03,0.3850D-03,
41516 &0.3616D-03,0.3387D-03,0.3162D-03,0.2943D-03,0.2728D-03,0.2518D-03,
41517 &0.2314D-03,0.2114D-03,0.1919D-03,0.1731D-03,0.1546D-03,0.1369D-03,
41518 &0.1197D-03,0.1032D-03,0.8729D-04,0.7214D-04,0.5778D-04,0.4429D-04,
41519 &0.3179D-04,0.2044D-04,0.1053D-04,0.2601D-05/
41520 DATA (XPV(I,4,1),I=1,100)/
41521 &0.4299D-02,0.4223D-02,0.4115D-02,0.3974D-02,0.3799D-02,0.3595D-02,
41522 &0.3367D-02,0.3216D-02,0.3148D-02,0.3054D-02,0.2934D-02,0.2790D-02,
41523 &0.2625D-02,0.2476D-02,0.2426D-02,0.2353D-02,0.2260D-02,0.2147D-02,
41524 &0.2018D-02,0.1920D-02,0.1871D-02,0.1804D-02,0.1720D-02,0.1620D-02,
41525 &0.1532D-02,0.1489D-02,0.1431D-02,0.1359D-02,0.1277D-02,0.1234D-02,
41526 &0.1185D-02,0.1125D-02,0.1067D-02,0.1028D-02,0.9791D-03,0.9308D-03,
41527 &0.8936D-03,0.8491D-03,0.8150D-03,0.7777D-03,0.7459D-03,0.7125D-03,
41528 &0.6849D-03,0.6575D-03,0.6318D-03,0.6088D-03,0.5872D-03,0.5693D-03,
41529 &0.5524D-03,0.5380D-03,0.5254D-03,0.5159D-03,0.5084D-03,0.5028D-03,
41530 &0.5003D-03,0.4998D-03,0.5017D-03,0.5066D-03,0.5139D-03,0.5237D-03,
41531 &0.5360D-03,0.5508D-03,0.5679D-03,0.5875D-03,0.6093D-03,0.6334D-03,
41532 &0.6593D-03,0.6876D-03,0.7177D-03,0.7500D-03,0.7848D-03,0.8225D-03,
41533 &0.8639D-03,0.9103D-03,0.9634D-03,0.1025D-02,0.1097D-02,0.1174D-02,
41534 &0.1183D-02,0.1191D-02,0.1199D-02,0.1206D-02,0.1212D-02,0.1219D-02,
41535 &0.1224D-02,0.1229D-02,0.1232D-02,0.1235D-02,0.1236D-02,0.1235D-02,
41536 &0.1232D-02,0.1227D-02,0.1219D-02,0.1207D-02,0.1190D-02,0.1167D-02,
41537 &0.1133D-02,0.1085D-02,0.1009D-02,0.8680D-03/
41538 DATA (XPV(I,4,2),I=1,100)/
41539 &0.5972D-02,0.5895D-02,0.5773D-02,0.5610D-02,0.5402D-02,0.5156D-02,
41540 &0.4878D-02,0.4698D-02,0.4623D-02,0.4513D-02,0.4369D-02,0.4191D-02,
41541 &0.3984D-02,0.3798D-02,0.3743D-02,0.3659D-02,0.3544D-02,0.3402D-02,
41542 &0.3235D-02,0.3113D-02,0.3058D-02,0.2976D-02,0.2870D-02,0.2740D-02,
41543 &0.2626D-02,0.2578D-02,0.2507D-02,0.2414D-02,0.2305D-02,0.2257D-02,
41544 &0.2198D-02,0.2121D-02,0.2046D-02,0.2003D-02,0.1942D-02,0.1882D-02,
41545 &0.1840D-02,0.1786D-02,0.1749D-02,0.1707D-02,0.1674D-02,0.1639D-02,
41546 &0.1613D-02,0.1589D-02,0.1567D-02,0.1551D-02,0.1538D-02,0.1533D-02,
41547 &0.1530D-02,0.1533D-02,0.1540D-02,0.1554D-02,0.1573D-02,0.1597D-02,
41548 &0.1628D-02,0.1665D-02,0.1709D-02,0.1760D-02,0.1818D-02,0.1884D-02,
41549 &0.1957D-02,0.2038D-02,0.2125D-02,0.2221D-02,0.2324D-02,0.2434D-02,
41550 &0.2551D-02,0.2676D-02,0.2807D-02,0.2946D-02,0.3095D-02,0.3254D-02,
41551 &0.3428D-02,0.3621D-02,0.3839D-02,0.4092D-02,0.4382D-02,0.4698D-02,
41552 &0.4731D-02,0.4764D-02,0.4795D-02,0.4824D-02,0.4851D-02,0.4876D-02,
41553 &0.4898D-02,0.4917D-02,0.4931D-02,0.4941D-02,0.4945D-02,0.4943D-02,
41554 &0.4933D-02,0.4913D-02,0.4881D-02,0.4833D-02,0.4766D-02,0.4671D-02,
41555 &0.4538D-02,0.4344D-02,0.4039D-02,0.3475D-02/
41556 DATA (XPV(I,4,3),I=1,100)/
41557 &0.3908D-02,0.3834D-02,0.3728D-02,0.3592D-02,0.3425D-02,0.3231D-02,
41558 &0.3015D-02,0.2871D-02,0.2804D-02,0.2714D-02,0.2600D-02,0.2464D-02,
41559 &0.2309D-02,0.2169D-02,0.2119D-02,0.2050D-02,0.1962D-02,0.1855D-02,
41560 &0.1735D-02,0.1643D-02,0.1596D-02,0.1532D-02,0.1453D-02,0.1361D-02,
41561 &0.1278D-02,0.1237D-02,0.1183D-02,0.1116D-02,0.1040D-02,0.9992D-03,
41562 &0.9531D-03,0.8972D-03,0.8434D-03,0.8065D-03,0.7608D-03,0.7159D-03,
41563 &0.6806D-03,0.6392D-03,0.6067D-03,0.5717D-03,0.5414D-03,0.5098D-03,
41564 &0.4831D-03,0.4567D-03,0.4317D-03,0.4090D-03,0.3877D-03,0.3693D-03,
41565 &0.3517D-03,0.3363D-03,0.3224D-03,0.3109D-03,0.3010D-03,0.2928D-03,
41566 &0.2869D-03,0.2826D-03,0.2801D-03,0.2799D-03,0.2814D-03,0.2848D-03,
41567 &0.2899D-03,0.2967D-03,0.3051D-03,0.3151D-03,0.3263D-03,0.3390D-03,
41568 &0.3528D-03,0.3678D-03,0.3841D-03,0.4018D-03,0.4214D-03,0.4437D-03,
41569 &0.4700D-03,0.5022D-03,0.5431D-03,0.5965D-03,0.6670D-03,0.7574D-03,
41570 &0.7684D-03,0.7795D-03,0.7905D-03,0.8015D-03,0.8124D-03,0.8230D-03,
41571 &0.8335D-03,0.8436D-03,0.8533D-03,0.8624D-03,0.8708D-03,0.8784D-03,
41572 &0.8849D-03,0.8901D-03,0.8934D-03,0.8945D-03,0.8925D-03,0.8863D-03,
41573 &0.8739D-03,0.8517D-03,0.8113D-03,0.7282D-03/
41574 DATA (XPV(I,4,4),I=1,100)/
41575 &0.4411D-02,0.4336D-02,0.4226D-02,0.4084D-02,0.3907D-02,0.3700D-02,
41576 &0.3469D-02,0.3316D-02,0.3248D-02,0.3153D-02,0.3032D-02,0.2886D-02,
41577 &0.2718D-02,0.2567D-02,0.2516D-02,0.2444D-02,0.2349D-02,0.2235D-02,
41578 &0.2103D-02,0.2004D-02,0.1956D-02,0.1888D-02,0.1804D-02,0.1703D-02,
41579 &0.1613D-02,0.1571D-02,0.1514D-02,0.1441D-02,0.1359D-02,0.1317D-02,
41580 &0.1269D-02,0.1210D-02,0.1153D-02,0.1116D-02,0.1069D-02,0.1022D-02,
41581 &0.9882D-03,0.9465D-03,0.9161D-03,0.8828D-03,0.8558D-03,0.8276D-03,
41582 &0.8060D-03,0.7854D-03,0.7672D-03,0.7526D-03,0.7404D-03,0.7330D-03,
41583 &0.7277D-03,0.7261D-03,0.7277D-03,0.7338D-03,0.7434D-03,0.7565D-03,
41584 &0.7745D-03,0.7963D-03,0.8222D-03,0.8532D-03,0.8886D-03,0.9283D-03,
41585 &0.9728D-03,0.1021D-02,0.1074D-02,0.1131D-02,0.1192D-02,0.1257D-02,
41586 &0.1325D-02,0.1397D-02,0.1473D-02,0.1554D-02,0.1642D-02,0.1739D-02,
41587 &0.1852D-02,0.1988D-02,0.2158D-02,0.2377D-02,0.2664D-02,0.3029D-02,
41588 &0.3074D-02,0.3119D-02,0.3163D-02,0.3207D-02,0.3251D-02,0.3294D-02,
41589 &0.3336D-02,0.3377D-02,0.3416D-02,0.3452D-02,0.3486D-02,0.3517D-02,
41590 &0.3543D-02,0.3564D-02,0.3578D-02,0.3582D-02,0.3574D-02,0.3549D-02,
41591 &0.3500D-02,0.3411D-02,0.3249D-02,0.2916D-02/
41592 DATA (XPV(I,5,0),I=1,100)/
41593 &0.3395D+00,0.3321D+00,0.3219D+00,0.3090D+00,0.2933D+00,0.2751D+00,
41594 &0.2550D+00,0.2414D+00,0.2348D+00,0.2261D+00,0.2153D+00,0.2025D+00,
41595 &0.1881D+00,0.1751D+00,0.1704D+00,0.1640D+00,0.1559D+00,0.1464D+00,
41596 &0.1357D+00,0.1276D+00,0.1233D+00,0.1178D+00,0.1110D+00,0.1032D+00,
41597 &0.9616D-01,0.9268D-01,0.8813D-01,0.8262D-01,0.7648D-01,0.7317D-01,
41598 &0.6948D-01,0.6506D-01,0.6083D-01,0.5795D-01,0.5442D-01,0.5097D-01,
41599 &0.4827D-01,0.4513D-01,0.4265D-01,0.4000D-01,0.3769D-01,0.3529D-01,
41600 &0.3322D-01,0.3117D-01,0.2920D-01,0.2737D-01,0.2561D-01,0.2402D-01,
41601 &0.2245D-01,0.2098D-01,0.1958D-01,0.1829D-01,0.1704D-01,0.1585D-01,
41602 &0.1476D-01,0.1370D-01,0.1270D-01,0.1178D-01,0.1090D-01,0.1007D-01,
41603 &0.9286D-02,0.8547D-02,0.7848D-02,0.7182D-02,0.6551D-02,0.5949D-02,
41604 &0.5372D-02,0.4823D-02,0.4298D-02,0.3794D-02,0.3314D-02,0.2852D-02,
41605 &0.2413D-02,0.1995D-02,0.1599D-02,0.1223D-02,0.8693D-03,0.5397D-03,
41606 &0.5052D-03,0.4716D-03,0.4388D-03,0.4068D-03,0.3757D-03,0.3454D-03,
41607 &0.3160D-03,0.2875D-03,0.2599D-03,0.2332D-03,0.2073D-03,0.1825D-03,
41608 &0.1587D-03,0.1359D-03,0.1142D-03,0.9370D-04,0.7445D-04,0.5655D-04,
41609 &0.4018D-04,0.2553D-04,0.1296D-04,0.3149D-05/
41610 DATA (XPV(I,5,1),I=1,100)/
41611 &0.7886D-02,0.7728D-02,0.7505D-02,0.7221D-02,0.6873D-02,0.6469D-02,
41612 &0.6022D-02,0.5723D-02,0.5585D-02,0.5398D-02,0.5164D-02,0.4885D-02,
41613 &0.4568D-02,0.4283D-02,0.4181D-02,0.4041D-02,0.3864D-02,0.3650D-02,
41614 &0.3408D-02,0.3225D-02,0.3131D-02,0.3005D-02,0.2850D-02,0.2668D-02,
41615 &0.2506D-02,0.2427D-02,0.2321D-02,0.2191D-02,0.2045D-02,0.1968D-02,
41616 &0.1880D-02,0.1774D-02,0.1672D-02,0.1604D-02,0.1519D-02,0.1435D-02,
41617 &0.1371D-02,0.1295D-02,0.1236D-02,0.1172D-02,0.1118D-02,0.1062D-02,
41618 &0.1015D-02,0.9690D-03,0.9257D-03,0.8867D-03,0.8503D-03,0.8197D-03,
41619 &0.7906D-03,0.7655D-03,0.7432D-03,0.7255D-03,0.7107D-03,0.6987D-03,
41620 &0.6911D-03,0.6864D-03,0.6850D-03,0.6876D-03,0.6934D-03,0.7025D-03,
41621 &0.7147D-03,0.7300D-03,0.7482D-03,0.7692D-03,0.7926D-03,0.8187D-03,
41622 &0.8465D-03,0.8768D-03,0.9089D-03,0.9431D-03,0.9801D-03,0.1020D-02,
41623 &0.1065D-02,0.1116D-02,0.1177D-02,0.1250D-02,0.1336D-02,0.1431D-02,
41624 &0.1441D-02,0.1451D-02,0.1460D-02,0.1468D-02,0.1476D-02,0.1483D-02,
41625 &0.1489D-02,0.1494D-02,0.1497D-02,0.1499D-02,0.1499D-02,0.1497D-02,
41626 &0.1492D-02,0.1483D-02,0.1471D-02,0.1454D-02,0.1430D-02,0.1398D-02,
41627 &0.1354D-02,0.1291D-02,0.1195D-02,0.1022D-02/
41628 DATA (XPV(I,5,2),I=1,100)/
41629 &0.9523D-02,0.9362D-02,0.9127D-02,0.8821D-02,0.8442D-02,0.7997D-02,
41630 &0.7501D-02,0.7174D-02,0.7029D-02,0.6828D-02,0.6569D-02,0.6258D-02,
41631 &0.5901D-02,0.5579D-02,0.5475D-02,0.5323D-02,0.5125D-02,0.4884D-02,
41632 &0.4606D-02,0.4399D-02,0.4301D-02,0.4162D-02,0.3986D-02,0.3776D-02,
41633 &0.3590D-02,0.3508D-02,0.3391D-02,0.3242D-02,0.3073D-02,0.2992D-02,
41634 &0.2897D-02,0.2777D-02,0.2663D-02,0.2592D-02,0.2499D-02,0.2408D-02,
41635 &0.2344D-02,0.2263D-02,0.2207D-02,0.2144D-02,0.2095D-02,0.2043D-02,
41636 &0.2005D-02,0.1970D-02,0.1939D-02,0.1917D-02,0.1898D-02,0.1891D-02,
41637 &0.1887D-02,0.1891D-02,0.1901D-02,0.1921D-02,0.1948D-02,0.1981D-02,
41638 &0.2025D-02,0.2076D-02,0.2134D-02,0.2204D-02,0.2281D-02,0.2367D-02,
41639 &0.2463D-02,0.2566D-02,0.2678D-02,0.2798D-02,0.2925D-02,0.3060D-02,
41640 &0.3199D-02,0.3347D-02,0.3500D-02,0.3659D-02,0.3827D-02,0.4007D-02,
41641 &0.4203D-02,0.4424D-02,0.4679D-02,0.4981D-02,0.5336D-02,0.5723D-02,
41642 &0.5764D-02,0.5803D-02,0.5840D-02,0.5875D-02,0.5906D-02,0.5934D-02,
41643 &0.5959D-02,0.5978D-02,0.5992D-02,0.6000D-02,0.6000D-02,0.5991D-02,
41644 &0.5971D-02,0.5938D-02,0.5890D-02,0.5821D-02,0.5726D-02,0.5597D-02,
41645 &0.5419D-02,0.5166D-02,0.4781D-02,0.4089D-02/
41646 DATA (XPV(I,5,3),I=1,100)/
41647 &0.7505D-02,0.7347D-02,0.7127D-02,0.6848D-02,0.6508D-02,0.6113D-02,
41648 &0.5677D-02,0.5385D-02,0.5248D-02,0.5065D-02,0.4837D-02,0.4566D-02,
41649 &0.4259D-02,0.3982D-02,0.3881D-02,0.3744D-02,0.3571D-02,0.3365D-02,
41650 &0.3131D-02,0.2953D-02,0.2861D-02,0.2738D-02,0.2589D-02,0.2414D-02,
41651 &0.2257D-02,0.2179D-02,0.2077D-02,0.1952D-02,0.1812D-02,0.1736D-02,
41652 &0.1651D-02,0.1549D-02,0.1451D-02,0.1384D-02,0.1302D-02,0.1222D-02,
41653 &0.1159D-02,0.1086D-02,0.1028D-02,0.9666D-03,0.9136D-03,0.8587D-03,
41654 &0.8123D-03,0.7666D-03,0.7236D-03,0.6846D-03,0.6479D-03,0.6163D-03,
41655 &0.5861D-03,0.5595D-03,0.5354D-03,0.5152D-03,0.4975D-03,0.4824D-03,
41656 &0.4710D-03,0.4620D-03,0.4558D-03,0.4530D-03,0.4527D-03,0.4552D-03,
41657 &0.4601D-03,0.4675D-03,0.4771D-03,0.4889D-03,0.5026D-03,0.5181D-03,
41658 &0.5351D-03,0.5540D-03,0.5746D-03,0.5972D-03,0.6228D-03,0.6525D-03,
41659 &0.6882D-03,0.7329D-03,0.7908D-03,0.8669D-03,0.9668D-03,0.1092D-02,
41660 &0.1106D-02,0.1121D-02,0.1136D-02,0.1150D-02,0.1164D-02,0.1178D-02,
41661 &0.1191D-02,0.1203D-02,0.1214D-02,0.1225D-02,0.1234D-02,0.1242D-02,
41662 &0.1247D-02,0.1250D-02,0.1251D-02,0.1247D-02,0.1239D-02,0.1224D-02,
41663 &0.1199D-02,0.1159D-02,0.1093D-02,0.9633D-03/
41664 DATA (XPV(I,5,4),I=1,100)/
41665 &0.7997D-02,0.7838D-02,0.7615D-02,0.7329D-02,0.6980D-02,0.6573D-02,
41666 &0.6123D-02,0.5823D-02,0.5684D-02,0.5497D-02,0.5261D-02,0.4981D-02,
41667 &0.4662D-02,0.4375D-02,0.4274D-02,0.4134D-02,0.3955D-02,0.3741D-02,
41668 &0.3497D-02,0.3313D-02,0.3221D-02,0.3095D-02,0.2940D-02,0.2758D-02,
41669 &0.2596D-02,0.2518D-02,0.2414D-02,0.2285D-02,0.2140D-02,0.2065D-02,
41670 &0.1981D-02,0.1877D-02,0.1779D-02,0.1715D-02,0.1634D-02,0.1555D-02,
41671 &0.1497D-02,0.1427D-02,0.1376D-02,0.1320D-02,0.1276D-02,0.1229D-02,
41672 &0.1194D-02,0.1161D-02,0.1131D-02,0.1108D-02,0.1089D-02,0.1077D-02,
41673 &0.1069D-02,0.1067D-02,0.1070D-02,0.1080D-02,0.1095D-02,0.1116D-02,
41674 &0.1144D-02,0.1178D-02,0.1218D-02,0.1265D-02,0.1318D-02,0.1378D-02,
41675 &0.1444D-02,0.1516D-02,0.1594D-02,0.1677D-02,0.1764D-02,0.1858D-02,
41676 &0.1954D-02,0.2056D-02,0.2162D-02,0.2275D-02,0.2398D-02,0.2536D-02,
41677 &0.2696D-02,0.2890D-02,0.3134D-02,0.3450D-02,0.3859D-02,0.4365D-02,
41678 &0.4425D-02,0.4485D-02,0.4544D-02,0.4602D-02,0.4658D-02,0.4713D-02,
41679 &0.4765D-02,0.4815D-02,0.4861D-02,0.4903D-02,0.4940D-02,0.4970D-02,
41680 &0.4993D-02,0.5007D-02,0.5008D-02,0.4994D-02,0.4961D-02,0.4900D-02,
41681 &0.4801D-02,0.4642D-02,0.4373D-02,0.3853D-02/
41682 DATA (XPV(I,6,0),I=1,100)/
41683 &0.4823D+00,0.4713D+00,0.4562D+00,0.4371D+00,0.4141D+00,0.3874D+00,
41684 &0.3580D+00,0.3381D+00,0.3284D+00,0.3157D+00,0.3000D+00,0.2816D+00,
41685 &0.2609D+00,0.2422D+00,0.2354D+00,0.2262D+00,0.2147D+00,0.2012D+00,
41686 &0.1860D+00,0.1744D+00,0.1685D+00,0.1606D+00,0.1511D+00,0.1401D+00,
41687 &0.1304D+00,0.1255D+00,0.1192D+00,0.1116D+00,0.1031D+00,0.9852D-01,
41688 &0.9345D-01,0.8740D-01,0.8162D-01,0.7769D-01,0.7289D-01,0.6822D-01,
41689 &0.6457D-01,0.6033D-01,0.5700D-01,0.5343D-01,0.5035D-01,0.4714D-01,
41690 &0.4439D-01,0.4166D-01,0.3905D-01,0.3663D-01,0.3429D-01,0.3219D-01,
41691 &0.3012D-01,0.2819D-01,0.2634D-01,0.2464D-01,0.2300D-01,0.2142D-01,
41692 &0.1997D-01,0.1857D-01,0.1723D-01,0.1600D-01,0.1482D-01,0.1370D-01,
41693 &0.1263D-01,0.1162D-01,0.1065D-01,0.9734D-02,0.8858D-02,0.8020D-02,
41694 &0.7218D-02,0.6455D-02,0.5727D-02,0.5031D-02,0.4372D-02,0.3743D-02,
41695 &0.3148D-02,0.2587D-02,0.2059D-02,0.1563D-02,0.1101D-02,0.6756D-03,
41696 &0.6315D-03,0.5886D-03,0.5468D-03,0.5062D-03,0.4667D-03,0.4284D-03,
41697 &0.3913D-03,0.3553D-03,0.3206D-03,0.2871D-03,0.2547D-03,0.2238D-03,
41698 &0.1942D-03,0.1660D-03,0.1392D-03,0.1139D-03,0.9030D-04,0.6843D-04,
41699 &0.4849D-04,0.3074D-04,0.1557D-04,0.3784D-05/
41700 DATA (XPV(I,6,1),I=1,100)/
41701 &0.1205D-01,0.1178D-01,0.1142D-01,0.1096D-01,0.1041D-01,0.9763D-02,
41702 &0.9053D-02,0.8577D-02,0.8354D-02,0.8057D-02,0.7688D-02,0.7251D-02,
41703 &0.6756D-02,0.6310D-02,0.6149D-02,0.5929D-02,0.5654D-02,0.5325D-02,
41704 &0.4953D-02,0.4670D-02,0.4526D-02,0.4332D-02,0.4097D-02,0.3822D-02,
41705 &0.3577D-02,0.3456D-02,0.3297D-02,0.3102D-02,0.2885D-02,0.2769D-02,
41706 &0.2639D-02,0.2483D-02,0.2333D-02,0.2232D-02,0.2107D-02,0.1985D-02,
41707 &0.1891D-02,0.1781D-02,0.1696D-02,0.1604D-02,0.1526D-02,0.1445D-02,
41708 &0.1377D-02,0.1310D-02,0.1248D-02,0.1192D-02,0.1139D-02,0.1094D-02,
41709 &0.1052D-02,0.1015D-02,0.9816D-03,0.9544D-03,0.9311D-03,0.9114D-03,
41710 &0.8975D-03,0.8872D-03,0.8810D-03,0.8801D-03,0.8830D-03,0.8899D-03,
41711 &0.9007D-03,0.9151D-03,0.9330D-03,0.9541D-03,0.9781D-03,0.1005D-02,
41712 &0.1034D-02,0.1065D-02,0.1099D-02,0.1135D-02,0.1174D-02,0.1217D-02,
41713 &0.1266D-02,0.1323D-02,0.1392D-02,0.1478D-02,0.1581D-02,0.1696D-02,
41714 &0.1708D-02,0.1720D-02,0.1731D-02,0.1741D-02,0.1751D-02,0.1759D-02,
41715 &0.1766D-02,0.1772D-02,0.1776D-02,0.1778D-02,0.1778D-02,0.1775D-02,
41716 &0.1769D-02,0.1759D-02,0.1744D-02,0.1723D-02,0.1695D-02,0.1657D-02,
41717 &0.1604D-02,0.1530D-02,0.1417D-02,0.1218D-02/
41718 DATA (XPV(I,6,2),I=1,100)/
41719 &0.1365D-01,0.1339D-01,0.1302D-01,0.1254D-01,0.1195D-01,0.1127D-01,
41720 &0.1051D-01,0.1001D-01,0.9777D-02,0.9465D-02,0.9073D-02,0.8604D-02,
41721 &0.8069D-02,0.7589D-02,0.7425D-02,0.7195D-02,0.6900D-02,0.6544D-02,
41722 &0.6138D-02,0.5834D-02,0.5686D-02,0.5481D-02,0.5226D-02,0.4925D-02,
41723 &0.4658D-02,0.4536D-02,0.4367D-02,0.4157D-02,0.3918D-02,0.3801D-02,
41724 &0.3667D-02,0.3499D-02,0.3340D-02,0.3241D-02,0.3112D-02,0.2987D-02,
41725 &0.2897D-02,0.2787D-02,0.2709D-02,0.2624D-02,0.2557D-02,0.2487D-02,
41726 &0.2436D-02,0.2387D-02,0.2346D-02,0.2315D-02,0.2290D-02,0.2279D-02,
41727 &0.2273D-02,0.2277D-02,0.2289D-02,0.2313D-02,0.2346D-02,0.2387D-02,
41728 &0.2441D-02,0.2503D-02,0.2575D-02,0.2660D-02,0.2755D-02,0.2859D-02,
41729 &0.2974D-02,0.3099D-02,0.3232D-02,0.3374D-02,0.3523D-02,0.3680D-02,
41730 &0.3841D-02,0.4010D-02,0.4183D-02,0.4363D-02,0.4552D-02,0.4754D-02,
41731 &0.4976D-02,0.5229D-02,0.5526D-02,0.5885D-02,0.6313D-02,0.6782D-02,
41732 &0.6832D-02,0.6879D-02,0.6924D-02,0.6966D-02,0.7004D-02,0.7038D-02,
41733 &0.7067D-02,0.7091D-02,0.7108D-02,0.7117D-02,0.7116D-02,0.7105D-02,
41734 &0.7081D-02,0.7041D-02,0.6982D-02,0.6899D-02,0.6786D-02,0.6631D-02,
41735 &0.6421D-02,0.6123D-02,0.5672D-02,0.4871D-02/
41736 DATA (XPV(I,6,3),I=1,100)/
41737 &0.1167D-01,0.1141D-01,0.1105D-01,0.1060D-01,0.1005D-01,0.9414D-02,
41738 &0.8715D-02,0.8245D-02,0.8024D-02,0.7730D-02,0.7367D-02,0.6937D-02,
41739 &0.6451D-02,0.6013D-02,0.5853D-02,0.5637D-02,0.5366D-02,0.5044D-02,
41740 &0.4680D-02,0.4403D-02,0.4259D-02,0.4069D-02,0.3839D-02,0.3571D-02,
41741 &0.3331D-02,0.3212D-02,0.3055D-02,0.2866D-02,0.2654D-02,0.2540D-02,
41742 &0.2413D-02,0.2260D-02,0.2114D-02,0.2014D-02,0.1892D-02,0.1773D-02,
41743 &0.1680D-02,0.1572D-02,0.1488D-02,0.1398D-02,0.1320D-02,0.1240D-02,
41744 &0.1173D-02,0.1106D-02,0.1044D-02,0.9874D-03,0.9342D-03,0.8881D-03,
41745 &0.8442D-03,0.8052D-03,0.7698D-03,0.7399D-03,0.7134D-03,0.6903D-03,
41746 &0.6722D-03,0.6574D-03,0.6463D-03,0.6397D-03,0.6365D-03,0.6368D-03,
41747 &0.6405D-03,0.6473D-03,0.6570D-03,0.6695D-03,0.6844D-03,0.7019D-03,
41748 &0.7213D-03,0.7431D-03,0.7673D-03,0.7943D-03,0.8253D-03,0.8617D-03,
41749 &0.9063D-03,0.9627D-03,0.1036D-02,0.1133D-02,0.1259D-02,0.1412D-02,
41750 &0.1430D-02,0.1448D-02,0.1465D-02,0.1482D-02,0.1499D-02,0.1514D-02,
41751 &0.1529D-02,0.1543D-02,0.1556D-02,0.1567D-02,0.1576D-02,0.1583D-02,
41752 &0.1587D-02,0.1588D-02,0.1586D-02,0.1578D-02,0.1563D-02,0.1539D-02,
41753 &0.1504D-02,0.1448D-02,0.1358D-02,0.1189D-02/
41754 DATA (XPV(I,6,4),I=1,100)/
41755 &0.1216D-01,0.1189D-01,0.1153D-01,0.1107D-01,0.1051D-01,0.9868D-02,
41756 &0.9154D-02,0.8677D-02,0.8454D-02,0.8157D-02,0.7787D-02,0.7349D-02,
41757 &0.6851D-02,0.6404D-02,0.6244D-02,0.6025D-02,0.5749D-02,0.5420D-02,
41758 &0.5047D-02,0.4764D-02,0.4621D-02,0.4429D-02,0.4195D-02,0.3920D-02,
41759 &0.3677D-02,0.3559D-02,0.3402D-02,0.3211D-02,0.2996D-02,0.2884D-02,
41760 &0.2759D-02,0.2608D-02,0.2463D-02,0.2369D-02,0.2251D-02,0.2138D-02,
41761 &0.2053D-02,0.1952D-02,0.1879D-02,0.1800D-02,0.1736D-02,0.1670D-02,
41762 &0.1619D-02,0.1572D-02,0.1531D-02,0.1498D-02,0.1470D-02,0.1454D-02,
41763 &0.1442D-02,0.1439D-02,0.1442D-02,0.1455D-02,0.1475D-02,0.1502D-02,
41764 &0.1539D-02,0.1584D-02,0.1637D-02,0.1699D-02,0.1769D-02,0.1847D-02,
41765 &0.1934D-02,0.2027D-02,0.2128D-02,0.2235D-02,0.2348D-02,0.2468D-02,
41766 &0.2591D-02,0.2721D-02,0.2857D-02,0.3001D-02,0.3158D-02,0.3333D-02,
41767 &0.3538D-02,0.3788D-02,0.4102D-02,0.4506D-02,0.5022D-02,0.5648D-02,
41768 &0.5720D-02,0.5792D-02,0.5862D-02,0.5931D-02,0.5997D-02,0.6060D-02,
41769 &0.6120D-02,0.6176D-02,0.6226D-02,0.6271D-02,0.6308D-02,0.6337D-02,
41770 &0.6354D-02,0.6359D-02,0.6348D-02,0.6316D-02,0.6257D-02,0.6163D-02,
41771 &0.6019D-02,0.5797D-02,0.5436D-02,0.4755D-02/
41772 DATA (XPV(I,7,0),I=1,100)/
41773 &0.6367D+00,0.6216D+00,0.6010D+00,0.5752D+00,0.5440D+00,0.5081D+00,
41774 &0.4686D+00,0.4418D+00,0.4287D+00,0.4116D+00,0.3907D+00,0.3662D+00,
41775 &0.3385D+00,0.3137D+00,0.3045D+00,0.2923D+00,0.2772D+00,0.2594D+00,
41776 &0.2393D+00,0.2241D+00,0.2163D+00,0.2060D+00,0.1936D+00,0.1792D+00,
41777 &0.1665D+00,0.1602D+00,0.1520D+00,0.1421D+00,0.1311D+00,0.1252D+00,
41778 &0.1187D+00,0.1109D+00,0.1035D+00,0.9842D-01,0.9228D-01,0.8630D-01,
41779 &0.8164D-01,0.7624D-01,0.7200D-01,0.6747D-01,0.6355D-01,0.5948D-01,
41780 &0.5601D-01,0.5255D-01,0.4926D-01,0.4620D-01,0.4326D-01,0.4061D-01,
41781 &0.3801D-01,0.3557D-01,0.3324D-01,0.3109D-01,0.2903D-01,0.2705D-01,
41782 &0.2521D-01,0.2344D-01,0.2175D-01,0.2018D-01,0.1868D-01,0.1725D-01,
41783 &0.1589D-01,0.1460D-01,0.1337D-01,0.1219D-01,0.1107D-01,0.9999D-02,
41784 &0.8975D-02,0.8003D-02,0.7079D-02,0.6199D-02,0.5369D-02,0.4581D-02,
41785 &0.3839D-02,0.3144D-02,0.2492D-02,0.1883D-02,0.1320D-02,0.8054D-03,
41786 &0.7523D-03,0.7006D-03,0.6504D-03,0.6016D-03,0.5543D-03,0.5084D-03,
41787 &0.4640D-03,0.4210D-03,0.3796D-03,0.3397D-03,0.3011D-03,0.2644D-03,
41788 &0.2292D-03,0.1957D-03,0.1640D-03,0.1342D-03,0.1063D-03,0.8046D-04,
41789 &0.5699D-04,0.3611D-04,0.1829D-04,0.4453D-05/
41790 DATA (XPV(I,7,1),I=1,100)/
41791 &0.1667D-01,0.1629D-01,0.1577D-01,0.1511D-01,0.1431D-01,0.1340D-01,
41792 &0.1239D-01,0.1171D-01,0.1139D-01,0.1097D-01,0.1045D-01,0.9835D-02,
41793 &0.9139D-02,0.8514D-02,0.8286D-02,0.7979D-02,0.7594D-02,0.7137D-02,
41794 &0.6621D-02,0.6230D-02,0.6029D-02,0.5762D-02,0.5438D-02,0.5061D-02,
41795 &0.4726D-02,0.4560D-02,0.4342D-02,0.4078D-02,0.3784D-02,0.3626D-02,
41796 &0.3451D-02,0.3240D-02,0.3038D-02,0.2902D-02,0.2735D-02,0.2572D-02,
41797 &0.2446D-02,0.2299D-02,0.2185D-02,0.2064D-02,0.1960D-02,0.1852D-02,
41798 &0.1762D-02,0.1673D-02,0.1591D-02,0.1516D-02,0.1446D-02,0.1386D-02,
41799 &0.1329D-02,0.1278D-02,0.1233D-02,0.1195D-02,0.1162D-02,0.1134D-02,
41800 &0.1113D-02,0.1096D-02,0.1084D-02,0.1078D-02,0.1077D-02,0.1081D-02,
41801 &0.1090D-02,0.1103D-02,0.1119D-02,0.1140D-02,0.1164D-02,0.1191D-02,
41802 &0.1220D-02,0.1253D-02,0.1288D-02,0.1325D-02,0.1367D-02,0.1413D-02,
41803 &0.1466D-02,0.1530D-02,0.1609D-02,0.1708D-02,0.1830D-02,0.1967D-02,
41804 &0.1981D-02,0.1995D-02,0.2008D-02,0.2021D-02,0.2032D-02,0.2042D-02,
41805 &0.2051D-02,0.2058D-02,0.2063D-02,0.2066D-02,0.2066D-02,0.2063D-02,
41806 &0.2057D-02,0.2045D-02,0.2029D-02,0.2005D-02,0.1973D-02,0.1929D-02,
41807 &0.1869D-02,0.1784D-02,0.1655D-02,0.1427D-02/
41808 DATA (XPV(I,7,2),I=1,100)/
41809 &0.1825D-01,0.1787D-01,0.1734D-01,0.1666D-01,0.1584D-01,0.1488D-01,
41810 &0.1382D-01,0.1312D-01,0.1280D-01,0.1236D-01,0.1182D-01,0.1117D-01,
41811 &0.1044D-01,0.9780D-02,0.9550D-02,0.9233D-02,0.8830D-02,0.8348D-02,
41812 &0.7799D-02,0.7387D-02,0.7184D-02,0.6906D-02,0.6565D-02,0.6163D-02,
41813 &0.5808D-02,0.5642D-02,0.5418D-02,0.5140D-02,0.4827D-02,0.4670D-02,
41814 &0.4493D-02,0.4274D-02,0.4067D-02,0.3936D-02,0.3769D-02,0.3607D-02,
41815 &0.3489D-02,0.3347D-02,0.3246D-02,0.3136D-02,0.3050D-02,0.2959D-02,
41816 &0.2893D-02,0.2830D-02,0.2777D-02,0.2736D-02,0.2703D-02,0.2687D-02,
41817 &0.2678D-02,0.2680D-02,0.2693D-02,0.2720D-02,0.2757D-02,0.2805D-02,
41818 &0.2867D-02,0.2940D-02,0.3024D-02,0.3123D-02,0.3233D-02,0.3355D-02,
41819 &0.3489D-02,0.3632D-02,0.3785D-02,0.3948D-02,0.4118D-02,0.4297D-02,
41820 &0.4479D-02,0.4668D-02,0.4863D-02,0.5063D-02,0.5274D-02,0.5499D-02,
41821 &0.5750D-02,0.6038D-02,0.6381D-02,0.6800D-02,0.7306D-02,0.7864D-02,
41822 &0.7924D-02,0.7980D-02,0.8034D-02,0.8085D-02,0.8131D-02,0.8172D-02,
41823 &0.8208D-02,0.8236D-02,0.8258D-02,0.8270D-02,0.8271D-02,0.8259D-02,
41824 &0.8233D-02,0.8188D-02,0.8122D-02,0.8027D-02,0.7897D-02,0.7721D-02,
41825 &0.7480D-02,0.7139D-02,0.6624D-02,0.5709D-02/
41826 DATA (XPV(I,7,3),I=1,100)/
41827 &0.1630D-01,0.1592D-01,0.1540D-01,0.1475D-01,0.1396D-01,0.1305D-01,
41828 &0.1205D-01,0.1138D-01,0.1107D-01,0.1065D-01,0.1013D-01,0.9526D-02,
41829 &0.8839D-02,0.8222D-02,0.7995D-02,0.7690D-02,0.7310D-02,0.6860D-02,
41830 &0.6352D-02,0.5966D-02,0.5766D-02,0.5502D-02,0.5183D-02,0.4813D-02,
41831 &0.4483D-02,0.4318D-02,0.4103D-02,0.3844D-02,0.3555D-02,0.3399D-02,
41832 &0.3225D-02,0.3018D-02,0.2820D-02,0.2685D-02,0.2521D-02,0.2360D-02,
41833 &0.2235D-02,0.2091D-02,0.1978D-02,0.1857D-02,0.1754D-02,0.1647D-02,
41834 &0.1557D-02,0.1468D-02,0.1385D-02,0.1310D-02,0.1239D-02,0.1177D-02,
41835 &0.1118D-02,0.1066D-02,0.1018D-02,0.9774D-03,0.9411D-03,0.9091D-03,
41836 &0.8835D-03,0.8619D-03,0.8450D-03,0.8338D-03,0.8268D-03,0.8242D-03,
41837 &0.8257D-03,0.8312D-03,0.8403D-03,0.8529D-03,0.8686D-03,0.8875D-03,
41838 &0.9087D-03,0.9331D-03,0.9605D-03,0.9915D-03,0.1028D-02,0.1070D-02,
41839 &0.1124D-02,0.1191D-02,0.1279D-02,0.1395D-02,0.1545D-02,0.1725D-02,
41840 &0.1746D-02,0.1766D-02,0.1786D-02,0.1805D-02,0.1823D-02,0.1841D-02,
41841 &0.1857D-02,0.1872D-02,0.1886D-02,0.1897D-02,0.1907D-02,0.1913D-02,
41842 &0.1916D-02,0.1915D-02,0.1909D-02,0.1897D-02,0.1877D-02,0.1846D-02,
41843 &0.1799D-02,0.1729D-02,0.1618D-02,0.1411D-02/
41844 DATA (XPV(I,7,4),I=1,100)/
41845 &0.1678D-01,0.1640D-01,0.1587D-01,0.1522D-01,0.1442D-01,0.1350D-01,
41846 &0.1249D-01,0.1181D-01,0.1149D-01,0.1107D-01,0.1055D-01,0.9935D-02,
41847 &0.9238D-02,0.8611D-02,0.8385D-02,0.8078D-02,0.7694D-02,0.7237D-02,
41848 &0.6721D-02,0.6331D-02,0.6132D-02,0.5867D-02,0.5545D-02,0.5170D-02,
41849 &0.4837D-02,0.4676D-02,0.4462D-02,0.4202D-02,0.3912D-02,0.3761D-02,
41850 &0.3592D-02,0.3388D-02,0.3194D-02,0.3068D-02,0.2911D-02,0.2759D-02,
41851 &0.2646D-02,0.2513D-02,0.2415D-02,0.2310D-02,0.2226D-02,0.2139D-02,
41852 &0.2072D-02,0.2010D-02,0.1955D-02,0.1911D-02,0.1875D-02,0.1852D-02,
41853 &0.1836D-02,0.1830D-02,0.1833D-02,0.1848D-02,0.1872D-02,0.1905D-02,
41854 &0.1950D-02,0.2004D-02,0.2069D-02,0.2145D-02,0.2231D-02,0.2327D-02,
41855 &0.2432D-02,0.2547D-02,0.2669D-02,0.2800D-02,0.2937D-02,0.3082D-02,
41856 &0.3232D-02,0.3389D-02,0.3553D-02,0.3727D-02,0.3917D-02,0.4130D-02,
41857 &0.4378D-02,0.4681D-02,0.5061D-02,0.5547D-02,0.6163D-02,0.6897D-02,
41858 &0.6981D-02,0.7063D-02,0.7144D-02,0.7221D-02,0.7296D-02,0.7367D-02,
41859 &0.7433D-02,0.7494D-02,0.7548D-02,0.7595D-02,0.7632D-02,0.7658D-02,
41860 &0.7671D-02,0.7667D-02,0.7644D-02,0.7595D-02,0.7513D-02,0.7388D-02,
41861 &0.7203D-02,0.6923D-02,0.6476D-02,0.5646D-02/
41868 ENT(I)=LOG10(XT(I))
41873 ENT(IX+I)=LOG10(Q2T(I))
41877 C..various flavours (u-->2,d-->1)
41878 XPDF(0)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,0))
41879 XPDF(1)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,1))
41880 XPDF(2)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,2))
41881 XPDF(3)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,3))
41882 XPDF(4)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,4))
41889 *$ CREATE PHO_DBFINT.FOR
41891 CDECK ID>, PHO_DBFINT
41892 DOUBLE PRECISION FUNCTION PHO_DBFINT(NARG,ARG,NA,ENT,TABLE)
41893 C***********************************************************************
41895 C routine based on CERN library E104
41897 C multi-dimensional interpolation routine, needed for PHOJET
41898 C internal cross section tables and several PDF sets (GRV98 and AGL)
41900 C changed to avoid recursive function calls (R.Engel, 09/98)
41902 C***********************************************************************
41903 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
41906 INTEGER NA(NARG), INDEX(32)
41907 DOUBLE PRECISION ARG(NARG),ENT(NARG),TABLE(*),WEIGHT(32)
41914 IF(NARG .LT. 1 .OR. NARG .GT. 5) RETURN
41927 IF(NDIM .GT. 2) GOTO 10
41928 IF(NDIM .EQ. 1) GOTO 100
41930 IF(H .EQ. ZEROD) GOTO 90
41932 IF(X-ENT(LMIN+1) .EQ. ZEROD) GOTO 21
41934 ETA = H / (ENT(LMIN+1) - ENT(LMIN))
41937 11 LOCC = (LOCA+LOCB) / 2
41938 IF(X-ENT(LOCC)) 12, 20, 13
41942 14 IF(LOCB-LOCA .GT. 1) GOTO 11
41943 LOCA = MIN ( MAX (LOCA,LMIN), LMAX-1 )
41944 ISHIFT = (LOCA - LMIN) * ISTEP
41945 ETA = (X - ENT(LOCA)) / (ENT(LOCA+1) - ENT(LOCA))
41947 20 ISHIFT = (LOCC - LMIN) * ISTEP
41948 21 DO 22 K = 1, KNOTS
41949 INDEX(K) = INDEX(K) + ISHIFT
41952 30 DO 31 K = 1, KNOTS
41953 INDEX(K) = INDEX(K) + ISHIFT
41954 INDEX(K+KNOTS) = INDEX(K) + ISTEP
41955 WEIGHT(K+KNOTS) = WEIGHT(K) * ETA
41956 WEIGHT(K) = WEIGHT(K) - WEIGHT(K+KNOTS)
41959 90 ISTEP = ISTEP * NDIM
41961 DO 200 K = 1, KNOTS
41963 DBFINT = DBFINT + WEIGHT(K) * TABLE(I)
41966 PHO_DBFINT = DBFINT
41970 *$ CREATE PHVAL.FOR
41973 SUBROUTINE PHVAL(IGRP,ISET,XI,SCALE2,PD,IRET)
41974 C**********************************************************************
41976 C dummy subroutine, remove to link PHOLIB
41978 C**********************************************************************
41979 IMPLICIT DOUBLE PRECISION (A-H,O-Z)