 
 


CDECK  ID>, ipho_anti
      INTEGER FUNCTION IPHO_ANTI(ID)
C**********************************************************************
C
C     determine antiparticle for given ID
C
C     input:  ID gives CPC particle number
C
C     output: IPHO_ANTI antiparticle code
C
C**********************************************************************

      IMPLICIT NONE

      SAVE

      INTEGER ID

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  particle ID translation table
      INTEGER         ID_pdg_list,ID_list,ID_pdg_max
      CHARACTER*12    name_list
      COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
     &                ID_pdg_max

C  general particle data
      DOUBLE PRECISION xm_list,tau_list,gam_list,
     &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
     &  xm_bb82_list,xm_bb102_list
      INTEGER          ich3_list,iba3_list,iq_list,
     &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
      COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
     &  xm_psm2_list(6,6),xm_vem2_list(6,6),
     &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
     &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
     &  ich3_list(300),iba3_list(300),iq_list(3,300),
     &  id_psm_list(6,6),id_vem_list(6,6),
     &  id_b8_list(6,6,6),id_b10_list(6,6,6)

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

C  external functions
      INTEGER  IPHO_ID2PDG,IPHO_PDG2ID
      EXTERNAL IPHO_ID2PDG,IPHO_PDG2ID

C  local variables
      INTEGER IDabs,IDpdg,i_anti,l

      IPHO_ANTI = -ID
      IDabs = abs(ID)

C  baryons
      if(iba3_list(IDabs).ne.0) return

C  charged particles
      if(ich3_list(IDabs).ne.0) return

C  K0_s and K0_l
      IDpdg = IPHO_ID2PDG(ID)
      if(IDpdg.eq.310) then
        ID = IPHO_PDG2ID(130)
        return
      else if(IDpdg.eq.130) then
        ID = IPHO_PDG2ID(310)
        return
      endif

C  neutral mesons with open strangeness, charm, or beauty
      i_anti = 0
      do l=1,3
        i_anti = i_anti+iq_list(l,IDabs)
      enddo
      if(i_anti.ne.0) return

C  neutrinos
      IDpdg = abs(IDpdg)
      if((IDpdg.eq.12).or.(IDpdg.eq.14).or.(IDpdg.eq.16)) return

      IPHO_ANTI = ID

      END


 
 


CDECK  ID>, ipho_bar3
      INTEGER FUNCTION IPHO_BAR3(ID,mode)
C**********************************************************************
C
C     output of three times the baryon charge
C
C     index:  MODE
C             0   ID gives CPC particle number
C             1   ID gives PDG particle number
C             2   ID gives position of particle in /POEVT1/
C
C**********************************************************************

      IMPLICIT NONE

      SAVE

      INTEGER ID,mode

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

C  particle ID translation table
      INTEGER         ID_pdg_list,ID_list,ID_pdg_max
      CHARACTER*12    name_list
      COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
     &                ID_pdg_max

C  general particle data
      DOUBLE PRECISION xm_list,tau_list,gam_list,
     &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
     &  xm_bb82_list,xm_bb102_list
      INTEGER          ich3_list,iba3_list,iq_list,
     &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
      COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
     &  xm_psm2_list(6,6),xm_vem2_list(6,6),
     &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
     &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
     &  ich3_list(300),iba3_list(300),iq_list(3,300),
     &  id_psm_list(6,6),id_vem_list(6,6),
     &  id_b8_list(6,6,6),id_b10_list(6,6,6)

C  external functions
      INTEGER  IPHO_PDG2ID
      EXTERNAL IPHO_PDG2ID

C  local variables
      INTEGER i,IDpdg

      IPHO_BAR3 = 0

      if(mode.eq.0) then
        i = ID
      else if(mode.eq.1) then
        i = IPHO_PDG2ID(ID)
        if(i.eq.0) return
        IDpdg = ID
      else if(mode.eq.2) then
        if(ISTHEP(ID).gt.11) return
        i     = IMPART(ID)
        IDpdg = IDHEP(ID)
        IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
          IPHO_BAR3 = ICOLOR(2,ID)
          return
        endif
      else
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1x,a,2i4)')
     &    'IPHO_BAR3: invalid mode (ID,mode): ',ID,mode
        return
      endif

      if((i.eq.0).or.(abs(i).gt.ID_pdg_max)) then
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1x,a,3i8)')
     &    'IPHO_BAR3: invalid arguments (ID,mode,i): ',ID,mode,i
        IPHO_BAR3 = 1.D0/dble(i)
        return
      endif

      IPHO_BAR3 = iba3_list(abs(i))*sign(1,i)

      END


 
 


CDECK  ID>, ipho_chr3
      INTEGER FUNCTION IPHO_CHR3(ID,mode)
C**********************************************************************
C
C     output of three times the electric charge
C
C     input:  mode
C             0   ID gives CPC particle number
C             1   ID gives PDG particle number
C             2   ID gives position of particle in /POEVT1/
C
C**********************************************************************

      IMPLICIT NONE

      SAVE

      INTEGER ID,mode

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

C  particle ID translation table
      INTEGER         ID_pdg_list,ID_list,ID_pdg_max
      CHARACTER*12    name_list
      COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
     &                ID_pdg_max

C  general particle data
      DOUBLE PRECISION xm_list,tau_list,gam_list,
     &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
     &  xm_bb82_list,xm_bb102_list
      INTEGER          ich3_list,iba3_list,iq_list,
     &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
      COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
     &  xm_psm2_list(6,6),xm_vem2_list(6,6),
     &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
     &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
     &  ich3_list(300),iba3_list(300),iq_list(3,300),
     &  id_psm_list(6,6),id_vem_list(6,6),
     &  id_b8_list(6,6,6),id_b10_list(6,6,6)

C  external functions
      INTEGER  IPHO_PDG2ID
      EXTERNAL IPHO_PDG2ID

C  local variables
      INTEGER i,IDpdg

      IPHO_CHR3 = 0

      if(mode.eq.0) then
        i = ID
      else if(mode.eq.1) then
        i = IPHO_PDG2ID(ID)
        if(i.eq.0) return
        IDpdg = ID
      else if(mode.eq.2) then
        if(ISTHEP(ID).gt.11) return
        i     = IMPART(ID)
        IDpdg = IDHEP(ID)
        IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
          IPHO_CHR3 = ICOLOR(1,ID)
          return
        endif
      else
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1x,a,2i4)')
     &    'IPHO_CHR3: invalid mode (ID,mode): ',ID,mode
        return
      endif

      if((i.eq.0).or.(abs(i).gt.ID_pdg_max)) then
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1x,a,3i8)')
     &    'IPHO_CHR3: invalid arguments (ID,mode,i): ',ID,mode,i
        CALL PHO_ABORT
        Return
      endif

      IPHO_CHR3 = ich3_list(abs(i))*sign(1,i)

      END


 
 


CDECK  ID>, IPHO_CNV1
      INTEGER FUNCTION IPHO_CNV1(IPART)
C*********************************************************************
C
C     conversion of quark numbering scheme to PARTICLE DATA GROUP
C                                             convention
C
C     input:   old internal particle code of hard scattering
C                    0   gluon
C                    1   d
C                    2   u
C                    3   s
C                    4   c
C     valence quarks changed to standard numbering
C
C     output:  standard particle codes
C
C*********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE
C
      II = ABS(IPART)
C  change gluon number
      IF(II.EQ.0) THEN
        IPHO_CNV1 = 21
C  change valence quark
      ELSE IF((II.GT.6).AND.(II.LT.13)) THEN
        IPHO_CNV1 = SIGN(II-6,IPART)
      ELSE
        IPHO_CNV1 = IPART
      ENDIF
      END


 
 


CDECK  ID>, ipho_diqu
      INTEGER FUNCTION IPHO_DIQU(iq1,iq2)
C***********************************************************************
C
C     selection of diquark number (PDG convention)
C
C***********************************************************************

      IMPLICIT NONE

      SAVE

      INTEGER iq1,iq2

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  external functions
      DOUBLE PRECISION DT_RNDM

C  local variables
      INTEGER i0,i1,i2
      DOUBLE PRECISION dum

      i1 = abs(iq1)
      i2 = abs(iq2)

      if(i1.eq.i2) then
        i0 = i1*1100+3
      else
        i0 = max(i1,i2)*1000+min(i1,i2)*100
        if(DT_RNDM(dum).gt.PARMDL(135)) then
          i0 = i0+1
        else
          i0 = i0+3
        endif
      endif

      IPHO_DIQU = sign(i0,iq1)

      END


 
 

*
*===phoini=============================================================*
*
CDECK  ID>, IPHO_FINDIDX      
      INTEGER FUNCTION IPHO_FINDIDX(ISIDE, VALUE, NDIM)
c********************************************************************
c
c     Find index of
c
c********************************************************************
      IMPLICIT NONE
      SAVE

      INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN
      INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL
      DOUBLE PRECISION SQSGLOBMAX
      PARAMETER (MPARMAX=40)
      PARAMETER (MAXMAPPS=40)
      PARAMETER (IKNOWN=9)
      DIMENSION IPAVAIL(IKNOWN)
      DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/
      COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS),
     &           MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP

      INTEGER ISIDE, VALUE, NDIM, IDX

      IPHO_FINDIDX = -1

      DO IDX=1,NDIM
        IF (MPMAPP(ISIDE,IDX)==VALUE) THEN 
          IPHO_FINDIDX = IDX
          EXIT
        END IF
      END DO

      END



 
 


CDECK  ID>, IPHO_ID2PDG
      INTEGER FUNCTION IPHO_ID2PDG(IDcpc)
C**********************************************************************
C
C     conversion of internal particle code to PDG standard
C
C     input:     IDcpc        internal particle number
C     output:    IPHO_ID2PDG  PDG particle number
C                             (0 for invalid IDcpc)
C
C**********************************************************************

      IMPLICIT NONE

      SAVE

      INTEGER IDcpc

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  particle ID translation table
      INTEGER         ID_pdg_list,ID_list,ID_pdg_max
      CHARACTER*12    name_list
      COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
     &                ID_pdg_max

      INTEGER IDabs

      IDabs = abs(IDcpc)
      if((IDabs.lt.1).or.(IDabs.gt.ID_pdg_max)) then
        IPHO_ID2PDG = 0
        return
      endif

      IPHO_ID2PDG = sign(ID_pdg_list(IDabs),IDcpc)

      END


 
 


CDECK  ID>, IPHO_ISMAPPED
      INTEGER FUNCTION IPHO_ISMAPPED(ipdg)
c*********************************************************************
c
c     Returns PDG ID of particle to which ipdg is mapped. If it is not
c     mapped to anything the original ipdg is returned 
c
c     input:   PDG ID of incoming particle
c
c     output:  PDG ID under which the particle is tracked in 
c              initialization
c
c*********************************************************************
      IMPLICIT NONE
      SAVE

      INTEGER ipdg, i

      INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN
      INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL
      DOUBLE PRECISION SQSGLOBMAX
      PARAMETER (MPARMAX=40)
      PARAMETER (MAXMAPPS=40)
      PARAMETER (IKNOWN=9)
      DIMENSION IPAVAIL(IKNOWN)
      DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/
      COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS),
     &           MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP

      
      IPHO_ISMAPPED = ipdg
      If (nmapp.lt.1) Return
      Do i=1,nmapp
        If (ipdg==mpmapp(1,i)) Then
          IPHO_ISMAPPED = mpmapp(2,i)
          Exit
        End If
c   The array should not contain any zeros due in between values
        If (mpmapp(1,i) == 0) Exit
      End Do

      End 


 
 


CDECK  ID>, IPHO_LU2PDG
      INTEGER FUNCTION IPHO_LU2PDG(LUKF)
C**********************************************************************
C
C    conversion of JETSET KF code to PDG code
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE
      PARAMETER (NTAB=10)
      DIMENSION LU2PD(2,NTAB)
      DATA LU2PD / 4232, 4322,
     &             4322, 4232,
     &             3212, 3122,
     &             3122, 3212,
     &            30553, 20553,
     &            30443, 20443,
     &            20443, 10443,
     &            10443, 0,
     &            511,   0,
     &            10551, 551 /
C
      DO 100 I=1,NTAB
        IF(LU2PD(1,I).EQ.LUKF) THEN
          IPHO_LU2PDG=LU2PD(2,I)
          RETURN
        ENDIF
 100  CONTINUE
      IPHO_LU2PDG=LUKF

      END


 
 


CDECK  ID>, IPHO_PDG2ID
      INTEGER FUNCTION IPHO_PDG2ID(IDpdg)
C**********************************************************************
C
C     calculation internal particle code using the particle index i
C     according to the PDG proposal.
C
C     input:  IDpdg          PDG particle number
C     output: IPHO_PDG2ID    internal particle code
C                            (0 for invalid IDpdg)
C
C     the hash algorithm is based on a program by Gerry Lynch
C
C**********************************************************************

      IMPLICIT NONE

      SAVE

      integer IDpdg

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  particle ID translation table
      INTEGER         ID_pdg_list,ID_list,ID_pdg_max
      CHARACTER*12    name_list
      COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
     &                ID_pdg_max

      INTEGER Nin,Nout

      Nin = abs(IDpdg)

      if((Nin.gt.99999).or.(Nin.eq.0)) then
C  invalid particle number
        IF (LPRI.GT.4 .AND. ideb(71).gt.5)
     &  WRITE(LO,'(1x,A,I10)')
     &    'IPHO_PDG2ID: invalid PDG ID number ',IDpdg
        IPHO_PDG2ID = 0
        return
      else If(Nin.le.577) then
C  simple case
        Nout = Nin
      else
C  use hash algorithm
        Nout = mod(Nin,577)
      endif

 100  continue

C  particle not in table
      if(ID_list(Nout).Eq.0) then
        IF (LPRI.GT.4 .AND. ideb(71).ge.0)
     &  WRITE(LO,'(1x,A,I10)')
     &    'IPHO_PDG2ID: particle not in table ',IDpdg
        IPHO_PDG2ID = 0
        return
      endif

      if(ID_pdg_list(ID_list(Nout)).eq.Nin) then
C  particle ID found
        IPHO_PDG2ID = sign(ID_list(Nout),IDpdg)
        return
      else
C  increment and try again
        Nout = Nout + 5
        If(Nout.gt.577) Nout = Mod(Nout,577)
        goto 100
      endif

      END


 
 


CDECK  ID>, IPHO_PDG2LU
      INTEGER FUNCTION IPHO_PDG2LU(IPDG)
C**********************************************************************
C
C    conversion of PDG code to JETSET code
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE
      PARAMETER (NTAB=8)
      DIMENSION LU2PD(2,NTAB)
      DATA LU2PD / 4232, 4322,
     &             4322, 4232,
     &             3212, 3122,
     &             3122, 3212,
     &            30553, 20553,
     &            30443, 20443,
     &            20443, 10443,
     &            10551, 551 /
C
      DO 100 I=1,NTAB
        IF(LU2PD(2,I).EQ.IPDG) THEN
          IPHO_PDG2LU=LU2PD(1,I)
          RETURN
        ENDIF
 100  CONTINUE
      IPHO_PDG2LU=IPDG

      END


 
 


CDECK  ID>, PHO_ABORT
      SUBROUTINE PHO_ABORT
C**********************************************************************
C
C     top MC event generation due to fatal error,
C     print all information of event generation and history
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

C  color string configurations including collapsed strings and hadrons
      INTEGER MSTR
      PARAMETER (MSTR=2000)
      INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
      COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
     &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
     &                NNCH(MSTR),IBHAD(MSTR),ISTR

C  light-cone x fractions and c.m. momenta of soft cut string ends
      INTEGER MAXSOF
      PARAMETER ( MAXSOF = 2000 )
      INTEGER IJSI2,IJSI1
      DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
      COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
     &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
     &                IJSI1(MAXSOF),IJSI2(MAXSOF)

C  hard scattering data
      INTEGER MSCAHD
      PARAMETER ( MSCAHD = 1000 )
      INTEGER LSCAHD,LSC1HD,LSIDX,
     &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
      DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
      COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
     &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
     &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
     &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
     &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
     &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
     &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)


      WRITE(LO,'(//,1X,A,/,1X,A)')
     &  'PHO_ABORT: program execution stopped',
     &  '===================================='
      WRITE(LO,'(/,1X,A,/,1X,A)') 'listing of available data follows:'
C
      CALL PHO_SETMDL(0,0,-2)
      CALL PHO_PREVNT(-1)
      CALL PHO_ACTPDF(0,-2)
C  print selected parton flavours
      WRITE(LO,'(1X,A,I4)') 'selected soft flavours: ',KSOFT
      DO 700 I=1,KSOFT
        WRITE(LO,'(10X,2I5)') IJSI1(I),IJSI2(I)
 700  CONTINUE
      WRITE(LO,'(1X,A,I4)') 'selected hard flavours: ',KHARD
      DO 750 K=1,KHARD
        I = LSIDX(K)
        WRITE(LO,'(10X,A,I5)') 'process:',NPROHD(I)
        WRITE(LO,'(10X,A,2I4,7X,A,2I4)') 'initial:',NINHD(I,1),
     &    NINHD(I,2),'final:',NOUTHD(I,1),NOUTHD(I,2)
 750  CONTINUE
C  print selected parton momenta
      WRITE(LO,'(1X,A,I4)') 'selected soft momenta: ',KSOFT
      DO 300 I=1,KSOFT
        WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PSOFT1(II,I),II=1,4)
        WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PSOFT2(II,I),II=1,4)
 300  CONTINUE
      WRITE(LO,'(1X,A,I4)') 'selected hard momenta: ',KHARD
      DO 350 K=1,KHARD
        I = LSIDX(K)
        I3 = 8*I-4
        WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PPH(I3+II,1),II=1,4)
        WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PPH(I3+II,2),II=1,4)
 350  CONTINUE

C  print /POEVT1/
      CALL PHO_PREVNT(0)

C  fragmentation process
      IF(ISTR.GT.0) THEN
C  print /POSTRG/
        CALL PHO_PRSTRG

        IF(ISWMDL(6).GE.0) CALL PYLIST(1)

      ENDIF

C  last message
      WRITE(LO,'(////5X,A,///5X,A,///)')
     &  'PHO_ABORT: execution terminated due to fatal error',
     &'*** Simulating division by zero to get traceback information ***'
      ISTR = 100/IPAMDL(100)

      END


 
 


CDECK  ID>, PHO_ACTPDF
      SUBROUTINE PHO_ACTPDF(IDPDG,K)
C***************************************************************
C
C     activate PDF for QCD calculations
C
C     input:      IDPDG    PDG particle number
C                 K        1  first PDF in /POPPDF/
C                          2  second PDF in /POPPDF/
C                         -2  write current settings
C
C     output:     /POPPDF/
C
C***************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  currently activated parton density parametrizations
      CHARACTER*8 PDFNAM
      INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
      DOUBLE PRECISION PDFLAM,PDFQ2M
      COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
     &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD

C  currently activated parton density parametrizations
      INTEGER IDEQP,IDEQB,IHFLD,IHFLS
      DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
      COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
     &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)

      DOUBLE PRECISION PHO_ALPHAS
      EXTERNAL         PHO_ALPHAS

      IF(K.GT.0) THEN

C  read PDF from table
        CALL PHO_SETPDF(IDPDG,ITYPE(K),IGRP(K),ISET(K),IEXT(K),
     &                 IPAVA(K),1)

C** pass proper mother information to PDF routine.
        IF ((IDPDG.EQ.81).OR.(IDPDG.EQ.82)) THEN
          IPARID(K) = IDEQP(mod(IDPDG,80))
        ELSE
          IPARID(K) = IDPDG
        END IF
C  get PDF parameters
        CALL PHO_GETPDF(K,PDFNAM(K),PDFLAM(K),PDFQ2M(K),Q2MA,XMI,XMA)
C  initialize alpha_s calculation
        alam2 = PDFLAM(K)*PDFLAM(K)
        DUMMY = PHO_ALPHAS(alam2,-K)

        IF(IDEB(2).GE.20) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A)')
     &      'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,I2,2E12.3,2X,A8,4I4,I7)') 'SIDE',K,
     &      PDFLAM(K),PDFQ2M(K),PDFNAM(K),ITYPE(K),IGRP(K),ISET(K),
     &      IEXT(K),IPARID(K)
        ENDIF
        NPAOLD = K

      ELSE IF(K.EQ.-2) THEN

C  write table of current PDFs
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A)')
     &    'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 1:',PDFLAM(1),
     &    PDFQ2M(1),PDFNAM(1),ITYPE(1),IGRP(1),ISET(1),IEXT(1),
     &    IPARID(1)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 2:',PDFLAM(2),
     &    PDFQ2M(2),PDFNAM(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),
     &    IPARID(2)

      ELSE

        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,2I4)')
     &    'PHO_ACTPDF:ERROR: invalid arguments',IDPDG,K
        CALL PHO_ABORT

      ENDIF

      END


 
 


CDECK  ID>, PHO_ALLM97
      DOUBLE PRECISION FUNCTION PHO_ALLM97(Q2,W)
C**********************************************************************
C
C     ALLM97 parametrization for gamma*-p cross section
C     (for F2 see comments, code adapted from V. Shekelyan, H1)
C
C**********************************************************************

      IMPLICIT NONE

      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

      DOUBLE PRECISION Q2,W
      DOUBLE PRECISION M02,M12,LAM2,M22
      DOUBLE PRECISION S11,S12,S13,A11,A12,A13,B11,B12,B13
      DOUBLE PRECISION S21,S22,S23,A21,A22,A23,B21,B22,B23
      DOUBLE PRECISION ALFA,XMP2,W2,Q02,S,T,T0,Z,CIN,
     &                 AP,BP,AR,BR,XP,XR,SR,SP,F2P,F2R
      DATA ALFA,XMP2 /112.2D0 , .8802D0 /

      W2=W*W
      PHO_ALLM97 = 0.D0

C  pomeron
      S11   =   0.28067D0
      S12   =   0.22291D0
      S13   =   2.1979D0
      A11   =  -0.0808D0
      A12   =  -0.44812D0
      A13   =   1.1709D0
      B11   =   0.60243D0
      B12   =   1.3754D0
      B13   =   1.8439D0
      M12   =  49.457D0

C  reggeon
      S21   =   0.80107D0
      S22   =   0.97307D0
      S23   =   3.4942D0
      A21   =   0.58400D0
      A22   =   0.37888D0
      A23   =   2.6063D0
      B21   =   0.10711D0
      B22   =   1.9386D0
      B23   =   0.49338D0
      M22   =   0.15052D0
C
      M02   =   0.31985D0
      LAM2  =   0.065270D0
      Q02   =   0.46017D0 +LAM2

C
      S=0.
      T=LOG((Q2+Q02)/LAM2)
      T0=LOG(Q02/LAM2)
      IF(Q2.GT.0.D0) S=LOG(T/T0)
      Z=1.D0

      IF(Q2.GT.0.D0) Z=(W2-XMP2)/(Q2+W2-XMP2)

      IF(S.LT.0.01D0) THEN

C   pomeron part

        XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))

        AP=A11
        BP=B11**2

        SP=S11
        F2P=SP*XP**AP*Z**BP

C   reggeon part

        XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))

        AR=A21
        BR=B21**2

        SR=S21
        F2R=SR*XR**AR*Z**BR

      ELSE

C   pomeron part

        XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))

        AP=A11+(A11-A12)*(1.D0 /(1.D0 +S**A13)-1.D0 )

        BP=B11**2+B12**2*S**B13

        SP=S11+(S11-S12)*(1.D0 /(1.D0 +S**S13)-1.D0 )

        F2P=SP*XP**AP*Z**BP

C   reggeon part

        XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))

        AR=A21+A22*S**A23
        BR=B21**2+B22**2*S**B23

        SR=S21+S22*S**S23
        F2R=SR*XR**AR*Z**BR

      ENDIF

*     F2 = (F2P+F2R)*Q2/(Q2+M02)

      CIN=ALFA/(Q2+M02)*(1.D0 +4.D0*XMP2*Q2/(Q2+W2-XMP2)**2)/Z
      PHO_ALLM97 = CIN*(F2P+F2R)

      END


 
 


CDECK  ID>, PHO_ALPHAE
      DOUBLE PRECISION FUNCTION PHO_ALPHAE(Q2)
C**********************************************************************
C
C     calculation of ALPHA_em
C
C     input:    Q2      scale in GeV**2
C
C**********************************************************************

      IMPLICIT NONE

      SAVE

      DOUBLE PRECISION Q2

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

      DOUBLE PRECISION PYALEM

      PHO_ALPHAE = 1.D0/137.D0

      if(ipamdl(120).eq.1) then

        PHO_ALPHAE = PYALEM(Q2)

      endif

      END


 
 


CDECK  ID>, PHO_ALPHAS
      DOUBLE PRECISION FUNCTION PHO_ALPHAS(Q2,IMODE)
C**********************************************************************
C
C     calculation of ALPHA_S
C
C     input:    IMODE = 1         lambda_QCD**2 for PDF 1 evolution
C                       2         lambda_QCD**2 for PDF 2 evolution
C                       3         lambda_QCD**2 for hard scattering
C               Q2      scale in GeV**2
C
C     initialization needed:
C               IMODE = 0         lambda values taken from PDF table
C                       -1        given Q2 is 4-flavour lambda 1
C                       -2        given Q2 is 4-flavour lambda 2
C                       -3        given Q2 is 4-flavour lambda 3
C
C
C**********************************************************************

      IMPLICIT NONE

      SAVE

      DOUBLE PRECISION Q2, PHO_CT14ALPHAS, REGFAC
      INTEGER IMODE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  hard scattering parameters used for most recent hard interaction
      INTEGER NFbeta,NF
      DOUBLE PRECISION ALQCD2,BQCD
      COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF

C  currently activated parton density parametrizations
      CHARACTER*8 PDFNAM
      INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
      DOUBLE PRECISION PDFLAM,PDFQ2M
      COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
     &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD

      INTEGER NQQAL,NQQALI,NQQALF,NQQPD
      DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
      COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
     &                NQQAL,NQQALI,NQQALF,NQQPD

      INTEGER I

      PHO_ALPHAS = 0.D0
      IF(IMODE.GT.0) THEN
        IF ((IPAMDL(7).EQ.4).AND..NOT.(
     &     (AQQAL.LT.1.D0).OR.(AQQAL.GT.1.D0)).AND.(NQQAL .EQ. 1)) THEN
            REGFAC = Q2/(PARMDL(261)**2 + Q2)
          ELSE IF (IPAMDL(7).EQ.4) THEN
            WRITE(LO,*) AQQAL, PARMDL(261),NQQAL
            WRITE(LO,*) 
     &          'PHO_ALPHAS: MISUSE OF REGULARIZATION PARAMETERS.'
            CALL PHO_ABORT
          ELSE
            REGFAC = 1.D0
          ENDIF

        IF(Q2.LT.PARMDL(148)) THEN
          NFbeta = 1
        ELSE IF(Q2.LT.PARMDL(149)) THEN
          NFbeta = 2
        ELSE IF(Q2.LT.PARMDL(150)) THEN
          NFbeta = 3
        ELSE
          NFbeta = 4
        ENDIF

        IF (((IEXT(1)==0).AND.(IGRP(1)==2)).AND.(
     &       (IEXT(2)==0).AND.(IGRP(2)==2))) THEN
           PHO_ALPHAS = PHO_CT14ALPHAS(SQRT(Q2) + PARMDL(261))
        ELSE
           PHO_ALPHAS = BQCD(NFBETA)/LOG((Q2 + PARMDL(261)**2)/
     &                  ALQCD2(IMODE,NFBETA))
        ENDIF

        PHO_ALPHAS = regfac*PHO_ALPHAS
        NFbeta = NFbeta+2

      ELSE IF(IMODE.EQ.0) THEN

        DO I=1,3
          if(I.EQ.3) then
            ALQCD2(I,2) = PDFLAM(1)*PDFLAM(2)
          else
            ALQCD2(I,2) = PDFLAM(I)*PDFLAM(I)
          endif
          ALQCD2(I,1) = PARMDL(148)
     &                 *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
          ALQCD2(I,3) = PARMDL(149)
     &                 *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
          ALQCD2(I,4) = PARMDL(150)
     &                 *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))

        ENDDO

      ELSE IF(IMODE.LT.0) THEN

        if(IMODE.eq.-4) then
          I = 3
          ALQCD2(I,2) = SQRT(ALQCD2(1,2)*ALQCD2(2,2))
        else
          I = -IMODE
          ALQCD2(I,2) = Q2
        endif
        ALQCD2(I,1) = PARMDL(148)
     &               *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
        ALQCD2(I,3) = PARMDL(149)
     &               *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
        ALQCD2(I,4) = PARMDL(150)
     &               *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))

      ENDIF

      END


 
 


CDECK  ID>, PHO_ALTRA
      SUBROUTINE PHO_ALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
C*********************************************************************
C
C    arbitrary Lorentz transformation
C
C*********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      EP=PCX*BGX+PCY*BGY+PCZ*BGZ
      PE=EP/(GA+1.D0)+EC
      PX=PCX+BGX*PE
      PY=PCY+BGY*PE
      PZ=PCZ+BGZ*PE
      P=SQRT(PX*PX+PY*PY+PZ*PZ)
      E=GA*EC+EP

      END


 
 


CDECK  ID>, PHO_BAMASS
      SUBROUTINE PHO_BAMASS(I,J,K,AM8,AM82,AM10,AM102,I8,I10)
C**********************************************************************
C
C     determine baryon masses corresponding to the input flavours
C
C     input: I,J,K     quark flavours (PDG convention)
C
C     output: AM8      octett baryon mass
C             AM82     next possible two particle configuration
C                      (octett baryon and meson)
C             AM10     decuplett baryon mass
C             AM102    next possible two particle configuration
C                      (decuplett baryon and meson,
C                       baryon built up from first two quarks)
C             I8,I10   internal baryon numbers
C
C**********************************************************************

      IMPLICIT NONE

      SAVE

      INTEGER I,J,K,I8,I10
      DOUBLE PRECISION AM8,AM82,AM10,AM102

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  particle ID translation table
      INTEGER         ID_pdg_list,ID_list,ID_pdg_max
      CHARACTER*12    name_list
      COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
     &                ID_pdg_max

C  general particle data
      DOUBLE PRECISION xm_list,tau_list,gam_list,
     &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
     &  xm_bb82_list,xm_bb102_list
      INTEGER          ich3_list,iba3_list,iq_list,
     &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
      COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
     &  xm_psm2_list(6,6),xm_vem2_list(6,6),
     &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
     &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
     &  ich3_list(300),iba3_list(300),iq_list(3,300),
     &  id_psm_list(6,6),id_vem_list(6,6),
     &  id_b8_list(6,6,6),id_b10_list(6,6,6)

C  local variables
      INTEGER ii,jj,kk

C  find particle ID's
      ii = abs(I)
      jj = abs(J)
      kk = abs(K)
      I8  = id_b8_list(ii,jj,kk)
      I10 = id_b10_list(ii,jj,kk)

C  masses (if combination possible)
      if(I8.ne.0) then
        AM8 = xm_list(I8)
        I8  = sign(I8,i)
      else
        AM8 = 0.D0
      endif
      if(I10.ne.0) then
        AM10 = xm_list(I10)
        I10  = sign(I10,i)
      else
        AM10 = 0.D0
      endif

C  next possible two-particle configurations (add phase space)
      AM82  = xm_b82_list(ii,jj,kk)*1.5D0
      AM102 = xm_b102_list(ii,jj,kk)*1.1D0

      END


 
 


CDECK  ID>, PHO_BESSI0
      DOUBLE PRECISION FUNCTION PHO_BESSI0(X)
C**********************************************************************
C
C      Bessel Function I0
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      AX = ABS(X)
      IF (AX .LT. 3.75D0) THEN
        Y = (X/3.75D0)**2
        PHO_BESSI0 =
     &    1.0D0+Y*(3.5156229D0+Y*(3.0899424D0+Y*(1.2067492D0
     &    +Y*(0.2659732D0+Y*(0.360768D-1+Y*0.45813D-2)))))
      ELSE
        Y = 3.75D0/AX
        PHO_BESSI0 =
     &    (EXP(AX)/SQRT(AX))*(0.39894228D0+Y*(0.1328592D-1
     &    +Y*(0.225319D-2+Y*(-0.157565D-2+Y*(0.916281D-2
     &    +Y*(-0.2057706D-1+Y*(0.2635537D-1+Y*(-0.1647633D-1
     &    +Y*0.392377D-2))))))))
      ENDIF

      END


 
 


CDECK  ID>, PHO_BESSI1
      DOUBLE PRECISION FUNCTION PHO_BESSI1(X)
C**********************************************************************
C
C      Bessel Function I1
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      AX = ABS(X)

      IF (AX .LT. 3.75D0) THEN
        Y = (X/3.75D0)**2
        BESLI1 =
     &    AX*(0.5D0+Y*(0.87890594D0+Y*(0.51498869D0+Y*(0.15084934D0
     &    +Y*(0.2658733D-1+Y*(0.301532D-2+Y*0.32411D-3))))))
      ELSE
        Y = 3.75D0/AX
        BESLI1 =
     &    0.2282967D-1+Y*(-0.2895312D-1+Y*(0.1787654D-1
     &    -Y*0.420059D-2))
        BESLI1 =
     &    0.39894228D0+Y*(-0.3988024D-1+Y*(-0.362018D-2
     &    +Y*(0.163801D-2+Y*(-0.1031555D-1+Y*BESLI1))))
        BESLI1 = BESLI1 * EXP(AX)/SQRT(AX)
      ENDIF
      IF (X .LT. 0.D0) BESLI1 = -BESLI1

      PHO_BESSI1 = BESLI1

      END


 
 


CDECK  ID>, PHO_BESSJ0
      DOUBLE PRECISION FUNCTION PHO_BESSJ0(DX)
C**********************************************************************
C
C     CERN (KERN) LIB function C312
C
C     modified by R. Engel (03/02/93)
C
C**********************************************************************
      DOUBLE PRECISION DX
      DOUBLE PRECISION X,Y,V,H,ALFA,EIGHT
      DOUBLE PRECISION PI1,PI2,C1(0:14),C2(0:9),C3(0:10),B0,B1,B2,P,Q,R
      SAVE

      DATA EIGHT /8.0D0/
      DATA PI1 /0.79788 45608 0287D0/, PI2 /0.78539 81633 9745D0/

      DATA C1( 0) /+0.15772 79714 7489D0/
      DATA C1( 1) /-0.00872 34423 5285D0/
      DATA C1( 2) /+0.26517 86132 0334D0/
      DATA C1( 3) /-0.37009 49938 7265D0/
      DATA C1( 4) /+0.15806 71023 3210D0/
      DATA C1( 5) /-0.03489 37694 1141D0/
      DATA C1( 6) /+0.00481 91800 6947D0/
      DATA C1( 7) /-0.00046 06261 6621D0/
      DATA C1( 8) /+0.00003 24603 2882D0/
      DATA C1( 9) /-0.00000 17619 4691D0/
      DATA C1(10) /+0.00000 00760 8164D0/
      DATA C1(11) /-0.00000 00026 7925D0/
      DATA C1(12) /+0.00000 00000 7849D0/
      DATA C1(13) /-0.00000 00000 0194D0/
      DATA C1(14) /+0.00000 00000 0004D0/

      DATA C2( 0) /+0.99946 03493 4752D0/
      DATA C2( 1) /-0.00053 65220 4681D0/
      DATA C2( 2) /+0.00000 30751 8479D0/
      DATA C2( 3) /-0.00000 00517 0595D0/
      DATA C2( 4) /+0.00000 00016 3065D0/
      DATA C2( 5) /-0.00000 00000 7864D0/
      DATA C2( 6) /+0.00000 00000 0517D0/
      DATA C2( 7) /-0.00000 00000 0043D0/
      DATA C2( 8) /+0.00000 00000 0004D0/
      DATA C2( 9) /-0.00000 00000 0001D0/

      DATA C3( 0) /-0.01555 58546 05337D0/
      DATA C3( 1) /+0.00006 83851 99426D0/
      DATA C3( 2) /-0.00000 07414 49841D0/
      DATA C3( 3) /+0.00000 00179 72457D0/
      DATA C3( 4) /-0.00000 00007 27192D0/
      DATA C3( 5) /+0.00000 00000 42201D0/
      DATA C3( 6) /-0.00000 00000 03207D0/
      DATA C3( 7) /+0.00000 00000 00301D0/
      DATA C3( 8) /-0.00000 00000 00033D0/
      DATA C3( 9) /+0.00000 00000 00004D0/
      DATA C3(10) /-0.00000 00000 00001D0/

      X=DX
      V=ABS(X)
      IF(V .LT. EIGHT) THEN
       Y=V/EIGHT
       H=2.D0*Y**2-1.D0
       ALFA=-2.D0*H
       B1=0.D0
       B2=0.D0
       DO 1 I = 14,0,-1
       B0=C1(I)-ALFA*B1-B2
       B2=B1
    1  B1=B0
       B1=B0-H*B2
      ELSE
       R=1.D0/V
       Y=EIGHT*R
       H=2.D0*Y**2-1.D0
       ALFA=-2.D0*H
       B1=0.D0
       B2=0.D0
       DO 2 I = 9,0,-1
       B0=C2(I)-ALFA*B1-B2
       B2=B1
    2  B1=B0
       P=B0-H*B2
       B1=0.D0
       B2=0.D0
       DO 3 I = 10,0,-1
       B0=C3(I)-ALFA*B1-B2
       B2=B1
    3  B1=B0
       Q=Y*(B0-H*B2)
       B0=V-PI2
       B1=PI1*SQRT(R)*(P*COS(B0)-Q*SIN(B0))
      ENDIF
      PHO_BESSJ0=B1
      RETURN
      END


 
 


CDECK  ID>, PHO_BESSK0
      DOUBLE PRECISION FUNCTION PHO_BESSK0(X)
C**********************************************************************
C
C      Modified Bessel Function K0
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      IF (X .LT. 2.D0) THEN
        Y = X**2/4.D0
        PHO_BESSK0 =
     &    (-LOG(X/2.D0)*PHO_BESSI0(X))+(-.57721566D0+Y*(0.42278420D0
     &    +Y*(0.23069756D0+Y*(0.3488590D-1+Y*(0.262698D-2
     &    +Y*(0.10750D-3+Y*0.740D-5))))))
      ELSE
        Y = 2.D0/X
        PHO_BESSK0 =
     &    (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(-0.7832358D-1
     &    +Y*(0.2189568D-1+Y*(-0.1062446D-1+Y*(0.587872D-2
     &    +Y*(-0.251540D-2+Y*0.53208D-3))))))
      ENDIF

      END


 
 


CDECK  ID>, PHO_BESSK1
      DOUBLE PRECISION FUNCTION PHO_BESSK1(X)
C**********************************************************************
C
C      Modified Bessel Function K1
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      IF (X .LT. 2.D0) THEN
        Y = X**2/4.D0
        PHO_BESSK1 =
     &    (LOG(X/2.D0)*PHO_BESSI1(X))+(1.D0/X)*(1.D0+Y*(0.15443144D0
     &    +Y*(-0.67278579D0+Y*(-0.18156897D0+Y*(-0.1919402D-1
     &    +Y*(-0.110404D-2+Y*(-0.4686D-4)))))))
      ELSE
        Y=2.D0/X
        PHO_BESSK1 =
     &    (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(0.23498619D0
     &    +Y*(-0.3655620D-1+Y*(0.1504268D-1+Y*(-0.780353D-2
     &    +Y*(0.325614D-2+Y*(-0.68245D-3)))))))
      ENDIF

      END


 
 


CDECK  ID>, PHO_BETAF
      DOUBLE PRECISION FUNCTION PHO_BETAF(X1,X2,BET)
C********************************************************************
C
C     weights of different quark flavours
C
C********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      AX=0.D0
      BETX1=BET*X1
      IF(BETX1.LT.70.D0) AX=-1.D0/BET**2*(BETX1+1.D0)*EXP(-BETX1)
      AY=1.D0/BET**2*(BET*X2+1.D0)*EXP(-BET*X2)

      PHO_BETAF=AX+AY

      END


 
 


CDECK  ID>, PHO_BORNCS
      SUBROUTINE PHO_BORNCS(IP,IFHARD,XM1,XM2,XM3,XM4)
C*********************************************************************
C
C     calculation of Born graph cross sections and slopes
C
C     input: IP               particle combination
C            IFHARD           -1 calculate hard Born graph cross section
C                             0  take hard Born graph cross section
C                                from interpolation table if available
C                             1  assume that correct hard cross
C                                sections are already stored in /POSBRN/
C            XM1,XM2,XM3,XM4  masses of external lines
C                   /GLOCMS/  energy and PT cut-off
C                   /POPREG/  soft and hard parameters
C                   /POSBRN/  input cross sections
C                   /POZBRN/  scaled input values
C                    IFHARD   0  calculate hard input cross sections
C                             1  assume hard input cross sections exist
C
C     output: ZPOM            scaled pomeron cross section
C             ZIGR            scaled reggeon cross section
C             ZIGHR           scaled hard resolved cross section
C             ZIGHD           scaled hard direct cross section
C             ZIGT1           scaled triple-Pomeron cross section
C             ZIGT2           scaled triple-Pomeron cross section
C             ZIGL            scaled loop-Pomeron cross section
C
C*********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER(ITWO=2,
     &        ITHREE=3,
     &         IFOUR=4,
     &         IFIVE=5,
     &          FIVE=5.D0,
     &         THOUS=1.D3,
     &           EPS=0.01D0,
     &          DEPS=1.D-30)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  current beam selection
      INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN
      INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL
      DOUBLE PRECISION SQSGLOBMAX
      PARAMETER (MPARMAX=40)
      PARAMETER (MAXMAPPS=40)
      PARAMETER (IKNOWN=9)
      DIMENSION IPAVAIL(IKNOWN)
      DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/
      COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS),
     &           MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  names of hard scattering processes
      INTEGER Max_pro_1
      PARAMETER ( Max_pro_1 = 16 )
      CHARACTER*18 PROC
      COMMON /POHPRO/ PROC(0:Max_pro_1)

C  hard cross sections and MC selection weights
      INTEGER Max_pro_2
      PARAMETER ( Max_pro_2 = 16 )
      INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
     &  MH_acc_1,MH_acc_2
      DOUBLE PRECISION HFAC, HWGX, HSIG, HDPT, HECM_LAST, 
     &   HQ2A_LAST, HQ2B_LAST
      COMMON /POHRCS/HFAC(-1:MAX_PRO_2, MPARMAX), 
     &   HWGX(-1:MAX_PRO_2, MPARMAX),
     &   HSIG(-1:MAX_PRO_2, MPARMAX), HDPT(-1:MAX_PRO_2, MPARMAX), 
     &   HECM_LAST, HQ2A_LAST, HQ2B_LAST, IHA_LAST, IHB_LAST, 
     &   MH_PRO_ON(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_TRIED(-1:MAX_PRO_2, 0:4, MPARMAX), 
     &   MH_ACC_1(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_ACC_2(-1:MAX_PRO_2, 0:4, MPARMAX) 

C  interpolation tables for hard cross section and MC selection weights
      INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
      PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
      INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
      DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
     &  HQ2a_tab,HQ2b_tab,HEcm_tab
      COMMON /POHTAB/
     &  Hfac_tab(-1:Max_pro_tab,Max_tab_E,
     &           Max_tab_Q2,Max_tab_Q2,0:4,MPARMAX),
     &  HWgx_tab(-1:Max_pro_tab,Max_tab_E,
     &           Max_tab_Q2,Max_tab_Q2,0:4,MPARMAX),
     &  HSig_tab(-1:Max_pro_tab,Max_tab_E,
     &           Max_tab_Q2,Max_tab_Q2,0:4,MPARMAX),
     &  Hdpt_tab(-1:Max_pro_tab,Max_tab_E,
     &           Max_tab_Q2,Max_tab_Q2,0:4,MPARMAX),
     &  HQ2a_tab(1:Max_tab_Q2,0:4,MPARMAX),
     &  HQ2b_tab(1:Max_tab_Q2,0:4,MPARMAX),
     &  HEcm_tab(1:Max_tab_E,0:4,MPARMAX),
     &  IH_Q2a_up(0:4,MPARMAX),IH_Q2b_up(0:4,MPARMAX),
     &  IH_Ecm_up(0:4,MPARMAX)

C  Born graph cross sections and slopes
      INTEGER Max_pro_3
      PARAMETER ( Max_pro_3 = 16 )
      COMPLEX*16      SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
     &                SIGD1,SIGD2,DSIGH
      COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
     &                SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)

C  scaled cross sections and slopes
      COMPLEX*16      ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1,ZIGT2,ZIGL,ZIGDP,
     &                ZIGD1,ZIGD2,
     &                BPOM,BREG,BHAR,BHAD,BTR1,BTR2,BLOO,BDP,BD1,BD2
      COMMON /POZBRN/ ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1(2),ZIGT2(2),ZIGL,
     &                ZIGDP(4),ZIGD1(2),ZIGD2(2),
     &                BPOM,BREG,BHAR,BHAD,BTR1(2),BTR2(2),BLOO,BDP(4),
     &                BD1(2),BD2(2)

C  Reggeon phenomenology parameters
      DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
     &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
      COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
     &                ALREG,ALREGP,GR(2),B0REG(2),
     &                GPPP,GPPR,B0PPP,B0PPR,
     &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC

C  parameters of 2x2 channel model
      DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
      COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC

C  data of c.m. system of Pomeron / Reggeon exchange
      INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
      DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
     &                 SIDP,CODP,SIFP,COFP
      COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
     &                SIDP,CODP,SIFP,COFP,NPOSP(2),
     &                IDPDG1,IDBAM1,IDPDG2,IDBAM2

C  obsolete cut-off information
      DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
      COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN

C  data needed for soft-pt calculation
      DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
      COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON

      COMPLEX*16      CZERO,BP4,BR4,BHR4,BHD4,BT14,BT24,BD4,SP,SR,SS,
     &                BPOM1,BPOM2,BREG1,BREG2,B0HARD
      DIMENSION       SCB1(4),SCB2(4),SCG1(4),SCG2(4)
      DIMENSION       BT14(2),BT24(2),BD4(4)
      DIMENSION       DSPT(0:Max_pro_2)

      DATA  XMPOM / 0.766D0 /
      DATA  CZERO /(0.D0,0.D0)/

C  debug output
      IF (LPRI.GT.4 .AND. IDEB(48).GE.10)
     &WRITE(LO,'(/1X,A,I3,4E16.9,I3)')
     &  'PHO_BORNCS: IP,M1..M4,IFHARD',IP,XM1,XM2,XM3,XM4,IFHARD
C  scales
      CALL PHO_SCALES(XM1,XM2,XM3,XM4,SCALE1,SCALE2,SCALB1,SCALB2)
C
C  calculate hard input cross sections (output in mb)
      IF(IFHARD.NE.1) THEN
        IF((IFHARD.EQ.0).AND.(HEcm_tab(1,IP,IDXMPAR).GT.1.D0)) THEN
C  double-log interpolation
          CALL PHO_HARINT(IP,ECMP,0.D0,0.D0,0,Max_pro_2,3,4,1)
          DO 60 M=0,Max_pro_2
            DSIGH(M) = HSig(M,IDXMPAR)
            DSPT(M)  = Hdpt(M,IDXMPAR)
 60       CONTINUE
        ELSE
C  new calculation
          CALL PHO_HARINT(IP,ECMP,0.D0,0.D0,0,-2,0,0,1)
          CALL PHO_HARXTO(ECMP,PTCUT(IP),PTCUT(IP),DSIGH,DSPT)
        ENDIF
C
C  save values to calculate soft pt distribution
        IF(IP.EQ.1) THEN
          VDMQ2F(1) = VDMFAC(1)
          VDMQ2F(2) = VDMFAC(2)
          VDMQ2F(3) = VDMFAC(3)
          VDMQ2F(4) = VDMFAC(4)
        ELSE IF(IP.EQ.2) THEN
          VDMQ2F(1) = VDMFAC(1)
          VDMQ2F(2) = VDMFAC(2)
          VDMQ2F(3) = 1.D0
          VDMQ2F(4) = 0.D0
        ELSE IF(IP.EQ.3) THEN
          VDMQ2F(1) = VDMFAC(3)
          VDMQ2F(2) = VDMFAC(4)
          VDMQ2F(3) = 1.D0
          VDMQ2F(4) = 0.D0
        ELSE
          VDMQ2F(1) = 1.D0
          VDMQ2F(2) = 0.D0
          VDMQ2F(3) = 1.D0
          VDMQ2F(4) = 0.D0
        ENDIF
C  VDM factors
        AMPFAC(1) = SQRT(VDMQ2F(1)*VDMQ2F(3))
        AMPFAC(2) = SQRT(VDMQ2F(2)*VDMQ2F(3))
        AMPFAC(3) = SQRT(VDMQ2F(1)*VDMQ2F(4))
        AMPFAC(4) = SQRT(VDMQ2F(2)*VDMQ2F(4))
        ELAFAC(1) = VDMQ2F(1)*VDMQ2F(3)+VDMQ2F(2)*VDMQ2F(3)
     &             +VDMQ2F(1)*VDMQ2F(4)+VDMQ2F(2)*VDMQ2F(4)
        ELAFAC(2) = 2.D0*(AMPFAC(1)*AMPFAC(2)+AMPFAC(3)*AMPFAC(4))
        ELAFAC(3) = 2.D0*(AMPFAC(1)*AMPFAC(3)+AMPFAC(2)*AMPFAC(4))
        ELAFAC(4) = 4.D0*AMPFAC(1)*AMPFAC(4)
        VFAC = ELAFAC(1)+PHISUP(1)*PHISUP(2)*ELAFAC(4)
     &        +PHISUP(1)*ELAFAC(2)+PHISUP(2)*ELAFAC(3)
        DSIGHP = DSPT(9)/VFAC
        SIGH   = DSIGH(9)/VFAC
C  extract real part
        IF(IPAMDL(1).EQ.0) THEN
          DO 50 I=0,Max_pro_2
            DSIGH(I)=DCMPLX(DREAL(DSIGH(I)),0.D0)
 50       CONTINUE
        ENDIF
C  write out results
        IF(IDEB(48).GE.15) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,1P,2E11.3)')
     &       'PHO_BORNCS: QCD-PM cross sections (mb)',ECMP,PTCUT(IP)
          DO 200 I=0,Max_pro_2
            IF (LPRI.GT.4)
     &      WRITE(LO,'(10X,A,2E20.10)') PROC(I),DSIGH(I)
 200      CONTINUE
        ENDIF
      ENDIF

C  DPMJET interface: subtract anomalous part
      IF((IP.EQ.1).AND.(IPAMDL(13).GT.0))
     &  DSIGH(9) = DSIGH(9)-DCMPLX(DT_SANO(ECMP),0.D0)

      SCALE = ABS(DSIGH(15))
      IF(SCALE.LT.DEPS) THEN
        SIGHD=CZERO
      ELSE
        SIGHD=DSIGH(15)
      ENDIF
      SCALE = ABS(DSIGH(9))
      IF(SCALE.LT.DEPS) THEN
        SIGHR=CZERO
      ELSE
        SIGHR=DSIGH(9)*SCALE1*SCALE2/VFAC
      ENDIF

C  calculate soft input cross sections (output in mb)
      SS=DCMPLX(ECMP**2-PMASSP(1)**2-PMASSP(2)**2+0.01D0,0.D0)
      IF(IPAMDL(1).EQ.1) THEN
C  pomeron signature
        SP=SS*DCMPLX(0.D0,-1.D0)
C  reggeon signature
        SR=SS*DCMPLX(0.D0,1.D0)
      ELSE
        SP=SS
        SR=SS
      ENDIF
C  coupling constants (mb**1/2)
C  particle dependent slopes (GeV**-2)
      IF(IP.EQ.1) THEN
        GP1 = GP(1)
        GP2 = GP(2)
        GR1 = GR(1)
        GR2 = GR(2)
        B0POM1 = B0POM(1)
        B0POM2 = B0POM(2)
        B0REG1 = B0REG(1)
        B0REG2 = B0REG(2)
        B0HARD = B0HAR
        RMASS1 = RMASS(1)
        RMASS2 = RMASS(2)
      ELSE IF(IP.EQ.2) THEN
        GP1 = GP(1)
        GP2 = PARMDL(77)
        GR1 = GR(1)
        GR2 = PARMDL(77)*GPPR/GPPP
        B0POM1 = B0POM(1)
        B0POM2 = B0PPP
        B0REG1 = B0REG(1)
        B0REG2 = B0PPR
        B0HARD = B0POM1+B0POM2
        RMASS1 = RMASS(1)
        RMASS2 = XMPOM
      ELSE IF(IP.EQ.3) THEN
        GP1 = GP(2)
        GP2 = PARMDL(77)
        GR1 = GR(2)
        GR2 = PARMDL(77)*GPPR/GPPP
        B0POM1 = B0POM(2)
        B0POM2 = B0PPP
        B0REG1 = B0REG(2)
        B0REG2 = B0PPR
        B0HARD = B0POM1+B0POM2
        RMASS1 = RMASS(2)
        RMASS2 = XMPOM
      ELSE IF(IP.EQ.4) THEN
        GP1 = PARMDL(77)
        GP2 = GP1
        GR1 = PARMDL(77)*GPPR/GPPP
        GR2 = GR1
        B0POM1 = B0PPP
        B0POM2 = B0PPP
        B0REG1 = B0PPR
        B0REG2 = B0PPR
        B0HARD = B0POM1+B0POM2
        RMASS1 = XMPOM
        RMASS2 = XMPOM
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,I7)') 'PHO_BORNCS:ERROR:invalid IP',IP
        CALL PHO_ABORT
      ENDIF
      GP1 = GP1*SCALE1
      GP2 = GP2*SCALE2
      GR1 = GR1*SCALE1
      GR2 = GR2*SCALE2
C  input slope parameters (GeV**-2)
      BPOM1 = B0POM1*SCALB1
      BPOM2 = B0POM2*SCALB2
      BREG1 = B0REG1*SCALB1
      BREG2 = B0REG2*SCALB2
C  effective slopes
      XMR2 = (2.D0*MIN(XM1,XM3)*MIN(XM2,XM4))**2
      SCALE = SS*XMR2/((XM1**2+XM3**2)*(XM2**2+XM4**2))+2.D0
      BPOM = BPOM1 + BPOM2 + ALPOMP*LOG(SCALE)
      BREG = BREG1 + BREG2 + ALREGP*LOG(SCALE)
      IF(IPAMDL(9).EQ.0) THEN
        BHAR = B0HARD
        BHAD = B0HARD
      ELSE IF(IPAMDL(9).EQ.1) THEN
        BHAR = B0HARD*(SCALB1+SCALB2)/2.D0
        BHAD = BHAR
      ELSE IF(IPAMDL(9).EQ.2) THEN
        BHAR = BPOM1+BPOM2
        BHAD = BHAR
      ELSE IF(IPAMDL(9).EQ.3) THEN
        ALHARP = PARMDL(260)*ALPOMP
        BHAR = B0HARD + ALHARP*LOG(SCALE)
        BHAD = BHAR
      ELSE
        BHAR = BPOM
        BHAD = BPOM
      ENDIF
C  input cross section pomeron
      SIGP=GP1*GP2*EXP((ALPOM-1.D0)*LOG(SP))
      SIGR=GR1*GR2*EXP((ALREG-1.D0)*LOG(SR))
C  save value to calculate soft pt distribution
      SIGS = (SIGR+SIGP)/(SCALE1*SCALE2)

C  higher order graphs
      VIRT1 = PVIRTP(1)
      VIRT2 = PVIRTP(2)
C  bare/renormalized intercept for enhanced graphs
      IF(IPAMDL(8).EQ.0) THEN
        DELTAP = ALPOM-1.D0
      ELSE
        DELTAP = PARMDL(48)-1.D0
      ENDIF
      SD = ECMP**2
      BP1 = 2.D0*BPOM1
      BP2 = 2.D0*BPOM2
C  input cross section high-mass double diffraction
      CALL PHO_LOOREG(SD,GP1,BP1,GP2,BP2,
     &            DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,VIRT2,SIGTR,BTR)
      SIGL = DCMPLX(SIGTR,0.D0)
      BLOO = DCMPLX(BTR,0.D0)
C
C  input cross section high mass diffraction particle 1
C  first possibility
      CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
     &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
      CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
     &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
      SCALB1 = (SCB1(1)+SCB1(2))/2.D0
      SCALB2 = (SCB2(1)+SCB2(2))/2.D0
      BP1 = 2.D0*BPOM1*SCALB1
      BP2 = 2.D0*BPOM2*SCALB2
C  input cross section high mass diffraction
      CALL PHO_TRIREG(SD,GP1,BP1,GP2,BP2,
     &               DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,SIGTR,BTR)
      SIGT1(1) = SCG1(1)*SCG2(1)*SCG2(2)*DCMPLX(SIGTR,0.D0)
      BTR1(1)  = DCMPLX(BTR,0.D0)
C  second possibility:  high-low mass double diffraction
      CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
     &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
      CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
     &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
      SCALB1 = (SCB1(1)+SCB1(2))/2.D0
      SCALB2 = (SCB2(1)+SCB2(2))/2.D0
      BP1 = 2.D0*BPOM1*SCALB1
      BP2 = 2.D0*BPOM2*SCALB2
C  input cross section high mass diffraction
      CALL PHO_TRIREG(SD,GP1,BP1,GP2,BP2,
     &               DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,SIGTR,BTR)
      SIGT1(2) = SCG1(1)*SCG2(1)*SCG2(2)*DCMPLX(SIGTR,0.D0)
      BTR1(2)  = DCMPLX(BTR,0.D0)
C
C  input cross section high mass diffraction particle 2
C  first possibility
      CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
     &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
      CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
     &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
      SCALB1 = (SCB1(1)+SCB1(2))/2.D0
      SCALB2 = (SCB2(1)+SCB2(2))/2.D0
      BP1 = 2.D0*BPOM1*SCALB1
      BP2 = 2.D0*BPOM2*SCALB2
C  input cross section high mass diffraction
      CALL PHO_TRIREG(SD,GP2,BP2,GP1,BP1,
     &               DELTAP,ALPOMP,GPPP,B0PPP,VIRT2,SIGTR,BTR)
      SIGT2(1) = SCG1(1)*SCG1(2)*SCG2(1)*DCMPLX(SIGTR,0.D0)
      BTR2(1)  = DCMPLX(BTR,0.D0)
C  second possibility:  high-low mass double diffraction
      CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
     &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
      CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
     &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
      SCALB1 = (SCB1(1)+SCB1(2))/2.D0
      SCALB2 = (SCB2(1)+SCB2(2))/2.D0
      BP1 = 2.D0*BPOM1*SCALB1
      BP2 = 2.D0*BPOM2*SCALB2
C  input cross section high mass diffraction
      CALL PHO_TRIREG(SD,GP2,BP2,GP1,BP1,
     &               DELTAP,ALPOMP,GPPP,B0PPP,VIRT2,SIGTR,BTR)
      SIGT2(2) = SCG1(1)*SCG1(2)*SCG2(1)*DCMPLX(SIGTR,0.D0)
      BTR2(2)  = DCMPLX(BTR,0.D0)
C
C  input cross section for loop-pomeron
C  first possibility
      CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
     &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
      CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
     &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
      CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
     &  SCG1(3),SCG2(3),SCB1(3),SCB2(3))
      CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
     &  SCG1(4),SCG2(4),SCB1(4),SCB2(4))
      SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
      SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
      BP1 = BPOM1*SCALB1
      BP2 = BPOM2*SCALB2
      CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
     &  SIGTX,BTX)
      SIGDP(1) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
      BDP(1)   = DCMPLX(BTX,0.D0)
C  second possibility
      CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
     &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
      CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
     &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
      CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
     &  SCG1(3),SCG2(3),SCB1(3),SCB2(3))
      CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
     &  SCG1(4),SCG2(4),SCB1(4),SCB2(4))
      SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
      SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
      BP1 = BPOM1*SCALB1
      BP2 = BPOM2*SCALB2
      CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
     &  SIGTX,BTX)
      SIGDP(2) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
      BDP(2)   = DCMPLX(BTX,0.D0)
C  third possibility
      CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
     &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
      CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
     &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
      CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
     &  SCG1(3),SCG2(3),SCB1(3),SCB2(3))
      CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
     &  SCG1(4),SCG2(4),SCB1(4),SCB2(4))
      SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
      SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
      BP1 = BPOM1*SCALB1
      BP2 = BPOM2*SCALB2
      CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
     &  SIGTX,BTX)
      SIGDP(3) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
      BDP(3)   = DCMPLX(BTX,0.D0)
C  fourth possibility
      CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
     &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
      CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
     &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
      CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
     &  SCG1(3),SCG2(3),SCB1(3),SCB2(3))
      CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
     &  SCG1(4),SCG2(4),SCB1(4),SCB2(4))
      SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
      SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
      BP1 = BPOM1*SCALB1
      BP2 = BPOM2*SCALB2
      CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
     &  SIGTX,BTX)
      SIGDP(4) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
      BDP(4)   = DCMPLX(BTX,0.D0)
C
C  input cross section for YY-iterated triple-pomeron
C     .....
C
C  write out input cross sections
      IF(IDEB(48).GE.5) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(2(/1X,A))')
     &    'Born graph input cross sections and slopes',
     &    '------------------------------------------'
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,3E16.9)') 'energy                  ',ECMP,PVIRTP
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,4E16.9)') 'external masses 1,2,3,4 ',
     &       XM1,XM2,XM3,XM4
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A)') ' input cross sections (millibarn):'
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,2E16.9)') '           SIGR     ',SIGR
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,2E16.9)') ' (soft)    SIGP     ',SIGP
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,2E16.9)') ' (hard)    SIGHR    ',SIGHR
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,2E16.9)') '           SIGHD    ',SIGHD
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,4E16.9)') '           SIGT1    ',SIGT1
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,4E16.9)') '           SIGT2    ',SIGT2
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,2E16.9)') '           SIGL     ',SIGL
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,4E16.9)') '         SIGDP(1-2) ',SIGDP(1),SIGDP(2)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,4E16.9)') '         SIGDP(3-4) ',SIGDP(3),SIGDP(4)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A)') ' input slopes (GeV**-2)'
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,2E16.9)') '           BREG     ',BREG
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,2E16.9)') '            BREG1   ',BREG1
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,2E16.9)') '            BREG2   ',BREG2
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,2E16.9)') '           BPOM     ',BPOM
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,2E16.9)') '            BPOM1   ',BPOM1
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,2E16.9)') '            BPOM2   ',BPOM2
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,2E16.9)') '           BHAR     ',BHAR
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,2E16.9)') '           BHAD     ',BHAD
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,E16.9)')  '           B0PPP    ',B0PPP
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,4E16.9)') '           BTR1     ',BTR1
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,4E16.9)') '           BTR2     ',BTR2
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,2E16.9)') '           BLOO     ',BLOO
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,4E16.9)') '           BDP(1-2) ',BDP(1),BDP(2)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,4E16.9)') '           BDP(3-4) ',BDP(3),BDP(4)
      ENDIF
C
      BPOM  = BPOM*GEV2MB
      BREG  = BREG*GEV2MB
      BHAR  = BHAR*GEV2MB
      BHAD  = BHAD*GEV2MB
      BTR1(1)  = BTR1(1)*GEV2MB
      BTR1(2)  = BTR1(2)*GEV2MB
      BTR2(1)  = BTR2(1)*GEV2MB
      BTR2(2)  = BTR2(2)*GEV2MB
      BLOO  = BLOO*GEV2MB
C
      BP4 =BPOM*4.D0
      BR4 =BREG*4.D0
      BHR4=BHAR*4.D0
      BHD4=BHAD*4.D0
      BT14(1)=BTR1(1)*4.D0
      BT14(2)=BTR1(2)*4.D0
      BT24(1)=BTR2(1)*4.D0
      BT24(2)=BTR2(2)*4.D0
      BL4 =BLOO*4.D0
C
      ZIGP     = SIGP/(PI2*BP4)
      ZIGR     = SIGR/(PI2*BR4)
      ZIGHR    = SIGHR/(PI2*BHR4)
      ZIGHD    = SIGHD/(PI2*BHD4)
      ZIGT1(1) = SIGT1(1)/(PI2*BT14(1))
      ZIGT1(2) = SIGT1(2)/(PI2*BT14(2))
      ZIGT2(1) = SIGT2(1)/(PI2*BT24(1))
      ZIGT2(2) = SIGT2(2)/(PI2*BT24(2))
      ZIGL = SIGL/(PI2*BL4)
      DO 20 I=1,4
        BDP(I) = BDP(I)*GEV2MB
        BD4(I) = BDP(I)*4.D0
        ZIGDP(I) = SIGDP(I)/(PI2*BD4(I))
 20   CONTINUE
C
      IF(IDEB(48).GE.10) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A)') ' normalized input values:'
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,2E16.9)') '           ZIGR ',ZIGR
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,2E16.9)') '           BREG ',BREG
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,2E16.9)') '           ZIGP ',ZIGP
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,2E16.9)') '           BPOM ',BPOM
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,2E16.9)') '          ZIGHR ',ZIGHR
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,2E16.9)') '           BHAR ',BHAR
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,2E16.9)') '          ZIGHD ',ZIGHD
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,2E16.9)') '           BHAD ',BHAD
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,4E16.9)') '          ZIGT1 ',ZIGT1
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,4E16.9)') '          ZIGT2 ',ZIGT2
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,2E16.9)') '           ZIGL ',ZIGL
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,4E16.9)') '     ZIGDP(1-2) ',ZIGDP(1),ZIGDP(2)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,4E16.9)') '     ZIGDP(3-4) ',ZIGDP(3),ZIGDP(4)
      ENDIF
      END


 
 


CDECK  ID>, PHO_CASCMOD
      SUBROUTINE PHO_CASCMOD
c*********************************************************************
c
c     Initializes default set of particles for cascade calcualtions
c
c*********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      SAVE

      INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN
      INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL
      DOUBLE PRECISION SQSGLOBMAX
      PARAMETER (MPARMAX=40)
      PARAMETER (MAXMAPPS=40)
      PARAMETER (IKNOWN=9)
      DIMENSION IPAVAIL(IKNOWN)
      DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/
      COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS),
     &           MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP

      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD


      INTEGER PROJIDS(4)

      DATA PROJIDS / 2212,2112,211,321/
C      3122,3112,130,111 /


      DO I=1,4
        CALL PHO_SETPAR(1,PROJIDS(I),0,0.D0)
        CALL PHO_SETPAR(2,2212,0,0.D0)
        CALL PHO_SETPCOMB
        CALL PHO_SETPAR(2,2112,0,0.D0)
        CALL PHO_SETPCOMB
      END DO


      END


 
 


CDECK  ID>, PHO_CDIFF
      SUBROUTINE PHO_CDIFF(IMOTH1,IMOTH2,MSOFT,MHARD,IMODE,IREJ)
C**********************************************************************
C
C     preparation of /POEVT1/ for double-pomeron scattering
C
C     input:   IMOTH1/2   index of mother particles in /POEVT1/
C
C              IMODE   1  sampling of pomeron-pomeron scattering
C                     -1  initialization
C                     -2  output of statistics
C
C     output:   MSOFT     number of generated soft strings
C               MHARD     number of generated hard strings
C               IREJ      0  accepted
C                         1  rejected
C                        50  user rejection
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( EPS  = 1.D-10,
     &            DEPS = 1.D-10)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  internal rejection counters
      INTEGER NMXJ
      PARAMETER (NMXJ=60)
      CHARACTER*10 REJTIT
      INTEGER IFAIL
      COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  general process information
      INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
      COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)

C  Reggeon phenomenology parameters
      DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
     &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
      COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
     &                ALREG,ALREGP,GR(2),B0REG(2),
     &                GPPP,GPPR,B0PPP,B0PPR,
     &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC

C  parameters of 2x2 channel model
      DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
      COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

C**anfe COMMON not needed here
C  energy-interpolation table
C      include 'inc/potabl'
C  table of particle indices for recursive PHOJET calls
      INTEGER MAXIPX
      PARAMETER ( MAXIPX = 500 )
      INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
      COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
     &                IPOIX1,IPOIX2,IPOIX3

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

      DIMENSION PD(4)

      if(IMODE.ne.1) return

      IREJ = 0
      IP = 4
C  select first diffraction
      IF(DT_RNDM(DUM).GT.0.5D0) THEN
        IPAR1 = 1
        IPAR2 = 0
      ELSE
        IPAR1 = 0
        IPAR2 = 1
      ENDIF
      ITRY2 = 0
      ITRYM = 1000

C  save current status
      MSOFT = 0
      MHARD = 0
      KHPOMS = KHPOM
      KSPOMS = KSPOM
      KSREGS = KSREG
      KHDIRS = KHDIR
      IPOIS1 = IPOIX1
      IPOIS2 = IPOIX2
      IPOIS3 = IPOIX3
      JDA11 = JDAHEP(1,IMOTH1)
      JDA21 = JDAHEP(2,IMOTH1)
      JDA12 = JDAHEP(1,IMOTH2)
      JDA22 = JDAHEP(2,IMOTH2)
      ISTH1 = ISTHEP(IMOTH1)
      ISTH2 = ISTHEP(IMOTH2)
      NHEPS = NHEP

C  find mother particle production process
      IGEN = IPHIST(2,IMOTH1)
      if(IGEN.eq.0) IGEN = 4

C  main generation loop
 60   CONTINUE

      KSPOM = KSPOMS
      KHPOM = KHPOMS
      KHDIR = KHDIRS
      KSREG = KSREGS
      I1 = IPAR1
      I2 = IPAR2
C  reset mother-daugther relations
      NHEP = NHEPS
      JDAHEP(1,IMOTH1) = JDA11
      JDAHEP(2,IMOTH1) = JDA21
      JDAHEP(1,IMOTH2) = JDA12
      JDAHEP(2,IMOTH2) = JDA22
      ISTHEP(IMOTH1) = ISTH1
      ISTHEP(IMOTH2) = ISTH2
      IPOIX1 = IPOIS1
      IPOIX2 = IPOIS2
      IPOIX3 = IPOIS3
C  rejection counter
      ITRY2 = ITRY2+1
      IF(ITRY2.GT.1) THEN
        IFAIL(39) = IFAIL(39)+1
        IF(ITRY2.GE.ITRYM) GOTO 50
      ENDIF
C  generate two diffractive events
      CALL PHO_DIFDIS(I1,I2,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
      IF(IREJ.NE.0) GOTO 50
      CALL PHO_DIFDIS(I2,I1,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
      IF(IREJ.NE.0) GOTO 50
C  mass of pomeron-pomeron system
      DO 100 I2 = NHEP,1,-1
        IF(IDHEP(I2).EQ.990) GOTO 110
 100  CONTINUE
 110  CONTINUE
      DO 120 I1 = I2-1,1,-1
        IF(IDHEP(I1).EQ.990) GOTO 130
 120  CONTINUE
 130  CONTINUE
      DO 140 I=1,4
        PD(I) = PHEP(I,I1)+PHEP(I,I2)
 140  CONTINUE
      XMASS = (PD(4)-PD(3))*(PD(4)+PD(3))-PD(1)**2-PD(2)**2
      IF (LPRI.GT.4 .AND. IDEB(59).GE.20)
     &WRITE(LO,'(1X,A,2I3,E12.4)')
     &  'PHO_CDIFF: IPOM1,IPOM2,MASS**2',I1,I2,XMASS
C  af 27/01/2013 corrected minimal squared diff. mass check    
      IF(XMASS.LT.MIN(0.1D0,PARMDL(71)**2)) GOTO 60
      XMASS = SQRT(XMASS)
      IF(XMASS.LT.PARMDL(71)) GOTO 60

C  sample pomeron-pomeron interaction process
      CALL PHO_DIFPRO(4,ISWMDL(17),990,990,XMASS,0.D0,0.D0,1.D0,
     &            IPROC,ISAM,JSAM,KSAM,IDIR)

C  non-diffractive pomeron-pomeron interactions
      IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
 200    CONTINUE
        IF(ISAM+JSAM+KSAM+IDIR.EQ.0) JSAM = 1
C  debug output
        IF (LPRI.GT.4 .AND. IDEB(59).GE.15)
     &  WRITE(LO,'(1X,A,/5X,I3,E12.4,4I5)')
     &    'PHO_CDIFF: IP,XMASS,ISAM,JSAM,KSAM,IDIR,',
     &    IP,XMASS,ISAM,JSAM,KSAM,IDIR
C  store debug information
        IF(IDIR.GT.0) THEN
          IPAR = 4
        ELSE IF(KSAM.GT.0) THEN
          IPAR = 3
        ELSE IF(ISAM.GT.0) THEN
          IPAR = 2
        ELSE
          IPAR = 1
        ENDIF
        IDDPOM = IPAR
        IF(ISAM+JSAM.GT.0) KSDPO = 1
        IF(KSAM+IDIR.GT.0) KHDPO = 1
        KSPOM = ISAM
        KSREG = JSAM
        KHPOM = KSAM
        KHDIR = IDIR
        KSTRG = 0
        KSLOO = 0
C  generate pomeron-pomeron interaction
        CALL PHO_STDPAR(I1,I2,IGEN,ISAM,JSAM,KSAM,IDIR,IREJ)
        IF(IREJ.NE.0) THEN
          IFAIL(3) = IFAIL(3)+1
          IF(IPAR.GT.1) THEN
            IF(IPAR.EQ.3) IFAIL(9) = IFAIL(9)+1
            IF(IDIR.GT.0) THEN
              IFAIL(10) = IFAIL(10)+1
              IDIR = 0
            ELSE IF(KSAM.GT.0) THEN
              KSAM = KSAM-1
            ELSE IF(ISAM.GT.0) THEN
              ISAM = ISAM-1
            ENDIF
            GOTO 200
          ELSE
            IF (LPRI.GT.4 .AND. IDEB(59).GE.2)
     .      WRITE(LO,'(1X,A,2I3,E11.3)')
     &        'PHO_CDIFF: rejection by PHO_STDPAR (I,IPAR,XM)',
     &        I,IPAR,XMASS
            GOTO 50
          ENDIF
        ENDIF

C  diffractive pomeron-pomeron interactions
      ELSE
        IPOIX2 = IPOIX2+1
        IPORES(IPOIX2)   = IPROC
        IPOPOS(1,IPOIX2) = I1
        IPOPOS(2,IPOIX2) = I2
        IPAR = 10+IPROC
        IDDPOM = IPAR
      ENDIF

C  update debug information
      KSPOM = KSPOMS+ISAM
      KSREG = KSREGS+JSAM
      KHPOM = KHPOMS+KSAM
      KHDIR = KHDIRS+IDIR
C  comment line for central diffraction
      CALL PHO_REGPAR(40,4,IPAR,IMOTH1,IMOTH2,PD(1),PD(2),PD(3),PD(4),
     &            I1,I2,IDHEP(IMOTH1),IDHEP(IMOTH2),IPOS,1)
      PHEP(5,IPOS) = XMASS
C  debug output
      IF(IDEB(59).GE.15) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(2(/1X,A))') 'PHO_CDIFF: output of /POEVT1/',
     &                        '-----------------------------'
        CALL PHO_PREVNT(0)
      ENDIF
      RETURN

C  treatment of rejection
 50   CONTINUE
      IREJ = 1
      IFAIL(40) = IFAIL(40)+1
      IF(IDEB(59).GE.3) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A)')
     &    'PHO_CDIFF: rejection (ITRY,ITRYM)',ITRY2,ITRYM
        IF(IDEB(59).GE.10) THEN
          CALL PHO_PREVNT(0)
        ELSE
          CALL PHO_PREVNT(-1)
        ENDIF
      ENDIF

      END


 
 


CDECK  ID>, PHO_CHAN2A
      SUBROUTINE PHO_CHAN2A(BB)
C***********************************************************************
C
C     simple two channel model to realize low mass diffraction
C     (version A, iteration of triple- and loop-Pomeron)
C
C     input:     BB      impact parameter (mb**1/2)
C
C     output:    /POINT4/
C                AMPEL      elastic amplitude
C                AMPVM(4,4) q-elastic VM production
C                AMLMSD(2)  low mass single diffraction amplitude
C                AMHMSD(2)  high mass single diffraction amplitude
C                AMLMDD     low mass double diffraction amplitude
C                AMHMDD     high mass double diffraction amplitude
C                AMPDP(4)   central diffraction amplitude
C
C***********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER (DEPS  = 1.D-5,
     &           EIGHT = 8.D0)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

C  complex Born graph amplitudes used for unitarization
      COMPLEX*16      AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
     &                AMHMDD,AMPDP
      COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
     &                AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)

C  unitarized amplitudes for different diffraction channels
      DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
     &                 ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
     &                 ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
     &                 ZXL,BXL
      COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
     &                ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
     &                ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
     &                ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
     &                ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
     &                ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
     &                ZXL(4,4),BXL(4,4)

C  Reggeon phenomenology parameters
      DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
     &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
      COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
     &                ALREG,ALREGP,GR(2),B0REG(2),
     &                GPPP,GPPR,B0PPP,B0PPR,
     &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC

C  parameters of 2x2 channel model
      DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
      COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC

C  global event kinematics and particle IDs
      INTEGER IFPAP,IFPAB
      DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
      COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)


C  local variables
      DIMENSION  AB(9,4),CHI(4),CHDS(4),CHDH(4),CHDA(4),CHDB(4),
     &           CHDD(4),CHDPE(4),CHDPA(4),CHDPB(4),CHDPD(4),
     &           AMPCHA(4),EX1CHI(4),EX2CHI(4),ABSUM(4),AMPELA(4,0:9)
      DIMENSION CHIFAC(4,4),EXPFAC(4,4),IELTAB(4,4)

C  combinatorical factors
      DATA      CHIFAC / 1.D0, 1.D0,-1.D0,-1.D0,
     &                   1.D0,-1.D0, 1.D0,-1.D0,
     &                   1.D0,-1.D0,-1.D0, 1.D0,
     &                   1.D0, 1.D0, 1.D0, 1.D0 /
      DATA      EXPFAC / 1.D0, 1.D0, 1.D0, 1.D0,
     &                   1.D0,-1.D0,-1.D0, 1.D0,
     &                  -1.D0, 1.D0,-1.D0, 1.D0,
     &                  -1.D0,-1.D0, 1.D0, 1.D0 /
      DATA      IELTAB / 1, 2, 3, 4,
     &                   2, 1, 4, 3,
     &                   3, 4, 1, 2,
     &                   4, 3, 2, 1 /

      IF (LPRI.GT.4 .AND. IDEB(86).GE.20)
     &WRITE(LO,'(1X,A,E12.3)')
     &  'PHO_CHAN2A: impact parameter B',BB

      B24 = BB**2/4.D0
      DO 25 I=1,4
        AB(1,I) = ZXP(1,I)*EXP(-B24/BXP(1,I))
     &           +ZXR(1,I)*EXP(-B24/BXR(1,I))
        AB(2,I) = ZXH(1,I)*EXP(-B24/BXH(1,I))
        AB(3,I) =-ZXT1A(1,I)*EXP(-B24/BXT1A(1,I))
        AB(4,I) =-ZXT2A(1,I)*EXP(-B24/BXT2A(1,I))
        AB(5,I) =-ZXL(1,I)*EXP(-B24/BXL(1,I))
     &           -ZXT1B(1,I)*EXP(-B24/BXT1B(1,I))
     &           -ZXT2B(1,I)*EXP(-B24/BXT2B(1,I))
        AB(6,I) = ZXDPE(1,I)*EXP(-B24/BXDPE(1,I))
        AB(7,I) = ZXDPA(1,I)*EXP(-B24/BXDPA(1,I))
        AB(8,I) = ZXDPB(1,I)*EXP(-B24/BXDPB(1,I))
        AB(9,I) = ZXDPD(1,I)*EXP(-B24/BXDPD(1,I))
 25   CONTINUE

      DO 50 I=1,4
        ABSUM(I)  = 0.D0
        DO 75 II=9,1,-1
          ABSUM(I) = ABSUM(I) + AB(II,I)
 75     CONTINUE
 50   CONTINUE
      IF (LPRI.GT.4 .AND. IDEB(86).GE.20)
     &WRITE(LO,'(1X,A,4E12.3)')
     &  'PHO_CHAN2A: ABSUM',ABSUM

      DO 100 I=1,4
        CHI(I)  = 0.D0
        CHDS(I) = 0.D0
        CHDH(I) = 0.D0
        CHDA(I) = 0.D0
        CHDB(I) = 0.D0
        CHDD(I) = 0.D0
        CHDPE(I) = 0.D0
        CHDPA(I) = 0.D0
        CHDPB(I) = 0.D0
        CHDPD(I) = 0.D0
        AMPELA(I,0) = 0.D0
        AMPELA(I,9) = 0.D0
        DO 200 K=1,4
          AMPELA(I,K) = 0.D0
          AMPELA(I,K+4) = 0.D0
          AMPVM(I,K)  = 0.D0
          CHI(I)  = CHI(I)  + CHIFAC(K,I)*ABSUM(K)
          CHDS(I) = CHDS(I) + CHIFAC(K,I)*AB(1,K)
          CHDH(I) = CHDH(I) + CHIFAC(K,I)*AB(2,K)
          CHDA(I) = CHDA(I) + CHIFAC(K,I)*AB(3,K)
          CHDB(I) = CHDB(I) + CHIFAC(K,I)*AB(4,K)
          CHDD(I) = CHDD(I) + CHIFAC(K,I)*AB(5,K)
          CHDPE(I) = CHDPE(I) + CHIFAC(K,I)*AB(6,K)
          CHDPA(I) = CHDPA(I) + CHIFAC(K,I)*AB(7,K)
          CHDPB(I) = CHDPB(I) + CHIFAC(K,I)*AB(8,K)
          CHDPD(I) = CHDPD(I) + CHIFAC(K,I)*AB(9,K)
 200    CONTINUE
        IF(CHI(I).LT.-DEPS) THEN
          IF(IDEB(86).GE.0) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,A,I3,2E12.3)')
     &        'PHO_CHAN2A: neg.eigenvalue (I,B,CHI)',I,BB,CHI(I)
            IF (LPRI.GT.4)
     &      WRITE(LO,'(5X,A,5E12.3)') 'E,CHIs:',ECM,(ABSUM(K),K=1,4)
          ENDIF
        ENDIF
        IF(ABS(CHI(I)).GT.200.D0) THEN
          EX1CHI(I) = 0.D0
          EX2CHI(I) = 0.D0
        ELSE
          TMP       = EXP(-CHI(I))
          EX1CHI(I) = TMP
          EX2CHI(I) = TMP*TMP
        ENDIF
 100  CONTINUE
      IF(IDEB(86).GE.20) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,4E12.3)') 'PHO_CHAN2A: EX1CHI',EX1CHI
      ENDIF

      AMPELA(1,0) = 4.D0
      DO 300 K=1,4
        DO 400 J=1,4
          CFAC = 2.D0*EXPFAC(J,K)*EX2CHI(J)
          AMPELA(K,0) = AMPELA(K,0) - EXPFAC(J,K)*EX1CHI(J)
          AMPELA(K,1) = AMPELA(K,1) + CFAC*CHDS(J)
          AMPELA(K,2) = AMPELA(K,2) + CFAC*CHDH(J)
          AMPELA(K,3) = AMPELA(K,3) - CFAC*CHDA(J)
          AMPELA(K,4) = AMPELA(K,4) - CFAC*CHDB(J)
          AMPELA(K,5) = AMPELA(K,5) - CFAC*CHDD(J)
          AMPELA(K,6) = AMPELA(K,6) + CFAC*CHDPE(J)
          AMPELA(K,7) = AMPELA(K,7) + CFAC*CHDPA(J)
          AMPELA(K,8) = AMPELA(K,8) + CFAC*CHDPB(J)
          AMPELA(K,9) = AMPELA(K,9) + CFAC*CHDPD(J)
 400    CONTINUE
 300  CONTINUE
      IF(IDEB(86).GE.25) THEN
        DO 305 I=1,9
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,I3,4E10.3)') 'PHO_CHAN2A: AMPELA(1-4,I)',I,
     &      (AMPELA(K,1),K=1,4)
 305    CONTINUE
      ENDIF

C  VDM factors --> amplitudes
C  low mass excitations
      DO 500 I=1,4
        AMPCHA(I) = 0.D0
        DO 600 K=1,4
          AMPCHA(I) = AMPCHA(I) + AMPFAC(K)*AMPELA(IELTAB(K,I),0)
 600    CONTINUE
 500  CONTINUE
      AMPVME    = AMPCHA(1)/EIGHT
      AMLMSD(1) = AMPCHA(2)/EIGHT
      AMLMSD(2) = AMPCHA(3)/EIGHT
      AMLMDD    = AMPCHA(4)/EIGHT
C  elastic part, high mass diffraction
      AMPEL = 0.5D0*ZXD(1,1)*EXP(-B24/BXD(1,1))
      AMPSOF    = 0.D0
      AMPHAR    = 0.D0
      AMHMSD(1) = 0.D0
      AMHMSD(2) = 0.D0
      AMHMDD    = 0.D0
      AMPDP(1)  = 0.D0
      AMPDP(2)  = 0.D0
      AMPDP(3)  = 0.D0
      AMPDP(4)  = 0.D0
      DO 450 I=1,4
        AMPEL     = AMPEL     + ELAFAC(I)*AMPELA(I,0)/8.D0
        AMPSOF    = AMPSOF    + ELAFAC(I)*AMPELA(I,1)
        AMPHAR    = AMPHAR    + ELAFAC(I)*AMPELA(I,2)
        AMHMSD(1) = AMHMSD(1) + ELAFAC(I)*AMPELA(I,3)
        AMHMSD(2) = AMHMSD(2) + ELAFAC(I)*AMPELA(I,4)
        AMHMDD    = AMHMDD    + ELAFAC(I)*AMPELA(I,5)
        AMPDP(1)  = AMPDP(1)  + ELAFAC(I)*AMPELA(I,6)
        AMPDP(2)  = AMPDP(2)  + ELAFAC(I)*AMPELA(I,7)
        AMPDP(3)  = AMPDP(3)  + ELAFAC(I)*AMPELA(I,8)
        AMPDP(4)  = AMPDP(4)  + ELAFAC(I)*AMPELA(I,9)
 450  CONTINUE
      AMPSOF    = AMPSOF/16.D0
      AMPHAR    = AMPHAR/16.D0
      AMHMSD(1) = AMHMSD(1)/16.D0
      AMHMSD(2) = AMHMSD(2)/16.D0
      AMHMDD    = AMHMDD/16.D0
      AMPDP(1)  = AMPDP(1)/16.D0
      AMPDP(2)  = AMPDP(2)/16.D0
      AMPDP(3)  = AMPDP(3)/16.D0
      AMPDP(4)  = AMPDP(4)/16.D0
      IF(DREAL(AMHMSD(1)).LE.0.D0) AMHMSD(1) = 0.D0
      IF(DREAL(AMHMSD(2)).LE.0.D0) AMHMSD(2) = 0.D0
      IF(DREAL(AMHMDD).LE.0.D0)    AMHMDD = 0.D0
      IF(DREAL(AMPDP(1)).LE.0.D0) AMPDP(1) = 0.D0
      IF(DREAL(AMPDP(2)).LE.0.D0) AMPDP(2) = 0.D0
      IF(DREAL(AMPDP(3)).LE.0.D0) AMPDP(3) = 0.D0
      IF(DREAL(AMPDP(4)).LE.0.D0) AMPDP(4) = 0.D0

C  vector-meson production, weight factors
      IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22)) THEN
        IF(IFPAP(1).EQ.22) THEN
          IF(IFPAP(2).EQ.22) THEN
            DO 10 I=1,4
              DO 15 J=1,4
                AMPVM(I,J) = PARMDL(9+I)*PARMDL(9+J)*AMPVME
 15           CONTINUE
 10         CONTINUE
          ELSE
            AMPVM(1,1) = PARMDL(10)*AMPVME
            AMPVM(2,1) = PARMDL(11)*AMPVME
            AMPVM(3,1) = PARMDL(12)*AMPVME
            AMPVM(4,1) = PARMDL(13)*AMPVME
          ENDIF
        ELSE IF(IFPAP(2).EQ.22) THEN
          AMPVM(1,1) = PARMDL(10)*AMPVME
          AMPVM(1,2) = PARMDL(11)*AMPVME
          AMPVM(1,3) = PARMDL(12)*AMPVME
          AMPVM(1,4) = PARMDL(13)*AMPVME
        ENDIF
      ENDIF
C  debug output
      IF(IDEB(86).GE.10) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/,1X,A)')
     &    'PHO_CHAN2A: impact parameter amplitudes'
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,1P,2E12.3)') '       AMPEL',AMPEL
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(1,1-4)',(AMPVM(1,K),K=1,4)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(2,1-4)',(AMPVM(2,K),K=1,4)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(3,1-4)',(AMPVM(3,K),K=1,4)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(4,1-4)',(AMPVM(4,K),K=1,4)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,1P,4E12.3)') '  AMPSOF/HAR',AMPSOF,AMPHAR
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,1P,4E12.3)') '      AMLMSD',AMLMSD
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,1P,4E12.3)') '      AMHMSD',AMHMSD
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,1P,2E12.3)') '      AMLMDD',AMLMDD
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,1P,2E12.3)') '      AMHMDD',AMHMDD
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,1P,8E10.3)') '  AMPDP(1-4)',AMPDP
      ENDIF

      END


 
 


CDECK  ID>, PHO_CHECK
      SUBROUTINE PHO_CHECK(MD,IDEV)
C**********************************************************************
C
C     check quantum numbers of entries in /POEVT1/ and /POEVT2/
C           (energy, momentum, charge, baryon number conservation)
C
C     input:    MD      -1  check overall momentum conservation
C                           and perform detailed check only in case of
C                           deviations
C                        1  test all branchings, mother-daughter
C                           relations
C
C     output:   IDEV     0  no deviations
C                        1  deviations found
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  global event kinematics and particle IDs
      INTEGER IFPAP,IFPAB
      DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
      COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)

C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
      INTEGER IDEQP,IDEQB,IHFLD,IHFLS
      DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
      COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
     &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

C  color string configurations including collapsed strings and hadrons
      INTEGER MSTR
      PARAMETER (MSTR=2000)
      INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
      COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
     &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
     &                NNCH(MSTR),IBHAD(MSTR),ISTR

C  count number of errors to avoid disk overflow
      DATA IERR / 0 /

      IDEV = 0
C  conservation check suppressed
      IF((IPAMDL(15).EQ.0).OR.(IDEB(20).LE.-10)) RETURN

      IF(IPAMDL(13).GT.0) THEN

C  DPMJET call with x limitations
        MODE = -1
        ECM1 = SQRT(XPSUB*XTSUB)*ECM

      ELSE

C  standard call
        MODE = MD
C  first two entries are considered as scattering particles
        EE1 = PHEP(4,1) + PHEP(4,2)
        PX1 = PHEP(1,1) + PHEP(1,2)
        PY1 = PHEP(2,1) + PHEP(2,2)
        PZ1 = PHEP(3,1) + PHEP(3,2)

      ENDIF

      DDREL = PARMDL(75)
      DDABS = PARMDL(76)
      IF(MODE.EQ.-1) GOTO 500

 50   CONTINUE

      I = 1
 100  CONTINUE

C  recognize only decayed particles as mothers
        IF(ISTHEP(I).EQ.2) THEN
C  search for other mother particles
          K = JDAHEP(1,I)
          IF(K.EQ.0) THEN
            IF(IPAMDL(178).NE.0 .AND. LPRI.GT.4)
     &        WRITE(LO,'(1X,2A,I4)') 'PHO_CHECK: ',
     &        'entry marked as decayed but no dauther given:',I
            GOTO 99
          ENDIF
          K1 = JMOHEP(1,K)
          K2 = JMOHEP(2,K)
C  sum over mother particles
          ICH1 = IPHO_CHR3(K1,2)
          IBA1 = IPHO_BAR3(K1,2)
          EE1 = PHEP(4,K1)
          PX1 = PHEP(1,K1)
          PY1 = PHEP(2,K1)
          PZ1 = PHEP(3,K1)
          IF(K2.LT.0) THEN
            K2 = -K2
            IF((K1.GT.I).OR.(K2.LT.I)) THEN
              IF (LPRI.GT.4)
     &        WRITE(LO,'(/,1X,2A,3I4)') 'PHO_CHECK: ',
     &          'inconsistent mother/daughter relation found',I,K1,K2
              CALL PHO_PREVNT(-1)
            ENDIF
            DO 400 II=K1+1,K2
              IF(ABS(ISTHEP(II)).LE.2) THEN
                ICH1 = ICH1 + IPHO_CHR3(II,2)
                IBA1 = IBA1 + IPHO_BAR3(II,2)
                EE1 = EE1 + PHEP(4,II)
                PX1 = PX1 + PHEP(1,II)
                PY1 = PY1 + PHEP(2,II)
                PZ1 = PZ1 + PHEP(3,II)
              ENDIF
 400        CONTINUE
          ELSE IF((K2.GT.0).AND.(K2.NE.K1)) THEN
            ICH1 = ICH1 + IPHO_CHR3(K2,2)
            IBA1 = IBA1 + IPHO_BAR3(K2,2)
            EE1 = EE1 + PHEP(4,K2)
            PX1 = PX1 + PHEP(1,K2)
            PY1 = PY1 + PHEP(2,K2)
            PZ1 = PZ1 + PHEP(3,K2)
          ENDIF

C  sum over daughter particles
          ICH2 = 0
          IBA2 = 0
          EE2 = 0.D0
          PX2 = 0.D0
          PY2 = 0.D0
          PZ2 = 0.D0
          DO 200 II=JDAHEP(1,I),JDAHEP(2,I)
            IF(ABS(ISTHEP(II)).LE.2) THEN
              ICH2 = ICH2 + IPHO_CHR3(II,2)
              IBA2 = IBA2 + IPHO_BAR3(II,2)
              EE2 = EE2 + PHEP(4,II)
              PX2 = PX2 + PHEP(1,II)
              PY2 = PY2 + PHEP(2,II)
              PZ2 = PZ2 + PHEP(3,II)
            ENDIF
 200      CONTINUE
C  conservation check
          ESC = MAX(MAX(EE1,EE2)*DDREL,DDABS)
          IF(ABS(EE1-EE2).GT.ESC) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E10.3)')
     &        'PHO_CHECK: energy conservation violated for',
     &        'entry,initial,final:',I,EE1,EE2
            IDEV = 1
          ENDIF
          ESC = MAX(MAX(ABS(PX1),ABS(PX2))*DDREL,DDABS)
          IF(ABS(PX1-PX2).GT.ESC) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
     &        'PHO_CHECK: x-momentum conservation violated for',
     &        'entry,initial,final:',I,PX1,PX2
            IDEV = 1
          ENDIF
          ESC = MAX(MAX(ABS(PY1),ABS(PY2))*DDREL,DDABS)
          IF(ABS(PY1-PY2).GT.ESC) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
     &        'PHO_CHECK: y-momentum conservation violated for',
     &        'entry,initial,final:',I,PY1,PY2
            IDEV = 1
          ENDIF
          ESC = MAX(MAX(ABS(PZ1),ABS(PZ2))*DDREL,DDABS)
          IF(ABS(PZ1-PZ2).GT.ESC) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
     &        'PHO_CHECK: z-momentum conservation violated for',
     &        'entry,initial,final:',I,PZ1,PZ2
            IDEV = 1
          ENDIF
          IF(ICH1.NE.ICH2) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,A,/,5X,A,I3,2X,2I5)')
     &        'PHO_CHECK: charge conservation violated for',
     &        'entry,initial,final:',I,ICH1,ICH2
            IDEV = 1
          ENDIF
          IF(IBA1.NE.IBA2) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,2A,/,5X,A,I3,2X,2I5)') 'PHO_CHECK: ',
     &        'baryon charge conservation violated for',
     &        'entry,initial,final:',I,IBA1,IBA2
            IDEV = 1
          ENDIF
          IF(IDEB(20).GE.35) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,
     &        '(/,1X,A,A,2(2X,I4,A,I4),2(/,5X,A,4E13.4),/5X,A,4I5)')
     &      'PHO_CHECK diagnostics:',
     &      '(1.mother/l.mother,1.daughter/l.daughter):',
     &      K1,'/',K2,JDAHEP(1,I),'/',JDAHEP(2,I),
     &      'mother momenta   ',PX1,PY1,PZ1,EE1,
     &      'daughter momenta ',PX2,PY2,PZ2,EE2,
     &      'charge,baryon no ',ICH1,ICH2,IBA1,IBA2
          ENDIF
        ENDIF
 99     CONTINUE
        I = I+1
      IF(I.LE.NHEP) GOTO 100

 55   CONTINUE

      IERR = IERR+IDEV

C  write complete event in case of deviations
      IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
        CALL PHO_PREVNT(1)
        IF(ISTR.GT.0) THEN
          CALL PHO_PRSTRG

          IF(ISWMDL(6).GE.0) CALL PYLIST(1)

        ENDIF
      ENDIF

C  stop after too many errors
      IF(IERR.GT.IPAMDL(179)) THEN
        WRITE(LO,'(////1X,2A,I6,////)') 'PHO_CHECK:ERROR:',
     &    'too many inconsistencies found, program terminated',IERR
        CALL PHO_ABORT
      ENDIF

      RETURN

C  overall check only (less time consuming)

 500  CONTINUE

      ICH2 = 0
      IBA2 = 0
      EE2 = 0.D0
      PX2 = 0.D0
      PY2 = 0.D0
      PZ2 = 0.D0

      DO 300 K=3,NHEP
C  recognize only existing particles as possible daughters
        IF(ABS(ISTHEP(K)).EQ.1) THEN
          ICH2 = ICH2 + IPHO_CHR3(K,2)
          IBA2 = IBA2 + IPHO_BAR3(K,2)
          EE2 = EE2 + PHEP(4,K)
          PX2 = PX2 + PHEP(1,K)
          PY2 = PY2 + PHEP(2,K)
          PZ2 = PZ2 + PHEP(3,K)
        ENDIF
 300  CONTINUE

C  check energy-momentum conservation
      ESC = ECM*DDREL

      IF(IPAMDL(13).GT.0) THEN

C  DPMJET call with x limitations
        ECM2 = SQRT((EE2-PZ2)*(EE2+PZ2)-PX2**2-PY2**2)
        IF(ABS(ECM1-ECM2).GT.ESC) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
     &      'PHO_CHECK: c.m. energy conservation violated',
     &      'initial/final energy:',ECM1,ECM2
          IDEV = 1
        ENDIF

      ELSE

C  standard call
        IF(ABS(EE1-EE2).GT.ESC) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
     &      'PHO_CHECK: energy conservation violated',
     &      'initial/final energy:',EE1,EE2
          IDEV = 1
        ENDIF
        IF(ABS(PX1-PX2).GT.ESC) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
     &      'PHO_CHECK: x-momentum conservation violated',
     &      'initial/final x-momentum:',PX1,PX2
          IDEV = 1
        ENDIF
        IF(ABS(PY1-PY2).GT.ESC) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
     &      'PHO_CHECK: y-momentum conservation violated',
     &      'initial/final y-momentum:',PY1,PY2
          IDEV = 1
        ENDIF
        IF(ABS(PZ1-PZ2).GT.ESC) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
     &      'PHO_CHECK: z-momentum conservation violated',
     &      'initial/final z-momentum:',PZ1,PZ2
          IDEV = 1
        ENDIF

C  check of quantum number conservation

        ICH1 = IPHO_CHR3(1,2) + IPHO_CHR3(2,2)
        IBA1 = IPHO_BAR3(1,2) + IPHO_BAR3(2,2)

        IF(ICH1.NE.ICH2) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,/,5X,A,2I5)')
     &      'PHO_CHECK: charge conservation violated',
     &      'initial/final charge sum',ICH1,ICH2
          IDEV = 1
        ENDIF
        IF(IBA1.NE.IBA2) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,2A,/,5X,A,2I5)') 'PHO_CHECK: ',
     &      'baryonic charge conservation violated',
     &      'initial/final baryonic charge sum',IBA1,IBA2
          IDEV = 1
        ENDIF

      ENDIF

C  perform detailed checks in case of deviations
      IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
        IF(IPAMDL(13).GT.0) THEN
          GOTO 55
        ELSE
          DDREL = DDREL/2.D0
          DDABS = DDABS/2.D0
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,2A,2E12.4)') 'PHO_CHECK: ',
     &      'increasing precision of tests to',DDREL,DDABS
          GOTO 50
        ENDIF
      ENDIF

      END


 
 


CDECK  ID>, PHO_CKMTFV
      REAL FUNCTION PHO_CKMTFV(X,FVL)
C**********************************************************************
C
C     LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
C     FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
C     NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
C     IN MAIN ROUTINE.
C
C**********************************************************************
      SAVE

      DIMENSION FVL(25),XGRID(25)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

      DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
     *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/

      PHO_CKMTFV=0.
      DO 1 I=1,NX
      IF(X.LT.XGRID(I)) GO TO 2
    1 CONTINUE
    2 I=I-1
      IF(I.EQ.0) THEN
         I=I+1
      ELSE IF(I.GT.23) THEN
         I=23
      ENDIF
      J=I+1
      K=J+1
      AXI=LOG(XGRID(I))
      BXI=LOG(1.-XGRID(I))
      AXJ=LOG(XGRID(J))
      BXJ=LOG(1.-XGRID(J))
      AXK=LOG(XGRID(K))
      BXK=LOG(1.-XGRID(K))
      FI=LOG(ABS(FVL(I)) +1.E-15)
      FJ=LOG(ABS(FVL(J)) +1.E-16)
      FK=LOG(ABS(FVL(K)) +1.E-17)
      DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
      ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
     $ BXI))/DET
      ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
      BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
      IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
     1RETURN
C      IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
C         WRITE(LO,2001) X,FVL
C 2001    FORMAT(8E12.4)
C         WRITE(LO,2001) ALPHA,BETA,ALOGA,DET
C      ENDIF
      PHO_CKMTFV=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA

      END


 
 


CDECK  ID>, PHO_CKMTPA
      SUBROUTINE PHO_CKMTPA(IPA,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
C**********************************************************************
C
C     PDF based on Regge theory, evolved with .... by ....
C
C     input: IPAR     2212   proton (not installed)
C                      990   Pomeron
C
C     output: parameters of parametrization
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      CHARACTER*8 PDFNA

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

      REAL PROP(40),POMP(40)
      DATA PROP /
     & .230000E+00, .200000E+01, .150200E+00, .120000E+01, .263100E+00,
     & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
     & .100000E+00, .330000E-01, .352102E-01, .200000E+01, .200000E+01,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .100000E+00, .200000E+01, .100000E+09/
      DATA POMP /
     & .230000E+00, .500000E+01, .150200E+00, .120000E+01, .263100E+00,
     & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
     & .700000E-01, .700000E-01, .137161E+00, .300000E+01, .200000E+01,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .100000E+00, .500000E+01, .100000E+09/

      IF(IPA.EQ.2212) THEN
        ALA  =PROP(1)
        Q2MI = PROP(39)
        Q2MA = PROP(40)
        PDFNA = 'CKMT-PRO'
      ELSE IF(IPA.EQ.990) THEN
        ALA  = POMP(1)
        Q2MI = POMP(39)
        Q2MA = POMP(40)
        PDFNA = 'CKMT-POM'
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I7)')
     &    'PHO_CKMTPA:ERROR: invalid particle code',IPA
        STOP
      ENDIF
      XMI = 1.D-4
      XMA = 1.D0
      END


 
 


CDECK  ID>, PHO_CKMTPD
      SUBROUTINE PHO_CKMTPD(IPAR,X,SCALE2,PD)
C**********************************************************************
C
C     PDF based on Regge theory, evolved with .... by ....
C
C     input: IPAR     2212   proton (not installed)
C                      990   Pomeron
C
C     output: PD(-6:6) x*f(x)  parton distribution functions
C            (PDFLIB convention: d = PD(1), u = PD(2) )
C
C**********************************************************************
      SAVE
C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

      DOUBLE PRECISION  X,SCALE2,PD(-6:6),CDN,CUP
      DIMENSION QQ(7)

      Q2=SNGL(SCALE2)
      Q1S=Q2
      XX=SNGL(X)
C  QCD lambda for evolution
      OWLAM = 0.23
      OWLAM2=OWLAM**2
C  Q0**2 for evolution
      Q02 = 2.D0
C
C
C  the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
C                        q(6)=x*charm, q(7)=x*gluon
C
      SB=0.
      IF(Q2-Q02) 1,1,2
    2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
    1 CONTINUE
      IF(IPAR.EQ.2212) THEN
*       CALL PHO_CKMTPR(XX,SB,QQ
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,I6)') 'PHO_CKMTPD:ERROR: invalid particle',IPAR
        CALL PHO_ABORT
      ELSE
        CALL PHO_CKMTPO(XX,SB,QQ)
      ENDIF
C
      PD(-6) = 0.D0
      PD(-5) = 0.D0
      PD(-4) = DBLE(QQ(6))
      PD(-3) = DBLE(QQ(3))
      PD(-2) = DBLE(QQ(4))
      PD(-1) = DBLE(QQ(5))
      PD(0)  = DBLE(QQ(7))
      PD(1)  = DBLE(QQ(2))
      PD(2)  = DBLE(QQ(1))
      PD(3)  = DBLE(QQ(3))
      PD(4)  = DBLE(QQ(6))
      PD(5)  = 0.D0
      PD(6)  = 0.D0
      IF(IPAR.EQ.990) THEN
        CDN = (PD(1)-PD(-1))/2.D0
        CUP = (PD(2)-PD(-2))/2.D0
        PD(-1) = PD(-1) + CDN
        PD(-2) = PD(-2) + CUP
        PD(1) = PD(-1)
        PD(2) = PD(-2)
      ENDIF
      END


 
 


CDECK  ID>, PHO_CKMTPO
      SUBROUTINE PHO_CKMTPO(X,S,QQ)
C**********************************************************************
C
C    calculation partons in Pomeron
C
C**********************************************************************
      SAVE

      DIMENSION QQ(7)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

      DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
      EQUIVALENCE (GF(1,1,1),DL(1))
      DATA DELTA/.10/

C  RNG=  -.5
C  DEU.NORM. QUARKS,GLUONS,NEW NORM   .6223E+00   .2754E+00   .1372E+01
C  POM.NORM. QUARKS,GLUONS,ALL    .132E+00    .275E+00    .407E+00
      DATA (DL(K),K=    1,   85) /
     & .324159E-01, .324159E-01, .298895E-01, .298895E-01, .298895E-01,
     & .298895E-01, .486150E+00,-.867362E-18, .362035E-01, .362035E-01,
     & .335142E-01, .335151E-01, .335151E-01, .335142E-01, .745381E+00,
     & .399157E-02, .417146E-01, .417146E-01, .388545E-01, .388564E-01,
     & .388564E-01, .388545E-01, .107588E+01, .969559E-02, .493208E-01,
     & .493208E-01, .462819E-01, .462849E-01, .462849E-01, .462819E-01,
     & .148168E+01, .174837E-01, .593251E-01, .593251E-01, .560991E-01,
     & .561035E-01, .561035E-01, .560991E-01, .196422E+01, .276588E-01,
     & .720220E-01, .720220E-01, .686007E-01, .686065E-01, .686065E-01,
     & .686007E-01, .252331E+01, .405154E-01, .876695E-01, .876695E-01,
     & .840445E-01, .840520E-01, .840520E-01, .840445E-01, .315730E+01,
     & .563115E-01, .106489E+00, .106489E+00, .102652E+00, .102662E+00,
     & .102662E+00, .102652E+00, .386313E+01, .752690E-01, .128662E+00,
     & .128662E+00, .124605E+00, .124616E+00, .124616E+00, .124605E+00,
     & .463661E+01, .975686E-01, .154326E+00, .154326E+00, .150039E+00,
     & .150053E+00, .150053E+00, .150039E+00, .547247E+01, .123348E+00,
     & .183571E+00, .183571E+00, .179048E+00, .179063E+00, .179063E+00/
      DATA (DL(K),K=   86,  170) /
     & .179048E+00, .636464E+01, .152698E+00, .216445E+00, .216445E+00,
     & .211676E+00, .211694E+00, .211694E+00, .211676E+00, .730631E+01,
     & .185666E+00, .252948E+00, .252948E+00, .247925E+00, .247946E+00,
     & .247946E+00, .247925E+00, .829017E+01, .222252E+00, .293037E+00,
     & .293037E+00, .287752E+00, .287776E+00, .287776E+00, .287752E+00,
     & .930850E+01, .262414E+00, .336625E+00, .336625E+00, .331070E+00,
     & .331097E+00, .331097E+00, .331070E+00, .103534E+02, .306065E+00,
     & .383587E+00, .383587E+00, .377754E+00, .377785E+00, .377785E+00,
     & .377754E+00, .114166E+02, .353079E+00, .433760E+00, .433760E+00,
     & .427641E+00, .427675E+00, .427675E+00, .427641E+00, .124903E+02,
     & .403294E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .296507E-01, .296507E-01, .258624E-01, .258624E-01, .258624E-01,
     & .258624E-01, .422709E+00,-.173472E-17, .330029E-01, .330029E-01/
      DATA (DL(K),K=  171,  255) /
     & .289773E-01, .289787E-01, .289787E-01, .289773E-01, .642996E+00,
     & .344499E-02, .377610E-01, .377610E-01, .334880E-01, .334910E-01,
     & .334910E-01, .334880E-01, .914159E+00, .828363E-02, .441590E-01,
     & .441590E-01, .396285E-01, .396333E-01, .396333E-01, .396285E-01,
     & .123635E+01, .147501E-01, .523710E-01, .523710E-01, .475730E-01,
     & .475798E-01, .475798E-01, .475730E-01, .160820E+01, .230185E-01,
     & .625514E-01, .625514E-01, .574758E-01, .574848E-01, .574848E-01,
     & .574758E-01, .202705E+01, .332433E-01, .748195E-01, .748195E-01,
     & .694563E-01, .694678E-01, .694678E-01, .694563E-01, .248945E+01,
     & .455440E-01, .892611E-01, .892611E-01, .836006E-01, .836147E-01,
     & .836147E-01, .836006E-01, .299114E+01, .600067E-01, .105928E+00,
     & .105928E+00, .999607E-01, .999776E-01, .999776E-01, .999607E-01,
     & .352735E+01, .766833E-01, .124839E+00, .124839E+00, .118555E+00,
     & .118575E+00, .118575E+00, .118555E+00, .409288E+01, .955921E-01,
     & .145978E+00, .145978E+00, .139368E+00, .139391E+00, .139391E+00,
     & .139368E+00, .468226E+01, .116719E+00, .169300E+00, .169300E+00,
     & .162355E+00, .162382E+00, .162382E+00, .162355E+00, .528987E+01/
      DATA (DL(K),K=  256,  340) /
     & .140017E+00, .194730E+00, .194730E+00, .187441E+00, .187471E+00,
     & .187471E+00, .187441E+00, .591007E+01, .165413E+00, .222167E+00,
     & .222167E+00, .214525E+00, .214559E+00, .214559E+00, .214525E+00,
     & .653724E+01, .192806E+00, .251486E+00, .251486E+00, .243482E+00,
     & .243521E+00, .243521E+00, .243482E+00, .716591E+01, .222070E+00,
     & .282539E+00, .282539E+00, .274165E+00, .274208E+00, .274208E+00,
     & .274165E+00, .779082E+01, .253058E+00, .315161E+00, .315161E+00,
     & .306410E+00, .306458E+00, .306458E+00, .306410E+00, .840695E+01,
     & .285608E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .279581E-01, .279581E-01, .222797E-01, .222797E-01, .222797E-01,
     & .222797E-01, .367732E+00, .867362E-18, .309604E-01, .309604E-01,
     & .249419E-01, .249441E-01, .249441E-01, .249419E-01, .552053E+00,
     & .296633E-02, .350831E-01, .350831E-01, .287126E-01, .287173E-01/
      DATA (DL(K),K=  341,  425) /
     & .287173E-01, .287126E-01, .770476E+00, .704001E-02, .404554E-01,
     & .404554E-01, .337212E-01, .337286E-01, .337286E-01, .337212E-01,
     & .102096E+01, .123504E-01, .471588E-01, .471588E-01, .400495E-01,
     & .400599E-01, .400599E-01, .400495E-01, .130079E+01, .189795E-01,
     & .552518E-01, .552518E-01, .477564E-01, .477700E-01, .477700E-01,
     & .477564E-01, .160637E+01, .269860E-01, .647649E-01, .647649E-01,
     & .568725E-01, .568897E-01, .568897E-01, .568725E-01, .193388E+01,
     & .364007E-01, .757021E-01, .757021E-01, .674022E-01, .674232E-01,
     & .674232E-01, .674022E-01, .227916E+01, .472280E-01, .880430E-01,
     & .880430E-01, .793257E-01, .793507E-01, .793507E-01, .793257E-01,
     & .263802E+01, .594481E-01, .101745E+00, .101745E+00, .926005E-01,
     & .926297E-01, .926297E-01, .926005E-01, .300628E+01, .730184E-01,
     & .116745E+00, .116745E+00, .107164E+00, .107198E+00, .107198E+00,
     & .107164E+00, .337982E+01, .878765E-01, .132961E+00, .132961E+00,
     & .122936E+00, .122974E+00, .122974E+00, .122936E+00, .375469E+01,
     & .103942E+00, .150298E+00, .150298E+00, .139820E+00, .139863E+00,
     & .139863E+00, .139820E+00, .412714E+01, .121118E+00, .168645E+00/
      DATA (DL(K),K=  426,  510) /
     & .168645E+00, .157706E+00, .157754E+00, .157754E+00, .157706E+00,
     & .449366E+01, .139296E+00, .187883E+00, .187883E+00, .176476E+00,
     & .176529E+00, .176529E+00, .176476E+00, .485100E+01, .158356E+00,
     & .207882E+00, .207882E+00, .196000E+00, .196059E+00, .196059E+00,
     & .196000E+00, .519622E+01, .178170E+00, .228506E+00, .228506E+00,
     & .216145E+00, .216209E+00, .216209E+00, .216145E+00, .552665E+01,
     & .198603E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .275294E-01, .275294E-01, .190245E-01, .190245E-01, .190245E-01,
     & .190245E-01, .320228E+00, .000000E+00, .302671E-01, .302671E-01,
     & .212851E-01, .212884E-01, .212884E-01, .212851E-01, .470861E+00,
     & .255059E-02, .338703E-01, .338703E-01, .243988E-01, .244059E-01,
     & .244059E-01, .243988E-01, .642452E+00, .595399E-02, .383922E-01,
     & .383922E-01, .284195E-01, .284305E-01, .284305E-01, .284195E-01/
      DATA (DL(K),K=  511,  595) /
     & .831913E+00, .102638E-01, .438519E-01, .438519E-01, .333669E-01,
     & .333821E-01, .333821E-01, .333669E-01, .103618E+01, .155000E-01,
     & .502475E-01, .502475E-01, .392399E-01, .392595E-01, .392595E-01,
     & .392399E-01, .125172E+01, .216612E-01, .575580E-01, .575580E-01,
     & .460181E-01, .460425E-01, .460425E-01, .460181E-01, .147519E+01,
     & .287272E-01, .657445E-01, .657445E-01, .536635E-01, .536929E-01,
     & .536929E-01, .536635E-01, .170330E+01, .366597E-01, .747539E-01,
     & .747539E-01, .621238E-01, .621582E-01, .621582E-01, .621238E-01,
     & .193297E+01, .454066E-01, .845205E-01, .845205E-01, .713340E-01,
     & .713738E-01, .713738E-01, .713340E-01, .216133E+01, .549027E-01,
     & .949687E-01, .949687E-01, .812194E-01, .812646E-01, .812646E-01,
     & .812194E-01, .238578E+01, .650733E-01, .106015E+00, .106015E+00,
     & .916972E-01, .917480E-01, .917480E-01, .916972E-01, .260395E+01,
     & .758355E-01, .117569E+00, .117569E+00, .102678E+00, .102735E+00,
     & .102735E+00, .102678E+00, .281373E+01, .871004E-01, .129537E+00,
     & .129537E+00, .114070E+00, .114133E+00, .114133E+00, .114070E+00,
     & .301327E+01, .987750E-01, .141824E+00, .141824E+00, .125777E+00/
      DATA (DL(K),K=  596,  680) /
     & .125846E+00, .125846E+00, .125777E+00, .320098E+01, .110764E+00,
     & .154331E+00, .154331E+00, .137703E+00, .137778E+00, .137778E+00,
     & .137703E+00, .337553E+01, .122970E+00, .166962E+00, .166962E+00,
     & .149753E+00, .149833E+00, .149833E+00, .149753E+00, .353582E+01,
     & .135299E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .286766E-01, .286766E-01, .159579E-01, .159579E-01, .159579E-01,
     & .159579E-01, .279430E+00,-.867362E-18, .312327E-01, .312327E-01,
     & .178644E-01, .178691E-01, .178691E-01, .178644E-01, .399186E+00,
     & .219459E-02, .344289E-01, .344289E-01, .204015E-01, .204111E-01,
     & .204111E-01, .204015E-01, .529978E+00, .501953E-02, .382657E-01,
     & .382657E-01, .235713E-01, .235860E-01, .235860E-01, .235713E-01,
     & .668515E+00, .847682E-02, .427243E-01, .427243E-01, .273559E-01,
     & .273758E-01, .273758E-01, .273559E-01, .812075E+00, .125486E-01/
      DATA (DL(K),K=  681,  765) /
     & .477691E-01, .477691E-01, .317212E-01, .317465E-01, .317465E-01,
     & .317212E-01, .957801E+00, .172006E-01, .533547E-01, .533547E-01,
     & .366231E-01, .366539E-01, .366539E-01, .366231E-01, .110327E+01,
     & .223886E-01, .594259E-01, .594259E-01, .420076E-01, .420441E-01,
     & .420441E-01, .420076E-01, .124628E+01, .280584E-01, .659213E-01,
     & .659213E-01, .478149E-01, .478570E-01, .478570E-01, .478149E-01,
     & .138496E+01, .341502E-01, .727749E-01, .727749E-01, .539803E-01,
     & .540280E-01, .540280E-01, .539803E-01, .151767E+01, .405990E-01,
     & .799178E-01, .799178E-01, .604361E-01, .604895E-01, .604895E-01,
     & .604361E-01, .164304E+01, .473372E-01, .872796E-01, .872796E-01,
     & .671134E-01, .671724E-01, .671724E-01, .671134E-01, .175992E+01,
     & .542955E-01, .947896E-01, .947896E-01, .739429E-01, .740075E-01,
     & .740075E-01, .739429E-01, .186739E+01, .614047E-01, .102378E+00,
     & .102378E+00, .808565E-01, .809266E-01, .809266E-01, .808565E-01,
     & .196473E+01, .685965E-01, .109978E+00, .109978E+00, .877881E-01,
     & .878637E-01, .878637E-01, .877881E-01, .205141E+01, .758045E-01,
     & .117525E+00, .117525E+00, .946745E-01, .947553E-01, .947553E-01/
      DATA (DL(K),K=  766,  850) /
     & .946745E-01, .212709E+01, .829655E-01, .124958E+00, .124958E+00,
     & .101456E+00, .101542E+00, .101542E+00, .101456E+00, .219159E+01,
     & .900196E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .318691E-01, .318691E-01, .129081E-01, .129081E-01, .129081E-01,
     & .129081E-01, .244842E+00,-.867362E-18, .343104E-01, .343104E-01,
     & .145076E-01, .145124E-01, .145124E-01, .145076E-01, .337040E+00,
     & .189443E-02, .371900E-01, .371900E-01, .165461E-01, .165557E-01,
     & .165557E-01, .165461E-01, .433081E+00, .422691E-02, .404763E-01,
     & .404763E-01, .189941E-01, .190085E-01, .190085E-01, .189941E-01,
     & .530109E+00, .696769E-02, .441304E-01, .441304E-01, .218150E-01,
     & .218342E-01, .218342E-01, .218150E-01, .626129E+00, .100799E-01,
     & .481031E-01, .481031E-01, .249615E-01, .249853E-01, .249853E-01,
     & .249615E-01, .719221E+00, .135159E-01, .523426E-01, .523426E-01/
      DATA (DL(K),K=  851,  935) /
     & .283837E-01, .284122E-01, .284122E-01, .283837E-01, .807951E+00,
     & .172259E-01, .567940E-01, .567940E-01, .320288E-01, .320619E-01,
     & .320619E-01, .320288E-01, .891154E+00, .211568E-01, .614022E-01,
     & .614022E-01, .358436E-01, .358811E-01, .358811E-01, .358436E-01,
     & .967928E+00, .252549E-01, .661122E-01, .661122E-01, .397750E-01,
     & .398169E-01, .398169E-01, .397750E-01, .103759E+01, .294673E-01,
     & .708708E-01, .708708E-01, .437716E-01, .438176E-01, .438176E-01,
     & .437716E-01, .109966E+01, .337422E-01, .756269E-01, .756269E-01,
     & .477840E-01, .478342E-01, .478342E-01, .477840E-01, .115380E+01,
     & .380302E-01, .803322E-01, .803322E-01, .517659E-01, .518200E-01,
     & .518200E-01, .517659E-01, .119986E+01, .422846E-01, .849423E-01,
     & .849423E-01, .556743E-01, .557322E-01, .557322E-01, .556743E-01,
     & .123782E+01, .464624E-01, .894164E-01, .894164E-01, .594701E-01,
     & .595315E-01, .595315E-01, .594701E-01, .126777E+01, .505242E-01,
     & .937178E-01, .937178E-01, .631181E-01, .631829E-01, .631829E-01,
     & .631181E-01, .128993E+01, .544348E-01, .978144E-01, .978144E-01,
     & .665876E-01, .666556E-01, .666556E-01, .665876E-01, .130457E+01/
      DATA (DL(K),K=  936, 1020) /
     & .581632E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .377668E-01, .377668E-01, .968304E-02, .968304E-02, .968304E-02,
     & .968304E-02, .216392E+00,-.130104E-17, .401066E-01, .401066E-01,
     & .110266E-01, .110291E-01, .110291E-01, .110266E-01, .284113E+00,
     & .164283E-02, .426983E-01, .426983E-01, .126461E-01, .126510E-01,
     & .126510E-01, .126461E-01, .350879E+00, .355790E-02, .454940E-01,
     & .454940E-01, .144965E-01, .145039E-01, .145039E-01, .144965E-01,
     & .414611E+00, .570002E-02, .484493E-01, .484493E-01, .165364E-01,
     & .165462E-01, .165462E-01, .165364E-01, .474149E+00, .802739E-02,
     & .515153E-01, .515153E-01, .187191E-01, .187313E-01, .187313E-01,
     & .187191E-01, .528511E+00, .104932E-01, .546458E-01, .546458E-01,
     & .210009E-01, .210154E-01, .210154E-01, .210009E-01, .577107E+00,
     & .130535E-01, .577962E-01, .577962E-01, .233395E-01, .233563E-01/
      DATA (DL(K),K= 1021, 1105) /
     & .233563E-01, .233395E-01, .619574E+00, .156658E-01, .609249E-01,
     & .609249E-01, .256954E-01, .257143E-01, .257143E-01, .256954E-01,
     & .655725E+00, .182905E-01, .639938E-01, .639938E-01, .280322E-01,
     & .280532E-01, .280532E-01, .280322E-01, .685523E+00, .208909E-01,
     & .669681E-01, .669681E-01, .303170E-01, .303399E-01, .303399E-01,
     & .303170E-01, .709053E+00, .234341E-01, .698172E-01, .698172E-01,
     & .325206E-01, .325454E-01, .325454E-01, .325206E-01, .726501E+00,
     & .258907E-01, .725141E-01, .725141E-01, .346176E-01, .346442E-01,
     & .346442E-01, .346176E-01, .738139E+00, .282352E-01, .750364E-01,
     & .750364E-01, .365866E-01, .366148E-01, .366148E-01, .365866E-01,
     & .744304E+00, .304461E-01, .773653E-01, .773653E-01, .384099E-01,
     & .384396E-01, .384396E-01, .384099E-01, .745388E+00, .325056E-01,
     & .794860E-01, .794860E-01, .400736E-01, .401046E-01, .401046E-01,
     & .400736E-01, .741819E+00, .343996E-01, .813873E-01, .813873E-01,
     & .415670E-01, .415993E-01, .415993E-01, .415670E-01, .734051E+00,
     & .361177E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
      DATA (DL(K),K= 1106, 1190) /
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .433773E-01, .433773E-01, .745094E-02, .745094E-02, .745094E-02,
     & .745094E-02, .201612E+00,-.130104E-17, .455998E-01, .455998E-01,
     & .866239E-02, .866443E-02, .866443E-02, .866239E-02, .255046E+00,
     & .149977E-02, .479569E-01, .479569E-01, .100584E-01, .100624E-01,
     & .100624E-01, .100584E-01, .305549E+00, .317779E-02, .503976E-01,
     & .503976E-01, .115911E-01, .115970E-01, .115970E-01, .115911E-01,
     & .351606E+00, .498612E-02, .528804E-01, .528804E-01, .132216E-01,
     & .132293E-01, .132293E-01, .132216E-01, .392560E+00, .688553E-02,
     & .553621E-01, .553621E-01, .149087E-01, .149181E-01, .149181E-01,
     & .149087E-01, .427948E+00, .883486E-02, .578049E-01, .578049E-01,
     & .166165E-01, .166276E-01, .166276E-01, .166165E-01, .457612E+00,
     & .107980E-01, .601739E-01, .601739E-01, .183120E-01, .183246E-01,
     & .183246E-01, .183120E-01, .481565E+00, .127419E-01, .624390E-01,
     & .624390E-01, .199661E-01, .199801E-01, .199801E-01, .199661E-01/
      DATA (DL(K),K= 1191, 1275) /
     & .499943E+00, .146375E-01, .645736E-01, .645736E-01, .215535E-01,
     & .215688E-01, .215688E-01, .215535E-01, .512983E+00, .164593E-01,
     & .665556E-01, .665556E-01, .230528E-01, .230693E-01, .230693E-01,
     & .230528E-01, .520995E+00, .181859E-01, .683669E-01, .683669E-01,
     & .244463E-01, .244639E-01, .244639E-01, .244463E-01, .524347E+00,
     & .197998E-01, .699932E-01, .699932E-01, .257201E-01, .257387E-01,
     & .257387E-01, .257201E-01, .523447E+00, .212869E-01, .714240E-01,
     & .714240E-01, .268637E-01, .268832E-01, .268832E-01, .268637E-01,
     & .518729E+00, .226367E-01, .726523E-01, .726523E-01, .278697E-01,
     & .278900E-01, .278900E-01, .278697E-01, .510641E+00, .238420E-01,
     & .736741E-01, .736741E-01, .287338E-01, .287547E-01, .287547E-01,
     & .287338E-01, .499630E+00, .248984E-01, .744886E-01, .744886E-01,
     & .294542E-01, .294757E-01, .294757E-01, .294542E-01, .486140E+00,
     & .258043E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
      DATA (DL(K),K= 1276, 1360) /
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .499162E-01, .499162E-01, .534441E-02, .534441E-02, .534441E-02,
     & .534441E-02, .191108E+00,-.151788E-17, .519197E-01, .519197E-01,
     & .646285E-02, .646402E-02, .646402E-02, .646285E-02, .232539E+00,
     & .137669E-02, .539504E-01, .539504E-01, .769150E-02, .769377E-02,
     & .769377E-02, .769150E-02, .269907E+00, .285489E-02, .559598E-01,
     & .559598E-01, .898389E-02, .898721E-02, .898721E-02, .898389E-02,
     & .302186E+00, .438814E-02, .579130E-01, .579130E-01, .103061E-01,
     & .103104E-01, .103104E-01, .103061E-01, .329124E+00, .594258E-02,
     & .597754E-01, .597754E-01, .116245E-01, .116297E-01, .116297E-01,
     & .116245E-01, .350643E+00, .748452E-02, .615191E-01, .615191E-01,
     & .129113E-01, .129174E-01, .129174E-01, .129113E-01, .366890E+00,
     & .898645E-02, .631204E-01, .631204E-01, .141428E-01, .141497E-01,
     & .141497E-01, .141428E-01, .378134E+00, .104247E-01, .645601E-01,
     & .645601E-01, .152995E-01, .153071E-01, .153071E-01, .152995E-01,
     & .384719E+00, .117798E-01, .658236E-01, .658236E-01, .163657E-01,
     & .163739E-01, .163739E-01, .163657E-01, .387045E+00, .130362E-01/
      DATA (DL(K),K= 1361, 1445) /
     & .669000E-01, .669000E-01, .173294E-01, .173381E-01, .173381E-01,
     & .173294E-01, .385547E+00, .141821E-01, .677824E-01, .677824E-01,
     & .181820E-01, .181912E-01, .181912E-01, .181820E-01, .380677E+00,
     & .152091E-01, .684672E-01, .684672E-01, .189180E-01, .189277E-01,
     & .189277E-01, .189180E-01, .372894E+00, .161119E-01, .689539E-01,
     & .689539E-01, .195349E-01, .195449E-01, .195449E-01, .195349E-01,
     & .362650E+00, .168880E-01, .692447E-01, .692447E-01, .200324E-01,
     & .200427E-01, .200427E-01, .200324E-01, .350383E+00, .175374E-01,
     & .693442E-01, .693442E-01, .204123E-01, .204229E-01, .204229E-01,
     & .204123E-01, .336505E+00, .180622E-01, .692590E-01, .692590E-01,
     & .206783E-01, .206891E-01, .206891E-01, .206783E-01, .321403E+00,
     & .184661E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .554152E-01, .554152E-01, .386683E-02, .386683E-02, .386683E-02/
      DATA (DL(K),K= 1446, 1530) /
     & .386683E-02, .185844E+00,-.151788E-17, .571372E-01, .571372E-01,
     & .493623E-02, .493704E-02, .493704E-02, .493623E-02, .219342E+00,
     & .129037E-02, .588098E-01, .588098E-01, .606768E-02, .606924E-02,
     & .606924E-02, .606768E-02, .248288E+00, .263296E-02, .603896E-01,
     & .603896E-01, .721747E-02, .721973E-02, .721973E-02, .721747E-02,
     & .271974E+00, .398431E-02, .618484E-01, .618484E-01, .835658E-02,
     & .835949E-02, .835949E-02, .835658E-02, .290397E+00, .531560E-02,
     & .631600E-01, .631600E-01, .945726E-02, .946074E-02, .946074E-02,
     & .945726E-02, .303702E+00, .659930E-02, .643051E-01, .643051E-01,
     & .104983E-01, .105023E-01, .105023E-01, .104983E-01, .312209E+00,
     & .781443E-02, .652691E-01, .652691E-01, .114624E-01, .114669E-01,
     & .114669E-01, .114624E-01, .316328E+00, .894407E-02, .660416E-01,
     & .660416E-01, .123367E-01, .123416E-01, .123416E-01, .123367E-01,
     & .316509E+00, .997546E-02, .666169E-01, .666169E-01, .131119E-01,
     & .131171E-01, .131171E-01, .131119E-01, .313229E+00, .108996E-01,
     & .669925E-01, .669925E-01, .137818E-01, .137874E-01, .137874E-01,
     & .137818E-01, .306974E+00, .117107E-01, .671695E-01, .671695E-01/
      DATA (DL(K),K= 1531, 1615) /
     & .143437E-01, .143495E-01, .143495E-01, .143437E-01, .298224E+00,
     & .124061E-01, .671517E-01, .671517E-01, .147970E-01, .148031E-01,
     & .148031E-01, .147970E-01, .287441E+00, .129858E-01, .669454E-01,
     & .669454E-01, .151437E-01, .151499E-01, .151499E-01, .151437E-01,
     & .275064E+00, .134517E-01, .665590E-01, .665590E-01, .153872E-01,
     & .153935E-01, .153935E-01, .153872E-01, .261497E+00, .138078E-01,
     & .660023E-01, .660023E-01, .155327E-01, .155391E-01, .155391E-01,
     & .155327E-01, .247105E+00, .140595E-01, .652865E-01, .652865E-01,
     & .155864E-01, .155929E-01, .155929E-01, .155864E-01, .232218E+00,
     & .142131E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .601098E-01, .601098E-01, .278641E-02, .278641E-02, .278641E-02,
     & .278641E-02, .183460E+00, .130104E-17, .614949E-01, .614949E-01,
     & .382710E-02, .382771E-02, .382771E-02, .382710E-02, .211150E+00/
      DATA (DL(K),K= 1616, 1700) /
     & .122320E-02, .627722E-01, .627722E-01, .489465E-02, .489580E-02,
     & .489580E-02, .489465E-02, .234040E+00, .246333E-02, .639042E-01,
     & .639042E-01, .594825E-02, .594990E-02, .594990E-02, .594825E-02,
     & .251649E+00, .367998E-02, .648697E-01, .648697E-01, .696315E-02,
     & .696526E-02, .696526E-02, .696315E-02, .264143E+00, .484875E-02,
     & .656502E-01, .656502E-01, .791658E-02, .791907E-02, .791907E-02,
     & .791658E-02, .271822E+00, .594722E-02, .662343E-01, .662343E-01,
     & .879236E-02, .879520E-02, .879520E-02, .879236E-02, .275124E+00,
     & .695957E-02, .666152E-01, .666152E-01, .957846E-02, .958160E-02,
     & .958160E-02, .957846E-02, .274549E+00, .787413E-02, .667905E-01,
     & .667905E-01, .102668E-01, .102702E-01, .102702E-01, .102668E-01,
     & .270615E+00, .868318E-02, .667616E-01, .667616E-01, .108528E-01,
     & .108564E-01, .108564E-01, .108528E-01, .263847E+00, .938250E-02,
     & .665331E-01, .665331E-01, .113349E-01, .113387E-01, .113387E-01,
     & .113349E-01, .254756E+00, .997082E-02, .661123E-01, .661123E-01,
     & .117139E-01, .117179E-01, .117179E-01, .117139E-01, .243828E+00,
     & .104494E-01, .655090E-01, .655090E-01, .119931E-01, .119971E-01/
      DATA (DL(K),K= 1701, 1785) /
     & .119971E-01, .119931E-01, .231518E+00, .108217E-01, .647345E-01,
     & .647345E-01, .121770E-01, .121811E-01, .121811E-01, .121770E-01,
     & .218237E+00, .110927E-01, .638017E-01, .638017E-01, .122717E-01,
     & .122759E-01, .122759E-01, .122717E-01, .204353E+00, .112689E-01,
     & .627241E-01, .627241E-01, .122842E-01, .122884E-01, .122884E-01,
     & .122842E-01, .190187E+00, .113573E-01, .615161E-01, .615161E-01,
     & .122221E-01, .122262E-01, .122262E-01, .122221E-01, .176012E+00,
     & .113659E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .641221E-01, .641221E-01, .198544E-02, .198544E-02, .198544E-02,
     & .198544E-02, .183018E+00, .184314E-17, .651208E-01, .651208E-01,
     & .300778E-02, .300823E-02, .300823E-02, .300778E-02, .206180E+00,
     & .116844E-02, .659664E-01, .659664E-01, .402903E-02, .402989E-02,
     & .402989E-02, .402903E-02, .224390E+00, .232648E-02, .666277E-01/
      DATA (DL(K),K= 1786, 1870) /
     & .666277E-01, .501117E-02, .501238E-02, .501238E-02, .501117E-02,
     & .237332E+00, .343657E-02, .670904E-01, .670904E-01, .593321E-02,
     & .593473E-02, .593473E-02, .593321E-02, .245310E+00, .447818E-02,
     & .673435E-01, .673435E-01, .677663E-02, .677843E-02, .677843E-02,
     & .677663E-02, .248743E+00, .543320E-02, .673832E-01, .673832E-01,
     & .752958E-02, .753161E-02, .753161E-02, .752958E-02, .248162E+00,
     & .629021E-02, .672099E-01, .672099E-01, .818432E-02, .818655E-02,
     & .818655E-02, .818432E-02, .244140E+00, .704188E-02, .668281E-01,
     & .668281E-01, .873688E-02, .873927E-02, .873927E-02, .873688E-02,
     & .237247E+00, .768463E-02, .662457E-01, .662457E-01, .918650E-02,
     & .918903E-02, .918903E-02, .918650E-02, .228043E+00, .821808E-02,
     & .654734E-01, .654734E-01, .953502E-02, .953766E-02, .953766E-02,
     & .953502E-02, .217054E+00, .864446E-02, .645238E-01, .645238E-01,
     & .978645E-02, .978915E-02, .978915E-02, .978645E-02, .204766E+00,
     & .896811E-02, .634114E-01, .634114E-01, .994639E-02, .994915E-02,
     & .994915E-02, .994639E-02, .191614E+00, .919500E-02, .621515E-01,
     & .621515E-01, .100217E-01, .100245E-01, .100245E-01, .100217E-01/
      DATA (DL(K),K= 1871, 1955) /
     & .177983E+00, .933229E-02, .607602E-01, .607602E-01, .100200E-01,
     & .100228E-01, .100228E-01, .100200E-01, .164201E+00, .938793E-02,
     & .592539E-01, .592539E-01, .994938E-02, .995217E-02, .995217E-02,
     & .994938E-02, .150544E+00, .937032E-02, .576488E-01, .576488E-01,
     & .981814E-02, .982091E-02, .982091E-02, .981814E-02, .137234E+00,
     & .928803E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .675167E-01, .675167E-01, .139130E-02, .139130E-02, .139130E-02,
     & .139130E-02, .184090E+00, .113841E-17, .680840E-01, .680840E-01,
     & .240061E-02, .240097E-02, .240097E-02, .240061E-02, .203559E+00,
     & .112278E-02, .684634E-01, .684634E-01, .338513E-02, .338580E-02,
     & .338580E-02, .338513E-02, .217944E+00, .221249E-02, .686304E-01,
     & .686304E-01, .430938E-02, .431032E-02, .431032E-02, .430938E-02,
     & .227068E+00, .323420E-02, .685779E-01, .685779E-01, .515589E-02/
      DATA (DL(K),K= 1956, 2040) /
     & .515707E-02, .515707E-02, .515589E-02, .231353E+00, .417091E-02,
     & .683023E-01, .683023E-01, .591002E-02, .591140E-02, .591140E-02,
     & .591002E-02, .231327E+00, .500843E-02, .678068E-01, .678068E-01,
     & .656383E-02, .656537E-02, .656537E-02, .656383E-02, .227606E+00,
     & .573925E-02, .670989E-01, .670989E-01, .711344E-02, .711513E-02,
     & .711513E-02, .711344E-02, .220833E+00, .635992E-02, .661895E-01,
     & .661895E-01, .755852E-02, .756031E-02, .756031E-02, .755852E-02,
     & .211624E+00, .687048E-02, .650923E-01, .650923E-01, .790162E-02,
     & .790350E-02, .790350E-02, .790162E-02, .200567E+00, .727387E-02,
     & .638232E-01, .638232E-01, .814753E-02, .814946E-02, .814946E-02,
     & .814753E-02, .188197E+00, .757524E-02, .623994E-01, .623994E-01,
     & .830271E-02, .830469E-02, .830469E-02, .830271E-02, .174994E+00,
     & .778139E-02, .608390E-01, .608390E-01, .837482E-02, .837682E-02,
     & .837682E-02, .837482E-02, .161373E+00, .790029E-02, .591605E-01,
     & .591605E-01, .837226E-02, .837426E-02, .837426E-02, .837226E-02,
     & .147685E+00, .794065E-02, .573824E-01, .573824E-01, .830376E-02,
     & .830575E-02, .830575E-02, .830376E-02, .134218E+00, .791148E-02/
      DATA (DL(K),K= 2041, 2125) /
     & .555224E-01, .555224E-01, .817811E-02, .818008E-02, .818008E-02,
     & .817811E-02, .121200E+00, .782185E-02, .535980E-01, .535980E-01,
     & .800390E-02, .800584E-02, .800584E-02, .800390E-02, .108803E+00,
     & .768059E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .703249E-01, .703249E-01, .953926E-03, .953926E-03, .953926E-03,
     & .953926E-03, .186497E+00, .108420E-18, .704188E-01, .704188E-01,
     & .195267E-02, .195297E-02, .195297E-02, .195267E-02, .202831E+00,
     & .108414E-02, .702995E-01, .702995E-01, .290528E-02, .290582E-02,
     & .290582E-02, .290528E-02, .213933E+00, .211514E-02, .699499E-01,
     & .699499E-01, .377873E-02, .377950E-02, .377950E-02, .377873E-02,
     & .219748E+00, .306054E-02, .693699E-01, .693699E-01, .455903E-02,
     & .455997E-02, .455997E-02, .455903E-02, .220821E+00, .390679E-02,
     & .685634E-01, .685634E-01, .523531E-02, .523640E-02, .523640E-02/
      DATA (DL(K),K= 2126, 2210) /
     & .523531E-02, .217787E+00, .464347E-02, .675406E-01, .675406E-01,
     & .580340E-02, .580462E-02, .580462E-02, .580340E-02, .211353E+00,
     & .526681E-02, .663155E-01, .663155E-01, .626315E-02, .626446E-02,
     & .626446E-02, .626315E-02, .202230E+00, .577705E-02, .649052E-01,
     & .649052E-01, .661759E-02, .661897E-02, .661897E-02, .661759E-02,
     & .191081E+00, .617758E-02, .633285E-01, .633285E-01, .687230E-02,
     & .687373E-02, .687373E-02, .687230E-02, .178518E+00, .647434E-02,
     & .616058E-01, .616058E-01, .703464E-02, .703611E-02, .703611E-02,
     & .703464E-02, .165082E+00, .667499E-02, .597580E-01, .597580E-01,
     & .711320E-02, .711468E-02, .711468E-02, .711320E-02, .151241E+00,
     & .678842E-02, .578059E-01, .578059E-01, .711723E-02, .711872E-02,
     & .711872E-02, .711723E-02, .137382E+00, .682417E-02, .557702E-01,
     & .557702E-01, .705628E-02, .705776E-02, .705776E-02, .705628E-02,
     & .123821E+00, .679205E-02, .536704E-01, .536704E-01, .693979E-02,
     & .694125E-02, .694125E-02, .693979E-02, .110798E+00, .670173E-02,
     & .515252E-01, .515252E-01, .677689E-02, .677832E-02, .677832E-02,
     & .677689E-02, .984933E-01, .656256E-02, .493519E-01, .493519E-01/
      DATA (DL(K),K= 2211, 2295) /
     & .657614E-02, .657753E-02, .657753E-02, .657614E-02, .870270E-01,
     & .638332E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .725555E-01, .725555E-01, .636424E-03, .636424E-03, .636424E-03,
     & .636424E-03, .190200E+00,-.271051E-17, .721364E-01, .721364E-01,
     & .162522E-02, .162546E-02, .162546E-02, .162522E-02, .203770E+00,
     & .105090E-02, .714881E-01, .714881E-01, .254763E-02, .254807E-02,
     & .254807E-02, .254763E-02, .211914E+00, .202976E-02, .706012E-01,
     & .706012E-01, .337323E-02, .337384E-02, .337384E-02, .337323E-02,
     & .214704E+00, .290668E-02, .694832E-01, .694832E-01, .409164E-02,
     & .409240E-02, .409240E-02, .409164E-02, .212817E+00, .367169E-02,
     & .681454E-01, .681454E-01, .469593E-02, .469679E-02, .469679E-02,
     & .469593E-02, .207013E+00, .431823E-02, .666048E-01, .666048E-01,
     & .518578E-02, .518673E-02, .518673E-02, .518578E-02, .198095E+00/
      DATA (DL(K),K= 2296, 2380) /
     & .484637E-02, .648819E-01, .648819E-01, .556473E-02, .556575E-02,
     & .556575E-02, .556473E-02, .186850E+00, .525997E-02, .629989E-01,
     & .629989E-01, .583908E-02, .584014E-02, .584014E-02, .583908E-02,
     & .173986E+00, .556566E-02, .609795E-01, .609795E-01, .601725E-02,
     & .601834E-02, .601834E-02, .601725E-02, .160140E+00, .577215E-02,
     & .588474E-01, .588474E-01, .610889E-02, .611000E-02, .611000E-02,
     & .610889E-02, .145850E+00, .588934E-02, .566261E-01, .566261E-01,
     & .612435E-02, .612547E-02, .612547E-02, .612435E-02, .131564E+00,
     & .592785E-02, .543385E-01, .543385E-01, .607415E-02, .607526E-02,
     & .607526E-02, .607415E-02, .117636E+00, .589841E-02, .520060E-01,
     & .520060E-01, .596861E-02, .596970E-02, .596970E-02, .596861E-02,
     & .104336E+00, .581156E-02, .496485E-01, .496485E-01, .581753E-02,
     & .581860E-02, .581860E-02, .581753E-02, .918563E-01, .567728E-02,
     & .472842E-01, .472842E-01, .563002E-02, .563105E-02, .563105E-02,
     & .563002E-02, .803205E-01, .550487E-02, .449295E-01, .449295E-01,
     & .541435E-02, .541535E-02, .541535E-02, .541435E-02, .697975E-01,
     & .530276E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
      DATA (DL(K),K= 2381, 2465) /
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .742000E-01, .742000E-01, .410482E-03, .410482E-03, .410482E-03,
     & .410482E-03, .195273E+00,-.143657E-17, .732296E-01, .732296E-01,
     & .138854E-02, .138874E-02, .138874E-02, .138854E-02, .206298E+00,
     & .102151E-02, .720241E-01, .720241E-01, .228017E-02, .228054E-02,
     & .228054E-02, .228017E-02, .211639E+00, .195225E-02, .705820E-01,
     & .705820E-01, .305794E-02, .305844E-02, .305844E-02, .305794E-02,
     & .211509E+00, .276522E-02, .689187E-01, .689187E-01, .371549E-02,
     & .371609E-02, .371609E-02, .371549E-02, .206745E+00, .345441E-02,
     & .670527E-01, .670527E-01, .425016E-02, .425084E-02, .425084E-02,
     & .425016E-02, .198254E+00, .401749E-02, .650080E-01, .650080E-01,
     & .466572E-02, .466647E-02, .466647E-02, .466572E-02, .186950E+00,
     & .445856E-02, .628107E-01, .628107E-01, .496948E-02, .497027E-02,
     & .497027E-02, .496948E-02, .173701E+00, .478517E-02, .604878E-01/
      DATA (DL(K),K= 2466, 2550) /
     & .604878E-01, .517094E-02, .517175E-02, .517175E-02, .517094E-02,
     & .159263E+00, .500709E-02, .580665E-01, .580665E-01, .528116E-02,
     & .528199E-02, .528199E-02, .528116E-02, .144287E+00, .513562E-02,
     & .555730E-01, .555730E-01, .531181E-02, .531265E-02, .531265E-02,
     & .531181E-02, .129304E+00, .518264E-02, .530325E-01, .530325E-01,
     & .527468E-02, .527550E-02, .527550E-02, .527468E-02, .114731E+00,
     & .516012E-02, .504682E-01, .504682E-01, .518116E-02, .518198E-02,
     & .518198E-02, .518116E-02, .100877E+00, .507964E-02, .479014E-01,
     & .479014E-01, .504198E-02, .504278E-02, .504278E-02, .504198E-02,
     & .879578E-01, .495209E-02, .453511E-01, .453511E-01, .486695E-02,
     & .486772E-02, .486772E-02, .486695E-02, .761077E-01, .478741E-02,
     & .428340E-01, .428340E-01, .466486E-02, .466560E-02, .466560E-02,
     & .466486E-02, .653932E-01, .459453E-02, .403645E-01, .403645E-01,
     & .444342E-02, .444413E-02, .444413E-02, .444342E-02, .558281E-01,
     & .438128E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
      DATA (DL(K),K= 2551, 2635) /
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .752337E-01, .752337E-01, .253875E-03, .253875E-03, .253875E-03,
     & .253875E-03, .201902E+00,-.159920E-17, .736752E-01, .736752E-01,
     & .121909E-02, .121925E-02, .121925E-02, .121909E-02, .210465E+00,
     & .994282E-03, .718865E-01, .718865E-01, .207747E-02, .207776E-02,
     & .207776E-02, .207747E-02, .212997E+00, .187854E-02, .698746E-01,
     & .698746E-01, .280521E-02, .280560E-02, .280560E-02, .280521E-02,
     & .209895E+00, .262933E-02, .676629E-01, .676629E-01, .340063E-02,
     & .340109E-02, .340109E-02, .340063E-02, .202191E+00, .324527E-02,
     & .652775E-01, .652775E-01, .386588E-02, .386641E-02, .386641E-02,
     & .386588E-02, .190971E+00, .372876E-02, .627483E-01, .627483E-01,
     & .420910E-02, .420967E-02, .420967E-02, .420910E-02, .177278E+00,
     & .408818E-02, .601066E-01, .601066E-01, .444148E-02, .444208E-02,
     & .444208E-02, .444148E-02, .162071E+00, .433493E-02, .573831E-01,
     & .573831E-01, .457564E-02, .457625E-02, .457625E-02, .457564E-02,
     & .146148E+00, .448183E-02, .546072E-01, .546072E-01, .462506E-02/
      DATA (DL(K),K= 2636, 2720) /
     & .462567E-02, .462567E-02, .462506E-02, .130166E+00, .454252E-02,
     & .518065E-01, .518065E-01, .460307E-02, .460368E-02, .460368E-02,
     & .460307E-02, .114632E+00, .453052E-02, .490062E-01, .490062E-01,
     & .452252E-02, .452312E-02, .452312E-02, .452252E-02, .999175E-01,
     & .445880E-02, .462287E-01, .462287E-01, .439529E-02, .439588E-02,
     & .439588E-02, .439529E-02, .862750E-01, .433936E-02, .434937E-01,
     & .434937E-01, .423211E-02, .423268E-02, .423268E-02, .423211E-02,
     & .738542E-01, .418306E-02, .408180E-01, .408180E-01, .404245E-02,
     & .404299E-02, .404299E-02, .404245E-02, .627228E-01, .399946E-02,
     & .382157E-01, .382157E-01, .383446E-02, .383498E-02, .383498E-02,
     & .383446E-02, .528847E-01, .379682E-02, .356980E-01, .356980E-01,
     & .361508E-02, .361557E-02, .361557E-02, .361508E-02, .442963E-01,
     & .358213E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
      DATA (DL(K),K= 2721, 2805) /
     & .756149E-01, .756149E-01, .148956E-03, .148956E-03, .148956E-03,
     & .148956E-03, .210410E+00,-.149078E-18, .734321E-01, .734321E-01,
     & .109779E-02, .109791E-02, .109791E-02, .109779E-02, .216444E+00,
     & .967243E-03, .710369E-01, .710369E-01, .191860E-02, .191882E-02,
     & .191882E-02, .191860E-02, .215992E+00, .180426E-02, .684452E-01,
     & .684452E-01, .259230E-02, .259259E-02, .259259E-02, .259230E-02,
     & .209697E+00, .249224E-02, .656884E-01, .656884E-01, .312270E-02,
     & .312305E-02, .312305E-02, .312270E-02, .198844E+00, .303522E-02,
     & .627994E-01, .627994E-01, .351747E-02, .351786E-02, .351786E-02,
     & .351747E-02, .184740E+00, .344105E-02, .598138E-01, .598138E-01,
     & .378940E-02, .378981E-02, .378981E-02, .378940E-02, .168578E+00,
     & .372269E-02, .567666E-01, .567666E-01, .395362E-02, .395405E-02,
     & .395405E-02, .395362E-02, .151409E+00, .389544E-02, .536907E-01,
     & .536907E-01, .402569E-02, .402613E-02, .402613E-02, .402569E-02,
     & .134065E+00, .397499E-02, .506163E-01, .506163E-01, .402117E-02,
     & .402161E-02, .402161E-02, .402117E-02, .117191E+00, .397702E-02,
     & .475706E-01, .475706E-01, .395467E-02, .395511E-02, .395511E-02/
      DATA (DL(K),K= 2806, 2890) /
     & .395467E-02, .101250E+00, .391626E-02, .445771E-01, .445771E-01,
     & .383961E-02, .384003E-02, .384003E-02, .383961E-02, .865500E-01,
     & .380621E-02, .416559E-01, .416559E-01, .368789E-02, .368830E-02,
     & .368830E-02, .368789E-02, .732657E-01, .365888E-02, .388235E-01,
     & .388235E-01, .350985E-02, .351025E-02, .351025E-02, .350985E-02,
     & .614686E-01, .348466E-02, .360931E-01, .360931E-01, .331425E-02,
     & .331462E-02, .331462E-02, .331425E-02, .511511E-01, .329240E-02,
     & .334751E-01, .334751E-01, .310835E-02, .310870E-02, .310870E-02,
     & .310835E-02, .422485E-01, .308941E-02, .309768E-01, .309768E-01,
     & .289805E-02, .289838E-02, .289838E-02, .289805E-02, .346590E-01,
     & .288164E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .752796E-01, .752796E-01, .816906E-04, .816906E-04, .816906E-04,
     & .816906E-04, .221322E+00, .298156E-18, .724376E-01, .724376E-01/
      DATA (DL(K),K= 2891, 2975) /
     & .100884E-02, .100894E-02, .100894E-02, .100884E-02, .224569E+00,
     & .938046E-03, .694166E-01, .694166E-01, .178592E-02, .178609E-02,
     & .178609E-02, .178592E-02, .220745E+00, .172460E-02, .662414E-01,
     & .662414E-01, .240001E-02, .240024E-02, .240024E-02, .240001E-02,
     & .210839E+00, .234694E-02, .629511E-01, .629511E-01, .286144E-02,
     & .286171E-02, .286171E-02, .286144E-02, .196463E+00, .281556E-02,
     & .595849E-01, .595849E-01, .318412E-02, .318441E-02, .318441E-02,
     & .318412E-02, .179204E+00, .314448E-02, .561822E-01, .561822E-01,
     & .338573E-02, .338605E-02, .338605E-02, .338573E-02, .160420E+00,
     & .335151E-02, .527801E-01, .527801E-01, .348530E-02, .348562E-02,
     & .348562E-02, .348530E-02, .141254E+00, .345578E-02, .494117E-01,
     & .494117E-01, .350098E-02, .350131E-02, .350131E-02, .350098E-02,
     & .122547E+00, .347555E-02, .461061E-01, .461061E-01, .344994E-02,
     & .345026E-02, .345026E-02, .344994E-02, .104908E+00, .342804E-02,
     & .428876E-01, .428876E-01, .334753E-02, .334784E-02, .334784E-02,
     & .334753E-02, .887264E-01, .332868E-02, .397764E-01, .397764E-01,
     & .320718E-02, .320748E-02, .320748E-02, .320718E-02, .742160E-01/
      DATA (DL(K),K= 2976, 3060) /
     & .319097E-02, .367882E-01, .367882E-01, .304033E-02, .304062E-02,
     & .304062E-02, .304033E-02, .614556E-01, .302641E-02, .339348E-01,
     & .339348E-01, .285650E-02, .285677E-02, .285677E-02, .285650E-02,
     & .504214E-01, .284454E-02, .312247E-01, .312247E-01, .266337E-02,
     & .266363E-02, .266363E-02, .266337E-02, .410205E-01, .265311E-02,
     & .286629E-01, .286629E-01, .246705E-02, .246730E-02, .246730E-02,
     & .246705E-02, .331166E-01, .245826E-02, .262521E-01, .262521E-01,
     & .227226E-02, .227248E-02, .227248E-02, .227226E-02, .265498E-01,
     & .226473E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .741335E-01, .741335E-01, .409835E-04, .409835E-04, .409835E-04,
     & .409835E-04, .235495E+00,-.158395E-17, .705990E-01, .705990E-01,
     & .938808E-03, .938883E-03, .938883E-03, .938808E-03, .235413E+00,
     & .903728E-03, .669383E-01, .669383E-01, .166382E-02, .166395E-02/
      DATA (DL(K),K= 3061, 3145) /
     & .166395E-02, .166382E-02, .227523E+00, .163381E-02, .631853E-01,
     & .631853E-01, .221128E-02, .221145E-02, .221145E-02, .221128E-02,
     & .213316E+00, .218562E-02, .593855E-01, .593855E-01, .259911E-02,
     & .259931E-02, .259931E-02, .259911E-02, .194833E+00, .257720E-02,
     & .555825E-01, .555825E-01, .284819E-02, .284841E-02, .284841E-02,
     & .284819E-02, .174012E+00, .282950E-02, .518174E-01, .518174E-01,
     & .298117E-02, .298140E-02, .298140E-02, .298117E-02, .152385E+00,
     & .296523E-02, .481268E-01, .481268E-01, .302067E-02, .302090E-02,
     & .302090E-02, .302067E-02, .131168E+00, .300708E-02, .445413E-01,
     & .445413E-01, .298689E-02, .298712E-02, .298712E-02, .298689E-02,
     & .111177E+00, .297532E-02, .410859E-01, .410859E-01, .289793E-02,
     & .289815E-02, .289815E-02, .289793E-02, .929352E-01, .288809E-02,
     & .377798E-01, .377798E-01, .276920E-02, .276941E-02, .276941E-02,
     & .276920E-02, .767178E-01, .276084E-02, .346372E-01, .346372E-01,
     & .261353E-02, .261373E-02, .261373E-02, .261353E-02, .626102E-01,
     & .260643E-02, .316676E-01, .316676E-01, .244134E-02, .244154E-02,
     & .244154E-02, .244134E-02, .505665E-01, .243531E-02, .288765E-01/
      DATA (DL(K),K= 3146, 3230) /
     & .288765E-01, .226087E-02, .226105E-02, .226105E-02, .226087E-02,
     & .404527E-01, .225576E-02, .262660E-01, .262660E-01, .207845E-02,
     & .207862E-02, .207862E-02, .207845E-02, .320820E-01, .207412E-02,
     & .238351E-01, .238351E-01, .189881E-02, .189897E-02, .189897E-02,
     & .189881E-02, .252422E-01, .189514E-02, .215808E-01, .215808E-01,
     & .172536E-02, .172551E-02, .172551E-02, .172536E-02, .197186E-01,
     & .172225E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .720339E-01, .720339E-01, .181946E-04, .181946E-04, .181946E-04,
     & .181946E-04, .254393E+00, .469256E-18, .677768E-01, .677768E-01,
     & .875835E-03, .875888E-03, .875888E-03, .875835E-03, .249966E+00,
     & .860480E-03, .634725E-01, .634725E-01, .153792E-02, .153801E-02,
     & .153801E-02, .153792E-02, .236824E+00, .152496E-02, .591619E-01,
     & .591619E-01, .201036E-02, .201048E-02, .201048E-02, .201036E-02/
      DATA (DL(K),K= 3231, 3315) /
     & .217211E+00, .199944E-02, .548948E-01, .548948E-01, .231978E-02,
     & .231992E-02, .231992E-02, .231978E-02, .193739E+00, .231058E-02,
     & .507162E-01, .507162E-01, .249460E-02, .249475E-02, .249475E-02,
     & .249460E-02, .168773E+00, .248686E-02, .466653E-01, .466653E-01,
     & .256217E-02, .256232E-02, .256232E-02, .256217E-02, .144012E+00,
     & .255566E-02, .427744E-01, .427744E-01, .254804E-02, .254820E-02,
     & .254820E-02, .254804E-02, .120695E+00, .254258E-02, .390676E-01,
     & .390676E-01, .247365E-02, .247380E-02, .247380E-02, .247365E-02,
     & .995452E-01, .246906E-02, .355626E-01, .355626E-01, .235710E-02,
     & .235725E-02, .235725E-02, .235710E-02, .809281E-01, .235325E-02,
     & .322703E-01, .322703E-01, .221303E-02, .221317E-02, .221317E-02,
     & .221303E-02, .649429E-01, .220980E-02, .291963E-01, .291963E-01,
     & .205294E-02, .205307E-02, .205307E-02, .205294E-02, .515039E-01,
     & .205024E-02, .263419E-01, .263419E-01, .188569E-02, .188581E-02,
     & .188581E-02, .188569E-02, .404102E-01, .188343E-02, .237044E-01,
     & .237044E-01, .171783E-02, .171795E-02, .171795E-02, .171783E-02,
     & .313959E-01, .171594E-02, .212782E-01, .212782E-01, .155409E-02/
      DATA (DL(K),K= 3316, 3400) /
     & .155419E-02, .155419E-02, .155409E-02, .241750E-01, .155251E-02,
     & .190555E-01, .190555E-01, .139767E-02, .139777E-02, .139777E-02,
     & .139767E-02, .184646E-01, .139635E-02, .170270E-01, .170270E-01,
     & .125065E-02, .125074E-02, .125074E-02, .125065E-02, .139996E-01,
     & .124955E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .687547E-01, .687547E-01, .676181E-05, .676181E-05, .676181E-05,
     & .676181E-05, .280728E+00,-.145838E-17, .637529E-01, .637529E-01,
     & .808781E-03, .808818E-03, .808818E-03, .808781E-03, .270033E+00,
     & .803169E-03, .588180E-01, .588180E-01, .139388E-02, .139394E-02,
     & .139394E-02, .139388E-02, .249568E+00, .138922E-02, .539945E-01,
     & .539945E-01, .178168E-02, .178176E-02, .178176E-02, .178168E-02,
     & .222743E+00, .177782E-02, .493317E-01, .493317E-01, .200838E-02,
     & .200848E-02, .200848E-02, .200838E-02, .192919E+00, .200519E-02/
      DATA (DL(K),K= 3401, 3485) /
     & .448709E-01, .448709E-01, .211009E-02, .211019E-02, .211019E-02,
     & .211009E-02, .162975E+00, .210745E-02, .406433E-01, .406433E-01,
     & .211805E-02, .211815E-02, .211815E-02, .211805E-02, .134716E+00,
     & .211586E-02, .366716E-01, .366716E-01, .205957E-02, .205968E-02,
     & .205968E-02, .205957E-02, .109289E+00, .205776E-02, .329687E-01,
     & .329687E-01, .195606E-02, .195616E-02, .195616E-02, .195606E-02,
     & .871955E-01, .195457E-02, .295400E-01, .295400E-01, .182447E-02,
     & .182456E-02, .182456E-02, .182447E-02, .685399E-01, .182323E-02,
     & .263849E-01, .263849E-01, .167765E-02, .167774E-02, .167774E-02,
     & .167765E-02, .531615E-01, .167663E-02, .234975E-01, .234975E-01,
     & .152505E-02, .152514E-02, .152514E-02, .152505E-02, .407334E-01,
     & .152421E-02, .208683E-01, .208683E-01, .137342E-02, .137350E-02,
     & .137350E-02, .137342E-02, .308674E-01, .137273E-02, .184852E-01,
     & .184852E-01, .122732E-02, .122739E-02, .122739E-02, .122732E-02,
     & .231578E-01, .122675E-02, .163340E-01, .163340E-01, .108968E-02,
     & .108975E-02, .108975E-02, .108968E-02, .172149E-01, .108921E-02,
     & .143996E-01, .143996E-01, .962198E-03, .962260E-03, .962260E-03/
      DATA (DL(K),K= 3486, 3570) /
     & .962198E-03, .126908E-01, .961815E-03, .126661E-01, .126661E-01,
     & .845675E-03, .845732E-03, .845732E-03, .845675E-03, .928555E-02,
     & .845361E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .639050E-01, .639050E-01, .189600E-05, .189600E-05, .189600E-05,
     & .189600E-05, .320203E+00, .545701E-18, .581555E-01, .581555E-01,
     & .725861E-03, .725886E-03, .725886E-03, .725861E-03, .299305E+00,
     & .724320E-03, .526376E-01, .526376E-01, .121568E-02, .121572E-02,
     & .121572E-02, .121568E-02, .267591E+00, .121442E-02, .473911E-01,
     & .473911E-01, .150820E-02, .150825E-02, .150825E-02, .150820E-02,
     & .230364E+00, .150718E-02, .424558E-01, .424558E-01, .164949E-02,
     & .164955E-02, .164955E-02, .164949E-02, .191972E+00, .164867E-02,
     & .378600E-01, .378600E-01, .168256E-02, .168262E-02, .168262E-02,
     & .168256E-02, .155818E+00, .168189E-02, .336181E-01, .336181E-01/
      DATA (DL(K),K= 3571, 3655) /
     & .164080E-02, .164086E-02, .164086E-02, .164080E-02, .123609E+00,
     & .164026E-02, .297349E-01, .297349E-01, .155136E-02, .155142E-02,
     & .155142E-02, .155136E-02, .961680E-01, .155092E-02, .262052E-01,
     & .262052E-01, .143382E-02, .143388E-02, .143388E-02, .143382E-02,
     & .735522E-01, .143346E-02, .230171E-01, .230171E-01, .130247E-02,
     & .130253E-02, .130253E-02, .130247E-02, .553916E-01, .130218E-02,
     & .201539E-01, .201539E-01, .116733E-02, .116739E-02, .116739E-02,
     & .116733E-02, .411453E-01, .116710E-02, .175955E-01, .175955E-01,
     & .103505E-02, .103510E-02, .103510E-02, .103505E-02, .301858E-01,
     & .103486E-02, .153199E-01, .153199E-01, .909828E-03, .909880E-03,
     & .909880E-03, .909828E-03, .218957E-01, .909677E-03, .133043E-01,
     & .133043E-01, .794097E-03, .794146E-03, .794146E-03, .794097E-03,
     & .157204E-01, .793976E-03, .115259E-01, .115259E-01, .689012E-03,
     & .689057E-03, .689057E-03, .689012E-03, .111816E-01, .688913E-03,
     & .996208E-02, .996208E-02, .594880E-03, .594922E-03, .594922E-03,
     & .594880E-03, .788559E-02, .594801E-03, .859151E-02, .859151E-02,
     & .511455E-03, .511493E-03, .511493E-03, .511455E-03, .551865E-02/
      DATA (DL(K),K= 3656, 3740) /
     & .511392E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .567030E-01, .567030E-01, .317692E-06, .317692E-06, .317692E-06,
     & .317692E-06, .387655E+00,-.196551E-18, .502560E-01, .502560E-01,
     & .611827E-03, .611838E-03, .611838E-03, .611827E-03, .346975E+00,
     & .611576E-03, .442838E-01, .442838E-01, .981907E-03, .981929E-03,
     & .981929E-03, .981907E-03, .295290E+00, .981708E-03, .388018E-01,
     & .388018E-01, .116826E-02, .116829E-02, .116829E-02, .116826E-02,
     & .241157E+00, .116810E-02, .338227E-01, .338227E-01, .122537E-02,
     & .122541E-02, .122541E-02, .122537E-02, .190062E+00, .122525E-02,
     & .293442E-01, .293442E-01, .120047E-02, .120052E-02, .120052E-02,
     & .120047E-02, .145706E+00, .120037E-02, .253494E-01, .253494E-01,
     & .112580E-02, .112585E-02, .112585E-02, .112580E-02, .109110E+00,
     & .112572E-02, .218132E-01, .218132E-01, .102498E-02, .102503E-02/
      DATA (DL(K),K= 3741, 3825) /
     & .102503E-02, .102498E-02, .800661E-01, .102492E-02, .187030E-01,
     & .187030E-01, .913395E-03, .913450E-03, .913450E-03, .913395E-03,
     & .577342E-01, .913348E-03, .159833E-01, .159833E-01, .800935E-03,
     & .800990E-03, .800990E-03, .800935E-03, .409782E-01, .800898E-03,
     & .136172E-01, .136172E-01, .693698E-03, .693751E-03, .693751E-03,
     & .693698E-03, .286780E-01, .693669E-03, .115681E-01, .115681E-01,
     & .595013E-03, .595064E-03, .595064E-03, .595013E-03, .198197E-01,
     & .594990E-03, .980105E-02, .980105E-02, .506423E-03, .506471E-03,
     & .506471E-03, .506423E-03, .135410E-01, .506405E-03, .828286E-02,
     & .828286E-02, .428323E-03, .428368E-03, .428368E-03, .428323E-03,
     & .915498E-02, .428309E-03, .698303E-02, .698303E-02, .360397E-03,
     & .360439E-03, .360439E-03, .360397E-03, .613133E-02, .360386E-03,
     & .587373E-02, .587373E-02, .301934E-03, .301973E-03, .301973E-03,
     & .301934E-03, .407092E-02, .301925E-03, .492985E-02, .492985E-02,
     & .252029E-03, .252064E-03, .252064E-03, .252029E-03, .268179E-02,
     & .252022E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
      DATA (DL(K),K= 3826, 3910) /
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .450567E-01, .450567E-01, .151200E-07, .151200E-07, .151200E-07,
     & .151200E-07, .542258E+00,-.767310E-18, .381624E-01, .381624E-01,
     & .438685E-03, .438751E-03, .438751E-03, .438685E-03, .447480E+00,
     & .438674E-03, .321250E-01, .321250E-01, .653465E-03, .653574E-03,
     & .653574E-03, .653465E-03, .347952E+00, .653456E-03, .268827E-01,
     & .268827E-01, .724735E-03, .724868E-03, .724868E-03, .724735E-03,
     & .258636E+00, .724728E-03, .223751E-01, .223751E-01, .709421E-03,
     & .709567E-03, .709567E-03, .709421E-03, .185088E+00, .709417E-03,
     & .185359E-01, .185359E-01, .650478E-03, .650626E-03, .650626E-03,
     & .650478E-03, .128686E+00, .650474E-03, .152906E-01, .152906E-01,
     & .572423E-03, .572567E-03, .572567E-03, .572423E-03, .873875E-01,
     & .572420E-03, .125654E-01, .125654E-01, .490165E-03, .490302E-03,
     & .490302E-03, .490165E-03, .581141E-01, .490163E-03, .102901E-01,
     & .102901E-01, .411740E-03, .411866E-03, .411866E-03, .411740E-03/
      DATA (DL(K),K= 3911, 3995) /
     & .379596E-01, .411738E-03, .839975E-02, .839975E-02, .340986E-03,
     & .341101E-03, .341101E-03, .340986E-03, .244073E-01, .340985E-03,
     & .683634E-02, .683634E-02, .279417E-03, .279520E-03, .279520E-03,
     & .279417E-03, .154717E-01, .279416E-03, .554846E-02, .554846E-02,
     & .227114E-03, .227204E-03, .227204E-03, .227114E-03, .968450E-02,
     & .227113E-03, .449143E-02, .449143E-02, .183425E-03, .183504E-03,
     & .183504E-03, .183425E-03, .599306E-02, .183425E-03, .362676E-02,
     & .362676E-02, .147387E-03, .147455E-03, .147455E-03, .147387E-03,
     & .366977E-02, .147387E-03, .292164E-02, .292164E-02, .117936E-03,
     & .117995E-03, .117995E-03, .117936E-03, .222583E-02, .117936E-03,
     & .234830E-02, .234830E-02, .940414E-04, .940914E-04, .940914E-04,
     & .940414E-04, .133844E-02, .940412E-04, .188339E-02, .188339E-02,
     & .747651E-04, .748074E-04, .748074E-04, .747651E-04, .798451E-03,
     & .747649E-04, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
      DATA (DL(K),K= 3996, 4000) /
     & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/

      DO 10 I=1,7
        QQ(I) = 0.
 10   CONTINUE
      IF(X.GT.0.9985) RETURN

      IS = S/DELTA+1
      IS = MIN(IS,19)
      IS1 = IS+1
      DO 20 I=1,7
        IF(I.EQ.3.AND.X.GT.0.95) GOTO 19
        IF(I.EQ.8.AND.X.GT.0.95) GOTO 19
        DO 30 L=1,25
          F1(L)=GF(I,IS,L)
          F2(L)=GF(I,IS1,L)
 30     CONTINUE
        S1=(IS-1)*DELTA
        S2=S1+DELTA
        A1 = PHO_CKMTFV(X,F1)
        A2 = PHO_CKMTFV(X,F2)
        QQ(I)=A1*(S2-S)/DELTA+A2*(S-S1)/DELTA
 19     CONTINUE
 20   CONTINUE

      END


 
 


CDECK  ID>, PHO_CONN0
      DOUBLE PRECISION FUNCTION PHO_CONN0(BETA)
C***********************************************************************
C
C    auxiliary function to determine parameters of soft
C    pt distribution  dNs/dP_t = P_t * AAS * EXP(-BETA*P_t**2)
C
C    internal factors: FS  number of soft partons in soft Pomeron
C                      FH  number of soft partons in hard Pomeron
C
C***********************************************************************

      IMPLICIT NONE

      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  average number of cut soft and hard ladders (obsolete)
      DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
      COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN

C  data needed for soft-pt calculation
      DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
      COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON

      DOUBLE PRECISION BETA,XX,FF

      XX = BETA*PTCON**2
      IF(ABS(XX).LT.1.D-3) THEN
        FF = FS*SIGS+FH*SIGH
     &       - DSIGHP*(PTCON/2.D0+PTCON**3*BETA/4.D0)
      ELSE
        FF = FS*SIGS+FH*SIGH
     &       - DSIGHP/(2.D0*PTCON*BETA)*(EXP(XX)-1.D0)
      ENDIF
      PHO_CONN0 = FF

*     WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:BETA,AAS,FF',BETA,AAS,FF
*     WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP

      END


 
 


CDECK  ID>, PHO_CONN1
      DOUBLE PRECISION FUNCTION PHO_CONN1(BETA)
C***********************************************************************
C
C    auxiliary function to determine parameters of soft
C    pt distribution  dNs/dP_t = P_t * AAS * EXP(-BETA*P_t)
C
C    internal factors: FS  number of soft partons in soft Pomeron
C                      FH  number of soft partons in hard Pomeron
C
C***********************************************************************

      IMPLICIT NONE

      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  average number of cut soft and hard ladders (obsolete)
      DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
      COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN

C  data needed for soft-pt calculation
      DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
      COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON

      DOUBLE PRECISION BETA,XX,FF

      XX = BETA*PTCON
      IF(ABS(XX).LT.1.D-3) THEN
        FF = FS*SIGS+FH*SIGH
     &       - DSIGHP*(PTCON/2.D0+PTCON**2*BETA/6.D0)
      ELSE
        FF = FS*SIGS+FH*SIGH
     &       - DSIGHP/(PTCON*BETA**2)*(EXP(XX)-1.D0-BETA*PTCON)
      ENDIF
      PHO_CONN1 = FF

*     WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:BETA,AAS,FF',BETA,AAS,FF
*     WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP

      END


 
 


CDECK  ID>, pho_cpcini
      SUBROUTINE PHO_CPCINI(Nrows,Number,List)
C***********************************************************************
C
C     initialization of particle hash table
C
C     input:   Number     vector with Nrows entries according to PDG
C                         convention
C
C     output:  List       vector with hash table
C
C     (this code is based on the function initpns written by
C      Gerry Lynch, LBL, January 1990)
C
C***********************************************************************

      IMPLICIT NONE

      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

      INTEGER Number(*),List(*),Nrows

      INTEGER Nin,Nout,Ip,I

      do I = 1,577
        List(I) = 0
      enddo

C    Loop over all of the elements in the Number vector

        Do 500 Ip = 1,Nrows
            Nin = Number(Ip)

C    Calculate a list number for this particle id number
            If(Nin.Gt.99999.or.Nin.Le.0) Then
                 Nout = -1
            Else If(Nin.Le.577) Then
                 Nout = Nin
            Else
                 Nout = Mod(Nin,577)

            End If
 200        continue

            If(Nout.Lt.0) Then
C    Count the bad entries
                IF (LPRI.GT.4)
     &          WRITE(LO,'(1x,a,i10)')
     &            'PHO_CPCINI: invalid particle ID',Nin
                Go to 500
            End If
            If(List(Nout).eq.0) Then
                List(Nout) = Ip
            Else
                If(Nin.eq.Number(List(Nout))) Then
                  IF (LPRI.GT.4)
     &            WRITE(LO,'(1x,a,i10)')
     &              'PHO_CPCINI: double particle ID',Nin
                End If
                Nout = Nout + 5
                If(Nout.Gt.577) Nout = Mod(Nout, 577)

                Go to 200
            End If
 500      Continue

      END


 
 


CDECK  ID>, PHO_CSDIFF
      SUBROUTINE PHO_CSDIFF(Id1,Id2,SS,Xi_min,Xi_max,
     &  sig_sd1,sig_sd2,sig_dd)
C***********************************************************************
C
C     cross section for diffraction dissociation according to
C     Goulianos' parametrization (Ref: PL B358 (1995) 379)
C
C     in addition rescaling for different particles is applied using
C     internal rescaling tables (not implemented yet)
C
C     input:     Id1/2       PDG ID's of incoming particles
C                SS          squared c.m. energy (GeV**2)
C                Xi_min      min. diff mass (squared) = Xi_min*SS
C                Xi_max      max. diff mass (squared) = Xi_max*SS
C
C     output:    sig_sd1     cross section for diss. of particle 1 (mb)
C                sig_sd2     cross section for diss. of particle 2 (mb)
C                sig_dd      cross section for diss. of both particles
C
C***********************************************************************

      IMPLICIT NONE

      SAVE

      INTEGER Id1,Id2
      DOUBLE PRECISION SS,Xi_min,Xi_max,sig_sd1,sig_sd2,sig_dd

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

      DOUBLE PRECISION xpos1(96),xwgh1(96),xpos2(96),xwgh2(96)
      DOUBLE PRECISION delta,alphap,beta0,gpom0,xm_p,x_rad2,xm4_p2,
     &  fac,tt,t1,t2,tl,tu,Xnorm,xi,xil,xiu,w_xi,alpha_t,f2_t,
     &  xms_1,xms_2,CSdiff

      INTEGER Ngau1,Ngau2,i1,i2

C  model parameters
      DATA delta    / 0.104d0 /
      DATA alphap   / 0.25d0 /
      DATA beta0    / 6.56d0 /
      DATA gpom0    / 1.21d0 /
      DATA xm_p     / 0.938d0 /
      DATA x_rad2   / 0.71d0 /

C  integration precision
      DATA Ngau1    / 96 /
      DATA Ngau2    / 96 /

      sig_sd1 = 0.d0
      sig_sd2 = 0.d0
      sig_dd  = 0.d0

      IF ((ABS(id1).EQ.2212).AND.(ABS(id2).EQ.2212)) THEN

        xm4_p2 = 4.D0*xm_p**2
        fac = beta0**2/(16.D0*PI)

        t1 = -5.D0
        t2 = 0.D0
        tl = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
        tu = x_rad2/3.D0/(1.D0-t2/x_rad2)**3

C  flux renormalization and cross section

        Xnorm  = 0.d0

        xil = log(1.5d0/SS)
        xiu = log(0.1d0)

        IF(xiu.LE.xil) goto 1000

        CALL PHO_GAUSET(xil,xiu,Ngau1,xpos1,xwgh1)
        CALL PHO_GAUSET(tl,tu,Ngau2,xpos2,xwgh2)

        do i1=1,Ngau1

          xi = exp(xpos1(i1))
          w_xi = Xwgh1(i1)

          do i2=1,Ngau2

            tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)

            alpha_t =  1.D0+delta+alphap*tt
            f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2

            Xnorm = Xnorm
     &        + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi

          enddo
        enddo

        Xnorm = Xnorm*fac

 1000   continue

        XIL = LOG(Xi_min)
        XIU = LOG(Xi_max)

        T1 = -5.D0
        T2 = 0.D0

        TL = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
        TU = x_rad2/3.D0/(1.D0-t2/x_rad2)**3

C  single diffraction diss. cross section

        CSdiff = 0.d0

        IF(XIU.LE.XIL) goto 2000

        CALL PHO_GAUSET(XIL,XIU,NGAU1,XPOS1,XWGH1)
        CALL PHO_GAUSET(TL,TU,NGAU2,XPOS2,XWGH2)

        do i1=1,Ngau1

          xi = exp(xpos1(i1))
          w_xi = Xwgh1(i1)*beta0*gpom0*(xi*ss)**delta

          do i2=1,Ngau2

            tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)

            alpha_t =  1.D0+delta+alphap*tt
            f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2

            CSdiff = CSdiff
     &        + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi

          enddo
        enddo

        CSdiff = CSdiff*fac*GEV2MB/MAX(1.d0,Xnorm)

*       WRITE(LO,'(1x,1p,4e14.3)')
*    &    sqrt(SS),Xnorm,2.*CSdiff*MAX(1.d0,Xnorm),2.*CSdiff

        sig_sd1 = CSdiff
        sig_sd2 = CSdiff

 2000   continue

C  double diffraction dissociation cross section

        CSdiff = 0.d0

        xil = log(1.5d0/SS)
        xiu = log(Xi_max/1.5d0)

        IF(xiu.LE.xil) goto 3000

        fac = (beta0*gpom0*SS**delta
     &         /(4.d0*sqrt(PI)*MAX(1.d0,Xnorm)))**2
     &       /(2.d0*alphap)

        CALL PHO_GAUSET(xil,xiu,ngau1,xpos1,xwgh1)

        do i1=1,Ngau1

          xi = exp(xpos1(i1))
          xms_1 = xi*SS

          xiu = log(Xi_max/(xi*SS))

          if(xil.lt.xiu) then

            CALL PHO_GAUSET(xil,xiu,Ngau2,xpos2,xwgh2)

            do i2=1,Ngau2

              xms_2 = exp(xpos2(i2))*SS
              CSdiff = CSdiff
     &          + 1.d0/((xms_1*xms_2)**delta*log(SS/(xms_1*xms_2)))
     &            *xwgh1(i1)*xwgh2(i2)

            enddo

          endif

        enddo

        sig_dd = CSdiff*fac*GEV2MB

 3000   continue

      ELSE

        IF (LPRI.GT.4)
     &  WRITE(LO,'(1x,2a,2I8)') 'PHO_CSDIFF: ',
     &    'invalid particle combination (Id1/2)',Id1,Id2

      ENDIF

      END


 
 


CDECK  ID>, PHO_CSINT
      SUBROUTINE PHO_CSINT(IP,IFPA,IFPB,IHLA,IHLB,ECM,PVIR2A,PVIR2B)
C********************************************************************
C
C     calculate cross sections by interpolation
C
C     input:   IP          particle combination
C              IFPA/B      particle PDG number
C              IHLA/B      particle helicity (photons only)
C              ECM         c.m. energy (GeV)
C              PVIR2A      virtuality of particle A (GeV**2, positive)
C              PVIR2B      virtuality of particle B (GeV**2, positive)
C
C     output:  cross sections stored in /POCSEC/
C
C********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( EPS    =  1.D-5,
     &            DEPS   =  1.D-15 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  current beam selection
      INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN
      INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL
      DOUBLE PRECISION SQSGLOBMAX
      PARAMETER (MPARMAX=40)
      PARAMETER (MAXMAPPS=40)
      PARAMETER (IKNOWN=9)
      DIMENSION IPAVAIL(IKNOWN)
      DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/
      COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS),
     &           MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  energy-interpolation table
      INTEGER IEETA2
      PARAMETER ( IEETA2 = 20 )
      INTEGER ISIMAX
      DOUBLE PRECISION SIGTAB,SIGECM, ECMF
      COMMON /POTABL/ SIGTAB(80, IEETA2, 4, MPARMAX),
     &                SIGECM(IEETA2, 4, MPARMAX), ECMF(4, MPARMAX),
     &                ISIMAX(MPARMAX)

C  cross sections
      INTEGER IPFIL,IFAFIL,IFBFIL
      DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
     &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
     &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
     &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
     &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
      COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
     &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
     &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
     &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
     &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
     &                IPFIL,IFAFIL,IFBFIL

C  hard cross sections and MC selection weights
      INTEGER Max_pro_2
      PARAMETER ( Max_pro_2 = 16 )
      INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
     &  MH_acc_1,MH_acc_2
      DOUBLE PRECISION HFAC, HWGX, HSIG, HDPT, HECM_LAST, 
     &   HQ2A_LAST, HQ2B_LAST
      COMMON /POHRCS/HFAC(-1:MAX_PRO_2, MPARMAX), 
     &   HWGX(-1:MAX_PRO_2, MPARMAX),
     &   HSIG(-1:MAX_PRO_2, MPARMAX), HDPT(-1:MAX_PRO_2, MPARMAX), 
     &   HECM_LAST, HQ2A_LAST, HQ2B_LAST, IHA_LAST, IHB_LAST, 
     &   MH_PRO_ON(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_TRIED(-1:MAX_PRO_2, 0:4, MPARMAX), 
     &   MH_ACC_1(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_ACC_2(-1:MAX_PRO_2, 0:4, MPARMAX) 

C  obsolete cut-off information
      DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
      COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
      
      DIMENSION PVIRT(2),SIGSRH(2),FSUT(2),FSUL(2),ILPAP(2),IHEL(2)

      DIMENSION PD(-6:6),FH_T(2),FH_L(2) 
      DOUBLE PRECISION PHO_PTCUT
      EXTERNAL         PHO_PTCUT
      DATA IPCOMB / 0 /

C  debug
      IF (LPRI.GT.4 .AND. IDEB(15).GE.10)
     &WRITE(LO,'(1X,A,/10X,I3,2I6,1P3E12.4)')
     &  'PHO_CSINT: called with IP, IFP1, IFP2, ECM, PVIR1, PVIR2',
     &  IP,IFPA,IFPB,ECM,PVIR2A,PVIR2B
C**anfe Initialize the ptcut common block information
      ptcut(ip) = PHO_PTCUT(ecm, ip)
C  check currently stored cross sections
      IF((IP.EQ.IPFIL).AND.(ECM.EQ.ECMFIL)
     &   .AND.(PVIR2A.EQ.P2AFIL).AND.(PVIR2B.EQ.P2BFIL)
     &   .AND.(IFPA.EQ.IFAFIL).AND.(IFPB.EQ.IFBFIL).AND.
     &   (IPCOMB==IDXMPAR)) THEN
C  nothing to calculate
        IF(IDEB(15).GE.20 .AND. LPRI.GT.4)
     &    WRITE(LO,'(1X,A)') 'PHO_CSINT: nothing done'
        RETURN
      ELSE

C  copy to local fields
        ILPAP(1) = IFPA
        ILPAP(2) = IFPB
        IHEL(1)  = IHLA
        IHEL(2)  = IHLB
        PVIRT(1) = PVIR2A
        PVIRT(2) = PVIR2B
C  load cross sections from interpolation table
        IF(ECM.LE.SIGECM(1,IP,IDXMPAR)) THEN
          I1 = 1
          I2 = 2
        ELSE IF(ECM.LE.SIGECM(ISIMAX(IDXMPAR),IP,IDXMPAR)) THEN
          DO 50 I=2,ISIMAX(IDXMPAR)
            IF(ECM.LE.SIGECM(I,IP,IDXMPAR)) GOTO 200
 50       CONTINUE
 200      CONTINUE
          I1 = I-1
          I2 = I
        ELSE
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,2E12.3)')
     &      'PHO_CSINT: too high energy',ECM,
     &      SIGECM(ISIMAX(IDXMPAR),IP,IDXMPAR)
          CALL PHO_PREVNT(-1)
          I1 = ISIMAX(IDXMPAR)-1
          I2 = ISIMAX(IDXMPAR)
        ENDIF
        FAC2=0.D0
        IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(I1,IP,IDXMPAR))
     &                    /LOG(SIGECM(I2,IP,IDXMPAR)/
     &                    SIGECM(I1,IP,IDXMPAR))
        FAC1=1.D0-FAC2

C  cross section dependence on photon virtualities
        DO 140 K=1,2
          FSUP(K) = 1.D0
          FSUD(K) = 1.D0
          FSUH(K) = 1.D0
          IF(ILPAP(K).EQ.22) THEN
            IF(ISWMDL(10).GE.1) THEN
              FSUP(K) = 0.D0
              FSUT(K) = 0.D0
              FSUL(K) = 0.D0
              FSUH(K) = 0.D0
C  GVDM factors for transverse/longitudinal photons
              DO 150 I=1,3
                FSUT(K) = FSUT(K)+PARMDL(26+I)
     &                   /(1.D0+PVIRT(K)/PARMDL(30+I))**2
                FSUL(K) = FSUL(K)
     &                   +PARMDL(26+I)*PVIRT(K)/(4.D0*PARMDL(30+I))
     &                   /(1.D0+PVIRT(K)/PARMDL(30+I))**2
 150          CONTINUE
              FSUT(K) = FSUT(K)+PARMDL(30)/(1.D0+PVIRT(K)/PARMDL(34))
C  transverse part
              IF((ABS(IHEL(K)).EQ.1).OR.(ISWMDL(10).EQ.1)) THEN
                FSUP(K) = FSUT(K)
                FSUH(K) = FSUT(K)/(FSUT(K)+FSUL(K))
C  diffraction of trans. photons corresponds mainly to leading twist
                FSUD(K) = 1.D0
              ENDIF
C  longitudinal (scalar) part
              IF((IHEL(K).LE.0).OR.(ISWMDL(10).EQ.1)) THEN
                FSUP(K) = FSUP(K)+FSUL(K)
                FSUH(K) = FSUH(K)+FSUL(K)/(FSUT(K)+FSUL(K))
C  diffraction of long. photons corresponds mainly to higher twist
                FSUD(K) = 0.5D0*LOG(((ECM*PARMDL(45))**2+PVIRT(K))
     &                   /((0.765D0+PARMDL(46))**2+PVIRT(K)))
     &                   /LOG(ECM*PARMDL(45)/(0.765D0+PARMDL(46)))
              ENDIF
C  debug output
              if(ideb(15).ge.10) then
                IF (LPRI.GT.4)
     &          WRITE(LO,'(1x,2a,2i3,/,5x,1p5e12.4)') 'PHO_CSINT: ',
     &            'side,helicity,F_tran,F_long,F_eff,F_hard,F_diff',
     &            K,IHEL(K),FSUT(K),FSUL(K),FSUP(K),FSUH(K),FSUD(K)
              endif
            ENDIF
          ENDIF
 140    CONTINUE

        FACP = FSUP(1)*FSUP(2)
        FACH = FSUH(1)*FSUH(2)
        FACD = FSUD(1)*FSUD(2)

C  matching of model cross section to F2(x,Q2,P2) in limit of Q2 >> P2

        if((ILPAP(1).eq.22).and.(ILPAP(2).eq.22)
     &     .and.(IPAMDL(117).gt.0)) then
C  check kinematic limit
          Q2_max = max(PVIRT(1),PVIRT(2))
          Q2_min = min(PVIRT(1),PVIRT(2))
          if((Q2_max.gt.1.D0).and.(Q2_min.lt.1.D0)) then

C  calculate F2 from current parton density
            if(PVIRT(1).gt.PVIRT(2)) then
              K = 2
            else
              K = 1
            endif
            Q2 = Q2_max
            P2 = Q2_min
            X = Q2/(ECM**2+Q2+P2)
            CALL PHO_ACTPDF(ILPAP(K),K)
            CALL PHO_PDF(K,X,Q2,P2,PD)
C  light quark contribution
            F2_light = 0.D0
            do j=1,3
              F2_light = F2_light+Q_ch2(j)*(PD(j)+PD(-j))
            enddo
C  heavy quark contribution
            CALL PHO_QPMPDF(4,X,Q2,0.D0,P2,xpdf_c)
            F2_c = 2.D0*4.D0/9.D0*xpdf_c
            F2 = (F2_light+F2_c)

C  calculate model prediction
            SIGTOT = FAC2*SIGTAB(1,I2,IP,IDXMPAR)+
     &               FAC1*SIGTAB(1,I1,IP,IDXMPAR)
            SIGINE = FAC2*SIGTAB(28,I2,IP,IDXMPAR)+
     &               FAC1*SIGTAB(28,I1,IP,IDXMPAR)
            CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)

            if(ISWMDL(10).ge.2) then

C  calculate all helicity combinations
              if(IPAMDL(115).eq.0) then
                SIGDIH    = HSig(14,IDXMPAR)
                SIGSRH(1) = HSig(10,IDXMPAR)+HSig(11,IDXMPAR)
                SIGSRH(2) = HSig(12,IDXMPAR)+HSig(13,IDXMPAR)
                SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
C  photon helicity factors
                FH_T(1) = FSUT(1)/(FSUT(1)+FSUL(1))
                FH_L(1) = 1.D0-FH_T(1)
                FH_T(2) = FSUT(2)/(FSUT(2)+FSUL(2))
                FH_L(2) = 1.D0-FH_T(2)
                SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
     &                  + SIGDIH*FH_T(1)*FH_T(2)
     &                  + SIGSRH(1)*FH_T(1)*FSUT(2)
     &                  + SIGSRH(2)*FSUT(1)*FH_T(2)
                SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
     &                  + SIGDIH*FH_T(1)*FH_L(2)
     &                  + SIGSRH(1)*FH_T(1)*FSUL(2)
     &                  + SIGSRH(2)*FSUT(1)*FH_L(2)
                SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
     &                  + SIGDIH*FH_L(1)*FH_T(2)
     &                  + SIGSRH(1)*FH_L(1)*FSUT(2)
     &                  + SIGSRH(2)*FSUL(1)*FH_T(2)
                SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
     &                  + SIGDIH*FH_L(1)*FH_L(2)
     &                  + SIGSRH(1)*FH_L(1)*FSUL(2)
     &                  + SIGSRH(2)*FSUL(1)*FH_L(2)
              else
C  use explicit PDF virtuality dependence (pre-tabulated)
                SIGDIH    = HSig(14,IDXMPAR)
                SIGSRH(1) = HSig(10,IDXMPAR)+HSig(11,IDXMPAR)
                SIGSRH(2) = HSig(12,IDXMPAR)+HSig(13,IDXMPAR)
                SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
                IF (LPRI.GT.4)
     &          WRITE(LO,*)' PHO_CSINT: invalid option for F2 matching'
                stop
*               CALL PHO_HARINT(IP,ECM,PVIRT(1),PVIRT(2),0,
*    &                          Max_pro_2,3,4,1)
*               SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
*    &            + HSig(10,IDXMPAR)+HSig(12,IDXMPAR)+
*    &            +HSig(14,IDXMPAR)+HSig(16,IDXMPAR)+HSig(18,IDXMPAR)
*               SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
*    &            + HSig(10,IDXMPAR)+HSig(12,IDXMPAR)+
*    &            + HSig(14,IDXMPAR)+HSig(16,IDXMPAR)+HSig(19,IDXMPAR)
*               SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
*    &            + HSig(11,IDXMPAR)+HSig(13,IDXMPAR)+
*    &            + HSig(15,IDXMPAR)+HSig(17,IDXMPAR)+HSig(20,IDXMPAR)
*               SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
*    &            + HSig(11,IDXMPAR)+HSig(13,IDXMPAR)+
*    &            + HSig(15,IDXMPAR)+HSig(17,IDXMPAR)+HSig(21,IDXMPAR)
              endif
              Xnu = Ecm*Ecm+Q2+P2
              F2_fac = Q2*Xnu/sqrt(Xnu*Xnu-Q2*P2)/(4.D0*Pi*Pi)
     &             *137.D0/GeV2mb
              if(K.eq.2) then
                F2m = F2_fac*(SIG_TT+SIG_LT-0.5D0*SIG_TL-0.5D0*SIG_LL)
                F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUL(1)*FSUT(2)
     &               -0.5D0*FSUT(1)*FSUL(2)-0.5D0*FSUL(1)*FSUL(2))
              else
                F2m = F2_fac*(SIG_TT+SIG_TL-0.5D0*SIG_LT-0.5D0*SIG_LL)
                F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUT(1)*FSUL(2)
     &               -0.5D0*FSUL(1)*FSUT(2)-0.5D0*FSUL(1)*FSUL(2))
              endif

            else

C  assume sig_eff = sigtot
              SIGDIH    = HSig(14,IDXMPAR)
              SIGSRH(1) = HSig(10,IDXMPAR)+HSig(11,IDXMPAR)
              SIGSRH(2) = HSig(12,IDXMPAR)+HSig(13,IDXMPAR)
              SIGtmp = SIGTOT-SIGSRH(1)-SIGSRH(2)-SIGDIH
              SIGeff = SIGtmp*FSUP(1)*FSUP(2)
     &                +SIGSRH(1)*FSUP(2)+SIGSRH(2)*FSUP(1)+SIGDIH
              Xnu = Ecm*Ecm+Q2+P2
              F2_fac = Q2*Xnu/sqrt(Xnu*Xnu-Q2*P2)/(4.D0*Pi*Pi)
     &             *137.D0/GeV2mb
              F2m = F2_fac*SIGeff
              F2s = F2_fac*SIGtmp*FSUP(1)*FSUP(2)
            endif
*           WRITE(LO,*)' PHO_CSINT: Q2_1,Q2_2,W ',PVIRT(1),PVIRT(2),Ecm
*           WRITE(LO,*)' PHO_CSINT: F2_mod,F2_pdf,mod/pdf ',
*    &                    F2m,F2,F2m/F2

C  global factor to re-scale suppression of soft contributions
            Fcorr = (F2-F2m+F2s)/F2s
*          WRITE(LO,*)' PHO_CSINT: re-scaling factor: ',Fcorr,FACP*Fcorr
            FACP = FACP*Fcorr

          endif
        endif

        SIGTOT = (FAC2*SIGTAB(1,I2,IP,IDXMPAR)+
     &            FAC1*SIGTAB(1,I1,IP,IDXMPAR))*FACP
        SIGINE = (FAC2*SIGTAB(28,I2,IP,IDXMPAR)+
     &            FAC1*SIGTAB(28,I1,IP,IDXMPAR))*FACP
        SIGELA = (FAC2*SIGTAB(2,I2,IP,IDXMPAR)+
     &            FAC1*SIGTAB(2,I1,IP,IDXMPAR))*FACP
        J = 2
        DO 5 I=0,4
          DO 6 K=0,4
            J = J+1
            SIGVM(I,K) = (FAC2*SIGTAB(J,I2,IP,IDXMPAR)+
     &                    FAC1*SIGTAB(J,I1,IP,IDXMPAR))*FACP**2
 6        CONTINUE
 5      CONTINUE

        SIGDIR = FAC2*SIGTAB(29,I2,IP,IDXMPAR)+
     &           FAC1*SIGTAB(29,I1,IP,IDXMPAR)
        SIGHAR = FAC2*SIGTAB(58,I2,IP,IDXMPAR)+
     &           FAC1*SIGTAB(58,I1,IP,IDXMPAR)
C  suppression of multi-pomeron graphs (diffraction)
        SIGLSD(1) = (FAC2*SIGTAB(30,I2,IP,IDXMPAR)+
     &               FAC1*SIGTAB(30,I1,IP,IDXMPAR))*FACP*FSUP(2)*FSUD(1)
        SIGLSD(2) = (FAC2*SIGTAB(31,I2,IP,IDXMPAR)+
     &               FAC1*SIGTAB(31,I1,IP,IDXMPAR))*FACP*FSUP(1)*FSUD(2)
        SIGHSD(1) = (FAC2*SIGTAB(32,I2,IP,IDXMPAR)+
     &               FAC1*SIGTAB(32,I1,IP,IDXMPAR))*FACP*FSUP(2)*FSUD(1)
        SIGHSD(2) = (FAC2*SIGTAB(33,I2,IP,IDXMPAR)+
     &               FAC1*SIGTAB(33,I1,IP,IDXMPAR))*FACP*FSUP(1)*FSUD(2)
        SIGLDD    = (FAC2*SIGTAB(34,I2,IP,IDXMPAR)+
     &               FAC1*SIGTAB(34,I1,IP,IDXMPAR))*FACP**2*FACD
        SIGHDD    = (FAC2*SIGTAB(35,I2,IP,IDXMPAR)+
     &               FAC1*SIGTAB(35,I1,IP,IDXMPAR))*FACP
        SIGCDF(0) = (FAC2*SIGTAB(36,I2,IP,IDXMPAR)+
     &               FAC1*SIGTAB(36,I1,IP,IDXMPAR))*FACP**2
        SIGTR1(1) = (FAC2*SIGTAB(60,I2,IP,IDXMPAR)+
     &               FAC1*SIGTAB(60,I1,IP,IDXMPAR))*FACP*FSUP(2)*FSUD(1)
        SIGTR1(2) = (FAC2*SIGTAB(61,I2,IP,IDXMPAR)+
     &               FAC1*SIGTAB(61,I1,IP,IDXMPAR))*FACP*FSUP(2)*FSUD(1)
        SIGTR2(1) = (FAC2*SIGTAB(62,I2,IP,IDXMPAR)+
     &               FAC1*SIGTAB(62,I1,IP,IDXMPAR))*FACP*FSUP(1)*FSUD(2)
        SIGTR2(2) = (FAC2*SIGTAB(63,I2,IP,IDXMPAR)+
     &               FAC1*SIGTAB(63,I1,IP,IDXMPAR))*FACP*FSUP(1)*FSUD(2)
        SIGLOO    = (FAC2*SIGTAB(64,I2,IP,IDXMPAR)+
     &               FAC1*SIGTAB(64,I1,IP,IDXMPAR))*FACP
        SIGDPO(1) = (FAC2*SIGTAB(65,I2,IP,IDXMPAR)+
     &               FAC1*SIGTAB(65,I1,IP,IDXMPAR))*FACP**2
        SIGDPO(2) = (FAC2*SIGTAB(66,I2,IP,IDXMPAR)+
     &               FAC1*SIGTAB(66,I1,IP,IDXMPAR))*FACP**2
        SIGDPO(3) = (FAC2*SIGTAB(67,I2,IP,IDXMPAR)+
     &               FAC1*SIGTAB(67,I1,IP,IDXMPAR))*FACP**2
        SIGDPO(4) = (FAC2*SIGTAB(68,I2,IP,IDXMPAR)+
     &               FAC1*SIGTAB(68,I1,IP,IDXMPAR))*FACP**2

C  corrections due to photon virtuality dependence of PDFs
        if(iswmdl(2).eq.1) then
          CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
C  minimum bias event generation
          IF(IPAMDL(115).GE.1) THEN
C  all the virtuality dependence is given by PDF parametrization
            SIGHIN = FAC2*SIGTAB(80,I2,IP,IDXMPAR)+
     &               FAC1*SIGTAB(80,I1,IP,IDXMPAR)
            IF(IPAMDL(116).GE.2) THEN
C  direct interaction according to full QPM calculation
              SIGDIH = HSig(14,IDXMPAR)
              SIGSRH(1) = HSig(10,IDXMPAR)+HSig(11,IDXMPAR)
              SIGSRH(2) = HSig(12,IDXMPAR)+HSig(13,IDXMPAR)
            ELSE
C  direct interaction suppressed according to helicity factor
              SIGDIH = HSig(14,IDXMPAR)*FACH
              SIGSRH(1) = (HSig(10,IDXMPAR)+HSig(11,IDXMPAR))*FSUH(1)
              SIGSRH(2) = (HSig(12,IDXMPAR)+HSig(13,IDXMPAR))*FSUH(2)
            ENDIF
            IF (LPRI.GT.4)
     &      WRITE(LO,*)' PHO_CSINT: option not supported yet'
            stop
          ELSE
C  rescale relevant hard processes
            SIGDIH    = HSig(14,IDXMPAR)
            SIGSRH(1) = HSig(10,IDXMPAR)+HSig(11,IDXMPAR)
            SIGSRH(2) = HSig(12,IDXMPAR)+HSig(13,IDXMPAR)
            SIGtmp = SIGINE-(SIGDIH+SIGSRH(1)+SIGSRH(2))*FACP
            SIGDIR = HSig(14,IDXMPAR)*FACH+SIGSRH(1)*FSUH(1)*FSUP(2)
     &              +SIGSRH(2)*FSUP(1)*FSUH(2)
            SIGINE = SIGtmp+SIGDIR
            SIGTOT = SIGINE+SIGELA
          ENDIF
        else
C  only hard interactions
          CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
          SIGSRH(1) = (HSig(10,IDXMPAR)+HSig(11,IDXMPAR))*FSUH(1)
          SIGSRH(2) = (HSig(12,IDXMPAR)+HSig(13,IDXMPAR))*FSUH(2)
          SIGDIR = HSig(14,IDXMPAR)+SIGSRH(1)+SIGSRH(2)
          SIGHAR = HSig(9,IDXMPAR)*FACH
        endif

        SIG1SO = (FAC2*SIGTAB(37,I2,IP,IDXMPAR)+
     &            FAC1*SIGTAB(37,I1,IP,IDXMPAR))*FACP
        SIG1HA = (FAC2*SIGTAB(38,I2,IP,IDXMPAR)+
     &            FAC1*SIGTAB(38,I1,IP,IDXMPAR))*FACH
        SLOEL = FAC2*SIGTAB(39,I2,IP,IDXMPAR)+
     &          FAC1*SIGTAB(39,I1,IP,IDXMPAR)
        J = 39
        DO 9 I=1,4
          DO 10 K=1,4
            J = J+1
            SLOVM(I,K) = FAC2*SIGTAB(J,I2,IP,IDXMPAR)+
     &                   FAC1*SIGTAB(J,I1,IP,IDXMPAR)
 10       CONTINUE
 9      CONTINUE
        SIGPOM = (FAC2*SIGTAB(56,I2,IP,IDXMPAR)+
     &            FAC1*SIGTAB(56,I1,IP,IDXMPAR))*FACP
        SIGREG = (FAC2*SIGTAB(57,I2,IP,IDXMPAR)+
     &            FAC1*SIGTAB(57,I1,IP,IDXMPAR))*FACP

        IPFIL  = IP
        IFAFIL = IFPA
        IFBFIL = IFPB
        ECMFIL = ECM
        ipcomb = idxmpar
        P2AFIL = PVIR2A
        P2BFIL = PVIR2B

        IF(IDEB(15).GE.20 .AND. LPRI.GT.4)
     &    WRITE(LO,'(1X,A)') 'PHO_CSINT: cross sections calculated'

      ENDIF

      END



      DOUBLE PRECISION FUNCTION PHO_CT14ALPHAS (QQ)

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      PARAMETER (MXX = 201, MXQ = 40, MXF = 6, MaxVal=4)
      PARAMETER (MXPQX = (MXF+1+MaxVal) * MXQ * MXX)
      DOUBLE PRECISION Alsout
      
      COMMON
     > / CtqPar1 / qBase,XV(0:MXX), TV(0:MXQ), UPD(MXPQX),AlsCTEQ(0:mxq)
     > / CtqPar2 / Nx, Nt, NfMx, MxVal
     > / XQrange / Qini, Qmax, Xmin
     > /Setchange/ Isetch, ipdsset, ipdsformat

      DATA Q, JQ /-1D0, 0/
      SAVE

      if (ipdsset.ne.1) 
     >  STOP 'PHO_CT14ALPHAS: the PDF table was not initialized'

      
      if (ipdsformat.lt.11) then
        IF (LPRI.GT.4)
     &   WRITE(LO,*)  
     >  'STOP in PHO_CT14ALPHAS: the PDF table file has an older format'
        IF (LPRI.GT.4)
     &   WRITE(LO,*) 
     >    'and does not include the table of QCD coupling values.'
        IF (LPRI.GT.4)
     &   WRITE(LO,*) 
     >    'You can still compute the PDFs, but do not call'
        IF (LPRI.GT.4)
     &   WRITE(LO,*) 
     >   'the pho_CT14alphas function for the interpolation of alpha_s.'
        stop
      endif

      Q = QQ
      tt = log(log(Q/qBase))

c         --------------   Find lower end of interval containing Q, i.e.,
c                          get jq such that qv(jq) .le. q .le. qv(jq+1)...
      JLq = -1
      JU = NT+1
 13   If (JU-JLq .GT. 1) Then
        JM = (JU+JLq) / 2
        If (tt .GE. TV(JM)) Then
            JLq = JM
          Else
            JU = JM
          Endif
          Goto 13
       Endif

      If     (JLq .LE. 0) Then
         Jq = 0
      Elseif (JLq .LE. Nt-2) Then
C                                  keep q in the middle, as shown above
         Jq = JLq - 1
      Else
C                         JLq .GE. Nt-1 case:  Keep at least 4 points >= Jq.
        Jq = Nt - 3

      Endif
C                                 This is the interpolation variable in Q
      CALL PHO_POlINT4F (TV(jq), AlsCTEQ(jq), tt, Alsout)
      
      PHO_CT14ALPHAS = Alsout
      
      Return
      End



      SUBROUTINE PHO_CT14GETPARS(xmin,Qini,Qmax,Nloops,Nfl)
c**********************************************************************
c Get various parameters associated with the PDF grid
c Output: xmin  is the minimal value of x 
c         Qmin  is the initial Q scale  
c         Qmax  is the maximal Q scale
c         Nloop is the number of QCD loops
c         Nfl   is the maximal number of quark flavors
c**********************************************************************
      IMPLICIT NONE
      SAVE
      DOUBLE PRECISION QINI0, Qmax0, Xmin0, xmin, Qini, Qmax
      INTEGER Nloops, Ipk, Iorder, Nfl, Nfl0
      DOUBLE PRECISION AlfaQ, Qalfa

      COMMON / XQrange / Qini0, Qmax0, Xmin0
      COMMON / QCDtbl /  AlfaQ, Qalfa, Ipk, Iorder, Nfl0
     
      Qini=Qini0; Qmax=Qmax0; Xmin=Xmin0
      Nloops=Iorder-1; Nfl=Nfl0
      
      return 
      end



      DOUBLE PRECISION FUNCTION PHO_CT14MASS(i)
c**********************************************************************
c     Returns the value of the quark mass for the i-th flavor 
c     The flavors are:
c     1  2  3  4  5  6
c     u  d  s  c  b  t
c**********************************************************************
      IMPLICIT NONE
      SAVE
      DOUBLE PRECISION Amass
      INTEGER  Isetch, ipdsset, i, ipdsformat
      COMMON/Setchange/ Isetch, ipdsset, ipdsformat
     >  / Masstbl / Amass(6)


      if (ipdsset.ne.1) 
     >  STOP 'PHO_CT14MASS: the PDF table was not initialized'

      PHO_CT14MASS = Amass(i)

      RETURN 
      END


C============================================================================
C                CTEQ-TEA Parton Distribution Functions: version 2014
C                       May 14, 2015
C
C   Reference: S. Dulat, T.-J. Hou, J. Gao, M. Guzzi, J. Huston, P. M.
C   Nadolsky, J. Pumplin, C. Schmidt, D. Stump, C.-P. Yuan,  arXiv:
C
C   This package provides a standard interface for CT10 and CT14 
C   parton distribution functions.

C   The following sets of CTEQ PDF table files can be computed 
C    with this program: 
C   (1) 1+50 sets of CT10 NNLO PDF's;
C   (2) 1+52 sets of CT10 NLO PDF's;
C   (3) 4 sets of CT10 NNLO and NLO PDF's with alternative alpha_s values;
C   (4) 1+56 sets of CT14 NNLO PDF's;
C   (5) 1+56 sets of CT14 NLO PDF's;
C   (6) 2 sets of CT14 LO PDF's;

C ===========================================================================
C   The table grids are generated for 
C       10^-9 < x < 1 and 1.3 < Q < 10^5 (GeV).
C
C   PDF values outside of the above range are returned using extrapolation.
C
C   The Table_Files are assumed to be in the working directory.
C
C   Before using the PDF, it is necessary to do the initialization by
C       Call SetCT14(Iset)
C   where Tablefile is a 40-character text string with the name of the
c   the desired PDF specified in the above table.table (.pds) file
C
C   Other provided functions include:
C   The function pho_CT14Pdf (Iparton, X, Q)
C     returns the parton distribution inside the proton for parton [Iparton]
C     at [X] Bjorken_X and scale [Q] (GeV) in PDF set [Iset].
C     Iparton  is the parton label (5, 4, 3, 2, 1, 0, -1, ......, -5)
C                              for (b, c, s, d, u, g, u_bar, ..., b_bar),
C
C   The function CT14Alphas (Q) 
C     returns the value of the QCD coupling strength alpha_s(Q) at
C     an energy scale Q. The alpha_s value is obtained from the interpolation
C     of a numerical table of alpha_s included in each .pds file. 
C     In the PDF fit, the alpha_s values are obtained at each momentum
c     scale by evolution in the HOPPET program at the respective QCD order 
C     (NLO or NNLO). The table of alpha_s values at discrete Q values
C     is included in the input .pds file. The function CT14Alphas
c     estimates alpha_s at an arbitrary Q value, which agrees
c     with the direct evolution by HOPPET within a fraction of percent
c     point at typical Q. 
C 
C   The function CT14Mass(i)
c     returns the value of the quark mass for the i-th flavor.
c     The flavors are:
c     1  2  3  4  5  6
c     u  d  s  c  b  t
c
C   Values of various PDF parameters assumed in the computation of the
c    PDFs can be obtained by 
C     Call CT14GetPars( xmin,Qini,Qmax,Nloops,Nfl), 
C   which returns
c     xmin, the minimal value of x;
c     Qmin,  the initial Q scale for the PDF evolution;  
c     Qmax,  the maximal Q scale included in the PDF table;
c     Nloop, the number of QCD loops (order of the PDF in the QCD coupling);
c     Nfl,   the maximal number of quark flavors assumed in the PDF and 
c            alpha_s evolution.

C   These programs, as provided, are in double precision.  By removing the
C   "Implicit Double Precision" lines, they can also be run in single
C   precision.
C   If you have detailed questions concerning these CT14 distributions,
C   or if you find problems/bugs using this package, direct inquires to
C   nadolsky@physics.smu.edu.
C
C===========================================================================

      FUNCTION PHO_CT14PDF (IPARTON, X, Q)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI
      
      LOGICAL WARN
      INTEGER isetch, ipdsformat
      COMMON
     > / CtqPar2 / Nx, Nt, NfMx, MxVal
     > / QCDtbl /  AlfaQ, Qalfa, Ipk, Iorder, Nfl !for external use
     >  /Setchange/ Isetch, ipdsset, ipdsformat
      SAVE 

      DATA WARN /.true./
      DATA QSML /.3d0/


      if (ipdsset.ne.1) 
     >  STOP 'PHO_CT14PDF: the PDF table was not initialized'

      If (X .lt. 0.d0 .or. X .gt. 1.D0) Then
        IF (LPRI.GT.4)
     &   WRITE(LO,*) 'X out of range in PHO_CT14PDF: ', X
        PHO_CT14PDF = 0.D0
        Return
      Endif

      If (Q .lt. Qsml) Then
        IF (LPRI.GT.4)
     &   WRITE(LO,*) 'Q out of range in PHO_CT14PDF: ', Q, Qsml
        Stop
      Endif

      If (abs(Iparton).gt. NfMx) Then
        If (Warn) Then
C        print a warning for calling extra flavor
          Warn = .false.
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'Warning: Iparton out of range in pho_CT14Pdf! '
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'Iparton, MxFlvN0: ', Iparton, NfMx
        Endif
        pho_CT14Pdf = 0D0
      else

        PHO_CT14PDF = PHO_PARTONX12 (IPARTON, X, Q)
        if (PHO_CT14PDF.lt.0D0) PHO_CT14PDF = 0D0
      endif                     !if (abs(Iparton...

      Return

      End


 
 


CDECK  ID>, PHO_DATINI
      SUBROUTINE PHO_DATINI
C*********************************************************************
C
C     initialization of variables and switches
C
C*********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  event weights and generated cross section
      INTEGER IPOWGC,ISWCUT,IVWGHT
      DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
      COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
     &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)

C  scale parameters for parton model calculations
      INTEGER NQQAL,NQQALI,NQQALF,NQQPD
      DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
      COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
     &                NQQAL,NQQALI,NQQALF,NQQPD

C  integration precision for hard cross sections (obsolete)
      INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
      COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO

C  hard scattering parameters used for most recent hard interaction
      INTEGER NFbeta,NF
      DOUBLE PRECISION ALQCD2,BQCD
      COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF

C  current beam selection
      INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN
      INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL
      DOUBLE PRECISION SQSGLOBMAX
      PARAMETER (MPARMAX=40)
      PARAMETER (MAXMAPPS=40)
      PARAMETER (IKNOWN=9)
      DIMENSION IPAVAIL(IKNOWN)
      DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/
      COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS),
     &           MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP

C  cut probability distribution
      INTEGER IEETA1,IIMAX,KKMAX
      PARAMETER( IEETA1=20, IIMAX=20, KKMAX=500 )
      INTEGER IEEMAX,IMAX,KMAX
      DOUBLE PRECISION EPTAB, PROB
      COMMON /POPROB/ PROB(IEETA1, 0:IIMAX, 0:KKMAX, 4, MPARMAX),
     &          EPTAB(IEETA1, 4, MPARMAX), IEEMAX, IMAX, KMAX

C  gamma-lepton or gamma-hadron vertex information
      INTEGER IGHEL,IDPSRC,IDBSRC
      DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
     &                 RADSRC,AMSRC,GAMSRC
      COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
     &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
     &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)

C  photon flux kinematics and cuts
      DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
     &                 YMIN1,YMAX1,YMIN2,YMAX2,
     &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
     &                 THMIN1,THMAX1,THMIN2,THMAX2
      INTEGER          ITAG1,ITAG2
      COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
     &                YMIN1,YMAX1,YMIN2,YMAX2,
     &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
     &                THMIN1,THMAX1,THMIN2,THMAX2,
     &                ITAG1,ITAG2

C  obsolete cut-off information
      DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
      COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN

C  global event kinematics and particle IDs
      INTEGER IFPAP,IFPAB
      DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
      COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)

C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
      INTEGER IDEQP,IDEQB,IHFLD,IHFLS
      DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
      COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
     &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)

C  some hadron information, will be deleted in future versions
      INTEGER NFS
      DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
      COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  general process information
      INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
      COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)

C  parameters of the "simple" Vector Dominance Model
      DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
      COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)

C  parameters for DGLAP backward evolution in ISR
      INTEGER NFSISR
      DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
      COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR

C  particles created by initial state evolution
      INTEGER MXISR1,MXISR2
      PARAMETER ( MXISR1 = 150, MXISR2 = 1000 )
      INTEGER IFLISR,IPOISR,IMXISR
      DOUBLE PRECISION PHISR
      COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
     &                IPOISR(2,2,MXISR2),IMXISR(2)

C  names of hard scattering processes
      INTEGER Max_pro_1
      PARAMETER ( Max_pro_1 = 16 )
      CHARACTER*18 PROC
      COMMON /POHPRO/ PROC(0:Max_pro_1)

C  hard cross sections and MC selection weights
      INTEGER Max_pro_2
      PARAMETER ( Max_pro_2 = 16 )
      INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
     &  MH_acc_1,MH_acc_2
      DOUBLE PRECISION HFAC, HWGX, HSIG, HDPT, HECM_LAST, 
     &   HQ2A_LAST, HQ2B_LAST
      COMMON /POHRCS/HFAC(-1:MAX_PRO_2, MPARMAX), 
     &   HWGX(-1:MAX_PRO_2, MPARMAX),
     &   HSIG(-1:MAX_PRO_2, MPARMAX), HDPT(-1:MAX_PRO_2, MPARMAX), 
     &   HECM_LAST, HQ2A_LAST, HQ2B_LAST, IHA_LAST, IHB_LAST, 
     &   MH_PRO_ON(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_TRIED(-1:MAX_PRO_2, 0:4, MPARMAX), 
     &   MH_ACC_1(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_ACC_2(-1:MAX_PRO_2, 0:4, MPARMAX) 

C  interpolation tables for hard cross section and MC selection weights
      INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
      PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
      INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
      DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
     &  HQ2a_tab,HQ2b_tab,HEcm_tab
      COMMON /POHTAB/
     &  Hfac_tab(-1:Max_pro_tab,Max_tab_E,
     &           Max_tab_Q2,Max_tab_Q2,0:4,MPARMAX),
     &  HWgx_tab(-1:Max_pro_tab,Max_tab_E,
     &           Max_tab_Q2,Max_tab_Q2,0:4,MPARMAX),
     &  HSig_tab(-1:Max_pro_tab,Max_tab_E,
     &           Max_tab_Q2,Max_tab_Q2,0:4,MPARMAX),
     &  Hdpt_tab(-1:Max_pro_tab,Max_tab_E,
     &           Max_tab_Q2,Max_tab_Q2,0:4,MPARMAX),
     &  HQ2a_tab(1:Max_tab_Q2,0:4,MPARMAX),
     &  HQ2b_tab(1:Max_tab_Q2,0:4,MPARMAX),
     &  HEcm_tab(1:Max_tab_E,0:4,MPARMAX),
     &  IH_Q2a_up(0:4,MPARMAX),IH_Q2b_up(0:4,MPARMAX),
     &  IH_Ecm_up(0:4,MPARMAX)


C  initialize /POCONS/
      PI   = ATAN(1.D0)*4.D0
      PI2  = 2.D0*PI
      PI4  = 2.D0*PI2
C  GeV**-2 --> millibarn (multiply by GEV2MB to get mb as units)
      GEV2MB = 0.389365D0
C  precalculate quark charges
      do i=1,6
        Q_ch(i) = dble(2-3*mod(i,2))/3.D0
        Q_ch(-i) = -Q_ch(i)

        Q_ch2(i) = Q_ch(i)**2
        Q_ch2(-i) = Q_ch2(i)

        Q_ch4(i) = Q_ch2(i)**2
        Q_ch4(-i) = Q_ch4(i)
      enddo
      Q_ch(0)  = 0.D0
      Q_ch2(0) = 0.D0
      Q_ch4(0) = 0.D0

C  initialize /GLOCMS/
      ECM    = 50.D0
      PMASS(1) = 0.D0
      PVIRT(1) = 0.D0
      PMASS(2) = 0.D0
      PVIRT(2) = 0.D0
      IFPAP(1) = 22
      IFPAP(2) = 22
C  initialize /HADVAL/
      IHFLD(1,1) = 0
      IHFLD(1,2) = 0
      IHFLD(2,1) = 0
      IHFLD(2,2) = 0
      IHFLS(1) = 1
      IHFLS(2) = 1
C  initialize /MODELS/
      ISWMDL(1)  = 3
      MDLNA(1)  = 'AMPL MOD'
      ISWMDL(2)  = 1
      MDLNA(2)  = 'MIN-BIAS'
      ISWMDL(3)  = 1
      MDLNA(3)  = 'PTS DISH'
      ISWMDL(4)  = 1
      MDLNA(4)  = 'PTS DISP'
      ISWMDL(5)  = 2
      MDLNA(5)  = 'PTS ASSI'
      ISWMDL(6)  = 3
      MDLNA(6)  = 'HADRONIZ'
      ISWMDL(7)  = 2
      MDLNA(7)  = 'MASS COR'
      ISWMDL(8)  = 3
      MDLNA(8)  = 'PAR SHOW'
      ISWMDL(9)  = 0
      MDLNA(9)  = 'GLU SPLI'
      ISWMDL(10) = 2
      MDLNA(10) = 'VIRT PHO'
      ISWMDL(11) = 0
      MDLNA(11) = 'LARGE NC'
      ISWMDL(12) = 0
      MDLNA(12) = 'LIPA POM'
      ISWMDL(13) = 1
      MDLNA(13) = 'QELAS VM'
      ISWMDL(14) = 2
      MDLNA(14) = 'ENHA GRA'
      ISWMDL(15) = 4
      MDLNA(15) = 'MULT SCA'
      ISWMDL(16) = 4
      MDLNA(16) = 'MULT DIF'
      ISWMDL(17) = 4
      MDLNA(17) = 'MULT CDF'
      ISWMDL(18) = 0
      MDLNA(18) = 'BALAN PT'
      ISWMDL(19) = 1
      MDLNA(19) = 'POMV FLA'
      ISWMDL(20) = 0
      MDLNA(20) = 'SEA  FLA'
      ISWMDL(21) = 2
      MDLNA(21) = 'SPIN DEC'
      ISWMDL(22) = 1
      MDLNA(22) = 'DIF.MASS'
      ISWMDL(23) = 1
      MDLNA(23) = 'DIFF RES'
      ISWMDL(24) = 0
      MDLNA(24) = 'PTS HPOM'
      ISWMDL(25) = 0
      MDLNA(25) = 'POM CORR'
      ISWMDL(26) = 1
      MDLNA(26) = 'OVERLAP '
      ISWMDL(27) = 0
      MDLNA(27) = 'MUL R/AN'
      ISWMDL(28) = 1
      MDLNA(28) = 'SUR PROB'
      ISWMDL(29) = 1
      MDLNA(29) = 'PRIMO KT'
      ISWMDL(30) = 0
      MDLNA(30) = 'DIFF. CS'
      ISWMDL(31) = -9999
C  mass-independent sea flavour ratios (for low-mass strings)
      PARMDL(1)  = 0.425D0
      PARMDL(2)  = 0.425D0
      PARMDL(3)  = 0.15D0
      PARMDL(4)  = 0.D0
      PARMDL(5)  = 0.D0
      PARMDL(6)  = 0.D0
C  suppression by energy momentum conservation
      PARMDL(8)  = 9.D0
      PARMDL(9)  = 7.D0
C  VDM factors
      PARMDL(10) = 0.866D0
      PARMDL(11) = 0.288D0
      PARMDL(12) = 0.288D0
      PARMDL(13) = 0.288D0
      PARMDL(14) = 0.866D0
      PARMDL(15) = 0.288D0
      PARMDL(16) = 0.288D0
      PARMDL(17) = 0.288D0
      PARMDL(18) = 0.D0
C  lower energy limit for initialization
      PARMDL(19) = 2.5D0
C  soft pt for hard scattering remnants
      PARMDL(20) = 5.D0
C  low energy beta of soft pt distribution 1
      PARMDL(21) = 4.5D0
C  high energy beta of soft pt distribution 1
      PARMDL(22) = 3.0D0
C  low energy beta of soft pt distribution 0
      PARMDL(23) = 2.5D0
C  high energy beta of soft pt distribution 0
      PARMDL(24) = 0.4D0
C  effective quark mass in photon wave function
      PARMDL(25) = 0.2D0
C  normalization of unevolved Pomeron PDFs
      PARMDL(26) = 0.3D0
C  effective VDM parameters for Q**2 dependence of cross section
      PARMDL(27) = 0.65D0
      PARMDL(28) = 0.08D0
      PARMDL(29) = 0.05D0
      PARMDL(30) = 0.22D0
      PARMDL(31) = 0.589824D0
      PARMDL(32) = 0.609961D0
      PARMDL(33) = 1.038361D0
      PARMDL(34) = 1.96D0
C  Q**2 suppression of multiple interactions
      PARMDL(35) = 0.59D0
C  pt cutoff defaults
      PARMDL(36) = 2.5D0
      PARMDL(37) = 2.5D0
      PARMDL(38) = 2.5D0
      PARMDL(39) = 2.5D0
C  enhancement factor for diffractive cross sections
      PARMDL(40) = 1.D0
      PARMDL(41) = 1.D0
      PARMDL(42) = 1.D0
C  mass in soft pt distribution
      PARMDL(43) = 0.D0
C  maximum of x allowed for leading particle
      PARMDL(44) = 0.9D0
C  max. mass sampled in diffraction
      PARMDL(45) = sqrt(0.4D0)
C  mass threshold in diffraction (2pi mass)
      PARMDL(46) = 0.3D0
C  regularization of slope parameter in diffraction
      PARMDL(47) = 4.D0
C  renormalized intercept for enhanced graphs
      PARMDL(48) = 1.08D0
C  coherence constraint for diff. cross sections
      PARMDL(49) = sqrt(0.05D0)
C  exponents of x distributions
C  baryon
      PARMDL(50) = 1.5D0
      PARMDL(51) = -0.5D0
      PARMDL(52) = -0.99D0
      PARMDL(53) = -0.99D0
C  meson (non-strangeness part)
      PARMDL(54) = -0.5D0
      PARMDL(55) = -0.5D0
      PARMDL(56) = -0.99D0
      PARMDL(57) = -0.99D0
C  meson (strangeness part)
      PARMDL(58) = -0.2D0
      PARMDL(59) = -0.2D0
      PARMDL(60) = -0.99D0
      PARMDL(61) = -0.99D0
C  particle remnant (no valence quarks)
      PARMDL(62) = -0.5D0
      PARMDL(63) = -0.5D0
      PARMDL(64) = -0.99D0
      PARMDL(65) = -0.99D0
C  ratio beetween triple-pomeron/reggeon couplings grrp/gppp
      PARMDL(66) = 10.D0
C  ratio beetween triple-pomeron/reggeon couplings gppr/gppp
      PARMDL(67) = 10.D0
C  min. abs(t) in diffraction
      PARMDL(68) = 0.D0
C  max. abs(t) in diffraction
      PARMDL(69) = 10.D0
C  min. mass for elastic pomerons in central diffraction
      PARMDL(70) = 2.D0
C  min. mass of diffractive blob in central diffraction
      PARMDL(71) = 2.D0
C  min. Feynman x cut in central diffraction
      PARMDL(72) = 0.D0
C  direct pomeron coupling
      PARMDL(74) = 0.D0
C  relative deviation allowed for energy-momentum conservation
C  energy-momentum relative deviation
      PARMDL(75) = 0.01D0
C  transverse momentum deviation
      PARMDL(76) = 0.01D0
C  couplings for unitarization in diffraction
C  non-unitarized pomeron coupling (sqrt(mb))
      PARMDL(77)  = 3.D0
C  rescaling factor for pomeron PDF
      PARMDL(78)  = 3.D0
C  coupling probabilities
      PARMDL(79)  = 1.D0
      PARMDL(80)  = 0.D0
C  scales to calculate alpha-s of matrix element
      PARMDL(81) = 1.D0
      PARMDL(82) = 1.D0
      PARMDL(83) = 1.D0
C  scales to calculate alpha-s of initial state radiation
      PARMDL(84) = 1.D0
      PARMDL(85) = 1.D0
      PARMDL(86) = 1.D0
C  scales to calculate alpha-s of final state radiation
      PARMDL(87) = 1.D0
      PARMDL(88) = 1.D0
      PARMDL(89) = 1.D0
C  scales to calculate PDFs
      PARMDL(90) = 1.D0
      PARMDL(91) = 1.D0
      PARMDL(92) = 1.D0
C  scale for ISR starting virtuality
      PARMDL(93) = 1.D0
C  min. virtuality to generate time-like showers in ISR
      PARMDL(94) = 2.D0
C  factor to scale the max. allowed time-like parton shower virtuality
      PARMDL(95) = 4.D0
C  max. transverse momentum to include inhard cross section
      PARMDL(96) = 900.D0      
C  max. transverse momentum for primordial kt
      PARMDL(100) = 2.D0
C  weight factors for pt-distribution
      PARMDL(101) = 2.D0
      PARMDL(102) = 2.D0
      PARMDL(103) = 4.D0
      PARMDL(104) = 2.D0
      PARMDL(105) = 6.D0
      PARMDL(106) = 4.D0
C
*     PARMDL(110-125)  reserved for hard scattering
C  currently chosen scales for hard scattering
      DO 10 I=1,16
        PARMDL(109+I) = 0.D0
 10   CONTINUE
C  virtuality cutoff in initial state evolution
      PARMDL(126) = PARMDL(36)**2
      PARMDL(127) = PARMDL(37)**2
      PARMDL(128) = PARMDL(38)**2
      PARMDL(129) = PARMDL(39)**2
C  virtuality cutoff for direct contribution to photon PDF
      PARMDL(130) = 1.D30
      PARMDL(131) = 1.D30
      PARMDL(132) = 1.D30
      PARMDL(133) = 1.D30
C  fraction of events without popcorn
      PARMDL(134) = -1.D0
C  fraction of diquarks with spin 1 (relative to sum of spin 1 and 0)
      PARMDL(135) = 0.5D0
C  soft color re-connection (fraction)
C  g g final state
      PARMDL(140) = 1.D0/64.D0
C  g q final state
      PARMDL(141) = 1.D0/24.D0
C  q q final state
      PARMDL(142) = 1.D0/9.D0
C  effective scale in Drees-Godbole like suppresion in photon PDF
      PARMDL(144) = 0.766D0**2
C  QCD scales (if PDF scales are not used, 4 active flavours)
      PARMDL(145) = 0.2D0**2
      PARMDL(146) = 0.2D0**2
      PARMDL(147) = 0.2D0**2
C  threshold scales for variable flavour calculation (GeV**2)
      PARMDL(148) = 1.3D0**2
      PARMDL(149) = 4.75D0**2
      PARMDL(150) = 172.D0**2
C  constituent quark masses
      PARMDL(151) = 0.3D0
      PARMDL(152) = 0.3D0
      PARMDL(153) = 0.5D0
      PARMDL(154) = 1.6D0
      PARMDL(155) = 5.D0
      PARMDL(156) = 174.D0
C  min. masses of valence quark
      PARMDL(157) = 0.3D0
C  min. masses of valence diquark
      PARMDL(158) = 0.8D0
C  min. mass of sea quark
      PARMDL(159) = 0.D0
C  suppression of strange quarks as photon valences
      PARMDL(160) = 0.2D0
C  min. masses for strings (used in PHO_SOFTXX)
      PARMDL(161) = 1.D0
      PARMDL(162) = 1.D0
      PARMDL(163) = 1.D0
      PARMDL(164) = 1.D0
C  min. momentum fraction for soft processes
      PARMDL(165) = 0.3D0
C  min. phase space for x-sampling
      PARMDL(166) = 0.135D0
C  Ross-Stodolsky exponent
      PARMDL(170) = 4.2D0
C  cutoff on photon-pomeron invariant mass in hadron-hadron collisions
      PARMDL(175) = 2.D0

**sr
*  extra factor multiplying difference between Goulianos and PHOJET-
*  diff. cross sections
      PARMDL(200) = 0.6D0
**
c**af  energy dependence of pt-cutoff in Golec-Biernat-Wusthoff model
      PARMDL(250) = 2.0D0
      PARMDL(251) = 400.D0
      PARMDL(252) = 200.D0
      PARMDL(253) = 0.19D0
c       PARMDL(250) = 1.6D0
c       PARMDL(251) = 515.D0
c       PARMDL(252) = 230.D0
c       PARMDL(253) = 0.20D0
c**af  alpomhp
      PARMDL(260) = 0.10D0
c     Regularization factor for PYTHIA style p_T0 hep-ph/0402078
      parmdl(261) = 0.D0
c     Energy dependence of k-factor
      parmdl(262) = 0.13D0
C  complex amplitudes, eikonal functions
      IPAMDL(1)  = 0
C  allow for Reggeon cuts
      IPAMDL(2)  = 1
C  decay of hadron resonances in diffraction (0 iso, 1 trans, 2 long)
      IPAMDL(3)  = 0
C  polarization of photon resonances (0 none, 1 trans, 2 long)
      IPAMDL(4)  = 1
C  pt of valence partons
      IPAMDL(5)  = 1
C  pt of hard scattering remnant
      IPAMDL(6)  = 2
C  energy-dependent cutoff for hard scattering
      IPAMDL(7)  = 3
C  intercept used for the calculation of enhanced graphs
      IPAMDL(8)  = 1
C  effective slope of hard scattering amplitde
      IPAMDL(9)  = 3
C  mass dependence of slope parameters
      IPAMDL(10) = 0
C  lepton-photon vertex 1
      IPAMDL(11) = 0
C  lepton-photon vertex 2
      IPAMDL(12) = 0
C  call by DPMJET
      IPAMDL(13) = 0
C  method to sample x distributions
      IPAMDL(14) = 3
C  energy-momentum check
      IPAMDL(15) = 1
C  phase space correction for DPMJET interface
      IPAMDL(16) = 1
C  fragment strings from projectile/target/central diff. separately
      IPAMDL(17) = 1
C  method to construct strings for hard interactions
      IPAMDL(18) = 1
C  method to construct strings for soft sea (pomeron cuts)
      IPAMDL(19) = 0
C  method to construct strings in pomeron interactions
      IPAMDL(20) = 0
C  soft color re-connection
      IPAMDL(21) = 0
C  resummation of triple- and loop-Pomeron
      IPAMDL(24) = 1
C  resummation of X iterated triple-Pomeron
      IPAMDL(25) = 1
C  dimension of interpolation table for weights in hard scattering
      IPAMDL(30) = Max_tab_E
C  dimension of interpolation table for pomeron cut distribution
      IPAMDL(31) = IEETA1
C  number of cut soft pomerons (restriction by field dimension)
      IPAMDL(32) = IIMAX
C  number of cut hard pomerons (restriction by field dimension)
      IPAMDL(33) = KKMAX
C  tau pair production in direct photon-photon collisions
      IPAMDL(64) = 0
C  currently chosen scales for hard scattering
C  ATTENTION:   IPAMDL(65-80)  reserved for hard scattering!
      DO 15 I=1,16
        IPAMDL(64+I) = -99999
 15   CONTINUE
C  scales to calculate alpha-s of matrix element
      IPAMDL(81) = 1
      IPAMDL(82) = 1
      IPAMDL(83) = 1
C  scales to calculate alpha-s of initial state radiation
      IPAMDL(84) = 1
      IPAMDL(85) = 1
      IPAMDL(86) = 1
C  scales to calculate alpha-s of final state radiation
      IPAMDL(87) = 1
      IPAMDL(88) = 1
      IPAMDL(89) = 1
C  scales to calculate PDFs
      IPAMDL(90) = 1
      IPAMDL(91) = 1
      IPAMDL(92) = 1
C  where to get the parameter sets from
      IPAMDL(99) = 1
C  program PHO_ABORT for fatal errors (simulation of division by zero)
      IPAMDL(100) = 0
C  initial state parton showers for all / hardest interaction(s)
      IPAMDL(101) = 1
C  final state parton showers for all / hardest interaction(s)
      IPAMDL(102) = 1
C  initial virtuality for ISR generation
      IPAMDL(109) = 1
C  qqbar-gamma coupling in initial state showers
      IPAMDL(110) = 1
C  generation of time-like showers during ISR
      IPAMDL(111) = 1
C  reweighting of multiple soft contributions for virtual photons
      IPAMDL(114) = 1
C  reweighting / use photon virtuality in photon PDF calculations
      IPAMDL(115) = 0
C  use full QPM model incl. interference terms (direct part in gam-gam)
      IPAMDL(116) = 0
C  matching sigma_tot to F2 as given by parton density at high Q2
      IPAMDL(117) = 1
C  use virtuality of target in F2 calculations (two-gamma only)
      IPAMDL(118) = 1
C  calculation of alpha_em
      IPAMDL(120) = 1
C  strict pt cutoff for gamma-gamma events
      IPAMDL(121) = 0
C  photon virtuality sampled in photon flux approximations
      IPAMDL(174) = 1
C  photon-pomeron: 0,1,2: both,left,right photon emission
      IPAMDL(175) = 0
C  keep full history information in PHOJET-JETSET interface
      IPAMDL(178) = 1
C  max. number of conservation law violations allowed in one run
      IPAMDL(179) = 20
C  selection of soft X values
C  max. iteration number in PHO_SELSXS
      IPAMDL(180) = 50
C  max. iteration number in PHO_SELSXR
      IPAMDL(181) = 200
C  max. iteration number in PHO_SELSX2
      IPAMDL(182) = 100
C  max. iteration number in PHO_SELSXI
      IPAMDL(183) = 50

C  initialize /PROBAB/
      IEEMAX = IEETA1
      IMAX   = IIMAX
      KMAX   = KKMAX

      DO 20 I=1,30
        PARMDL(300+I) = -100000.D0
 20   CONTINUE
C  initialize /POHDRN/
      QMASS(1) =  PARMDL(151)
      QMASS(2) =  PARMDL(152)
      QMASS(3) =  PARMDL(153)
      QMASS(4) =  PARMDL(154)
      QMASS(5) =  PARMDL(155)
      QMASS(6) =  PARMDL(156)
      BET      = 8.D0
      PCOUDI   = 0.D0
      VALPRG(1) = 1.D0
      VALPRG(2) = 1.D0
C  number of light flavours (quarks treated as massless)
      NFS      = 4
C  initialize /POCUT1/
      PTCUT(1) = PARMDL(36)
      PTCUT(2) = PARMDL(37)
      PTCUT(3) = PARMDL(38)
      PTCUT(4) = PARMDL(39)
      PSOMIN = 0.D0
      XSOMIN = 0.D0
C  initialize /POHAPA/
      NFbeta  = 4
      NF      = 4
      BQCD(1) = PI4/(11.D0-(2.D0/3.D0)*3)
      BQCD(2) = PI4/(11.D0-(2.D0/3.D0)*4)
      BQCD(3) = PI4/(11.D0-(2.D0/3.D0)*5)
      BQCD(4) = PI4/(11.D0-(2.D0/3.D0)*6)
C  initialize /POGAUP/
      NGAUP1 = 12
      NGAUP2 = 12
      NGAUET = 16
      NGAUIN = 12
      NGAUSO = 96
C  initialize //
      DO 30 I=1,100
        IDEB(I) = 0
 30   CONTINUE
C  initialize /PROCES/
      DO 35 I=1,11
        IPRON(I,1) = 1
 35   CONTINUE

C  DPMJET default: no elastic scattering
      IPRON(2,1) = 0

      DO 36 K=2,4
        DO 37 I=2,11
          IPRON(I,K) = 0
 37     CONTINUE
        IPRON(1,K) = 1
        IPRON(8,K) = 1
 36   CONTINUE
C  initialize /POSVDM/
      TWOPIM = 0.28D0
      RMIN(1) = 0.285D0
      RMIN(2) = 0.45D0
      RMIN(3) = 1.D0
      RMIN(4) = TWOPIM
      VMAS(1) = 0.770D0
      VMAS(2) = 0.787D0
      VMAS(3) = 1.02D0
      VMAS(4) = TWOPIM
      GAMM(1) = 0.155D0
      GAMM(2) = 0.01D0
      GAMM(3) = 0.0045D0
      GAMM(4) = 1.D0
      RMAX(1) = VMAS(1)+TWOPIM
      RMAX(2) = VMAS(2)+TWOPIM
      RMAX(3) = VMAS(3)+TWOPIM
      RMAX(4) = VMAS(1)+TWOPIM
      VMSL(1) = 11.D0
      VMSL(2) = 10.D0
      VMSL(3) = 6.D0
      VMSL(4) = 4.D0
      VMFA(1) = 0.0033D0
      VMFA(2) = 0.00036D0
      VMFA(3) = 0.0002D0
      VMFA(4) = 0.0002D0
C  initialize /PODGL1/
      Q2MISR(1) = PARMDL(36)**2
      Q2MISR(2) = PARMDL(36)**2
      PMISR(1) = 1.D0
      PMISR(2) = 1.D0
      ZMISR(1) = 0.001D0
      ZMISR(2) = 0.001D0
      AL2ISR(1) = 0.046D0
      AL2ISR(2) = 0.046D0
      NFSISR  = 4
C  initialize /POPISR/
      DO 40 I=1,50
        IPOISR(1,2,I) = 0
        IPOISR(2,2,I) = 0
 40   CONTINUE
C  initialize /POHPRO/
      PROC(0) = 'sum over processes'
      PROC(1) = 'G  +G  --> G  +G  '
      PROC(2) = 'Q  +QB --> G  +G  '
      PROC(3) = 'G  +Q  --> G  +Q  '
      PROC(4) = 'G  +G  --> Q  +QB '
      PROC(5) = 'Q  +QB --> Q  +QB '
      PROC(6) = 'Q  +QB --> QP +QBP'
      PROC(7) = 'Q  +Q  --> Q  +Q  '
      PROC(8) = 'Q  +QP --> Q  +QP '
      PROC(9) = 'resolved processes'
      PROC(10) = 'gam+Q  --> G  +Q  '
      PROC(11) = 'gam+G  --> Q  +QB '
      PROC(12) = 'Q  +gam--> G  +Q  '
      PROC(13) = 'G  +gam--> Q  +QB '
      PROC(14) = 'gam+gam--> Q  +QB '
      PROC(15) = 'direct processes  '
      PROC(16) = 'gam+gam--> l+ +l- '

C  initialize /POHRCS/
      Do m = 1, max_pro_2
        Do k=1, mparmax
          hwgx(m, k) = 0.D0
          hsig(m, k) = 0.D0
          hdpt(m, k) = 0.D0
        End Do
      End Do
      Do i = 0, 4
        Do k = 1, mparmax
          Do m = -1, max_pro_2
C  switch all hard subprocesses on
            mh_pro_on(m, i, k) = 1
C  reset all counters
            mh_tried(m, i, k) = 0
            mh_acc_1(m, i, k) = 0
            mh_acc_2(m, i, k) = 0
          End Do
          mh_pro_on(16, i, k) = 0
        End Do
      End Do

C  initialize /POHTAB/
      Do i = 0, 4
        Do k = 1, mparmax
          ih_ecm_up(i, k) = 0
          ih_q2a_up(i, k) = 0
          ih_q2b_up(i, k) = 0
          hecm_tab(1, i, k) = 0.D0
        End Do
      End Do
      HEcm_last = 0.D0
      IHa_last = 0
      IHb_last = 0

C  initialize /POFSRC/
      IGHEL(1) = -1
      IGHEL(2) = -1
C  initialize /LEPCUT/
      ECMIN = 5.D0
      ECMAX = 1.D+30
      EEMIN1 = 1.D0
      EEMIN2 = 1.D0
      YMAX1 = -1.D0
      YMAX2 = -1.D0
      THMIN1 = 0.D0
      THMAX1 = PI
      THMIN2 = 0.D0
      THMAX2 = PI
      ITAG1 = 1
      ITAG2 = 1
C  initialize /POWGHT/
      DO 70 I=1,20
        HSWCUT(I) = 0.D0
        ISWCUT(I) = 0
 70   CONTINUE
      EVWGHT(1) = 1.D0
      IVWGHT(1) = 0
      SIGGEN(1) = 0.D0
      SIGGEN(2) = 0.D0
      SIGGEN(3) = 0.D0
      SIGGEN(4) = 0.D0

      END


 
 


CDECK  ID>, PHO_DBFINT
      DOUBLE PRECISION FUNCTION PHO_DBFINT(NARG,ARG,NA,ENT,TABLE)
C***********************************************************************
C
C     routine based on CERN library E104
C
C     multi-dimensional interpolation routine, needed for PHOJET
C     internal cross section tables and several PDF sets (GRV98 and AGL)
C
C     changed to avoid recursive function calls (R.Engel, 09/98)
C
C***********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      INTEGER NA(NARG), INDEX(32)
      DOUBLE PRECISION ARG(NARG),ENT(NARG),TABLE(*),WEIGHT(32)

      DATA ZEROD/0.D0/
      DATA ONED/1.D0/

      DBFINT    =  ZEROD
      PHO_DBFINT =  ZEROD
      IF(NARG .LT. 1  .OR.  NARG .GT. 5)  RETURN

           LMAX      =  0
           ISTEP     =  1
           KNOTS     =  1
           INDEX(1)  =  1
           WEIGHT(1) =  ONED
           DO 100    N  =  1, NARG
              X     =  ARG(N)
              NDIM  =  NA(N)
              LOCA  =  LMAX
              LMIN  =  LMAX + 1
              LMAX  =  LMAX + NDIM
              IF(NDIM .GT. 2)  GOTO 10
              IF(NDIM .EQ. 1)  GOTO 100
              H  =  X - ENT(LMIN)
              IF(H .EQ. ZEROD)  GOTO 90
              ISHIFT  =  ISTEP
              IF(X-ENT(LMIN+1) .EQ. ZEROD)  GOTO 21
              ISHIFT  =  0
              ETA     =  H / (ENT(LMIN+1) - ENT(LMIN))
              GOTO 30
   10         LOCB  =  LMAX + 1
   11         LOCC  =  (LOCA+LOCB) / 2
              IF(X-ENT(LOCC))  12, 20, 13
   12         LOCB  =  LOCC
              GOTO 14
   13         LOCA  =  LOCC
   14         IF(LOCB-LOCA .GT. 1)  GOTO 11
              LOCA    =  MIN ( MAX (LOCA,LMIN), LMAX-1 )
              ISHIFT  =  (LOCA - LMIN) * ISTEP
              ETA     =  (X - ENT(LOCA)) / (ENT(LOCA+1) - ENT(LOCA))
              GOTO 30
   20         ISHIFT  =  (LOCC - LMIN) * ISTEP
   21         DO 22  K  =  1, KNOTS
                 INDEX(K)  =  INDEX(K) + ISHIFT
   22         CONTINUE
              GOTO 90
   30         DO 31  K  =  1, KNOTS
                 INDEX(K)         =  INDEX(K) + ISHIFT
                 INDEX(K+KNOTS)   =  INDEX(K) + ISTEP
                 WEIGHT(K+KNOTS)  =  WEIGHT(K) * ETA
                 WEIGHT(K)        =  WEIGHT(K) - WEIGHT(K+KNOTS)
   31         CONTINUE
              KNOTS  =  2*KNOTS
   90         ISTEP  =  ISTEP * NDIM
  100      CONTINUE
           DO 200    K  =  1, KNOTS
              I  =  INDEX(K)
              DBFINT =  DBFINT + WEIGHT(K) * TABLE(I)
  200      CONTINUE

      PHO_DBFINT = DBFINT

      END


 
 


CDECK  ID>, PHO_DFMASS
      DOUBLE PRECISION FUNCTION PHO_DFMASS(XMIN,XMAX,PREF2,PVIRT2,IMODE)
C**********************************************************************
C
C     sampling of Mx diffractive mass distribution within
C              limits XMIN, XMAX
C
C     input:    XMIN,XMAX     mass limitations (GeV)
C               PREF2         original particle mass/ reference mass
C                             (squared, GeV**2)
C               PVIRT2        particle virtuality
C               IMODE         M**2 mass distribution
C                             1      1/(M**2+Q**2)
C                             2      1/(M**2+Q**2)**alpha
C                            -1      1/(M**2-Mref**2+Q**2)
C                            -2      1/(M**2-Mref**2+Q**2)**alpha
C
C     output:   diffractive mass (GeV)
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER(EPS  = 1.D-10)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)


      IF((XMIN.GE.XMAX).OR.(XMIN.LE.0.3D0)) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,2A,3E12.4)') 'PHO_DFMASS:ERROR: ',
     &    'invalid mass limits',XMIN,XMAX,PREF2
        CALL PHO_PREVNT(-1)
        PHO_DFMASS = 0.135D0
        RETURN
      ENDIF

      IF(IMODE.GT.0) THEN
        PM2 = -PVIRT2
      ELSE
        PM2 = PREF2 - PVIRT2
      ENDIF

C  critical pomeron
      IF(ABS(IMODE).EQ.1) THEN
        XMIN2 = LOG(XMIN**2-PM2)
        XMAX2 = LOG(XMAX**2-PM2)
        XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
        XMA2 = EXP(XI)+PM2

C  supercritical pomeron
      ELSE IF(ABS(IMODE).EQ.2) THEN
        DDELTA = 1.D0-PARMDL(48)
        XMIN2 = (XMIN**2-PM2)**DDELTA
        XMAX2 = (XMAX**2-PM2)**DDELTA
        XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
        XMA2 = XI**(1.D0/DDELTA)+PM2
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/,1X,A,I3)')
     &    'PHO_DFMASS:ERROR: unsupported mode',IMODE
        CALL PHO_ABORT
      ENDIF

      PHO_DFMASS = SQRT(XMA2)
C  debug output
      IF(IDEB(43).GE.15) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,4E12.3)') 'PHO_DFMASS:Mmin,Mmax,Mref,Mass',
     &    XMIN,XMAX,PREF2,SQRT(XMA2)
      ENDIF

      END


 
 


CDECK  ID>, PHO_DFWRAP
      SUBROUTINE PHO_DFWRAP(MODE,JM1,JM2)
C**********************************************************************
C
C     wrapper for diffraction dissociation in hadron-nucleus and
C     nucleus-nucleus collisions with DPMJET
C
C     input:      MODE     1:   transformation into CMS
C                          2:   transformation into Lab
C                 JM1/2    indices of old mother particles
C                 JM1/2N   indices of new mother particles
C
C**********************************************************************

      IMPLICIT NONE

      SAVE

      INTEGER MODE,JM1,JM2

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
      INTEGER IDEQP,IDEQB,IHFLD,IHFLS
      DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
      COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
     &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)

      DOUBLE PRECISION GAMBED(4),P1(4),P2(4),P3(4),P4(4),XM1,XM2
      DOUBLE PRECISION SS,ECMD,PTOT1,CODD,SIDD,COFD,SIFD,ANORF

      INTEGER I,NHEPS,JM1S,JM2S,JM1N,JM2N,IREJ

C  transformation into CMS

      IF(MODE.EQ.1) THEN

        JM1S = JM1
        JM2S = JM2
        NHEPS = NHEP

        XM1 = PHEP(5,JM1)
        XM2 = PHEP(5,JM2)

C  boost into CMS
        P1(1) = PHEP(1,JM1)+PHEP(1,JM2)
        P1(2) = PHEP(2,JM1)+PHEP(2,JM2)
        P1(3) = PHEP(3,JM1)+PHEP(3,JM2)
        P1(4) = PHEP(4,JM1)+PHEP(4,JM2)
        SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
        ECMD = SQRT(SS)
        DO 10 I=1,4
          GAMBED(I) = P1(I)/ECMD
 10     CONTINUE
        CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
     &             PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
     &             PHEP(4,JM1),PTOT1,P1(1),P1(2),P1(3),P1(4))
C  rotation angles
        CODD = P1(3)/PTOT1
        SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
        COFD = 1.D0
        SIFD = 0.D0
        IF(PTOT1*SIDD.GT.1.D-5) THEN
          COFD = P1(1)/(SIDD*PTOT1)
          SIFD = P1(2)/(SIDD*PTOT1)
          ANORF= SQRT(COFD*COFD+SIFD*SIFD)
          COFD = COFD/ANORF
          SIFD = SIFD/ANORF
        ENDIF

C  initial particles in CMS

        P1(1) = 0.D0
        P1(2) = 0.D0
        P1(3) = ECMD/2.D0*XPSUB
        P1(4) = P1(3)

        P2(1) = 0.D0
        P2(2) = 0.D0
        P2(3) = -ECMD/2.D0*XTSUB
        P2(4) = -P2(3)

        CALL PHO_MSHELL(P1,P2,XM1,XM2,P3,P4,IREJ)

        CALL PHO_REGPAR(1,IDHEP(JM1),IMPART(JM1),JM1,JM2,
     &    P3(1),P3(2),P3(3),P3(4),IPHIST(1,JM1),IPHIST(2,JM1),
     &    ICOLOR(1,JM1),ICOLOR(2,JM1),JM1N,1)

        CALL PHO_REGPAR(1,IDHEP(JM2),IMPART(JM2),JM2,JM1,
     &    P4(1),P4(2),P4(3),P4(4),IPHIST(1,JM2),IPHIST(2,JM2),
     &    ICOLOR(1,JM2),ICOLOR(2,JM2),JM2N,1)

        JM1 = JM1N
        JM2 = JM2N

C  transformation into lab.

      ELSE IF(MODE.EQ.2) THEN

        CALL PHO_LTRHEP(JM1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
     &    GAMBED(1),GAMBED(2),GAMBED(3))

        JM1 = JM1S
        JM2 = JM2S

C  clean up after rejection

      ELSE IF(MODE.EQ.-2) THEN

        NHEP = NHEPS

        JM1 = JM1S
        JM2 = JM2S

      ELSE

        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I6)') 'PHO_DFWRAP: invalid MODE parameter:',MODE

      ENDIF

      END


 
 


CDECK  ID>, PHO_DIFDIS
      SUBROUTINE PHO_DIFDIS(IDIF1,IDIF2,IMOTH1,IMOTH2,SPROB,IMODE,
     &                      MSOFT,MHARD,IREJ)
C***********************************************************************
C
C     sampling of diffractive events of different kinds,
C                            (produced particles stored in /POEVT1/)
C
C     input:   IDIF1/2   diffractive process particle 1/2
C                          0   elastic/quasi-elastic scattering
C                          1   diffraction dissociation
C              IMOTH1/2  index of mother particles in /POEVT1/
C              SPROB     suppression factor (survival probability) for
C                        resolved diffraction dissociation
C              IMODE     mode of operation
C                          0  sampling of diffractive cut
C                          1  sampling of enhanced cut
C                          2  sampling of diffractive cut without
C                             scattering (needed for double-pomeron)
C                         -1  initialization
C                         -2  output of statistics
C
C     output:   MSOFT    number of generated soft strings
C               MHARD    number of generated hard strings
C               IDIF1/2  diffraction label for particle 1/2 in /PROCES/
C                          0   quasi elastic scattering
C                          1   low-mass diffractive dissociation
C                          2   soft high-mass diffractive dissociation
C                          3   hard resolved diffractive dissociation
C                          4   hard direct diffractive dissociation
C               IREJ     rejection label
C                          0  successful generation of partons
C                          1  failure
C
C***********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( EPS  = 1.D-7,
     &            DEPS = 1.D-10)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  general process information
      INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
      COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)

C  internal rejection counters
      INTEGER NMXJ
      PARAMETER (NMXJ=60)
      CHARACTER*10 REJTIT
      INTEGER IFAIL
      COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)

C  global event kinematics and particle IDs
      INTEGER IFPAP,IFPAB
      DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
      COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)

C  c.m. kinematics of diffraction
      INTEGER NPOSD
      DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
     &                 SIDD,CODD,SIFD,COFD,PDCMS
      COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
     &                SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)

C  obsolete cut-off information
      DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
      COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  Reggeon phenomenology parameters
      DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
     &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
      COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
     &                ALREG,ALREGP,GR(2),B0REG(2),
     &                GPPP,GPPR,B0PPP,B0PPR,
     &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC

C  parameters of 2x2 channel model
      DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
      COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC

C  table of particle indices for recursive PHOJET calls
      INTEGER MAXIPX
      PARAMETER ( MAXIPX = 500 )
      INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
      COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
     &                IPOIX1,IPOIX2,IPOIX3

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

C  event weights and generated cross section
      INTEGER IPOWGC,ISWCUT,IVWGHT
      DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
      COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
     &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)

      DOUBLE PRECISION P1,P2,XMASS,AMP,PP,PD1,PD2
      DIMENSION P1(5),P2(5),XMASS(2),AMP(2),PP(7,2),PD1(7),PD2(7)
      DIMENSION IDPDG(2),IDBAM(2),IPAR(2),IPOSP(2,2),IRPDG(2),IVEC(2),
     &          IRBAM(2),IFL1P(2),IFL2P(2),ISAM(2),JSAM(2),KSAM(2),
     &          IDIR(2),IPROC(2)

      DOUBLE PRECISION PHO_PMASS
      EXTERNAL         PHO_PMASS

      IF(IMODE.EQ.-1) THEN
C  initialization
        RETURN
      ELSE IF(IMODE.EQ.-2) THEN
C  output of statistics
        RETURN
      ENDIF

      IREJ = 0
C  mass cuts
      PIMASS  = 0.140D0
C  debug output
      IF(IDEB(45).GE.10) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,2A,/16X,7I6)') 'PHO_DIFDIS: (1) ',
     &    'IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
     &    IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE
      ENDIF
      IPAR(1) = IDIF1
      IPAR(2) = IDIF2
C  save current status
      MSOFT = 0
      MHARD = 0
      KHPOMS = KHPOM
      KSPOMS = KSPOM
      KSREGS = KSREG
      KHDIRS = KHDIR
      IPOIS1 = IPOIX1
      IPOIS2 = IPOIX2
      IPOIS3 = IPOIX3
      JDA11 = JDAHEP(1,IMOTH1)
      JDA21 = JDAHEP(2,IMOTH1)
      JDA12 = JDAHEP(1,IMOTH2)
      JDA22 = JDAHEP(2,IMOTH2)
      ISTH1 = ISTHEP(IMOTH1)
      ISTH2 = ISTHEP(IMOTH2)
      NHEPS = NHEP
C  get mother data
      NPOSD(1) = IMOTH1
      NPOSD(2) = IMOTH2
      DO 20 I=1,2
        IDPDG(I) = IDHEP(NPOSD(I))
        IDBAM(I) = IMPART(NPOSD(I))
        IPOSP(1,I) = ICOLOR(1,NPOSD(I))
        IPOSP(2,I) = ICOLOR(2,NPOSD(I))
        AMP(I) = PHO_PMASS(IDBAM(I),0)
        IF(IDPDG(I).EQ.22) THEN
          PMASSD(I) = 0.765D0
          PVIRTD(I) = PHEP(5,NPOSD(I))**2
        ELSE
          PMASSD(I) = PHO_PMASS(IDBAM(I),0)
          PVIRTD(I) = 0.D0
        ENDIF
 20   CONTINUE
C  get CM system
      P1(1) = PHEP(1,IMOTH1)+PHEP(1,IMOTH2)
      P1(2) = PHEP(2,IMOTH1)+PHEP(2,IMOTH2)
      P1(3) = PHEP(3,IMOTH1)+PHEP(3,IMOTH2)
      P1(4) = PHEP(4,IMOTH1)+PHEP(4,IMOTH2)
      SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
      ECMD = SQRT(SS)
      IF (LPRI.GT.4 .AND. IDEB(45).GE.15)
     &WRITE(LO,'(1X,A,E12.4)')
     &  'PHO_DIFDIS: availabe energy',ECMD
C  check total available energy
      IF((AMP(1)+AMP(2)+0.1D0).GE.ECMD) THEN
        IF (LPRI.GT.4 .AND. IDEB(45).GE.2)
     &  WRITE(LO,'(1X,2A,/5X,A,1P,3E11.3)')
     &    'PHO_DIFDIS: ',
     &    'not enough energy for inelastic diffraction',
     &    'ECM, particle masses:',ECMD,AMP
        IFAIL(7) = IFAIL(7)+1
        IREJ = 1
        RETURN
      ENDIF
C  boost into CMS
      DO 10 I=1,4
        GAMBED(I) = P1(I)/ECMD
 10   CONTINUE
      CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
     &           PHEP(1,IMOTH1),PHEP(2,IMOTH1),PHEP(3,IMOTH1),
     &           PHEP(4,IMOTH1),PTOT1,P1(1),P1(2),P1(3),P1(4))
C  rotation angles
      CODD = P1(3)/PTOT1
      SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
      COFD = 1.D0
      SIFD = 0.D0
      IF(PTOT1*SIDD.GT.1.D-5) THEN
        COFD = P1(1)/(SIDD*PTOT1)
        SIFD = P1(2)/(SIDD*PTOT1)
        ANORF= SQRT(COFD*COFD+SIFD*SIFD)
        COFD = COFD/ANORF
        SIFD = SIFD/ANORF
      ENDIF
C  initial particles in CMS
      PDCMS(1,1) = 0.D0
      PDCMS(2,1) = 0.D0
      PDCMS(3,1) = PTOT1
      PDCMS(4,1) = P1(4)
      PDCMS(1,2) = 0.D0
      PDCMS(2,2) = 0.D0
      PDCMS(3,2) = -PTOT1
      PDCMS(4,2) = ECMD-P1(4)
C  get new CM momentum
      AM12 = PMASSD(1)**2
      AM22 = PMASSD(2)**2
      PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)

C  coherence constraint (min/max diffractive mass allowed)
      IF(IMODE.EQ.2) THEN
        THRM1 = PARMDL(71)/SQRT(1-PARMDL(72))
        THRM1 = MAX(THRM1,PARMDL(70)*PARMDL(71))
        THRM2 = SQRT(1-PARMDL(72))*ECMD
        THRM2 = MIN(THRM2,ECMD/PARMDL(70))
      ELSE
        THRM1 = PARMDL(46)
        THRM2 = PARMDL(45)*ECMD
C  check kinematic limits
        IF(THRM2.LE.(4.D0*PARMDL(162))) IPAR(1) = MIN(IPAR(1),1)
        IF(THRM2.LE.(4.D0*PARMDL(163))) IPAR(2) = MIN(IPAR(2),1)
      ENDIF

C  check energy vs. coherence constraints
      IF(MAX(PARMDL(162),PMASSD(1)+THRM1).GE.THRM2) IPAR(1) = 0
      IF(MAX(PARMDL(163),PMASSD(2)+THRM1).GE.THRM2) IPAR(2) = 0

C  no phase space available
      IF(IPAR(1)+IPAR(2).EQ.0) THEN
        IF (LPRI.GT.4 .AND. IDEB(45).GE.2)
     &  WRITE(LO,'(1X,2A,1P,E11.3,2(/5X,A,2E11.3))')
     &    'PHO_DIFDIS: ',
     &    'not enough phase space for ine. diffraction (Ecm)',ECMD,
     &    'side 1: min. mass, upper mass limit:',
     &    MAX(PARMDL(162),PMASSD(1)+THRM1),THRM2,
     &    'side 2: min. mass, upper mass limit:',
     &    MAX(PARMDL(163),PMASSD(2)+THRM1),THRM2
        IFAIL(7) = IFAIL(7)+1
        IREJ = 1
        RETURN
      ENDIF

      ITRY = 0
      ITRYM = 10
      IPARS1 = IPAR(1)
      IPARS2 = IPAR(2)

C  main rejection loop
C -------------------------------
 50   CONTINUE
      ITRY = ITRY+1
      IF(ITRY.GT.1) THEN
        IFAIL(13) = IFAIL(13)+1
        IF(ITRY.GE.ITRYM) THEN
          IF (LPRI.GT.4 .AND. IDEB(45).GE.2)
     &    WRITE(LO,'(1X,A,I10,2I3)')
     &      'PHO_DIFDIS: rejection (KEVE,IPAR1/2) ',KEVENT,IPAR
          IFAIL(7) = IFAIL(7)+1
          IREJ = 1
          RETURN
        ENDIF
      ENDIF
      KSPOM = KSPOMS
      KHPOM = KHPOMS
      KHDIR = KHDIRS
      KSREG = KSREGS
      IPAR(1) = IPARS1
      IPAR(2) = IPARS2
C  reset mother-daugther relations
      NHEP = NHEPS
      JDAHEP(1,IMOTH1) = JDA11
      JDAHEP(2,IMOTH1) = JDA21
      JDAHEP(1,IMOTH2) = JDA12
      JDAHEP(2,IMOTH2) = JDA22
      ISTHEP(IMOTH1) = ISTH1
      ISTHEP(IMOTH2) = ISTH2
      IPOIX1 = IPOIS1
      IPOIX2 = IPOIS2
      IPOIX3 = IPOIS3
C
      NSLP = 0
      NCOR = 0
 55   CONTINUE

C  calculation of kinematics
      DO 100 I=1,2
C  sampling of masses
        IRPDG(I) = 0
        IRBAM(I) = 0
        IFL1P(I) = IDPDG(I)
        IFL2P(I) = IDBAM(I)
        IVEC(I)  = 0
        IDIR(I) = 0
        ISAM(I) = 0
        JSAM(I) = 0
        KSAM(I) = 0
        IF(IPAR(I).EQ.0) THEN
C  vector meson dominance assumed
          XMASS(I) = AMP(I)
          CALL PHO_VECRES(IVEC(I),XMASS(I),IFL1P(I),IFL2P(I))
C  diffraction dissociation
        ELSE IF(IPAR(I).EQ.1) THEN
          XMMIN = MAX(PARMDL(161+I),PMASSD(I)+THRM1)
          PREF2 = PMASSD(I)**2
          XMASS(I) = PHO_DFMASS(XMMIN,THRM2,PREF2,PVIRTD(I),ISWMDL(22))
        ELSE
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,2I3)')
     &      'PHO_DIFDIS:ERROR:invalid IPAR1,IPAR2',IPAR(1),IPAR(2)
          CALL PHO_ABORT
        ENDIF
 100  CONTINUE

C  sampling of momentum transfer
      CALL PHO_DIFSLP(IPAR(1),IPAR(2),IVEC(1),IVEC(2),XMASS(1),XMASS(2),
     &            THRM2,TT,SLWGHT,IREJ)
      IF(IREJ.NE.0) THEN
        NSLP=NSLP+1
        IF(NSLP.LT.100) GOTO 55
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,2A,/10X,2I3,2E12.3)') 'PHO_DIFDIS: ',
     &   'too many slope rejections:IPAR1,IPAR2,M1,M2',IPAR,XMASS
        IREJ = 5
        RETURN
      ENDIF

C  correct for t-M^2 correlation in diffraction
      IF(DT_RNDM(TT).GT.SLWGHT) THEN
        NCOR=NCOR+1
        IF(NCOR.LT.100) GOTO 55
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,2A,I10)') 'PHO_DIFDIS: ',
     &   'too many rejections due to t-M**2 correlation (EVE)',KEVENT
        IREJ = 5
        RETURN
      ENDIF

C  debug output
      IF(IDEB(45).GE.5) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,/5X,2I3,3E12.3)')
     &    'PHO_DIFDIS: IPAR1,IPAR2,XMASS1,XMASS2,TT',IPAR,XMASS,TT
      ENDIF
C  not double pomeron scattering
      IF(IMODE.NE.2) THEN
C  sample diffractive interaction processes
        DO 120 I=1,2
          IF(IPAR(I).NE.0) THEN
C  find particle combination
            IF(IDPDG(I).EQ.IFPAP(1)) THEN
              IP = 2
            ELSE IF(IDPDG(I).EQ.IFPAP(2)) THEN
              IP = 3
            ELSE IF(IDPDG(I).EQ.990) THEN
              IP = 4
            ELSE
              IP = I+1
            ENDIF
C  sample dissociation process
            CALL PHO_DIFPRO(IP,ISWMDL(16),IDPDG(I),990,XMASS(I),
     &        PVIRTD(I),0.D0,SPROB,IPROC(I),ISAM(I),JSAM(I),
     &        KSAM(I),IDIR(I))
            IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
C  store process label
              IF(IDIR(I).GT.0) THEN
                IPAR(I) = 4
              ELSE IF(KSAM(I).GT.0) THEN
                IPAR(I) = 3
              ELSE IF(ISAM(I).GT.0) THEN
                IPAR(I) = 2
              ELSE
                IPAR(I) = 1
C  mass fine correction
                CALL PHO_MASSAD(IDPDG(I),IFL1P(I),IFL2P(I),PMASSD(I),
     &            XMASS(I),XMNEW,IRPDG(I),IRBAM(I))
                XMASS(I) = XMNEW
              ENDIF
            ELSE
C  diffractive pomeron-hadron interaction
              IPAR(I) = 10+IPROC(I)
            ENDIF
C  debug output
            IF (LPRI.GT.4 .AND. IDEB(45).GE.15)
     &      WRITE(LO,'(1X,A,/10X,I3,E12.4,5I3)')
     &        'PHO_DIFDIS: IP,XMASS,IPROC,ISAM,JSAM,KSAM,IDIR',
     &        IP,XMASS(I),IPROC(I),ISAM(I),JSAM(I),KSAM(I),IDIR(I)
          ENDIF
 120    CONTINUE
      ENDIF
C  actualize debug information
      IF(IMODE.EQ.1) THEN
        IDIFR1 = IPAR(1)
        IDIFR2 = IPAR(2)
      ENDIF
C  calculate new momenta in CMS
      CALL PHO_DIFKIN(XMASS(1),XMASS(2),TT,P1,P2,IREJ)
      IF(IREJ.NE.0) GOTO 50
      DO 130 I=1,4
        PP(I,1) = P1(I)
        PP(I,2) = P2(I)
 130  CONTINUE

C  comment line for diffraction
      ICPOS = 0
      CALL PHO_REGPAR(30,IPROCE,IMODE,NPOSD(1),NPOSD(2),XMASS(1),
     &   XMASS(2),TT,ECMD,IPAR(1),IPAR(2),IDPDG(1),IDPDG(2),ICPOS,1)
C  write diffractive strings/particles
      DO 200 I=1,2
        I1 = I
        I2 = 3-I1
        DO K=1,4
          PD1(K) = PP(K,I1)
          PD2(K) = PP(K,I2)
        ENDDO
        PP(6,I1) = SIGN(PHEP(5,NPOSD(I1))**2,PHEP(5,NPOSD(I1)))
        PP(7,I1) = TT
        IGEN = IPHIST(2,NPOSD(I1))
        if(IGEN.eq.0) IGEN = -I1*10
        CALL PHO_DIFPAR(NPOSD(I1),NPOSD(I2),IGEN,IFL1P(I1),IFL2P(I1),
     &    IPAR(I1),PD1,PD2,IPOSP(1,I1),IPOSP(2,I1),IMODE,IREJ)
        IF(IREJ.NE.0) THEN
          IFAIL(7+I) = IFAIL(7+I)+1
          IF (LPRI.GT.4 .AND. IDEB(45).GE.3)
     &    WRITE(LO,'(1X,A,2I3,E11.3)')
     &      'PHO_DIFDIS: rejection by PHO_DIFPAR (I,IPAR,XM)',
     &      I,IPAR(I),XMASS(I)
          GOTO 50
        ENDIF
        ICOLOR(I1,ICPOS) = IPOSP(1,I1)
 200  CONTINUE
C  double-pomeron scattering?
      IF(IMODE.EQ.2) GOTO 150

C  diffractive final states
      DO 300 I=1,2
 110    CONTINUE
        IF(IPAR(I).EQ.0) THEN
C  vector meson production
          IF(IDPDG(I).EQ.22) THEN
            IF(ISWMDL(21).GE.0) THEN
              ISP = IPAMDL(3)
              IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
              CALL PHO_SDECAY(IPOSP(1,I),ISP,2)
            ENDIF
C  hadronic state of multi-pomeron coupling
          ELSE IF(IDPDG(I).EQ.990) THEN
            CALL PHO_SDECAY(IPOSP(1,I),0,2)
          ENDIF
        ELSE
          IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
            IF(ISAM(I)+JSAM(I)+KSAM(I).EQ.0) JSAM(I) = 1
            IF(IDIR(I).GT.0) THEN
              IPAR(I) = 4
            ELSE IF(KSAM(I).GT.0) THEN
              IPAR(I) = 3
            ELSE IF(ISAM(I).GT.0) THEN
              IPAR(I) = 2
            ELSE
              IPAR(I) = 1
            ENDIF
          ELSE
            IPAR(I) = 10+IPROC(I)
          ENDIF
          IPHIST(I,ICPOS) = IPAR(I)
C  update debug informantion
          KSPOM = ISAM(I)
          KSREG = JSAM(I)
          KHPOM = KSAM(I)
          KHDIR = IDIR(I)
          IDIFR1 = IPAR(1)
          IDIFR2 = IPAR(2)
          IF((IRPDG(I).NE.0).AND.(ISWMDL(23).GT.0)) THEN

C  resonance decay, pi+pi- background
            P1(1) = PHEP(1,IPOSP(1,I))+PHEP(1,IPOSP(2,I))
            P1(2) = PHEP(2,IPOSP(1,I))+PHEP(2,IPOSP(2,I))
            P1(3) = PHEP(3,IPOSP(1,I))+PHEP(3,IPOSP(2,I))
            P1(4) = PHEP(4,IPOSP(1,I))+PHEP(4,IPOSP(2,I))
            CALL PHO_REGPAR(1,IRPDG(I),IRBAM(I),IPOSP(1,I),IPOSP(2,I),
     &        P1(1),P1(2),P1(3),P1(4),0,2,0,0,IPOS,1)
C  decay
            IF(IDPDG(I).EQ.22) THEN
              IPHIST(2,IPOS) = 3
              IF(ISWMDL(21).GE.0) THEN
                ISP = IPAMDL(3)
                IF(ISWMDL(21).GE.2) ISP = IPAMDL(4)
                CALL PHO_SDECAY(IPOS,ISP,2)
              ENDIF
            ELSE
              CALL PHO_SDECAY(IPOS,IPAMDL(3),2)
            ENDIF
            IREJ = 0
          ELSE

C  particle-pomeron scattering
            IF(IPAR(I).LE.4) THEN
C  non-diffractive particle-pomeron scattering
              IGEN = IPHIST(2,NPOSD(I))
              if(IGEN.eq.0) then
                if(I.eq.1) then
                  IGEN = 5
                else
                  IGEN = 6
                endif
              endif
              CALL PHO_STDPAR(IPOSP(1,I),IPOSP(2,I),IGEN,
     &          ISAM(I),JSAM(I),KSAM(I),IDIR(I),IREJ)
            ELSE
C  diffractive particle-pomeron scattering
              IPOIX2 = IPOIX2+1
              IPORES(IPOIX2)   = IPROC(I)
              IPOPOS(1,IPOIX2) = IPOSP(1,I)
              IPOPOS(2,IPOIX2) = IPOSP(2,I)
            ENDIF
          ENDIF
        ENDIF

C  rejection?
        IF(IREJ.NE.0) THEN
          IFAIL(20+I) = IFAIL(20+I)+1
          IF(IPAR(I).GT.1) THEN
            IF(IPAR(I).EQ.3) IFAIL(7+2*I) = IFAIL(7+2*I)+1
            IF(IPAR(I).EQ.4) IFAIL(8+2*I) = IFAIL(8+2*I)+1
            IF(IDIR(I).GT.0) THEN
              IDIR(I) = 0
            ELSE IF(KSAM(I).GT.0) THEN
              KSAM(I) = KSAM(I)-1
            ELSE IF(ISAM(I).GT.0) THEN
              ISAM(I) = ISAM(I)-1
            ENDIF
            GOTO 110
          ELSE
            IF (LPRI.GT.4 .AND. IDEB(45).GE.2)
     &      WRITE(LO,'(1X,A,2I3,E11.3)')
     &        'PHO_DIFDIS: rejection PHO_STDPAR (I,IPAR,XM)',
     &        I,IPAR(I),XMASS(I)
            GOTO 50
          ENDIF
        ENDIF
 300  CONTINUE

      IDIF1 = IPAR(1)
      IDIF2 = IPAR(2)
C  update debug information
      KSPOM = KSPOMS+ISAM(1)+ISAM(2)
      KSREG = KSREGS+JSAM(1)+JSAM(2)
      KHPOM = KHPOMS+KSAM(1)+KSAM(2)
      KHDIR = KHDIRS+IDIR(1)+IDIR(2)

 150  CONTINUE

C  debug output
      IF(IDEB(45).GE.10) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,2A,/18X,7I6)') 'PHO_DIFDIS: (2) ',
     &    'IPAR1,IPAR2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
     &    IPAR,NPOSD,MSOFT,MHARD,IMODE
      ENDIF
      IF(IDEB(45).GE.15) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(2(/1X,A))') 'PHO_DIFDIS: output of /POEVT1/',
     &                        '------------------------------'
        CALL PHO_PREVNT(0)
      ENDIF

      END


 
 


CDECK  ID>, PHO_DIFKIN
      SUBROUTINE PHO_DIFKIN(XMP1,XMP2,TT,PMOM1,PMOM2,IREJ)
C**********************************************************************
C
C     calculation of diffractive kinematics
C
C     input:    XMP1         mass of outgoing particle system 1 (GeV)
C               XMP2         mass of outgoing particle system 2 (GeV)
C               TT           momentum transfer    (GeV**2, negative)
C
C     output:   PMOM1(5)     four momentum of outgoing system 1
C               PMOM2(5)     four momentum of outgoing system 2
C               IREJ         0    kinematics consistent
C                            1    kinematics inconsistent
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER(EPS  = 1.D-10,
     &          DEPS = 0.001)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  c.m. kinematics of diffraction
      INTEGER NPOSD
      DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
     &                 SIDD,CODD,SIFD,COFD,PDCMS
      COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
     &                SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

      DOUBLE PRECISION PMOM1,PMOM2
      DIMENSION PMOM1(5),PMOM2(5)

C  debug output
      IF (LPRI.GT.4 .AND. IDEB(49).GT.10)
     &WRITE(LO,'(1X,A,/5X,5E12.4)')
     &    'PHO_DIFKIN: Ecmd,Pcmd,Mini-1,Mini-2,TT:',
     &    ECMD,PCMD,XMP1,XMP2,TT

C  general kinematic constraints
      IREJ = 1
      IF(ECMD.LE.1.1D0*(XMP1+XMP2)) RETURN

C  new squared cms momentum
      XMP12 = XMP1**2
      XMP22 = XMP2**2
      SS = ECMD**2
      PCM2 = PCMD**2
      PCMP2 = PHO_XLAM(SS,XMP12,XMP22)**2/(4.D0*SS)

C  new longitudinal/transverse momentum
      E1I = SQRT(PCM2+PMASSD(1)**2)
      E1F = SQRT(PCMP2+XMP12)
      E2F = SQRT(PCMP2+XMP22)
      PLONG = (TT+PCM2+PCMP2-(E1I-E1F)**2)/(2.D0*PCMD)
      PTRAN = PCMP2-PLONG**2

C  check consistency of kinematics
      IF(PTRAN.LT.0.D0) THEN
        IF(IDEB(49).GE.1) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,2A,I10)') 'PHO_DIFKIN: ',
     &      'inconsistent kinematics in event call: ',KEVENT
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,/5X,1p,6E11.3)')
     &      'PHO_DIFKIN: XMP1,XMP2,TT,PCMP,PLONG,PTRANS',
     &      XMP1,XMP2,TT,SQRT(PCMP2),PLONG,SIGN(SQRT(ABS(PTRAN)),PTRAN)
        ENDIF
        IREJ = 1
        RETURN
      ELSE
        PTRAN = SQRT(PTRAN)
      ENDIF
      XI = PI2*DT_RNDM(PTRAN)

C  outgoing momenta in cm. system
      PMOM1(4) = E1F
      PMOM1(1) = PTRAN*COS(XI)
      PMOM1(2) = PTRAN*SIN(XI)
      PMOM1(3) = PLONG
      PMOM1(5) = XMP1

      PMOM2(4) = E2F
      PMOM2(1) = -PMOM1(1)
      PMOM2(2) = -PMOM1(2)
      PMOM2(3) = -PLONG
      PMOM2(5) = XMP2
      IREJ = 0

C  debug output / precision check
      IF(IDEB(49).GE.0) THEN
C  check kinematics
        XM1 = (PMOM1(4)-PMOM1(3))*(PMOM1(4)+PMOM1(3))
     &        -PMOM1(1)**2-PMOM1(2)**2
        XM1 = SIGN(SQRT(ABS(XM1)),XM1)
        XM2 = (PMOM2(4)-PMOM2(3))*(PMOM2(4)+PMOM2(3))
     &        -PMOM2(1)**2-PMOM2(2)**2
        XM2 = SIGN(SQRT(ABS(XM2)),XM2)
        IF((ABS(XM1-XMP1).GT.DEPS).OR.(ABS(XM1-XMP1).GT.DEPS)) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,2A,/5X,4E11.4)') 'PHO_DIFKIN: ',
     &      'inconsistent masses: MINI-1,MOUT-1,MINI-2,MOUT-2',
     &      XMP1,XM1,XMP2,XM2
          CALL PHO_PREVNT(-1)
        ENDIF
C  output
        IF(IDEB(49).GT.10) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,5E11.3,/1X,A,5E11.3)')
     &      'PHO_DIFKIN: P1',PMOM1,'                 P2',PMOM2
        ENDIF
      ENDIF

      END


 
 


CDECK  ID>, PHO_DIFPAR
      SUBROUTINE PHO_DIFPAR(IMOTH1,IMOTH2,IGENM,IFL1,IFL2,IPAR,P1,P2,
     &                     IPOSH1,IPOSH2,IMODE,IREJ)
C***********************************************************************
C
C     perform string construction for diffraction dissociation
C
C     input:     IMOTH1,2     index of mother particles in POEVT1
C                IGENM        production process of mother particles
C                IFL1,IFL2    particle numbers
C                             (IDPDG,IDBAM for quasi-elas. hadron)
C                IPAR         0  quasi-elasic scattering
C                             1  single string configuration
C                             2  two string configuration
C                P1           massive 4 momentum of first
C                P1(6)        virtuality/squ.mass of particle (GeV**2)
C                P1(7)        virtuality of Pomeron (neg, GeV**2)
C                P2           massive 4 momentum of second particle
C                IMODE        1   diffraction dissociation
C                             2   double-pomeron scattering
C
C     output:    IPOSH1,2     index of the particles in /POEVT1/
C                IREJ         0  successful string construction
C                             1  no string construction possible
C
C***********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      DIMENSION P1(7),P2(7)

      PARAMETER ( EPS  = 1.D-7,
     &            DEPS = 1.D-10)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  internal rejection counters
      INTEGER NMXJ
      PARAMETER (NMXJ=60)
      CHARACTER*10 REJTIT
      INTEGER IFAIL
      COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)

C  c.m. kinematics of diffraction
      INTEGER NPOSD
      DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
     &                 SIDD,CODD,SIFD,COFD,PDCMS
      COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
     &                SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

      DIMENSION PCH1(2,4)
      DATA IC1 /0/
      DATA IC2 /0/

      IREJ = 0
      ILTR1 = NHEP+1
      IGEN = IGENM
      if(IGENM.le.-10) IGEN = 0

C  elastic part
      IF(IPAR.EQ.0) THEN
        IF((IFL1.EQ.92).OR.(IFL1.EQ.91)) THEN
          if(IGEN.eq.0) IGEN = 3
C  pi+/pi- isotropic background
          CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,
     &      P1(1),P1(2),P1(3),P1(4),0,IGEN,0,0,IPOSH1,1)
          CALL PHO_SDECAY(IPOSH1,0,-2)
        ELSE
          if(IGEN.eq.0) then
            IGEN = 2
            if(IFL1.ne.IDHEP(IMOTH1)) IGEN = 3
          endif
C  registration of particle or resonance
          CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,P1(1),P1(2),P1(3),
     &      P1(4),0,IGEN,0,0,IPOSH1,1)
        ENDIF

C  diffraction dissociation
      ELSE IF((IPAR.GE.1).AND.(IPAR.LE.18)) THEN
C  calculation of resulting particle momenta
        IF(IMOTH1.EQ.NPOSD(1)) THEN
          K = 2
        ELSE
          K = 1
        ENDIF
        DO 100 I=1,4
          PCH1(2,I) = PDCMS(I,K)-P2(I)
          PCH1(1,I) = P1(I)-PCH1(2,I)
 100    CONTINUE

C  registration
        if(IMODE.LT.2) then
          if(IGEN.eq.0) IGEN = -IGENM/10+4
          CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,PCH1(1,1),
     &      PCH1(1,2),PCH1(1,3),PCH1(1,4),-1,IGEN,IC1,IC2,IPOSH1,1)
        else
          if(IGEN.eq.0) IGEN = 4
        endif
        CALL PHO_REGPAR(1,990,0,IMOTH2,IMOTH1,PCH1(2,1),PCH1(2,2),
     &    PCH1(2,3),PCH1(2,4),-1,IGEN,IC1,IC2,IPOSH2,1)

C  invalid IPAR
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,I6)') 'PHO_DIFPAR:ERROR: invalid IPAR:',IPAR
        CALL PHO_ABORT
      ENDIF

C  back transformation
      CALL PHO_LTRHEP(ILTR1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
     &  GAMBED(1),GAMBED(2),GAMBED(3))

      END


 
 


CDECK  ID>, PHO_DIFPRO
      SUBROUTINE PHO_DIFPRO(IP,ICUT,ID1,ID2,XMASS,P2V1,P2V2,SPROB,
     &                  IPROC,ISAM,JSAM,KSAM,IDIR)
C*********************************************************************
C
C     sampling of diffraction dissociation process
C
C     input:  IP       particle combination
C             ICUT     user imposed limitations
C             ID1/2    PDG particle code of scattering particles
C             XMASS    diffractively produced mass (GeV)
C             P2V1/2   virtuality of scattering particles (Gev**2)
C             SPROB    suppression factor for resolved single and
C                      double diffraction dissociation
C
C     output: IRPOC    process ID
C             ISAM     number of cut pomerons (soft)
C             JSAM     number of cut reggeons
C             KSAM     number of cut pomerons (hard)
C             IDIR     direct hard interaction
C
C*********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  general process information
      INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
      COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C**anfe COMMON not needed here
C  energy-interpolation table
C      include 'inc/potabl'

      ISAM = 0
      JSAM = 0
      KSAM = 0
      IDIR = 0

      IF(XMASS.GT.3.D0) THEN
C  rapidity gap survival probability
        SPRO = 1.D0
        IF(ISWMDL(28).GE.1) SPRO = SPROB
C  sample interaction
        IPROC = 0
        CALL PHO_SAMPRO(IP,ID1,ID2,XMASS,P2V1,P2V2,SPRO,IPROC)
      ELSE
        IPROC = 1
      ENDIF
      IF(IPROC.EQ.1) CALL PHO_SAMPRB(XMASS,IP,ISAM,JSAM,KSAM)
C  non-diffractive hadron-pomeron interaction
      IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
C  option for suppression of multiple interaction
        IF(ICUT.EQ.0) THEN
          IPROC = 1
          IF(ISAM+KSAM+IDIR.GT.0) THEN
            ISAM = 1
            JSAM = 0
          ELSE
            JSAM = 1
          ENDIF
          KSAM = 0
          IDIR = 0
        ELSE IF(ICUT.EQ.1) THEN
          IF(IDIR.GT.0) THEN
          ELSE IF(KSAM.GT.0) THEN
            KSAM = 1
            ISAM = 0
            JSAM = 0
          ELSE IF(ISAM.GT.0) THEN
            ISAM = 1
            JSAM = 0
          ELSE
            JSAM = 1
          ENDIF
        ELSE IF(ICUT.EQ.2) THEN
          KSAM = MIN(KSAM,1)
        ELSE IF(ICUT.EQ.3) THEN
          ISAM = MIN(ISAM,1)
        ENDIF
      ENDIF
      END


 
 


CDECK  ID>, PHO_DIFRES
      SUBROUTINE PHO_DIFRES(IDMOTH,IVAL1,IVAL2,
     &                  IDPDG,IDBAM,RMASS,RGAM,RWG,LISTL)
C**********************************************************************
C
C     list of resonance states for low mass resonances
C
C     input:   IDMOTH       PDG ID of mother particle
C              IVAL1,2      quarks (photon only)
C
C     output:  IDPDG        list of PDG IDs for possible resonances
C              IDBAM        list of corresponding CPC IDs
C              RMASS        mass
C              RGAMS        decay width
C              RMASS        additional weight factor
C              LISTL        entries in current list
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      DIMENSION  IDPDG(10),IDBAM(10),RMASS(10),RGAM(10),RWG(10)

      PARAMETER (EPS    =  1.D-10,
     &           DEPS   =  1.D-15)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  particle ID translation table
      INTEGER         ID_pdg_list,ID_list,ID_pdg_max
      CHARACTER*12    name_list
      COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
     &                ID_pdg_max

C  general particle data
      DOUBLE PRECISION xm_list,tau_list,gam_list,
     &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
     &  xm_bb82_list,xm_bb102_list
      INTEGER          ich3_list,iba3_list,iq_list,
     &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
      COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
     &  xm_psm2_list(6,6),xm_vem2_list(6,6),
     &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
     &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
     &  ich3_list(300),iba3_list(300),iq_list(3,300),
     &  id_psm_list(6,6),id_vem_list(6,6),
     &  id_b8_list(6,6,6),id_b10_list(6,6,6)

      INTEGER  IPHO_PDG2ID
      EXTERNAL IPHO_PDG2ID
      DIMENSION RWGHT(20),IRPDG(20),IRBAM(20)
      DATA IRPDG /113, 223, 333, 50223, 40113, 60223, 10333, 30113,
     &            12212, 42212, -12212, -42212,
     &            8*0 /
      DATA RWGHT /1.D0, 0.11D0, 0.1D0, 0.11D0, 1.D0, 0.11D0, 0.1D0,
     &            1.D0, 1.D0, 1.D0, 1.D0, 1.D0,
     &            8*1.D0 /

      DATA INIT /0/

C  initialize table
      if(init.eq.0) then
        do i=1,20
          if(IRPDG(i).ne.0) then
            IRBAM(i) = IPHO_PDG2ID(IRPDG(i))
          endif
        enddo
        init = 1
      endif

C  copy table with particles and isospin weights
      LISTL = 0
      IF(IDMOTH.EQ.22) THEN
        I1 = 4
        I2 = 8
      ELSE IF(IDMOTH.EQ.2212) THEN
        I1 = 9
        I2 = 10
      ELSE IF(IDMOTH.EQ.-2212) THEN
        I1 = 11
        I2 = 12
      ELSE
        RETURN
      ENDIF

      DO 100 I=I1,I2
        LISTL = LISTL+1
        IDBAM(LISTL) = IRBAM(I)
        IDPDG(LISTL) = IRPDG(I)
        RMASS(LISTL) = xm_list(abs(IDBAM(LISTL)))
        RGAM(LISTL)  = gam_list(abs(IDBAM(LISTL)))
        RWG(LISTL)   = RWGHT(I)
 100  CONTINUE

C  debug output
      IF(IDEB(85).GE.20) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,3I7)') 'PHO_DIFRES: mother,quarks',IDMOTH,
     &    IVAL1,IVAL2
        DO 200 I=1,LISTL
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,I3,2I7,E12.4)') I,IDBAM(I),IDPDG(I),RMASS(I)
 200    CONTINUE
      ENDIF

      END


 
 


CDECK  ID>, PHO_DIFSLP
      SUBROUTINE PHO_DIFSLP(IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,XMX,
     &                  TT,SLWGHT,IREJ)
C**********************************************************************
C
C     sampling of T  (Mandelstam variable) distribution within
C     certain limits TMIN, TMAX
C
C     input:    IDF1,2     type of diffractive vertex
C                           0   elastic/quasi-elastic scattering
C                           1   diffraction dissociation
C               IVEC1,2    vector meson IDs in case of quasi-elastic
C                          scattering, otherwise 0
C               XM1        mass of diffractive system 1 (GeV)
C               XM2        mass of diffractive system 2 (GeV)
C               XMX        max. mass of diffractive system (GeV)
C
C     output:   TT         squared momentum transfer ( < 0, GeV**2)
C               SLWGHT     weight to allow for mass-dependent slope
C               IREJ       0  successful sampling
C                          1  masses too big for given T range
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER(EPS  = 1.D-10)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  internal rejection counters
      INTEGER NMXJ
      PARAMETER (NMXJ=60)
      CHARACTER*10 REJTIT
      INTEGER IFAIL
      COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)

C  c.m. kinematics of diffraction
      INTEGER NPOSD
      DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
     &                 SIDD,CODD,SIFD,COFD,PDCMS
      COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
     &                SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)

C  cross sections
      INTEGER IPFIL,IFAFIL,IFBFIL
      DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
     &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
     &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
     &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
     &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
      COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
     &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
     &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
     &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
     &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
     &                IPFIL,IFAFIL,IFBFIL

C  Reggeon phenomenology parameters
      DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
     &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
      COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
     &                ALREG,ALREGP,GR(2),B0REG(2),
     &                GPPP,GPPR,B0PPP,B0PPR,
     &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC

C  parameters of 2x2 channel model
      DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
      COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC

C  parameters of the "simple" Vector Dominance Model
      DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
      COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)


      IREJ = 0
      XM12 = XM1**2
      XM22 = XM2**2
      SS = ECMD**2
C
C  range of momentum transfer t
      TMIN = -PARMDL(68)
      TMAX = -PARMDL(69)
C  determine min. abs(t) necessary to produce masses
      PCM2 = PCMD**2
      PCMP2 = PHO_XLAM(SS,XM12,XM22)**2/(4.D0*SS)
      IF(PCMP2.LE.0.D0) THEN
        IREJ = 1
        TT = 0.D0
        RETURN
      ENDIF
      TMINP = PMASSD(1)**2+XM12+2.D0*PCMD*SQRT(PCMP2)
     &        -2.D0*SQRT((PMASSD(1)**2+PCM2)*(XM12+PCMP2))
C
      IF(TMINP.LT.TMAX) THEN
        IF(IDEB(44).GE.3) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
     &      'too large Tmin (XM1/2,TMIN,TMAX,TMINP)',
     &      XM1,XM2,TMIN,TMAX,TMINP
        ENDIF
        IFAIL(32) = IFAIL(32)+1
        IREJ = 1
        TT = 0.D0
        RETURN
      ENDIF
      TMINA = MIN(TMIN,TMINP)
C
C  calculation of slope (mass-dependent parametrization)
      IF(IDF1+IDF2.GT.0) THEN
C  diffraction dissociation
        XMP12 = XM1**2+PVIRTD(1)
        XMP22 = XM2**2+PVIRTD(2)
        XMX1 = SQRT(XMP12)
        XMX2 = SQRT(XMP22)
        CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
        FAC = 4.D0*(PMASSD(1)*PMASSD(2))**2
        SLOPE = DBLE(IDF1+IDF2)*B0PPP
     &    +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
     &    /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
        SLOPE = MAX(SLOPE,1.D0)
C
        XMA1 = XMX
        XMA2 = XMX
        IF(IDF1.EQ.0) THEN
          XMA1 = XM1
c  Typo corrected according to Anatoli:
c       ELSE IF(IDF1.EQ.0) THEN
        ELSE IF(IDF2.EQ.0) THEN
          XMA2 = XM2
        ENDIF
        XMP12 = XMA1**2+PVIRTD(1)
        XMP22 = XMA2**2+PVIRTD(2)
        XMX1 = SQRT(XMP12)
        XMX2 = SQRT(XMP22)
        CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
        SLMIN = DBLE(IDF1+IDF2)*B0PPP
     &    +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
     &    /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
        SLMIN = MAX(SLMIN,1.D0)
      ELSE
C  elastic/quasi-elastic scattering
        IF(ISWMDL(13).EQ.0) THEN
C  external slope values
          IF (LPRI.GT.4)
     &    WRITE(LO,*)'PHO_DIFSLP:ERROR: this option is not installed !'
          CALL PHO_ABORT
        ELSE IF(ISWMDL(13).EQ.1) THEN
C  model slopes
          IF(IVEC1*IVEC2.EQ.0) THEN
            SLOPE = SLOEL
          ELSE
            SLOPE = SLOVM(IVEC1,IVEC2)
          ENDIF
          SLMIN = SLOPE
        ELSE
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,I5)') 'SASDSDT:ERROR: invalid ISWMDL(13)',
     &      ISWMDL(13)
          CALL PHO_ABORT
        ENDIF
      ENDIF
C
C  determine max. abs(t) to avoid underflows
      TMAXP = -25.D0/SLOPE
      TMAXA = MAX(TMAX,TMAXP)
C
      IF(TMINA.LT.TMAXA) THEN
        IF(IDEB(44).GE.3) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
     &      'too small Tmax (XM1/2,TMINA,TMAXA,SLOPE)',
     &      XM1,XM2,TMINA,TMAXA,SLOPE
        ENDIF
        IFAIL(32) = IFAIL(32)+1
        IREJ = 1
        TT = 0.D0
        RETURN
      ENDIF
C
C  sampling from corrected range of T
      TMINE = EXP(SLMIN*TMINA)
      TMAXE = EXP(SLMIN*TMAXA)
      XI = (TMINE-TMAXE)*DT_RNDM(SLMIN)+TMAXE
      TT = LOG(XI)/SLMIN
      SLWGHT = EXP((SLOPE-SLMIN)*TT)
C
C  debug output
      IF(IDEB(44).GE.15) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,1P,E12.3/5X,A,2I2,2X,2I2,2E10.2,/5X,A,5E10.2)')
     &    'PHO_DIFSLP: sampled momentum transfer:',TT,
     &    'IDF1/2,IVEC1/2,XM1/2:',IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,
     &    'Tmi,Tmx,SLMIN,SLOPE,WGHT:',TMINP,TMAXP,SLMIN,SLOPE,SLWGHT
      ENDIF
      END


 
 


CDECK  ID>, PHO_DOR92FS
      DOUBLE PRECISION FUNCTION PHO_DOR92FS(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
      IMPLICIT DOUBLE PRECISION (A - Z)
      SAVE

       DX = SQRT (X)
       LX = LOG (1./X)
       IF (S .LE. ST) THEN
         PHO_DOR92FS = 0.D0
       ELSE
         PHO_DOR92FS = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
     1          * EXP (-E + SQRT (ES * S**BE * LX))

       END IF
      END


 
 


CDECK  ID>, PHO_DOR92FV
      DOUBLE PRECISION FUNCTION PHO_DOR92FV(X,N,AK,AG,B,D)
      IMPLICIT DOUBLE PRECISION (A - Z)
      SAVE
       DX = SQRT (X)
       PHO_DOR92FV = N * X**AK * (1.+ AG*DX + B*X) * (1.- X)**D

      END


 
 


CDECK  ID>, PHO_DOR92FW
      DOUBLE PRECISION FUNCTION PHO_DOR92FW(X,S,
     &                                      AL,BE,AK,BK,AG,BG,C,D,E,ES)
      IMPLICIT DOUBLE PRECISION (A - Z)
      SAVE
       LX = LOG (1./X)
       PHO_DOR92FW = (X**AK * (AG + X * (BG + X*C)) * LX**BK + S**AL
     1      * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D

      END


 
 


CDECK  ID>, PHO_DOR92HO
      SUBROUTINE PHO_DOR92HO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)

      IMPLICIT DOUBLE PRECISION (A - Z)
      SAVE

       MU2  = 0.3
       LAM2 = 0.248 * 0.248
       S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
       DS = SQRT (S)
       S2 = S * S
       S3 = S2 * S
C...X * (UV + DV) :
       NUD  = 0.330 + 0.151 * S - 0.059 * S2 + 0.027 * S3
       AKUD = 0.285
       AGUD = -2.28 + 15.73 * S -  4.58 * S2
       BUD  =  56.7 -  53.6 * S + 11.21 * S2
       DUD  =  3.17 +  1.17 * S -  0.47 * S2 +  0.09 * S3
       UDV  = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
C...X * DV :
       ND  = 0.459 + 0.315 * DS + 0.515 * S
       AKD = 0.624              - 0.031 * S
       AGD =  8.13 -  6.77 * DS +  0.46 * S
       BD  =  6.59 - 12.83 * DS +  5.65 * S
       DD  =  3.98              +  1.04 * S  -  0.34 * S2
       DV  = PHO_DOR92FV (X, ND, AKD, AGD, BD, DD)
C...X * G :
       ALG =  1.128
       BEG =  1.575
       AKG =  0.323 + 1.653 * S
       BKG =  0.811 + 2.044 * S
       AGG =   0.0  + 1.963 * S - 0.519 * S2
       BGG =  0.078 +  6.24 * S
       CG  =  30.77 - 24.19 * S
       DG  =  3.188 + 0.720 * S
       EG  = -0.881 + 2.687 * S
       ESG =  2.466
       GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
C...X * UBAR = X * DBAR :
       ALU =  0.594
       BEU =  0.614
       AKU =  0.636 - 0.084 * S
       BKU =   0.0
       AGU =  1.121 - 0.193 * S
       BGU =  0.751 - 0.785 * S
       CU  =   8.57 - 1.763 * S
       DU  =  10.22 + 0.668 * S
       EU  =  3.784 + 1.280 * S
       ESU =  1.808 + 0.980 * S
       UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
C...X * SBAR = X * S :
       SS  =   0.0
       ALS =  0.756
       BES =  0.101
       AKS =  2.942 - 1.016 * S
       AGS =  -4.60 + 1.167 * S
       BS  =   9.31 - 1.324 * S
       DS  =  11.49 - 1.198 * S + 0.053 * S2
       EST =  2.630 + 1.729 * S
       ESS =   8.12
       SB  = PHO_DOR92FS (X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
C...X * CBAR = X * C :
       SC  =  0.820
       ALC =   0.98
       BEC =   0.0
       AKC = -0.625 - 0.523 * S
       AGC =   0.0
       BC  =  1.896 + 1.616 * S
       DC  =   4.12 + 0.683 * S
       EC  =   4.36 + 1.328 * S
       ESC =  0.677 + 0.679 * S
       CB  = PHO_DOR92FS (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
C...X * BBAR = X * B :
       SBO =  1.297
       ALB =   0.99
       BEB =   0.0
       AKB =   0.0  - 0.193 * S
       AGB =   0.0
       BBO =   0.0
       DB  =  3.447 + 0.927 * S
       EB  =   4.68 + 1.259 * S
       ESB =  1.892 + 2.199 * S
       BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)

      END


 
 


CDECK  ID>, PHO_DOR92LO
*
      SUBROUTINE PHO_DOR92LO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
*
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*                                                                 *
*    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     *
*                                                                 *
*                 FOR A DETAILED EXPLANATION SEE :                *
*              M. GLUECK, E.REYA, A.VOGT: DO-TH 91/07             *
*                                                                 *
*   THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS   *
*   FOR Q ** 2 BETWEEN MU ** 2 (=  0.25 / 0.30  GEV ** 2  IN LO   *
*   / HO) AND  1.E8 GEV ** 2  AND FOR X BETWEEN  1.E-5  AND  1.   *
*   REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG-   *
*   LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT.  *
*                                                                 *
*              HEAVY QUARK THRESHOLDS  Q(H) = M(H) :              *
*         M(C)  =  1.5,  M(B)  =  4.5,  M(T)  =  100  GEV         *
*                                                                 *
*      CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS :     *
*      LO :   LAMBDA(3)  =  0.232,   LAMBDA(4)  =  0.200,         *
*             LAMBDA(5)  =  0.153,   LAMBDA(6)  =  0.082  GEV     *
*      HO :   LAMBDA(3)  =  0.248,   LAMBDA(4)  =  0.200,         *
*             LAMBDA(5)  =  0.131,   LAMBDA(6)  =  0.053  GEV     *
*                                                                 *
*   HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL.  *
*                                                                 *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

      IMPLICIT DOUBLE PRECISION (A - Z)
      SAVE

       MU2  = 0.25
       LAM2 = 0.232 * 0.232
       S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
       S2 = S * S
       S3 = S2 * S
C...X * (UV + DV) :
       NUD  = 0.663 + 0.191 * S - 0.041 * S2 + 0.031 * S3
       AKUD = 0.326
       AGUD = -1.97 +  6.74 * S -  1.96 * S2
       BUD  =  24.4 -  20.7 * S +  4.08 * S2
       DUD  =  2.86 +  0.70 * S -  0.02 * S2
       UDV  = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
C...X * DV :
       ND  = 0.579 + 0.283 * S + 0.047 * S2
       AKD = 0.523 - 0.015 * S
       AGD =  2.22 -  0.59 * S -  0.27 * S2
       BD  =  5.95 -  6.19 * S +  1.55 * S2
       DD  =  3.57 +  0.94 * S -  0.16 * S2
       DV  = PHO_DOR92FV (X,ND,AKD,AGD,BD,DD)
C...X * G :
       ALG =  0.558
       BEG =  1.218
       AKG =   1.00 -  0.17 * S
       BKG =   0.0
       AGG =   0.0  + 4.879 * S - 1.383 * S2
       BGG =  25.92 - 28.97 * S + 5.596 * S2
       CG  = -25.69 + 23.68 * S - 1.975 * S2
       DG  =  2.537 + 1.718 * S + 0.353 * S2
       EG  =  0.595 + 2.138 * S
       ESG =  4.066
       GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
C...X * UBAR = X * DBAR :
       ALU =  1.396
       BEU =  1.331
       AKU =  0.412 - 0.171 * S
       BKU =  0.566 - 0.496 * S
       AGU =  0.363
       BGU = -1.196
       CU  =  1.029 + 1.785 * S - 0.459 * S2
       DU  =  4.696 + 2.109 * S
       EU  =  3.838 + 1.944 * S
       ESU =  2.845
       UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
C...X * SBAR = X * S :
       SS  =   0.0
       ALS =  0.803
       BES =  0.563
       AKS =  2.082 - 0.577 * S
       AGS = -3.055 + 1.024 * S **  0.67
       BS  =   27.4 -  20.0 * S ** 0.154
       DS  =   6.22
       EST =   4.33 + 1.408 * S
       ESS =   8.27 - 0.437 * S
       SB = PHO_DOR92FS(X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
C...X * CBAR = X * C :
       SC  =  0.888
       ALC =   1.01
       BEC =   0.37
       AKC =   0.0
       AGC =   0.0
       BC  =   4.24 - 0.804 * S
       DC  =   3.46 + 1.076 * S
       EC  =   4.61 + 1.490 * S
       ESC =  2.555 + 1.961 * S
       CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
C...X * BBAR = X * B :
       SBO =  1.351
       ALB =   1.00
       BEB =   0.51
       AKB =   0.0
       AGB =   0.0
       BBO =  1.848
       DB  =  2.929 + 1.396 * S
       EB  =   4.71 + 1.514 * S
       ESB =   4.02 + 1.239 * S
       BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)

      END


 
 


CDECK  ID>, PHO_DOR94DI
      SUBROUTINE PHO_DOR94DI (X, Q2, UV, DV, DEL, UDB, SB, GL)
*
*...NLO PARAMETRIZATION (DIS) :
*

      IMPLICIT DOUBLE PRECISION (A - Z)
      SAVE

       MU2  = 0.34
       LAM2 = 0.248 * 0.248
       S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
       DS = SQRT (S)
       S2 = S * S
       S3 = S2 * S
*...UV :
       NU  =  2.484 + 0.116 * S + 0.093 * S2
       AKU =  0.563 - 0.025 * S
       BKU =  0.054 + 0.154 * S
       AU  = -0.326 - 0.058 * S - 0.135 * S2
       BU  = -3.322 + 8.259 * S - 3.119 * S2 + 0.291 * S3
       CU  =  11.52 - 12.99 * S + 3.161 * S2
       DU  =  2.808 + 1.400 * S - 0.557 * S2 + 0.119 * S3
       UV  = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
*...DV :
       ND  =  0.156 - 0.017 * S
       AKD =  0.299 - 0.022 * S
       BKD =  0.259 - 0.015 * S
       AD  =  3.445 + 1.278 * S + 0.326 * S2
       BD  = -6.934 + 37.45 * S - 18.95 * S2 + 1.463 * S3
       CD  =  55.45 - 69.92 * S + 20.78 * S2
       DD  =  3.577 + 1.441 * S - 0.683 * S2 + 0.179 * S3
       DV  = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
*...DEL :
       NE  =  0.099 + 0.019 * S + 0.002 * S2
       AKE =  0.419 - 0.013 * S
       BKE =  1.064 - 0.038 * S
       AE  = -44.00 + 98.70 * S - 14.79 * S2
       BE  =  28.59 - 40.94 * S - 13.66 * S2 + 2.523 * S3
       CE  =  84.57 - 108.8 * S + 31.52 * S2
       DE  =  7.469 + 2.480 * S - 0.866 * S2
       DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
*...UDB :
       ALX =  1.215
       BEX =  0.466
       AKX =  0.326 + 0.150 * S
       BKX =  0.956 + 0.405 * S
       AGX =  0.272
       BGX =  3.794 - 2.359 * DS
       CX  =  2.014
       DX  =  7.941 + 0.534 * DS - 0.940 * S + 0.410 * S2
       EX  =  3.049 + 1.597 * S
       ESX =  4.396 - 4.594 * DS + 3.268 * S
       UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
*...SB :
       ALS =  0.175
       BES =  0.344
       AKS =  1.415 - 0.641 * DS
       AS  =  0.580 - 9.763 * DS + 6.795 * S  - 0.558 * S2
       BS  =  5.617 + 5.709 * DS - 3.972 * S
       DST =  13.78 - 9.581 * S  + 5.370 * S2 - 0.996 * S3
       EST =  4.546 + 0.372 * S2
       ESS =  5.053 - 1.070 * S  + 0.805 * S2
       SB  = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
*...GL :
       ALG =  1.258
       BEG =  1.846
       AKG =  2.423
       BKG =  2.427 + 1.311 * S  - 0.153 * S2
       AG  =  25.09 - 7.935 * S
       BG  = -14.84 - 124.3 * DS + 72.18 * S
       CG  =  590.3 - 173.8 * S
       DG  =  5.196 + 1.857 * S
       EG  = -1.648 + 3.988 * S  - 0.432 * S2
       ESG =  3.232 - 0.542 * S
       GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)

       END


 
 


CDECK  ID>, PHO_DOR94FS
      DOUBLE PRECISION FUNCTION PHO_DOR94FS (X,S,AL,BE,AK,AG,B,D,E,ES)
      IMPLICIT DOUBLE PRECISION (A - Z)
      SAVE

      DX = SQRT (X)
      LX = LOG (1./X)
      PHO_DOR94FS = S**AL / LX**AK * (1.+ AG*DX + B*X) * (1.- X)**D
     1      * EXP (-E + SQRT (ES * S**BE * LX))

      END


 
 


CDECK  ID>, PHO_DOR94FV
      DOUBLE PRECISION FUNCTION PHO_DOR94FV (X,N,AK,BK,A,B,C,D)
*
*...FUNCTIONAL FORMS OF THE PARAMETRIZATIONS :
*
      IMPLICIT DOUBLE PRECISION (A - Z)
      SAVE

       DX = SQRT (X)
       PHO_DOR94FV = N*X**AK*(1.D0+A*X**BK+X*(B+C*DX))*(1.D0-X)**D

      END


 
 


CDECK  ID>, PHO_DOR94FW
      DOUBLE PRECISION FUNCTION PHO_DOR94FW(X,S,AL,BE,AK,BK,
     &                                      A,B,C,D,E,ES)
      IMPLICIT DOUBLE PRECISION (A - Z)
      SAVE

      LX = LOG (1./X)
      PHO_DOR94FW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
     1     * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D

      END


 
 


CDECK  ID>, PHO_DOR94HO
      SUBROUTINE PHO_DOR94HO (X, Q2, UV, DV, DEL, UDB, SB, GL)
*
*...NLO PARAMETRIZATION (MS(BAR)) :
*

      IMPLICIT DOUBLE PRECISION (A - Z)
      SAVE

       MU2  = 0.34
       LAM2 = 0.248 * 0.248
       S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
       DS = SQRT (S)
       S2 = S * S
       S3 = S2 * S
*...UV :
       NU  =  1.304 + 0.863 * S
       AKU =  0.558 - 0.020 * S
       BKU =          0.183 * S
       AU  = -0.113 + 0.283 * S - 0.321 * S2
       BU  =  6.843 - 5.089 * S + 2.647 * S2 - 0.527 * S3
       CU  =  7.771 - 10.09 * S + 2.630 * S2
       DU  =  3.315 + 1.145 * S - 0.583 * S2 + 0.154 * S3
       UV  = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
*...DV :
       ND  =  0.102 - 0.017 * S + 0.005 * S2
       AKD =  0.270 - 0.019 * S
       BKD =  0.260
       AD  =  2.393 + 6.228 * S - 0.881 * S2
       BD  =  46.06 + 4.673 * S - 14.98 * S2 + 1.331 * S3
       CD  =  17.83 - 53.47 * S + 21.24 * S2
       DD  =  4.081 + 0.976 * S - 0.485 * S2 + 0.152 * S3
       DV  = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
*...DEL :
       NE  =  0.070 + 0.042 * S - 0.011 * S2 + 0.004 * S3
       AKE =  0.409 - 0.007 * S
       BKE =  0.782 + 0.082 * S
       AE  = -29.65 + 26.49 * S + 5.429 * S2
       BE  =  90.20 - 74.97 * S + 4.526 * S2
       CE  =  0.0
       DE  =  8.122 + 2.120 * S - 1.088 * S2 + 0.231 * S3
       DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
*...UDB :
       ALX =  0.877
       BEX =  0.561
       AKX =  0.275
       BKX =  0.0
       AGX =  0.997
       BGX =  3.210 - 1.866 * S
       CX  =  7.300
       DX  =  9.010 + 0.896 * DS + 0.222 * S2
       EX  =  3.077 + 1.446 * S
       ESX =  3.173 - 2.445 * DS + 2.207 * S
       UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
*...SB :
       ALS =  0.756
       BES =  0.216
       AKS =  1.690 + 0.650 * DS - 0.922 * S
       AS  = -4.329 + 1.131 * S
       BS  =  9.568 - 1.744 * S
       DST =  9.377 + 1.088 * DS - 1.320 * S + 0.130 * S2
       EST =  3.031 + 1.639 * S
       ESS =  5.837 + 0.815 * S
       SB  = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
*...GL :
       ALG =  1.014
       BEG =  1.738
       AKG =  1.724 + 0.157 * S
       BKG =  0.800 + 1.016 * S
       AG  =  7.517 - 2.547 * S
       BG  =  34.09 - 52.21 * DS + 17.47 * S
       CG  =  4.039 + 1.491 * S
       DG  =  3.404 + 0.830 * S
       EG  = -1.112 + 3.438 * S  - 0.302 * S2
       ESG =  3.256 - 0.436 * S
       GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)

       END


 
 


CDECK  ID>, PHO_DOR94LO
      SUBROUTINE PHO_DOR94LO (X, Q2, UV, DV, DEL, UDB, SB, GL)
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*                                                                 *
*    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     *
*                                                                 *
*                         1994 UPDATE                             *
*                                                                 *
*                 FOR A DETAILED EXPLANATION SEE                  *
*                   M. GLUECK, E.REYA, A.VOGT :                   *
*                   DO-TH 94/24  =  DESY 94-206                   *
*                    (TO APPEAR IN Z. PHYS. C)                    *
*                                                                 *
*   THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR    *
*        Q**2 / GEV**2  BETWEEN   0.4   AND  1.E6                 *
*             X         BETWEEN  1.E-5  AND   1.                  *
*   LARGE-X REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION   *
*   IS NEGLIGIBLY SMALL, WERE EXCLUDED FROM THE FIT.              *
*                                                                 *
*   HEAVY QUARK THRESHOLDS  Q(H) = M(H)  IN THE BETA FUNCTION :   *
*                   M(C)  =  1.5,  M(B)  =  4.5                   *
*   CORRESPONDING LAMBDA(F) VALUES IN GEV FOR  Q**2 > M(H)**2 :   *
*      LO :   LAMBDA(3)  =  0.232,   LAMBDA(4)  =  0.200,         *
*             LAMBDA(5)  =  0.153,                                *
*      NLO :  LAMBDA(3)  =  0.248,   LAMBDA(4)  =  0.200,         *
*             LAMBDA(5)  =  0.131.                                *
*   THE NUMBER OF ACTIVE QUARK FLAVOURS IS  NF = 3  EVERYWHERE    *
*   EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,...    *
*   ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION.               *
*   IF NEEDED, HEAVY QUARK DENSITIES CAN BE TAKEN FROM THE 1991   *
*   GRV PARAMETRIZATION.                                          *
*                                                                 *
*   NLO DISTRIBUTIONS ARE GIVEN IN MS-BAR FACTORIZATION SCHEME    *
*   (SUBROUTINE GRV94HO) AS WELL AS IN THE DIS SCHEME (GRV94DI),  *
*   THE LEADING ORDER PARAMETRIZATION IS PROVIDED BY "GRV94LO".   *
*                                                                 *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*
*...INPUT PARAMETERS :
*
*    X   = MOMENTUM FRACTION
*    Q2  = SCALE Q**2 IN GEV**2
*
*...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION) :
*
*    UV  = U(VAL) = U - U(BAR)
*    DV  = D(VAL) = D - D(BAR)
*    DEL = D(BAR) - U(BAR)
*    UDB = U(BAR) + D(BAR)
*    SB  = S = S(BAR)
*    GL  = GLUON
*
*...LO PARAMETRIZATION :
*
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

      IMPLICIT DOUBLE PRECISION (A - Z)
      SAVE

       MU2  = 0.23
       LAM2 = 0.2322 * 0.2322
       S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
       DS = SQRT (S)
       S2 = S * S
       S3 = S2 * S
*...UV :
       NU  =  2.284 + 0.802 * S + 0.055 * S2
       AKU =  0.590 - 0.024 * S
       BKU =  0.131 + 0.063 * S
       AU  = -0.449 - 0.138 * S - 0.076 * S2
       BU  =  0.213 + 2.669 * S - 0.728 * S2
       CU  =  8.854 - 9.135 * S + 1.979 * S2
       DU  =  2.997 + 0.753 * S - 0.076 * S2
       UV  = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
*...DV :
       ND  =  0.371 + 0.083 * S + 0.039 * S2
       AKD =  0.376
       BKD =  0.486 + 0.062 * S
       AD  = -0.509 + 3.310 * S - 1.248 * S2
       BD  =  12.41 - 10.52 * S + 2.267 * S2
       CD  =  6.373 - 6.208 * S + 1.418 * S2
       DD  =  3.691 + 0.799 * S - 0.071 * S2
       DV  = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
*...DEL :
       NE  =  0.082 + 0.014 * S + 0.008 * S2
       AKE =  0.409 - 0.005 * S
       BKE =  0.799 + 0.071 * S
       AE  = -38.07 + 36.13 * S - 0.656 * S2
       BE  =  90.31 - 74.15 * S + 7.645 * S2
       CE  =  0.0
       DE  =  7.486 + 1.217 * S - 0.159 * S2
       DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
*...UDB :
       ALX =  1.451
       BEX =  0.271
       AKX =  0.410 - 0.232 * S
       BKX =  0.534 - 0.457 * S
       AGX =  0.890 - 0.140 * S
       BGX = -0.981
       CX  =  0.320 + 0.683 * S
       DX  =  4.752 + 1.164 * S + 0.286 * S2
       EX  =  4.119 + 1.713 * S
       ESX =  0.682 + 2.978 * S
       UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
*...SB :
       ALS =  0.914
       BES =  0.577
       AKS =  1.798 - 0.596 * S
       AS  = -5.548 + 3.669 * DS - 0.616 * S
       BS  =  18.92 - 16.73 * DS + 5.168 * S
       DST =  6.379 - 0.350 * S  + 0.142 * S2
       EST =  3.981 + 1.638 * S
       ESS =  6.402
       SB  = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
*...GL :
       ALG =  0.524
       BEG =  1.088
       AKG =  1.742 - 0.930 * S
       BKG =        - 0.399 * S2
       AG  =  7.486 - 2.185 * S
       BG  =  16.69 - 22.74 * S  + 5.779 * S2
       CG  = -25.59 + 29.71 * S  - 7.296 * S2
       DG  =  2.792 + 2.215 * S  + 0.422 * S2 - 0.104 * S3
       EG  =  0.807 + 2.005 * S
       ESG =  3.841 + 0.316 * S
       GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)

       END


 
 


CDECK  ID>, PHO_DOR98LO
      SUBROUTINE PHO_DOR98LO (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
C***********************************************************************
C
C   GRV98 parton densities, leading order set
C
C                  For a detailed explanation see
C                   M. Glueck, E. Reya, A. Vogt :
C        hep-ph/9806404  =  DO-TH 98/07  =  WUE-ITP-98-019
C                  (To appear in Eur. Phys. J. C)
C
C   interpolation routine based on the original GRV98PA routine,
C   adapted to define interpolation table as DATA statements
C
C                                                   (R.Engel, 09/98)
C
C
C   INPUT:   X  =  Bjorken-x        (between  1.E-9 and 1.)
C            Q2 =  scale in GeV**2  (between  0.8 and 1.E6)
C
C   OUTPUT:  UV = u - u(bar),  DV = d - d(bar),  US = u(bar),
C            DS = d(bar),  SS = s = s(bar),  GL = gluon.
C            Always x times the distribution is returned.
C
C******************************************************i****************
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

      PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
      DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
     1          XSF(NX,NQ), XGF(NX,NQ),
     2          XT(NARG), NA(NARG), ARRF(NX+NQ)

      DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
     &  XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)

      EQUIVALENCE (XUVF(1,1),XUVF_L(1))
      EQUIVALENCE (XDVF(1,1),XDVF_L(1))
      EQUIVALENCE (XDEF(1,1),XDEF_L(1))
      EQUIVALENCE (XUDF(1,1),XUDF_L(1))
      EQUIVALENCE (XSF(1,1),XSF_L(1))
      EQUIVALENCE (XGF(1,1),XGF_L(1))

      DATA (ARRF(K),K=    1,   95) /
     &  -2.0723D+01,-2.0135D+01,-1.9560D+01,-1.8983D+01,-1.8421D+01,
     &  -1.7833D+01,-1.7258D+01,-1.6680D+01,-1.6118D+01,-1.5530D+01,
     &  -1.4955D+01,-1.4378D+01,-1.3816D+01,-1.3479D+01,-1.3122D+01,
     &  -1.2717D+01,-1.2311D+01,-1.1913D+01,-1.1513D+01,-1.1176D+01,
     &  -1.0820D+01,-1.0414D+01,-1.0009D+01,-9.6108D+00,-9.2103D+00,
     &  -8.8739D+00,-8.5172D+00,-8.1117D+00,-7.7063D+00,-7.3082D+00,
     &  -6.9078D+00,-6.5713D+00,-6.2146D+00,-5.8091D+00,-5.4037D+00,
     &  -5.0056D+00,-4.6052D+00,-4.2687D+00,-3.9120D+00,-3.5066D+00,
     &  -3.1011D+00,-2.8134D+00,-2.5257D+00,-2.3026D+00,-2.0794D+00,
     &  -1.8971D+00,-1.7430D+00,-1.6094D+00,-1.4917D+00,-1.3863D+00,
     &  -1.2910D+00,-1.2040D+00,-1.1239D+00,-1.0498D+00,-9.8083D-01,
     &  -9.1629D-01,-7.9851D-01,-6.9315D-01,-5.9784D-01,-5.1083D-01,
     &  -4.3078D-01,-3.5667D-01,-2.8768D-01,-2.2314D-01,-1.6252D-01,
     &  -1.0536D-01,-5.1293D-02, 0.0000D+00,-2.2314D-01, 0.0000D+00,
     &   2.6236D-01, 5.8779D-01, 9.9325D-01, 1.3863D+00, 1.8563D+00,
     &   2.3026D+00, 2.7726D+00, 3.2189D+00, 3.6889D+00, 4.1589D+00,
     &   4.6052D+00, 5.1930D+00, 5.7683D+00, 6.3456D+00, 6.9078D+00,
     &   7.4955D+00, 8.0709D+00, 8.6482D+00, 9.2103D+00, 9.9988D+00,
     &   1.0736D+01, 1.1513D+01, 1.2301D+01, 1.3039D+01, 1.3816D+01/
      DATA (XUVF_L(K),K=    1,  114) /
     &2.3186D+00,2.2915D+00,2.2645D+00,2.2385D+00,2.2140D+00,2.1876D+00,
     &2.1623D+00,2.1366D+00,2.1121D+00,2.0862D+00,2.0612D+00,2.0358D+00,
     &2.0110D+00,1.9963D+00,1.9806D+00,1.9624D+00,1.9446D+00,1.9263D+00,
     &1.9072D+00,1.8904D+00,1.8724D+00,1.8515D+00,1.8294D+00,1.8085D+00,
     &1.7865D+00,1.7680D+00,1.7483D+00,1.7249D+00,1.6993D+00,1.6715D+00,
     &1.6385D+00,1.6141D+00,1.5884D+00,1.5597D+00,1.5337D+00,1.5121D+00,
     &1.4985D+00,1.4980D+00,1.5116D+00,1.5555D+00,1.6432D+00,1.7434D+00,
     &1.8861D+00,2.0327D+00,2.2174D+00,2.4015D+00,2.5849D+00,2.7671D+00,
     &2.9488D+00,3.1308D+00,3.3142D+00,3.4998D+00,3.6885D+00,3.8826D+00,
     &4.0815D+00,4.2069D+00,4.5481D+00,4.8830D+00,5.2116D+00,5.5351D+00,
     &5.8553D+00,6.1665D+00,6.4745D+00,6.7767D+00,7.0735D+00,7.3628D+00,
     &7.6283D+00,0.0000D+00,2.3948D+00,2.3665D+00,2.3388D+00,2.3126D+00,
     &2.2860D+00,2.2592D+00,2.2327D+00,2.2065D+00,2.1810D+00,2.1541D+00,
     &2.1284D+00,2.1020D+00,2.0760D+00,2.0605D+00,2.0443D+00,2.0259D+00,
     &2.0068D+00,1.9873D+00,1.9676D+00,1.9500D+00,1.9312D+00,1.9081D+00,
     &1.8860D+00,1.8635D+00,1.8406D+00,1.8221D+00,1.8007D+00,1.7764D+00,
     &1.7489D+00,1.7195D+00,1.6855D+00,1.6600D+00,1.6332D+00,1.6031D+00,
     &1.5760D+00,1.5532D+00,1.5397D+00,1.5376D+00,1.5507D+00,1.5929D+00,
     &1.6784D+00,1.7759D+00,1.9129D+00,2.0531D+00,2.2292D+00,2.4032D+00/
      DATA (XUVF_L(K),K=  115,  228) /
     &2.5752D+00,2.7449D+00,2.9135D+00,3.0810D+00,3.2491D+00,3.4183D+00,
     &3.5898D+00,3.7650D+00,3.9437D+00,4.0443D+00,4.3402D+00,4.6262D+00,
     &4.9009D+00,5.1640D+00,5.4156D+00,5.6530D+00,5.8759D+00,6.0779D+00,
     &6.2540D+00,6.3836D+00,6.4062D+00,0.0000D+00,2.4808D+00,2.4513D+00,
     &2.4236D+00,2.3948D+00,2.3680D+00,2.3397D+00,2.3127D+00,2.2853D+00,
     &2.2585D+00,2.2307D+00,2.2026D+00,2.1762D+00,2.1490D+00,2.1332D+00,
     &2.1164D+00,2.0964D+00,2.0766D+00,2.0565D+00,2.0353D+00,2.0171D+00,
     &1.9969D+00,1.9738D+00,1.9501D+00,1.9258D+00,1.9026D+00,1.8821D+00,
     &1.8594D+00,1.8330D+00,1.8046D+00,1.7734D+00,1.7378D+00,1.7112D+00,
     &1.6829D+00,1.6514D+00,1.6228D+00,1.5994D+00,1.5840D+00,1.5808D+00,
     &1.5927D+00,1.6334D+00,1.7157D+00,1.8093D+00,1.9406D+00,2.0735D+00,
     &2.2394D+00,2.4019D+00,2.5615D+00,2.7178D+00,2.8718D+00,3.0246D+00,
     &3.1766D+00,3.3284D+00,3.4820D+00,3.6370D+00,3.7952D+00,3.8716D+00,
     &4.1225D+00,4.3580D+00,4.5798D+00,4.7847D+00,4.9730D+00,5.1395D+00,
     &5.2832D+00,5.3945D+00,5.4634D+00,5.4612D+00,5.2940D+00,0.0000D+00,
     &2.5823D+00,2.5527D+00,2.5226D+00,2.4928D+00,2.4650D+00,2.4358D+00,
     &2.4071D+00,2.3783D+00,2.3505D+00,2.3212D+00,2.2928D+00,2.2636D+00,
     &2.2360D+00,2.2185D+00,2.2005D+00,2.1801D+00,2.1591D+00,2.1376D+00,
     &2.1153D+00,2.0960D+00,2.0747D+00,2.0505D+00,2.0247D+00,1.9991D+00/
      DATA (XUVF_L(K),K=  229,  342) /
     &1.9746D+00,1.9523D+00,1.9287D+00,1.9000D+00,1.8693D+00,1.8361D+00,
     &1.7994D+00,1.7711D+00,1.7409D+00,1.7076D+00,1.6772D+00,1.6517D+00,
     &1.6345D+00,1.6302D+00,1.6408D+00,1.6789D+00,1.7574D+00,1.8457D+00,
     &1.9692D+00,2.0939D+00,2.2474D+00,2.3969D+00,2.5419D+00,2.6837D+00,
     &2.8216D+00,2.9573D+00,3.0915D+00,3.2246D+00,3.3583D+00,3.4917D+00,
     &3.6273D+00,3.6791D+00,3.8823D+00,4.0673D+00,4.2350D+00,4.3813D+00,
     &4.5072D+00,4.6083D+00,4.6757D+00,4.7055D+00,4.6825D+00,4.5674D+00,
     &4.2566D+00,0.0000D+00,2.7025D+00,2.6705D+00,2.6393D+00,2.6093D+00,
     &2.5790D+00,2.5484D+00,2.5184D+00,2.4880D+00,2.4590D+00,2.4277D+00,
     &2.3971D+00,2.3669D+00,2.3380D+00,2.3200D+00,2.3002D+00,2.2782D+00,
     &2.2557D+00,2.2331D+00,2.2092D+00,2.1887D+00,2.1660D+00,2.1400D+00,
     &2.1126D+00,2.0859D+00,2.0586D+00,2.0351D+00,2.0094D+00,1.9786D+00,
     &1.9453D+00,1.9096D+00,1.8707D+00,1.8406D+00,1.8084D+00,1.7728D+00,
     &1.7392D+00,1.7128D+00,1.6933D+00,1.6875D+00,1.6949D+00,1.7295D+00,
     &1.8023D+00,1.8845D+00,1.9991D+00,2.1134D+00,2.2525D+00,2.3868D+00,
     &2.5160D+00,2.6405D+00,2.7609D+00,2.8781D+00,2.9929D+00,3.1059D+00,
     &3.2180D+00,3.3292D+00,3.4407D+00,3.4675D+00,3.6225D+00,3.7573D+00,
     &3.8710D+00,3.9617D+00,4.0270D+00,4.0642D+00,4.0675D+00,4.0263D+00,
     &3.9240D+00,3.7262D+00,3.3217D+00,0.0000D+00,2.8135D+00,2.7813D+00/
      DATA (XUVF_L(K),K=  343,  456) /
     &2.7489D+00,2.7166D+00,2.6850D+00,2.6527D+00,2.6212D+00,2.5898D+00,
     &2.5592D+00,2.5267D+00,2.4943D+00,2.4636D+00,2.4320D+00,2.4129D+00,
     &2.3929D+00,2.3695D+00,2.3453D+00,2.3211D+00,2.2959D+00,2.2740D+00,
     &2.2496D+00,2.2221D+00,2.1931D+00,2.1653D+00,2.1356D+00,2.1112D+00,
     &2.0830D+00,2.0503D+00,2.0147D+00,1.9766D+00,1.9361D+00,1.9037D+00,
     &1.8696D+00,1.8318D+00,1.7966D+00,1.7677D+00,1.7459D+00,1.7378D+00,
     &1.7430D+00,1.7738D+00,1.8407D+00,1.9169D+00,2.0223D+00,2.1273D+00,
     &2.2537D+00,2.3742D+00,2.4892D+00,2.5990D+00,2.7043D+00,2.8056D+00,
     &2.9038D+00,3.0000D+00,3.0936D+00,3.1864D+00,3.2782D+00,3.2867D+00,
     &3.4021D+00,3.4971D+00,3.5691D+00,3.6188D+00,3.6422D+00,3.6335D+00,
     &3.5908D+00,3.5036D+00,3.3552D+00,3.1085D+00,2.6634D+00,0.0000D+00,
     &2.9406D+00,2.9062D+00,2.8726D+00,2.8385D+00,2.8060D+00,2.7720D+00,
     &2.7392D+00,2.7058D+00,2.6734D+00,2.6399D+00,2.6057D+00,2.5722D+00,
     &2.5390D+00,2.5194D+00,2.4975D+00,2.4728D+00,2.4471D+00,2.4216D+00,
     &2.3945D+00,2.3712D+00,2.3458D+00,2.3152D+00,2.2856D+00,2.2545D+00,
     &2.2237D+00,2.1966D+00,2.1672D+00,2.1312D+00,2.0926D+00,2.0521D+00,
     &2.0093D+00,1.9748D+00,1.9384D+00,1.8975D+00,1.8601D+00,1.8275D+00,
     &1.8036D+00,1.7924D+00,1.7948D+00,1.8206D+00,1.8808D+00,1.9499D+00,
     &2.0450D+00,2.1390D+00,2.2512D+00,2.3570D+00,2.4564D+00,2.5501D+00/
      DATA (XUVF_L(K),K=  457,  570) /
     &2.6391D+00,2.7240D+00,2.8053D+00,2.8834D+00,2.9590D+00,3.0326D+00,
     &3.1042D+00,3.0942D+00,3.1727D+00,3.2289D+00,3.2628D+00,3.2739D+00,
     &3.2574D+00,3.2103D+00,3.1297D+00,3.0047D+00,2.8211D+00,2.5467D+00,
     &2.0897D+00,0.0000D+00,3.0557D+00,3.0193D+00,2.9840D+00,2.9497D+00,
     &2.9150D+00,2.8801D+00,2.8454D+00,2.8109D+00,2.7771D+00,2.7412D+00,
     &2.7065D+00,2.6716D+00,2.6360D+00,2.6149D+00,2.5923D+00,2.5663D+00,
     &2.5395D+00,2.5120D+00,2.4834D+00,2.4589D+00,2.4330D+00,2.4011D+00,
     &2.3676D+00,2.3363D+00,2.3027D+00,2.2736D+00,2.2422D+00,2.2040D+00,
     &2.1629D+00,2.1194D+00,2.0750D+00,2.0384D+00,1.9996D+00,1.9565D+00,
     &1.9160D+00,1.8811D+00,1.8541D+00,1.8409D+00,1.8399D+00,1.8611D+00,
     &1.9143D+00,1.9764D+00,2.0622D+00,2.1459D+00,2.2457D+00,2.3385D+00,
     &2.4249D+00,2.5051D+00,2.5806D+00,2.6515D+00,2.7182D+00,2.7823D+00,
     &2.8427D+00,2.9008D+00,2.9564D+00,2.9332D+00,2.9828D+00,3.0094D+00,
     &3.0142D+00,2.9955D+00,2.9537D+00,2.8796D+00,2.7735D+00,2.6260D+00,
     &2.4242D+00,2.1388D+00,1.6900D+00,0.0000D+00,3.1718D+00,3.1348D+00,
     &3.0971D+00,3.0610D+00,3.0260D+00,2.9896D+00,2.9533D+00,2.9173D+00,
     &2.8818D+00,2.8449D+00,2.8072D+00,2.7709D+00,2.7340D+00,2.7121D+00,
     &2.6877D+00,2.6605D+00,2.6319D+00,2.6032D+00,2.5732D+00,2.5471D+00,
     &2.5180D+00,2.4851D+00,2.4511D+00,2.4170D+00,2.3817D+00,2.3505D+00/
      DATA (XUVF_L(K),K=  571,  684) /
     &2.3172D+00,2.2762D+00,2.2328D+00,2.1868D+00,2.1400D+00,2.1012D+00,
     &2.0601D+00,2.0136D+00,1.9704D+00,1.9335D+00,1.9035D+00,1.8868D+00,
     &1.8827D+00,1.8990D+00,1.9452D+00,2.0005D+00,2.0763D+00,2.1507D+00,
     &2.2377D+00,2.3179D+00,2.3917D+00,2.4592D+00,2.5218D+00,2.5799D+00,
     &2.6336D+00,2.6843D+00,2.7314D+00,2.7753D+00,2.8166D+00,2.7824D+00,
     &2.8054D+00,2.8081D+00,2.7893D+00,2.7474D+00,2.6818D+00,2.5888D+00,
     &2.4646D+00,2.3032D+00,2.0902D+00,1.8025D+00,1.3740D+00,0.0000D+00,
     &3.2793D+00,3.2385D+00,3.2014D+00,3.1643D+00,3.1270D+00,3.0888D+00,
     &3.0517D+00,3.0141D+00,2.9773D+00,2.9392D+00,2.9009D+00,2.8610D+00,
     &2.8230D+00,2.8000D+00,2.7754D+00,2.7459D+00,2.7163D+00,2.6858D+00,
     &2.6545D+00,2.6270D+00,2.5962D+00,2.5617D+00,2.5271D+00,2.4903D+00,
     &2.4527D+00,2.4207D+00,2.3851D+00,2.3421D+00,2.2960D+00,2.2476D+00,
     &2.1987D+00,2.1578D+00,2.1146D+00,2.0670D+00,2.0202D+00,1.9796D+00,
     &1.9468D+00,1.9282D+00,1.9203D+00,1.9319D+00,1.9712D+00,2.0197D+00,
     &2.0872D+00,2.1524D+00,2.2288D+00,2.2981D+00,2.3606D+00,2.4177D+00,
     &2.4692D+00,2.5159D+00,2.5591D+00,2.5981D+00,2.6339D+00,2.6669D+00,
     &2.6962D+00,2.6528D+00,2.6566D+00,2.6395D+00,2.6028D+00,2.5437D+00,
     &2.4622D+00,2.3555D+00,2.2200D+00,2.0488D+00,1.8335D+00,1.5506D+00,
     &1.1442D+00,0.0000D+00,3.3868D+00,3.3470D+00,3.3075D+00,3.2689D+00/
      DATA (XUVF_L(K),K=  685,  798) /
     &3.2300D+00,3.1909D+00,3.1517D+00,3.1129D+00,3.0747D+00,3.0335D+00,
     &2.9946D+00,2.9537D+00,2.9140D+00,2.8896D+00,2.8638D+00,2.8337D+00,
     &2.8021D+00,2.7705D+00,2.7373D+00,2.7075D+00,2.6767D+00,2.6403D+00,
     &2.6031D+00,2.5649D+00,2.5258D+00,2.4917D+00,2.4537D+00,2.4080D+00,
     &2.3597D+00,2.3091D+00,2.2580D+00,2.2150D+00,2.1692D+00,2.1186D+00,
     &2.0701D+00,2.0257D+00,1.9901D+00,1.9679D+00,1.9571D+00,1.9629D+00,
     &1.9955D+00,2.0378D+00,2.0963D+00,2.1529D+00,2.2178D+00,2.2766D+00,
     &2.3287D+00,2.3749D+00,2.4162D+00,2.4529D+00,2.4850D+00,2.5140D+00,
     &2.5392D+00,2.5617D+00,2.5798D+00,2.5298D+00,2.5151D+00,2.4811D+00,
     &2.4282D+00,2.3561D+00,2.2611D+00,2.1439D+00,2.0005D+00,1.8252D+00,
     &1.6091D+00,1.3345D+00,9.5375D-01,0.0000D+00,3.4912D+00,3.4507D+00,
     &3.4100D+00,3.3696D+00,3.3310D+00,3.2893D+00,3.2496D+00,3.2088D+00,
     &3.1686D+00,3.1278D+00,3.0865D+00,3.0438D+00,3.0020D+00,2.9766D+00,
     &2.9494D+00,2.9180D+00,2.8850D+00,2.8520D+00,2.8174D+00,2.7877D+00,
     &2.7550D+00,2.7169D+00,2.6762D+00,2.6369D+00,2.5958D+00,2.5594D+00,
     &2.5195D+00,2.4721D+00,2.4211D+00,2.3680D+00,2.3145D+00,2.2695D+00,
     &2.2214D+00,2.1684D+00,2.1154D+00,2.0706D+00,2.0303D+00,2.0058D+00,
     &1.9909D+00,1.9920D+00,2.0177D+00,2.0531D+00,2.1031D+00,2.1511D+00,
     &2.2060D+00,2.2548D+00,2.2972D+00,2.3339D+00,2.3655D+00,2.3927D+00/
      DATA (XUVF_L(K),K=  799,  912) /
     &2.4159D+00,2.4357D+00,2.4520D+00,2.4644D+00,2.4735D+00,2.4171D+00,
     &2.3878D+00,2.3397D+00,2.2743D+00,2.1907D+00,2.0861D+00,1.9611D+00,
     &1.8128D+00,1.6351D+00,1.4227D+00,1.1584D+00,8.0371D-01,0.0000D+00,
     &3.5892D+00,3.5473D+00,3.5055D+00,3.4637D+00,3.4230D+00,3.3809D+00,
     &3.3396D+00,3.2976D+00,3.2571D+00,3.2126D+00,3.1696D+00,3.1272D+00,
     &3.0840D+00,3.0569D+00,3.0286D+00,2.9959D+00,2.9619D+00,2.9273D+00,
     &2.8910D+00,2.8598D+00,2.8266D+00,2.7863D+00,2.7448D+00,2.7029D+00,
     &2.6598D+00,2.6219D+00,2.5804D+00,2.5305D+00,2.4773D+00,2.4214D+00,
     &2.3662D+00,2.3191D+00,2.2698D+00,2.2126D+00,2.1577D+00,2.1092D+00,
     &2.0674D+00,2.0393D+00,2.0210D+00,2.0173D+00,2.0367D+00,2.0654D+00,
     &2.1076D+00,2.1485D+00,2.1942D+00,2.2338D+00,2.2678D+00,2.2959D+00,
     &2.3193D+00,2.3386D+00,2.3539D+00,2.3660D+00,2.3738D+00,2.3789D+00,
     &2.3799D+00,2.3197D+00,2.2776D+00,2.2186D+00,2.1426D+00,2.0495D+00,
     &1.9397D+00,1.8097D+00,1.6583D+00,1.4814D+00,1.2736D+00,1.0200D+00,
     &6.8880D-01,0.0000D+00,3.7157D+00,3.6699D+00,3.6275D+00,3.5842D+00,
     &3.5420D+00,3.4972D+00,3.4542D+00,3.4107D+00,3.3678D+00,3.3234D+00,
     &3.2774D+00,3.2332D+00,3.1870D+00,3.1600D+00,3.1297D+00,3.0952D+00,
     &3.0595D+00,3.0231D+00,2.9850D+00,2.9534D+00,2.9160D+00,2.8740D+00,
     &2.8312D+00,2.7872D+00,2.7408D+00,2.7014D+00,2.6568D+00,2.6045D+00/
      DATA (XUVF_L(K),K=  913, 1026) /
     &2.5481D+00,2.4895D+00,2.4315D+00,2.3817D+00,2.3283D+00,2.2697D+00,
     &2.2106D+00,2.1591D+00,2.1128D+00,2.0807D+00,2.0578D+00,2.0477D+00,
     &2.0583D+00,2.0796D+00,2.1122D+00,2.1433D+00,2.1777D+00,2.2069D+00,
     &2.2299D+00,2.2483D+00,2.2618D+00,2.2718D+00,2.2778D+00,2.2803D+00,
     &2.2797D+00,2.2749D+00,2.2668D+00,2.2019D+00,2.1468D+00,2.0761D+00,
     &1.9902D+00,1.8883D+00,1.7711D+00,1.6370D+00,1.4847D+00,1.3103D+00,
     &1.1091D+00,8.7047D-01,5.6856D-01,0.0000D+00,3.8327D+00,3.7877D+00,
     &3.7424D+00,3.6981D+00,3.6540D+00,3.6083D+00,3.5637D+00,3.5184D+00,
     &3.4753D+00,3.4271D+00,3.3800D+00,3.3325D+00,3.2860D+00,3.2564D+00,
     &3.2258D+00,3.1893D+00,3.1519D+00,3.1135D+00,3.0738D+00,3.0389D+00,
     &3.0010D+00,2.9580D+00,2.9118D+00,2.8654D+00,2.8178D+00,2.7758D+00,
     &2.7289D+00,2.6738D+00,2.6146D+00,2.5530D+00,2.4924D+00,2.4399D+00,
     &2.3845D+00,2.3213D+00,2.2605D+00,2.2040D+00,2.1540D+00,2.1186D+00,
     &2.0908D+00,2.0749D+00,2.0772D+00,2.0914D+00,2.1145D+00,2.1368D+00,
     &2.1613D+00,2.1804D+00,2.1941D+00,2.2037D+00,2.2088D+00,2.2101D+00,
     &2.2083D+00,2.2031D+00,2.1942D+00,2.1826D+00,2.1665D+00,2.0987D+00,
     &2.0321D+00,1.9516D+00,1.8571D+00,1.7497D+00,1.6281D+00,1.4923D+00,
     &1.3406D+00,1.1697D+00,9.7635D-01,7.5209D-01,4.7638D-01,0.0000D+00,
     &3.9497D+00,3.9009D+00,3.8555D+00,3.8080D+00,3.7630D+00,3.7163D+00/
      DATA (XUVF_L(K),K= 1027, 1140) /
     &3.6699D+00,3.6231D+00,3.5765D+00,3.5285D+00,3.4807D+00,3.4305D+00,
     &3.3810D+00,3.3511D+00,3.3185D+00,3.2805D+00,3.2414D+00,3.2016D+00,
     &3.1598D+00,3.1244D+00,3.0837D+00,3.0383D+00,2.9908D+00,2.9424D+00,
     &2.8919D+00,2.8477D+00,2.7990D+00,2.7403D+00,2.6784D+00,2.6142D+00,
     &2.5507D+00,2.4960D+00,2.4362D+00,2.3710D+00,2.3058D+00,2.2463D+00,
     &2.1931D+00,2.1539D+00,2.1216D+00,2.0996D+00,2.0940D+00,2.1012D+00,
     &2.1154D+00,2.1294D+00,2.1444D+00,2.1543D+00,2.1597D+00,2.1610D+00,
     &2.1585D+00,2.1523D+00,2.1432D+00,2.1307D+00,2.1155D+00,2.0964D+00,
     &2.0742D+00,2.0035D+00,1.9273D+00,1.8396D+00,1.7387D+00,1.6273D+00,
     &1.5032D+00,1.3665D+00,1.2164D+00,1.0501D+00,8.6515D-01,6.5470D-01,
     &4.0284D-01,0.0000D+00,4.0572D+00,4.0093D+00,3.9616D+00,3.9140D+00,
     &3.8670D+00,3.8185D+00,3.7706D+00,3.7224D+00,3.6746D+00,3.6251D+00,
     &3.5744D+00,3.5233D+00,3.4720D+00,3.4406D+00,3.4062D+00,3.3671D+00,
     &3.3263D+00,3.2847D+00,3.2414D+00,3.2046D+00,3.1620D+00,3.1150D+00,
     &3.0653D+00,3.0145D+00,2.9619D+00,2.9153D+00,2.8641D+00,2.8032D+00,
     &2.7388D+00,2.6715D+00,2.6056D+00,2.5481D+00,2.4880D+00,2.4171D+00,
     &2.3496D+00,2.2862D+00,2.2282D+00,2.1865D+00,2.1502D+00,2.1217D+00,
     &2.1086D+00,2.1086D+00,2.1149D+00,2.1216D+00,2.1275D+00,2.1295D+00,
     &2.1273D+00,2.1212D+00,2.1119D+00,2.0992D+00,2.0837D+00,2.0653D+00/
      DATA (XUVF_L(K),K= 1141, 1254) /
     &2.0442D+00,2.0194D+00,1.9912D+00,1.9193D+00,1.8359D+00,1.7412D+00,
     &1.6366D+00,1.5214D+00,1.3956D+00,1.2594D+00,1.1115D+00,9.5033D-01,
     &7.7356D-01,5.7585D-01,3.4506D-01,0.0000D+00,4.1710D+00,4.1201D+00,
     &4.0712D+00,4.0213D+00,3.9730D+00,3.9228D+00,3.8734D+00,3.8233D+00,
     &3.7726D+00,3.7217D+00,3.6699D+00,3.6160D+00,3.5640D+00,3.5311D+00,
     &3.4960D+00,3.4549D+00,3.4121D+00,3.3689D+00,3.3237D+00,3.2848D+00,
     &3.2425D+00,3.1917D+00,3.1399D+00,3.0866D+00,3.0319D+00,2.9838D+00,
     &2.9306D+00,2.8668D+00,2.7992D+00,2.7291D+00,2.6605D+00,2.6007D+00,
     &2.5375D+00,2.4631D+00,2.3919D+00,2.3261D+00,2.2643D+00,2.2183D+00,
     &2.1772D+00,2.1426D+00,2.1222D+00,2.1155D+00,2.1135D+00,2.1130D+00,
     &2.1102D+00,2.1039D+00,2.0941D+00,2.0815D+00,2.0652D+00,2.0466D+00,
     &2.0251D+00,2.0014D+00,1.9746D+00,1.9450D+00,1.9116D+00,1.8381D+00,
     &1.7481D+00,1.6484D+00,1.5404D+00,1.4225D+00,1.2963D+00,1.1611D+00,
     &1.0161D+00,8.6047D-01,6.9193D-01,5.0691D-01,2.9581D-01,0.0000D+00,
     &4.2754D+00,4.2238D+00,4.1737D+00,4.1233D+00,4.0740D+00,4.0219D+00,
     &3.9713D+00,3.9196D+00,3.8675D+00,3.8160D+00,3.7618D+00,3.7060D+00,
     &3.6510D+00,3.6173D+00,3.5808D+00,3.5380D+00,3.4941D+00,3.4493D+00,
     &3.4027D+00,3.3623D+00,3.3163D+00,3.2647D+00,3.2114D+00,3.1563D+00,
     &3.0989D+00,3.0489D+00,2.9929D+00,2.9263D+00,2.8563D+00,2.7837D+00/
      DATA (XUVF_L(K),K= 1255, 1368) /
     &2.7122D+00,2.6501D+00,2.5825D+00,2.5073D+00,2.4327D+00,2.3623D+00,
     &2.2962D+00,2.2474D+00,2.2020D+00,2.1616D+00,2.1335D+00,2.1209D+00,
     &2.1113D+00,2.1034D+00,2.0929D+00,2.0795D+00,2.0634D+00,2.0439D+00,
     &2.0222D+00,1.9982D+00,1.9716D+00,1.9428D+00,1.9113D+00,1.8773D+00,
     &1.8394D+00,1.7649D+00,1.6692D+00,1.5658D+00,1.4547D+00,1.3360D+00,
     &1.2095D+00,1.0761D+00,9.3485D-01,7.8430D-01,6.2380D-01,4.5010D-01,
     &2.5625D-01,0.0000D+00,4.3798D+00,4.3275D+00,4.2762D+00,4.2239D+00,
     &4.1730D+00,4.1196D+00,4.0674D+00,4.0143D+00,3.9623D+00,3.9056D+00,
     &3.8502D+00,3.7935D+00,3.7370D+00,3.7018D+00,3.6642D+00,3.6200D+00,
     &3.5742D+00,3.5277D+00,3.4786D+00,3.4371D+00,3.3901D+00,3.3359D+00,
     &3.2800D+00,3.2235D+00,3.1639D+00,3.1115D+00,3.0537D+00,2.9847D+00,
     &2.9116D+00,2.8364D+00,2.7623D+00,2.6973D+00,2.6275D+00,2.5497D+00,
     &2.4705D+00,2.3972D+00,2.3281D+00,2.2747D+00,2.2253D+00,2.1793D+00,
     &2.1444D+00,2.1253D+00,2.1081D+00,2.0939D+00,2.0755D+00,2.0555D+00,
     &2.0332D+00,2.0081D+00,1.9814D+00,1.9522D+00,1.9205D+00,1.8875D+00,
     &1.8520D+00,1.8139D+00,1.7725D+00,1.6968D+00,1.5976D+00,1.4911D+00,
     &1.3772D+00,1.2577D+00,1.1320D+00,1.0005D+00,8.6242D-01,7.1750D-01,
     &5.6466D-01,4.0150D-01,2.2333D-01,0.0000D+00,4.4809D+00,4.4265D+00,
     &4.3735D+00,4.3193D+00,4.2670D+00,4.2128D+00,4.1585D+00,4.1039D+00/
      DATA (XUVF_L(K),K= 1369, 1482) /
     &4.0509D+00,3.9928D+00,3.9351D+00,3.8769D+00,3.8180D+00,3.7821D+00,
     &3.7434D+00,3.6974D+00,3.6501D+00,3.6019D+00,3.5513D+00,3.5093D+00,
     &3.4594D+00,3.4035D+00,3.3456D+00,3.2870D+00,3.2250D+00,3.1715D+00,
     &3.1110D+00,3.0396D+00,2.9639D+00,2.8863D+00,2.8096D+00,2.7429D+00,
     &2.6702D+00,2.5884D+00,2.5068D+00,2.4296D+00,2.3560D+00,2.3003D+00,
     &2.2464D+00,2.1951D+00,2.1530D+00,2.1283D+00,2.1045D+00,2.0843D+00,
     &2.0591D+00,2.0328D+00,2.0047D+00,1.9749D+00,1.9429D+00,1.9096D+00,
     &1.8740D+00,1.8369D+00,1.7978D+00,1.7560D+00,1.7116D+00,1.6360D+00,
     &1.5322D+00,1.4233D+00,1.3084D+00,1.1885D+00,1.0637D+00,9.3449D-01,
     &7.9961D-01,6.6020D-01,5.1453D-01,3.6103D-01,1.9641D-01,0.0000D+00,
     &4.6169D+00,4.5608D+00,4.5060D+00,4.4504D+00,4.3960D+00,4.3395D+00,
     &4.2837D+00,4.2262D+00,4.1710D+00,4.1106D+00,4.0517D+00,3.9908D+00,
     &3.9300D+00,3.8920D+00,3.8509D+00,3.8030D+00,3.7538D+00,3.7035D+00,
     &3.6494D+00,3.6055D+00,3.5556D+00,3.4966D+00,3.4351D+00,3.3738D+00,
     &3.3090D+00,3.2518D+00,3.1888D+00,3.1141D+00,3.0348D+00,2.9533D+00,
     &2.8730D+00,2.8020D+00,2.7264D+00,2.6400D+00,2.5551D+00,2.4732D+00,
     &2.3941D+00,2.3329D+00,2.2742D+00,2.2147D+00,2.1644D+00,2.1317D+00,
     &2.0986D+00,2.0700D+00,2.0363D+00,2.0021D+00,1.9668D+00,1.9299D+00,
     &1.8922D+00,1.8532D+00,1.8125D+00,1.7704D+00,1.7270D+00,1.6809D+00/
      DATA (XUVF_L(K),K= 1483, 1596) /
     &1.6327D+00,1.5570D+00,1.4497D+00,1.3373D+00,1.2215D+00,1.1020D+00,
     &9.7897D-01,8.5304D-01,7.2349D-01,5.9074D-01,4.5411D-01,3.1307D-01,
     &1.6547D-01,0.0000D+00,4.7403D+00,4.6834D+00,4.6262D+00,4.5696D+00,
     &4.5140D+00,4.4557D+00,4.3978D+00,4.3393D+00,4.2817D+00,4.2191D+00,
     &4.1578D+00,4.0941D+00,4.0310D+00,3.9917D+00,3.9492D+00,3.8995D+00,
     &3.8481D+00,3.7958D+00,3.7411D+00,3.6937D+00,3.6405D+00,3.5806D+00,
     &3.5171D+00,3.4520D+00,3.3840D+00,3.3254D+00,3.2596D+00,3.1812D+00,
     &3.0985D+00,3.0137D+00,2.9301D+00,2.8556D+00,2.7782D+00,2.6879D+00,
     &2.5974D+00,2.5119D+00,2.4281D+00,2.3629D+00,2.2982D+00,2.2324D+00,
     &2.1730D+00,2.1332D+00,2.0922D+00,2.0570D+00,2.0152D+00,1.9739D+00,
     &1.9323D+00,1.8902D+00,1.8474D+00,1.8039D+00,1.7589D+00,1.7129D+00,
     &1.6654D+00,1.6163D+00,1.5652D+00,1.4896D+00,1.3789D+00,1.2649D+00,
     &1.1487D+00,1.0300D+00,9.0896D-01,7.8619D-01,6.6149D-01,5.3498D-01,
     &4.0654D-01,2.7586D-01,1.4208D-01,0.0000D+00,4.8699D+00,4.8107D+00,
     &4.7518D+00,4.6928D+00,4.6350D+00,4.5750D+00,4.5152D+00,4.4524D+00,
     &4.3956D+00,4.3299D+00,4.2674D+00,4.2014D+00,4.1350D+00,4.0939D+00,
     &4.0503D+00,3.9982D+00,3.9448D+00,3.8905D+00,3.8328D+00,3.7846D+00,
     &3.7300D+00,3.6664D+00,3.5991D+00,3.5326D+00,3.4620D+00,3.3998D+00,
     &3.3311D+00,3.2494D+00,3.1632D+00,3.0752D+00,2.9881D+00,2.9120D+00/
      DATA (XUVF_L(K),K= 1597, 1710) /
     &2.8299D+00,2.7339D+00,2.6398D+00,2.5493D+00,2.4611D+00,2.3911D+00,
     &2.3215D+00,2.2482D+00,2.1812D+00,2.1342D+00,2.0854D+00,2.0427D+00,
     &1.9932D+00,1.9453D+00,1.8978D+00,1.8504D+00,1.8030D+00,1.7545D+00,
     &1.7059D+00,1.6565D+00,1.6056D+00,1.5535D+00,1.4989D+00,1.4245D+00,
     &1.3108D+00,1.1959D+00,1.0798D+00,9.6219D-01,8.4358D-01,7.2422D-01,
     &6.0451D-01,4.8425D-01,3.6380D-01,2.4286D-01,1.2189D-01,0.0000D+00,
     &4.9964D+00,4.9356D+00,4.8755D+00,4.8147D+00,4.7550D+00,4.6935D+00,
     &4.6315D+00,4.5697D+00,4.5062D+00,4.4406D+00,4.3752D+00,4.3061D+00,
     &4.2380D+00,4.1962D+00,4.1500D+00,4.0963D+00,4.0405D+00,3.9832D+00,
     &3.9245D+00,3.8728D+00,3.8172D+00,3.7504D+00,3.6811D+00,3.6108D+00,
     &3.5381D+00,3.4734D+00,3.4018D+00,3.3164D+00,3.2269D+00,3.1352D+00,
     &3.0446D+00,2.9657D+00,2.8794D+00,2.7800D+00,2.6821D+00,2.5867D+00,
     &2.4930D+00,2.4184D+00,2.3433D+00,2.2634D+00,2.1877D+00,2.1342D+00,
     &2.0772D+00,2.0279D+00,1.9713D+00,1.9172D+00,1.8642D+00,1.8120D+00,
     &1.7600D+00,1.7076D+00,1.6553D+00,1.6027D+00,1.5491D+00,1.4938D+00,
     &1.4374D+00,1.3637D+00,1.2481D+00,1.1325D+00,1.0166D+00,9.0047D-01,
     &7.8428D-01,6.6889D-01,5.5381D-01,4.3953D-01,3.2652D-01,2.1461D-01,
     &1.0498D-01,0.0000D+00,5.1134D+00,5.0511D+00,4.9886D+00,4.9273D+00,
     &4.8660D+00,4.8016D+00,4.7382D+00,4.6744D+00,4.6106D+00,4.5420D+00/
      DATA (XUVF_L(K),K= 1711, 1824) /
     &4.4742D+00,4.4028D+00,4.3320D+00,4.2892D+00,4.2413D+00,4.1858D+00,
     &4.1281D+00,4.0682D+00,4.0067D+00,3.9556D+00,3.8955D+00,3.8271D+00,
     &3.7556D+00,3.6829D+00,3.6071D+00,3.5401D+00,3.4662D+00,3.3777D+00,
     &3.2849D+00,3.1898D+00,3.0960D+00,3.0140D+00,2.9244D+00,2.8224D+00,
     &2.7183D+00,2.6191D+00,2.5219D+00,2.4431D+00,2.3628D+00,2.2767D+00,
     &2.1931D+00,2.1332D+00,2.0695D+00,2.0145D+00,1.9514D+00,1.8920D+00,
     &1.8340D+00,1.7775D+00,1.7215D+00,1.6664D+00,1.6108D+00,1.5553D+00,
     &1.4995D+00,1.4421D+00,1.3839D+00,1.3103D+00,1.1944D+00,1.0782D+00,
     &9.6271D-01,8.4822D-01,7.3481D-01,6.2240D-01,5.1184D-01,4.0291D-01,
     &2.9618D-01,1.9206D-01,9.1846D-02,0.0000D+00,5.2367D+00,5.1713D+00,
     &5.1071D+00,5.0425D+00,4.9800D+00,4.9141D+00,4.8489D+00,4.7833D+00,
     &4.7181D+00,4.6457D+00,4.5768D+00,4.5034D+00,4.4300D+00,4.3847D+00,
     &4.3353D+00,4.2782D+00,4.2182D+00,4.1570D+00,4.0921D+00,4.0385D+00,
     &3.9782D+00,3.9074D+00,3.8331D+00,3.7575D+00,3.6781D+00,3.6086D+00,
     &3.5313D+00,3.4401D+00,3.3439D+00,3.2455D+00,3.1483D+00,3.0623D+00,
     &2.9694D+00,2.8629D+00,2.7561D+00,2.6527D+00,2.5508D+00,2.4669D+00,
     &2.3816D+00,2.2887D+00,2.1979D+00,2.1317D+00,2.0613D+00,2.0002D+00,
     &1.9307D+00,1.8659D+00,1.8033D+00,1.7426D+00,1.6834D+00,1.6247D+00,
     &1.5668D+00,1.5085D+00,1.4504D+00,1.3916D+00,1.3311D+00,1.2591D+00/
      DATA (XUVF_L(K),K= 1825, 1836) /
     &1.1415D+00,1.0256D+00,9.1107D-01,7.9840D-01,6.8736D-01,5.7902D-01,
     &4.7260D-01,3.6895D-01,2.6838D-01,1.7161D-01,8.0264D-02,0.0000D+00/
      DATA (XDVF_L(K),K=    1,  114) /
     &1.4230D+00,1.4064D+00,1.3903D+00,1.3749D+00,1.3590D+00,1.3424D+00,
     &1.3271D+00,1.3114D+00,1.2962D+00,1.2803D+00,1.2647D+00,1.2492D+00,
     &1.2340D+00,1.2246D+00,1.2155D+00,1.2044D+00,1.1927D+00,1.1814D+00,
     &1.1695D+00,1.1589D+00,1.1479D+00,1.1347D+00,1.1214D+00,1.1080D+00,
     &1.0944D+00,1.0824D+00,1.0700D+00,1.0544D+00,1.0371D+00,1.0188D+00,
     &9.9884D-01,9.8287D-01,9.6563D-01,9.4645D-01,9.2847D-01,9.1313D-01,
     &9.0246D-01,8.9955D-01,9.0461D-01,9.2737D-01,9.7648D-01,1.0343D+00,
     &1.1168D+00,1.2030D+00,1.3129D+00,1.4240D+00,1.5357D+00,1.6492D+00,
     &1.7643D+00,1.8818D+00,2.0016D+00,2.1253D+00,2.2535D+00,2.3853D+00,
     &2.5225D+00,2.5620D+00,2.7906D+00,3.0230D+00,3.2574D+00,3.4983D+00,
     &3.7459D+00,4.0062D+00,4.2803D+00,4.5790D+00,4.9150D+00,5.3263D+00,
     &5.9228D+00,0.0000D+00,1.4698D+00,1.4526D+00,1.4360D+00,1.4199D+00,
     &1.4030D+00,1.3864D+00,1.3702D+00,1.3542D+00,1.3386D+00,1.3221D+00,
     &1.3059D+00,1.2896D+00,1.2740D+00,1.2644D+00,1.2544D+00,1.2425D+00,
     &1.2309D+00,1.2185D+00,1.2061D+00,1.1953D+00,1.1836D+00,1.1697D+00,
     &1.1558D+00,1.1417D+00,1.1275D+00,1.1154D+00,1.1011D+00,1.0844D+00,
     &1.0663D+00,1.0471D+00,1.0261D+00,1.0092D+00,9.9133D-01,9.7103D-01,
     &9.5184D-01,9.3560D-01,9.2380D-01,9.1922D-01,9.2378D-01,9.4563D-01,
     &9.9235D-01,1.0474D+00,1.1262D+00,1.2078D+00,1.3110D+00,1.4146D+00/
      DATA (XDVF_L(K),K=  115,  228) /
     &1.5192D+00,1.6241D+00,1.7298D+00,1.8375D+00,1.9471D+00,2.0592D+00,
     &2.1741D+00,2.2925D+00,2.4144D+00,2.4425D+00,2.6407D+00,2.8375D+00,
     &3.0361D+00,3.2345D+00,3.4343D+00,3.6388D+00,3.8488D+00,4.0682D+00,
     &4.3043D+00,4.5737D+00,4.9280D+00,0.0000D+00,1.5226D+00,1.5047D+00,
     &1.4874D+00,1.4702D+00,1.4530D+00,1.4363D+00,1.4193D+00,1.4023D+00,
     &1.3860D+00,1.3690D+00,1.3520D+00,1.3351D+00,1.3190D+00,1.3083D+00,
     &1.2983D+00,1.2858D+00,1.2733D+00,1.2606D+00,1.2476D+00,1.2362D+00,
     &1.2237D+00,1.2092D+00,1.1943D+00,1.1795D+00,1.1645D+00,1.1509D+00,
     &1.1365D+00,1.1185D+00,1.0994D+00,1.0784D+00,1.0566D+00,1.0388D+00,
     &1.0195D+00,9.9801D-01,9.7765D-01,9.6019D-01,9.4712D-01,9.4158D-01,
     &9.4524D-01,9.6454D-01,1.0088D+00,1.0604D+00,1.1346D+00,1.2112D+00,
     &1.3076D+00,1.4038D+00,1.4995D+00,1.5957D+00,1.6918D+00,1.7888D+00,
     &1.8877D+00,1.9877D+00,2.0896D+00,2.1940D+00,2.2999D+00,2.3168D+00,
     &2.4844D+00,2.6497D+00,2.8098D+00,2.9678D+00,3.1219D+00,3.2743D+00,
     &3.4260D+00,3.5742D+00,3.7237D+00,3.8717D+00,4.0300D+00,0.0000D+00,
     &1.5849D+00,1.5662D+00,1.5482D+00,1.5298D+00,1.5130D+00,1.4944D+00,
     &1.4769D+00,1.4593D+00,1.4423D+00,1.4243D+00,1.4066D+00,1.3894D+00,
     &1.3720D+00,1.3607D+00,1.3499D+00,1.3366D+00,1.3237D+00,1.3101D+00,
     &1.2963D+00,1.2840D+00,1.2709D+00,1.2553D+00,1.2396D+00,1.2232D+00/
      DATA (XDVF_L(K),K=  229,  342) /
     &1.2075D+00,1.1932D+00,1.1776D+00,1.1584D+00,1.1377D+00,1.1152D+00,
     &1.0922D+00,1.0729D+00,1.0524D+00,1.0294D+00,1.0074D+00,9.8843D-01,
     &9.7377D-01,9.6751D-01,9.6901D-01,9.8606D-01,1.0264D+00,1.0745D+00,
     &1.1435D+00,1.2136D+00,1.3018D+00,1.3894D+00,1.4758D+00,1.5619D+00,
     &1.6474D+00,1.7332D+00,1.8194D+00,1.9063D+00,1.9941D+00,2.0832D+00,
     &2.1725D+00,2.1789D+00,2.3166D+00,2.4460D+00,2.5708D+00,2.6884D+00,
     &2.7987D+00,2.9025D+00,2.9974D+00,3.0823D+00,3.1538D+00,3.2013D+00,
     &3.2043D+00,0.0000D+00,1.6586D+00,1.6391D+00,1.6202D+00,1.6014D+00,
     &1.5830D+00,1.5638D+00,1.5457D+00,1.5267D+00,1.5087D+00,1.4899D+00,
     &1.4711D+00,1.4517D+00,1.4340D+00,1.4224D+00,1.4107D+00,1.3972D+00,
     &1.3827D+00,1.3684D+00,1.3535D+00,1.3404D+00,1.3263D+00,1.3096D+00,
     &1.2927D+00,1.2758D+00,1.2575D+00,1.2422D+00,1.2250D+00,1.2046D+00,
     &1.1821D+00,1.1579D+00,1.1331D+00,1.1127D+00,1.0905D+00,1.0655D+00,
     &1.0415D+00,1.0207D+00,1.0042D+00,9.9612D-01,9.9507D-01,1.0089D+00,
     &1.0451D+00,1.0887D+00,1.1514D+00,1.2146D+00,1.2936D+00,1.3711D+00,
     &1.4469D+00,1.5220D+00,1.5960D+00,1.6694D+00,1.7428D+00,1.8159D+00,
     &1.8894D+00,1.9620D+00,2.0344D+00,2.0313D+00,2.1357D+00,2.2333D+00,
     &2.3215D+00,2.4009D+00,2.4706D+00,2.5292D+00,2.5750D+00,2.6036D+00,
     &2.6096D+00,2.5783D+00,2.4673D+00,0.0000D+00,1.7269D+00,1.7065D+00/
      DATA (XDVF_L(K),K=  343,  456) /
     &1.6866D+00,1.6676D+00,1.6480D+00,1.6279D+00,1.6089D+00,1.5891D+00,
     &1.5701D+00,1.5502D+00,1.5307D+00,1.5113D+00,1.4910D+00,1.4799D+00,
     &1.4673D+00,1.4526D+00,1.4373D+00,1.4221D+00,1.4060D+00,1.3922D+00,
     &1.3771D+00,1.3596D+00,1.3414D+00,1.3234D+00,1.3045D+00,1.2879D+00,
     &1.2689D+00,1.2468D+00,1.2227D+00,1.1966D+00,1.1706D+00,1.1487D+00,
     &1.1248D+00,1.0980D+00,1.0724D+00,1.0495D+00,1.0310D+00,1.0212D+00,
     &1.0181D+00,1.0291D+00,1.0609D+00,1.1002D+00,1.1563D+00,1.2136D+00,
     &1.2840D+00,1.3528D+00,1.4201D+00,1.4854D+00,1.5492D+00,1.6125D+00,
     &1.6751D+00,1.7368D+00,1.7981D+00,1.8579D+00,1.9157D+00,1.9057D+00,
     &1.9875D+00,2.0577D+00,2.1190D+00,2.1700D+00,2.2094D+00,2.2370D+00,
     &2.2484D+00,2.2403D+00,2.2047D+00,2.1261D+00,1.9567D+00,0.0000D+00,
     &1.8047D+00,1.7833D+00,1.7626D+00,1.7418D+00,1.7220D+00,1.7009D+00,
     &1.6810D+00,1.6603D+00,1.6403D+00,1.6193D+00,1.5986D+00,1.5775D+00,
     &1.5570D+00,1.5441D+00,1.5309D+00,1.5156D+00,1.4991D+00,1.4828D+00,
     &1.4658D+00,1.4510D+00,1.4350D+00,1.4160D+00,1.3966D+00,1.3772D+00,
     &1.3565D+00,1.3386D+00,1.3184D+00,1.2942D+00,1.2680D+00,1.2404D+00,
     &1.2125D+00,1.1887D+00,1.1631D+00,1.1342D+00,1.1064D+00,1.0813D+00,
     &1.0608D+00,1.0480D+00,1.0426D+00,1.0500D+00,1.0774D+00,1.1111D+00,
     &1.1608D+00,1.2107D+00,1.2719D+00,1.3315D+00,1.3886D+00,1.4445D+00/
      DATA (XDVF_L(K),K=  457,  570) /
     &1.4984D+00,1.5505D+00,1.6020D+00,1.6524D+00,1.7009D+00,1.7480D+00,
     &1.7926D+00,1.7763D+00,1.8327D+00,1.8794D+00,1.9154D+00,1.9405D+00,
     &1.9531D+00,1.9537D+00,1.9362D+00,1.8986D+00,1.8325D+00,1.7203D+00,
     &1.5163D+00,0.0000D+00,1.8755D+00,1.8533D+00,1.8314D+00,1.8106D+00,
     &1.7890D+00,1.7672D+00,1.7464D+00,1.7248D+00,1.7038D+00,1.6817D+00,
     &1.6601D+00,1.6385D+00,1.6160D+00,1.6033D+00,1.5889D+00,1.5721D+00,
     &1.5552D+00,1.5380D+00,1.5199D+00,1.5042D+00,1.4871D+00,1.4670D+00,
     &1.4463D+00,1.4249D+00,1.4036D+00,1.3843D+00,1.3630D+00,1.3364D+00,
     &1.3086D+00,1.2791D+00,1.2500D+00,1.2245D+00,1.1971D+00,1.1662D+00,
     &1.1361D+00,1.1090D+00,1.0858D+00,1.0721D+00,1.0641D+00,1.0676D+00,
     &1.0898D+00,1.1195D+00,1.1627D+00,1.2069D+00,1.2603D+00,1.3118D+00,
     &1.3607D+00,1.4079D+00,1.4534D+00,1.4968D+00,1.5392D+00,1.5794D+00,
     &1.6181D+00,1.6552D+00,1.6888D+00,1.6690D+00,1.7073D+00,1.7353D+00,
     &1.7530D+00,1.7595D+00,1.7531D+00,1.7338D+00,1.6988D+00,1.6428D+00,
     &1.5583D+00,1.4293D+00,1.2136D+00,0.0000D+00,1.9470D+00,1.9238D+00,
     &1.9021D+00,1.8782D+00,1.8570D+00,1.8343D+00,1.8123D+00,1.7898D+00,
     &1.7680D+00,1.7449D+00,1.7222D+00,1.6994D+00,1.6760D+00,1.6624D+00,
     &1.6469D+00,1.6299D+00,1.6118D+00,1.5933D+00,1.5742D+00,1.5574D+00,
     &1.5392D+00,1.5179D+00,1.4955D+00,1.4738D+00,1.4506D+00,1.4300D+00/
      DATA (XDVF_L(K),K=  571,  684) /
     &1.4069D+00,1.3792D+00,1.3492D+00,1.3178D+00,1.2868D+00,1.2597D+00,
     &1.2307D+00,1.1976D+00,1.1654D+00,1.1363D+00,1.1108D+00,1.0945D+00,
     &1.0840D+00,1.0845D+00,1.1017D+00,1.1268D+00,1.1637D+00,1.2016D+00,
     &1.2473D+00,1.2910D+00,1.3324D+00,1.3719D+00,1.4090D+00,1.4450D+00,
     &1.4784D+00,1.5109D+00,1.5404D+00,1.5681D+00,1.5925D+00,1.5689D+00,
     &1.5916D+00,1.6043D+00,1.6067D+00,1.5981D+00,1.5779D+00,1.5449D+00,
     &1.4949D+00,1.4262D+00,1.3303D+00,1.1932D+00,9.7657D-01,0.0000D+00,
     &2.0122D+00,1.9881D+00,1.9640D+00,1.9418D+00,1.9190D+00,1.8954D+00,
     &1.8721D+00,1.8492D+00,1.8262D+00,1.8024D+00,1.7784D+00,1.7550D+00,
     &1.7300D+00,1.7157D+00,1.6999D+00,1.6818D+00,1.6627D+00,1.6435D+00,
     &1.6233D+00,1.6058D+00,1.5866D+00,1.5643D+00,1.5417D+00,1.5178D+00,
     &1.4926D+00,1.4705D+00,1.4465D+00,1.4174D+00,1.3856D+00,1.3527D+00,
     &1.3198D+00,1.2914D+00,1.2605D+00,1.2257D+00,1.1915D+00,1.1601D+00,
     &1.1326D+00,1.1142D+00,1.1016D+00,1.0982D+00,1.1114D+00,1.1321D+00,
     &1.1637D+00,1.1958D+00,1.2352D+00,1.2722D+00,1.3071D+00,1.3397D+00,
     &1.3704D+00,1.3995D+00,1.4267D+00,1.4516D+00,1.4736D+00,1.4942D+00,
     &1.5100D+00,1.4848D+00,1.4955D+00,1.4964D+00,1.4873D+00,1.4675D+00,
     &1.4366D+00,1.3933D+00,1.3349D+00,1.2585D+00,1.1565D+00,1.0171D+00,
     &8.0601D-01,0.0000D+00,2.0789D+00,2.0539D+00,2.0294D+00,2.0053D+00/
      DATA (XDVF_L(K),K=  685,  798) /
     &1.9820D+00,1.9581D+00,1.9336D+00,1.9096D+00,1.8860D+00,1.8609D+00,
     &1.8367D+00,1.8106D+00,1.7860D+00,1.7706D+00,1.7543D+00,1.7350D+00,
     &1.7150D+00,1.6945D+00,1.6735D+00,1.6550D+00,1.6349D+00,1.6112D+00,
     &1.5864D+00,1.5617D+00,1.5356D+00,1.5128D+00,1.4868D+00,1.4555D+00,
     &1.4224D+00,1.3876D+00,1.3532D+00,1.3231D+00,1.2904D+00,1.2536D+00,
     &1.2173D+00,1.1838D+00,1.1545D+00,1.1338D+00,1.1185D+00,1.1113D+00,
     &1.1199D+00,1.1362D+00,1.1627D+00,1.1895D+00,1.2222D+00,1.2529D+00,
     &1.2813D+00,1.3080D+00,1.3324D+00,1.3546D+00,1.3756D+00,1.3938D+00,
     &1.4103D+00,1.4232D+00,1.4319D+00,1.4055D+00,1.4052D+00,1.3959D+00,
     &1.3768D+00,1.3480D+00,1.3084D+00,1.2576D+00,1.1928D+00,1.1110D+00,
     &1.0066D+00,8.6804D-01,6.6615D-01,0.0000D+00,2.1434D+00,2.1178D+00,
     &2.0930D+00,2.0676D+00,2.0440D+00,2.0184D+00,1.9935D+00,1.9686D+00,
     &1.9439D+00,1.9179D+00,1.8915D+00,1.8663D+00,1.8400D+00,1.8239D+00,
     &1.8067D+00,1.7863D+00,1.7654D+00,1.7440D+00,1.7219D+00,1.7025D+00,
     &1.6814D+00,1.6565D+00,1.6311D+00,1.6045D+00,1.5766D+00,1.5526D+00,
     &1.5250D+00,1.4925D+00,1.4574D+00,1.4213D+00,1.3849D+00,1.3532D+00,
     &1.3191D+00,1.2800D+00,1.2418D+00,1.2062D+00,1.1743D+00,1.1517D+00,
     &1.1338D+00,1.1237D+00,1.1272D+00,1.1399D+00,1.1608D+00,1.1828D+00,
     &1.2092D+00,1.2341D+00,1.2570D+00,1.2774D+00,1.2962D+00,1.3135D+00/
      DATA (XDVF_L(K),K=  799,  912) /
     &1.3280D+00,1.3406D+00,1.3511D+00,1.3588D+00,1.3613D+00,1.3335D+00,
     &1.3246D+00,1.3067D+00,1.2801D+00,1.2441D+00,1.1985D+00,1.1418D+00,
     &1.0724D+00,9.8806D-01,8.8293D-01,7.4746D-01,5.5665D-01,0.0000D+00,
     &2.2035D+00,2.1769D+00,2.1514D+00,2.1259D+00,2.1000D+00,2.0743D+00,
     &2.0488D+00,2.0226D+00,1.9973D+00,1.9702D+00,1.9428D+00,1.9166D+00,
     &1.8890D+00,1.8729D+00,1.8548D+00,1.8337D+00,1.8116D+00,1.7895D+00,
     &1.7662D+00,1.7461D+00,1.7239D+00,1.6980D+00,1.6714D+00,1.6436D+00,
     &1.6146D+00,1.5889D+00,1.5604D+00,1.5266D+00,1.4895D+00,1.4515D+00,
     &1.4138D+00,1.3806D+00,1.3448D+00,1.3040D+00,1.2638D+00,1.2261D+00,
     &1.1920D+00,1.1669D+00,1.1469D+00,1.1341D+00,1.1335D+00,1.1420D+00,
     &1.1583D+00,1.1760D+00,1.1971D+00,1.2168D+00,1.2343D+00,1.2501D+00,
     &1.2640D+00,1.2762D+00,1.2866D+00,1.2942D+00,1.2996D+00,1.3020D+00,
     &1.3003D+00,1.2725D+00,1.2557D+00,1.2312D+00,1.1982D+00,1.1569D+00,
     &1.1068D+00,1.0465D+00,9.7460D-01,8.8884D-01,7.8459D-01,6.5333D-01,
     &4.7359D-01,0.0000D+00,2.2800D+00,2.2524D+00,2.2256D+00,2.1987D+00,
     &2.1730D+00,2.1459D+00,2.1192D+00,2.0922D+00,2.0656D+00,2.0374D+00,
     &2.0100D+00,1.9802D+00,1.9520D+00,1.9346D+00,1.9156D+00,1.8937D+00,
     &1.8706D+00,1.8475D+00,1.8228D+00,1.8017D+00,1.7783D+00,1.7509D+00,
     &1.7221D+00,1.6937D+00,1.6627D+00,1.6354D+00,1.6050D+00,1.5688D+00/
      DATA (XDVF_L(K),K=  913, 1026) /
     &1.5301D+00,1.4898D+00,1.4503D+00,1.4150D+00,1.3772D+00,1.3339D+00,
     &1.2911D+00,1.2510D+00,1.2138D+00,1.1866D+00,1.1637D+00,1.1458D+00,
     &1.1403D+00,1.1441D+00,1.1548D+00,1.1669D+00,1.1817D+00,1.1950D+00,
     &1.2065D+00,1.2163D+00,1.2249D+00,1.2313D+00,1.2355D+00,1.2379D+00,
     &1.2379D+00,1.2348D+00,1.2275D+00,1.1987D+00,1.1744D+00,1.1427D+00,
     &1.1035D+00,1.0570D+00,1.0018D+00,9.3862D-01,8.6494D-01,7.7913D-01,
     &6.7747D-01,5.5266D-01,3.8741D-01,0.0000D+00,2.3524D+00,2.3243D+00,
     &2.2963D+00,2.2689D+00,2.2420D+00,2.2137D+00,2.1858D+00,2.1579D+00,
     &2.1301D+00,2.1011D+00,2.0718D+00,2.0424D+00,2.0120D+00,1.9937D+00,
     &1.9743D+00,1.9509D+00,1.9267D+00,1.9020D+00,1.8763D+00,1.8541D+00,
     &1.8295D+00,1.8006D+00,1.7713D+00,1.7402D+00,1.7077D+00,1.6794D+00,
     &1.6475D+00,1.6087D+00,1.5679D+00,1.5259D+00,1.4840D+00,1.4470D+00,
     &1.4072D+00,1.3615D+00,1.3163D+00,1.2738D+00,1.2336D+00,1.2045D+00,
     &1.1783D+00,1.1563D+00,1.1459D+00,1.1457D+00,1.1504D+00,1.1577D+00,
     &1.1662D+00,1.1742D+00,1.1807D+00,1.1857D+00,1.1886D+00,1.1902D+00,
     &1.1899D+00,1.1878D+00,1.1830D+00,1.1751D+00,1.1633D+00,1.1345D+00,
     &1.1039D+00,1.0667D+00,1.0230D+00,9.7228D-01,9.1417D-01,8.4905D-01,
     &7.7478D-01,6.9004D-01,5.9155D-01,4.7371D-01,3.2191D-01,0.0000D+00,
     &2.4233D+00,2.3947D+00,2.3653D+00,2.3365D+00,2.3090D+00,2.2800D+00/
      DATA (XDVF_L(K),K= 1027, 1140) /
     &2.2512D+00,2.2220D+00,2.1934D+00,2.1628D+00,2.1319D+00,2.1007D+00,
     &2.0700D+00,2.0512D+00,2.0301D+00,2.0057D+00,1.9809D+00,1.9549D+00,
     &1.9281D+00,1.9049D+00,1.8791D+00,1.8497D+00,1.8175D+00,1.7854D+00,
     &1.7507D+00,1.7209D+00,1.6878D+00,1.6474D+00,1.6047D+00,1.5603D+00,
     &1.5164D+00,1.4777D+00,1.4358D+00,1.3879D+00,1.3403D+00,1.2952D+00,
     &1.2523D+00,1.2206D+00,1.1913D+00,1.1661D+00,1.1505D+00,1.1462D+00,
     &1.1460D+00,1.1481D+00,1.1518D+00,1.1545D+00,1.1559D+00,1.1562D+00,
     &1.1548D+00,1.1523D+00,1.1478D+00,1.1414D+00,1.1331D+00,1.1212D+00,
     &1.1055D+00,1.0763D+00,1.0405D+00,9.9877D-01,9.5130D-01,8.9815D-01,
     &8.3813D-01,7.7188D-01,6.9792D-01,6.1492D-01,5.2020D-01,4.0920D-01,
     &2.7020D-01,0.0000D+00,2.4906D+00,2.4607D+00,2.4307D+00,2.4014D+00,
     &2.3730D+00,2.3427D+00,2.3127D+00,2.2828D+00,2.2528D+00,2.2213D+00,
     &2.1903D+00,2.1577D+00,2.1250D+00,2.1053D+00,2.0839D+00,2.0583D+00,
     &2.0318D+00,2.0051D+00,1.9771D+00,1.9527D+00,1.9259D+00,1.8935D+00,
     &1.8607D+00,1.8269D+00,1.7917D+00,1.7606D+00,1.7253D+00,1.6833D+00,
     &1.6387D+00,1.5925D+00,1.5465D+00,1.5061D+00,1.4624D+00,1.4121D+00,
     &1.3623D+00,1.3152D+00,1.2700D+00,1.2349D+00,1.2036D+00,1.1745D+00,
     &1.1544D+00,1.1457D+00,1.1410D+00,1.1389D+00,1.1378D+00,1.1357D+00,
     &1.1332D+00,1.1290D+00,1.1244D+00,1.1176D+00,1.1099D+00,1.0996D+00/
      DATA (XDVF_L(K),K= 1141, 1254) /
     &1.0875D+00,1.0729D+00,1.0538D+00,1.0249D+00,9.8511D-01,9.3994D-01,
     &8.8948D-01,8.3410D-01,7.7332D-01,7.0681D-01,6.3377D-01,5.5280D-01,
     &4.6214D-01,3.5755D-01,2.2965D-01,0.0000D+00,2.5589D+00,2.5291D+00,
     &2.4979D+00,2.4676D+00,2.4370D+00,2.4060D+00,2.3753D+00,2.3443D+00,
     &2.3135D+00,2.2809D+00,2.2486D+00,2.2146D+00,2.1810D+00,2.1602D+00,
     &2.1376D+00,2.1114D+00,2.0841D+00,2.0557D+00,2.0265D+00,2.0011D+00,
     &1.9730D+00,1.9392D+00,1.9055D+00,1.8697D+00,1.8327D+00,1.8003D+00,
     &1.7635D+00,1.7197D+00,1.6727D+00,1.6246D+00,1.5770D+00,1.5346D+00,
     &1.4890D+00,1.4363D+00,1.3841D+00,1.3341D+00,1.2867D+00,1.2492D+00,
     &1.2151D+00,1.1824D+00,1.1578D+00,1.1451D+00,1.1356D+00,1.1298D+00,
     &1.1233D+00,1.1169D+00,1.1105D+00,1.1027D+00,1.0940D+00,1.0840D+00,
     &1.0726D+00,1.0592D+00,1.0444D+00,1.0265D+00,1.0045D+00,9.7613D-01,
     &9.3249D-01,8.8451D-01,8.3193D-01,7.7510D-01,7.1373D-01,6.4749D-01,
     &5.7554D-01,4.9725D-01,4.1072D-01,3.1254D-01,1.9551D-01,0.0000D+00,
     &2.6244D+00,2.5927D+00,2.5615D+00,2.5299D+00,2.4990D+00,2.4671D+00,
     &2.4356D+00,2.4034D+00,2.3717D+00,2.3377D+00,2.3034D+00,2.2689D+00,
     &2.2340D+00,2.2126D+00,2.1892D+00,2.1616D+00,2.1331D+00,2.1040D+00,
     &2.0736D+00,2.0471D+00,2.0180D+00,1.9830D+00,1.9472D+00,1.9112D+00,
     &1.8717D+00,1.8375D+00,1.7996D+00,1.7538D+00,1.7053D+00,1.6548D+00/
      DATA (XDVF_L(K),K= 1255, 1368) /
     &1.6053D+00,1.5612D+00,1.5138D+00,1.4590D+00,1.4045D+00,1.3516D+00,
     &1.3023D+00,1.2626D+00,1.2251D+00,1.1889D+00,1.1601D+00,1.1441D+00,
     &1.1302D+00,1.1201D+00,1.1098D+00,1.0996D+00,1.0888D+00,1.0782D+00,
     &1.0659D+00,1.0531D+00,1.0388D+00,1.0228D+00,1.0047D+00,9.8480D-01,
     &9.6040D-01,9.3234D-01,8.8589D-01,8.3563D-01,7.8162D-01,7.2366D-01,
     &6.6215D-01,5.9658D-01,5.2617D-01,4.5043D-01,3.6787D-01,2.7575D-01,
     &1.6826D-01,0.0000D+00,2.6886D+00,2.6564D+00,2.6234D+00,2.5908D+00,
     &2.5600D+00,2.5268D+00,2.4943D+00,2.4612D+00,2.4283D+00,2.3924D+00,
     &2.3582D+00,2.3219D+00,2.2860D+00,2.2642D+00,2.2394D+00,2.2113D+00,
     &2.1817D+00,2.1512D+00,2.1198D+00,2.0920D+00,2.0618D+00,2.0268D+00,
     &1.9890D+00,1.9503D+00,1.9098D+00,1.8739D+00,1.8343D+00,1.7867D+00,
     &1.7365D+00,1.6843D+00,1.6329D+00,1.5870D+00,1.5377D+00,1.4807D+00,
     &1.4239D+00,1.3692D+00,1.3169D+00,1.2751D+00,1.2350D+00,1.1954D+00,
     &1.1624D+00,1.1425D+00,1.1247D+00,1.1110D+00,1.0963D+00,1.0827D+00,
     &1.0687D+00,1.0547D+00,1.0396D+00,1.0240D+00,1.0070D+00,9.8853D-01,
     &9.6834D-01,9.4569D-01,9.1962D-01,8.9220D-01,8.4321D-01,7.9105D-01,
     &7.3592D-01,6.7777D-01,6.1620D-01,5.5143D-01,4.8272D-01,4.0962D-01,
     &3.3102D-01,2.4455D-01,1.4574D-01,0.0000D+00,2.7496D+00,2.7153D+00,
     &2.6835D+00,2.6504D+00,2.6180D+00,2.5834D+00,2.5502D+00,2.5161D+00/
      DATA (XDVF_L(K),K= 1369, 1482) /
     &2.4824D+00,2.4466D+00,2.4095D+00,2.3736D+00,2.3360D+00,2.3124D+00,
     &2.2875D+00,2.2580D+00,2.2274D+00,2.1960D+00,2.1631D+00,2.1347D+00,
     &2.1032D+00,2.0670D+00,2.0277D+00,1.9882D+00,1.9458D+00,1.9086D+00,
     &1.8675D+00,1.8179D+00,1.7658D+00,1.7122D+00,1.6586D+00,1.6112D+00,
     &1.5600D+00,1.5010D+00,1.4420D+00,1.3855D+00,1.3294D+00,1.2858D+00,
     &1.2435D+00,1.2006D+00,1.1641D+00,1.1410D+00,1.1193D+00,1.1023D+00,
     &1.0837D+00,1.0664D+00,1.0496D+00,1.0329D+00,1.0157D+00,9.9745D-01,
     &9.7803D-01,9.5735D-01,9.3539D-01,9.1075D-01,8.8302D-01,8.5608D-01,
     &8.0509D-01,7.5168D-01,6.9580D-01,6.3743D-01,5.7619D-01,5.1233D-01,
     &4.4547D-01,3.7496D-01,2.9995D-01,2.1862D-01,1.2745D-01,0.0000D+00,
     &2.8331D+00,2.7978D+00,2.7648D+00,2.7299D+00,2.6960D+00,2.6609D+00,
     &2.6263D+00,2.5910D+00,2.5561D+00,2.5197D+00,2.4802D+00,2.4424D+00,
     &2.4030D+00,2.3791D+00,2.3526D+00,2.3216D+00,2.2897D+00,2.2570D+00,
     &2.2225D+00,2.1925D+00,2.1595D+00,2.1199D+00,2.0799D+00,2.0383D+00,
     &1.9938D+00,1.9551D+00,1.9121D+00,1.8601D+00,1.8054D+00,1.7494D+00,
     &1.6932D+00,1.6435D+00,1.5898D+00,1.5280D+00,1.4659D+00,1.4056D+00,
     &1.3471D+00,1.3010D+00,1.2550D+00,1.2078D+00,1.1652D+00,1.1383D+00,
     &1.1114D+00,1.0902D+00,1.0668D+00,1.0451D+00,1.0248D+00,1.0039D+00,
     &9.8353D-01,9.6205D-01,9.4076D-01,9.1705D-01,8.9229D-01,8.6577D-01/
      DATA (XDVF_L(K),K= 1483, 1596) /
     &8.3604D-01,8.0985D-01,7.5687D-01,7.0190D-01,6.4516D-01,5.8700D-01,
     &5.2660D-01,4.6452D-01,3.9995D-01,3.3310D-01,2.6289D-01,1.8826D-01,
     &1.0655D-01,0.0000D+00,2.9096D+00,2.8732D+00,2.8390D+00,2.8027D+00,
     &2.7690D+00,2.7325D+00,2.6961D+00,2.6597D+00,2.6231D+00,2.5833D+00,
     &2.5456D+00,2.5047D+00,2.4650D+00,2.4391D+00,2.4120D+00,2.3799D+00,
     &2.3462D+00,2.3123D+00,2.2763D+00,2.2451D+00,2.2108D+00,2.1692D+00,
     &2.1276D+00,2.0835D+00,2.0378D+00,1.9974D+00,1.9525D+00,1.8983D+00,
     &1.8413D+00,1.7827D+00,1.7243D+00,1.6725D+00,1.6166D+00,1.5520D+00,
     &1.4872D+00,1.4244D+00,1.3627D+00,1.3136D+00,1.2649D+00,1.2130D+00,
     &1.1663D+00,1.1352D+00,1.1040D+00,1.0787D+00,1.0514D+00,1.0264D+00,
     &1.0021D+00,9.7883D-01,9.5548D-01,9.3171D-01,9.0763D-01,8.8283D-01,
     &8.5596D-01,8.2732D-01,7.9601D-01,7.7056D-01,7.1598D-01,6.6027D-01,
     &6.0340D-01,5.4514D-01,4.8601D-01,4.2556D-01,3.6359D-01,2.9984D-01,
     &2.3396D-01,1.6486D-01,9.0844D-02,0.0000D+00,2.9880D+00,2.9510D+00,
     &2.9150D+00,2.8782D+00,2.8430D+00,2.8048D+00,2.7677D+00,2.7301D+00,
     &2.6924D+00,2.6517D+00,2.6110D+00,2.5696D+00,2.5280D+00,2.5017D+00,
     &2.4728D+00,2.4393D+00,2.4042D+00,2.3687D+00,2.3313D+00,2.2988D+00,
     &2.2631D+00,2.2204D+00,2.1768D+00,2.1312D+00,2.0828D+00,2.0405D+00,
     &1.9928D+00,1.9364D+00,1.8772D+00,1.8164D+00,1.7558D+00,1.7018D+00/
      DATA (XDVF_L(K),K= 1597, 1710) /
     &1.6434D+00,1.5762D+00,1.5084D+00,1.4432D+00,1.3783D+00,1.3261D+00,
     &1.2741D+00,1.2182D+00,1.1669D+00,1.1315D+00,1.0961D+00,1.0671D+00,
     &1.0360D+00,1.0071D+00,9.7992D-01,9.5371D-01,9.2801D-01,9.0200D-01,
     &8.7588D-01,8.4862D-01,8.2038D-01,7.9020D-01,7.5770D-01,7.3298D-01,
     &6.7721D-01,6.2090D-01,5.6394D-01,5.0631D-01,4.4841D-01,3.8970D-01,
     &3.3019D-01,2.6973D-01,2.0791D-01,1.4420D-01,7.7416D-02,0.0000D+00,
     &3.0661D+00,3.0288D+00,2.9911D+00,2.9537D+00,2.9160D+00,2.8778D+00,
     &2.8392D+00,2.8000D+00,2.7610D+00,2.7200D+00,2.6782D+00,2.6345D+00,
     &2.5900D+00,2.5625D+00,2.5329D+00,2.4982D+00,2.4617D+00,2.4247D+00,
     &2.3857D+00,2.3518D+00,2.3145D+00,2.2697D+00,2.2245D+00,2.1764D+00,
     &2.1269D+00,2.0819D+00,2.0331D+00,1.9746D+00,1.9126D+00,1.8497D+00,
     &1.7862D+00,1.7303D+00,1.6696D+00,1.5995D+00,1.5285D+00,1.4608D+00,
     &1.3929D+00,1.3377D+00,1.2826D+00,1.2228D+00,1.1669D+00,1.1279D+00,
     &1.0882D+00,1.0555D+00,1.0205D+00,9.8876D-01,9.5876D-01,9.2969D-01,
     &9.0171D-01,8.7356D-01,8.4551D-01,8.1668D-01,7.8701D-01,7.5564D-01,
     &7.2196D-01,6.9797D-01,6.4121D-01,5.8469D-01,5.2810D-01,4.7131D-01,
     &4.1460D-01,3.5783D-01,3.0063D-01,2.4338D-01,1.8544D-01,1.2660D-01,
     &6.6270D-02,0.0000D+00,3.1379D+00,3.0995D+00,3.0600D+00,3.0213D+00,
     &2.9840D+00,2.9442D+00,2.9047D+00,2.8641D+00,2.8239D+00,2.7813D+00/
      DATA (XDVF_L(K),K= 1711, 1824) /
     &2.7383D+00,2.6928D+00,2.6470D+00,2.6191D+00,2.5880D+00,2.5519D+00,
     &2.5145D+00,2.4761D+00,2.4357D+00,2.4004D+00,2.3615D+00,2.3153D+00,
     &2.2678D+00,2.2180D+00,2.1669D+00,2.1208D+00,2.0699D+00,2.0087D+00,
     &1.9447D+00,1.8795D+00,1.8139D+00,1.7558D+00,1.6930D+00,1.6205D+00,
     &1.5467D+00,1.4759D+00,1.4054D+00,1.3484D+00,1.2895D+00,1.2267D+00,
     &1.1663D+00,1.1242D+00,1.0808D+00,1.0449D+00,1.0065D+00,9.7194D-01,
     &9.3967D-01,9.0840D-01,8.7834D-01,8.4891D-01,8.1928D-01,7.8930D-01,
     &7.5803D-01,7.2562D-01,6.9124D-01,6.6796D-01,6.1058D-01,5.5392D-01,
     &4.9752D-01,4.4176D-01,3.8633D-01,3.3127D-01,2.7648D-01,2.2186D-01,
     &1.6735D-01,1.1268D-01,5.7652D-02,0.0000D+00,3.2129D+00,3.1726D+00,
     &3.1325D+00,3.0928D+00,3.0540D+00,3.0127D+00,2.9717D+00,2.9303D+00,
     &2.8887D+00,2.8449D+00,2.8001D+00,2.7537D+00,2.7060D+00,2.6766D+00,
     &2.6453D+00,2.6073D+00,2.5683D+00,2.5286D+00,2.4866D+00,2.4501D+00,
     &2.4107D+00,2.3628D+00,2.3125D+00,2.2620D+00,2.2079D+00,2.1597D+00,
     &2.1067D+00,2.0440D+00,1.9778D+00,1.9097D+00,1.8421D+00,1.7819D+00,
     &1.7169D+00,1.6416D+00,1.5664D+00,1.4922D+00,1.4189D+00,1.3583D+00,
     &1.2971D+00,1.2300D+00,1.1652D+00,1.1200D+00,1.0729D+00,1.0343D+00,
     &9.9254D-01,9.5513D-01,9.2006D-01,8.8711D-01,8.5555D-01,8.2426D-01,
     &7.9305D-01,7.6193D-01,7.2963D-01,6.9636D-01,6.6128D-01,6.3868D-01/
      DATA (XDVF_L(K),K= 1825, 1836) /
     &5.8093D-01,5.2428D-01,4.6858D-01,4.1372D-01,3.5972D-01,3.0648D-01,
     &2.5392D-01,2.0208D-01,1.5083D-01,1.0018D-01,5.0068D-02,0.0000D+00/
      DATA (XDEF_L(K),K=    1,  114) /
     &4.3007D-01,4.2474D-01,4.1967D-01,4.1458D-01,4.0970D-01,4.0443D-01,
     &3.9925D-01,3.9397D-01,3.8864D-01,3.8302D-01,3.7707D-01,3.7100D-01,
     &3.6470D-01,3.6080D-01,3.5639D-01,3.5109D-01,3.4531D-01,3.3914D-01,
     &3.3238D-01,3.2609D-01,3.1913D-01,3.1062D-01,3.0152D-01,2.9176D-01,
     &2.8100D-01,2.7114D-01,2.5952D-01,2.4467D-01,2.2784D-01,2.0937D-01,
     &1.9117D-01,1.7470D-01,1.5685D-01,1.3678D-01,1.1825D-01,1.0349D-01,
     &9.4854D-02,9.5054D-02,1.0589D-01,1.3527D-01,1.8584D-01,2.3426D-01,
     &2.9021D-01,3.3527D-01,3.7670D-01,4.0255D-01,4.1326D-01,4.0880D-01,
     &3.8831D-01,3.5045D-01,2.9287D-01,2.1298D-01,1.0773D-01,0.0000D+00,
     &0.0000D+00,2.0644D-01,1.5422D-01,1.0950D-01,7.3614D-02,4.6726D-02,
     &2.7433D-02,1.4144D-02,6.5080D-03,2.4719D-03,0.0000D+00,0.0000D+00,
     &0.0000D+00,0.0000D+00,4.4398D-01,4.3864D-01,4.3346D-01,4.2809D-01,
     &4.2290D-01,4.1747D-01,4.1205D-01,4.0650D-01,4.0098D-01,3.9480D-01,
     &3.8873D-01,3.8226D-01,3.7560D-01,3.7145D-01,3.6678D-01,3.6108D-01,
     &3.5488D-01,3.4833D-01,3.4123D-01,3.3464D-01,3.2718D-01,3.1811D-01,
     &3.0838D-01,2.9811D-01,2.8670D-01,2.7630D-01,2.6412D-01,2.4861D-01,
     &2.3110D-01,2.1209D-01,1.9355D-01,1.7681D-01,1.5878D-01,1.3870D-01,
     &1.2044D-01,1.0620D-01,9.8341D-02,9.9345D-02,1.1086D-01,1.4055D-01,
     &1.9033D-01,2.3696D-01,2.8983D-01,3.3137D-01,3.6834D-01,3.8982D-01/
      DATA (XDEF_L(K),K=  115,  228) /
     &3.9672D-01,3.8896D-01,3.6609D-01,3.2678D-01,2.6933D-01,1.9181D-01,
     &9.1683D-02,0.0000D+00,0.0000D+00,1.8955D-01,1.4041D-01,9.8873D-02,
     &6.5928D-02,4.1462D-02,2.3905D-02,1.2324D-02,5.6113D-03,2.1050D-03,
     &0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,4.5980D-01,4.5420D-01,
     &4.4884D-01,4.4319D-01,4.3780D-01,4.3208D-01,4.2642D-01,4.2053D-01,
     &4.1457D-01,4.0824D-01,4.0181D-01,3.9484D-01,3.8780D-01,3.8328D-01,
     &3.7831D-01,3.7223D-01,3.6559D-01,3.5853D-01,3.5072D-01,3.4400D-01,
     &3.3590D-01,3.2633D-01,3.1598D-01,3.0508D-01,2.9301D-01,2.8197D-01,
     &2.6915D-01,2.5289D-01,2.3470D-01,2.1511D-01,1.9623D-01,1.7918D-01,
     &1.6098D-01,1.4092D-01,1.2294D-01,1.0928D-01,1.0224D-01,1.0401D-01,
     &1.1623D-01,1.4620D-01,1.9488D-01,2.3948D-01,2.8894D-01,3.2681D-01,
     &3.5905D-01,3.7613D-01,3.7908D-01,3.6817D-01,3.4299D-01,3.0266D-01,
     &2.4596D-01,1.7115D-01,7.6792D-02,0.0000D+00,0.0000D+00,1.7267D-01,
     &1.2670D-01,8.8446D-02,5.8458D-02,3.6380D-02,2.0551D-02,1.0608D-02,
     &4.7732D-03,1.7670D-03,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,
     &4.7845D-01,4.7258D-01,4.6687D-01,4.6107D-01,4.5540D-01,4.4938D-01,
     &4.4336D-01,4.3728D-01,4.3070D-01,4.2403D-01,4.1702D-01,4.0968D-01,
     &4.0210D-01,3.9723D-01,3.9181D-01,3.8522D-01,3.7808D-01,3.7047D-01,
     &3.6211D-01,3.5469D-01,3.4619D-01,3.3582D-01,3.2478D-01,3.1314D-01/
      DATA (XDEF_L(K),K=  229,  342) /
     &3.0021D-01,2.8848D-01,2.7488D-01,2.5781D-01,2.3886D-01,2.1865D-01,
     &1.9932D-01,1.8196D-01,1.6359D-01,1.4359D-01,1.2596D-01,1.1295D-01,
     &1.0678D-01,1.0933D-01,1.2234D-01,1.5242D-01,1.9969D-01,2.4187D-01,
     &2.8742D-01,3.2112D-01,3.4825D-01,3.6067D-01,3.5959D-01,3.4546D-01,
     &3.1813D-01,2.7719D-01,2.2151D-01,1.5037D-01,6.2862D-02,0.0000D+00,
     &0.0000D+00,1.5516D-01,1.1270D-01,7.7856D-02,5.0916D-02,3.1337D-02,
     &1.7279D-02,8.9355D-03,3.9672D-03,1.4465D-03,0.0000D+00,0.0000D+00,
     &0.0000D+00,0.0000D+00,5.0059D-01,4.9450D-01,4.8826D-01,4.8213D-01,
     &4.7610D-01,4.6972D-01,4.6326D-01,4.5655D-01,4.4999D-01,4.4265D-01,
     &4.3505D-01,4.2703D-01,4.1870D-01,4.1345D-01,4.0758D-01,4.0034D-01,
     &3.9260D-01,3.8434D-01,3.7539D-01,3.6725D-01,3.5804D-01,3.4696D-01,
     &3.3492D-01,3.2231D-01,3.0852D-01,2.9601D-01,2.8154D-01,2.6348D-01,
     &2.4363D-01,2.2272D-01,2.0295D-01,1.8526D-01,1.6669D-01,1.4678D-01,
     &1.2956D-01,1.1726D-01,1.1212D-01,1.1548D-01,1.2910D-01,1.5906D-01,
     &2.0458D-01,2.4395D-01,2.8508D-01,3.1418D-01,3.3593D-01,3.4343D-01,
     &3.3827D-01,3.2104D-01,2.9189D-01,2.5067D-01,1.9688D-01,1.3016D-01,
     &5.0498D-02,0.0000D+00,0.0000D+00,1.3742D-01,9.8602D-02,6.7357D-02,
     &4.3555D-02,2.6444D-02,1.4175D-02,7.3561D-03,3.2181D-03,1.1530D-03,
     &0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,5.2114D-01,5.1454D-01/
      DATA (XDEF_L(K),K=  343,  456) /
     &5.0806D-01,5.0160D-01,4.9520D-01,4.8843D-01,4.8165D-01,4.7456D-01,
     &4.6738D-01,4.5962D-01,4.5149D-01,4.4293D-01,4.3400D-01,4.2833D-01,
     &4.2194D-01,4.1420D-01,4.0580D-01,3.9678D-01,3.8741D-01,3.7848D-01,
     &3.6878D-01,3.5682D-01,3.4416D-01,3.3062D-01,3.1602D-01,3.0269D-01,
     &2.8749D-01,2.6857D-01,2.4798D-01,2.2641D-01,2.0626D-01,1.8828D-01,
     &1.6960D-01,1.4976D-01,1.3293D-01,1.2126D-01,1.1684D-01,1.2099D-01,
     &1.3505D-01,1.6471D-01,2.0841D-01,2.4521D-01,2.8248D-01,3.0770D-01,
     &3.2484D-01,3.2845D-01,3.1999D-01,3.0047D-01,2.7030D-01,2.2924D-01,
     &1.7739D-01,1.1482D-01,4.2174D-02,0.0000D+00,0.0000D+00,1.2330D-01,
     &8.7586D-02,5.9211D-02,3.7890D-02,2.2733D-02,1.1877D-02,6.1865D-03,
     &2.6713D-03,9.4247D-04,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,
     &5.4423D-01,5.3740D-01,5.3068D-01,5.2385D-01,5.1700D-01,5.0982D-01,
     &5.0256D-01,4.9509D-01,4.8731D-01,4.7895D-01,4.7023D-01,4.6094D-01,
     &4.5130D-01,4.4506D-01,4.3820D-01,4.2973D-01,4.2069D-01,4.1108D-01,
     &4.0069D-01,3.9131D-01,3.8063D-01,3.6796D-01,3.5430D-01,3.3991D-01,
     &3.2433D-01,3.1014D-01,2.9407D-01,2.7418D-01,2.5281D-01,2.3056D-01,
     &2.0999D-01,1.9171D-01,1.7291D-01,1.5321D-01,1.3677D-01,1.2578D-01,
     &1.2220D-01,1.2696D-01,1.4132D-01,1.7056D-01,2.1212D-01,2.4603D-01,
     &2.7912D-01,3.0023D-01,3.1274D-01,3.1234D-01,3.0087D-01,2.7925D-01/
      DATA (XDEF_L(K),K=  457,  570) /
     &2.4820D-01,2.0782D-01,1.5841D-01,1.0056D-01,3.5470D-02,0.0000D+00,
     &0.0000D+00,1.0941D-01,7.6864D-02,5.1391D-02,3.2506D-02,1.9250D-02,
     &9.7741D-03,5.1192D-03,2.1775D-03,0.0000D+00,0.0000D+00,0.0000D+00,
     &0.0000D+00,0.0000D+00,5.6542D-01,5.5814D-01,5.5101D-01,5.4385D-01,
     &5.3670D-01,5.2913D-01,5.2140D-01,5.1352D-01,5.0533D-01,4.9639D-01,
     &4.8702D-01,4.7710D-01,4.6670D-01,4.6011D-01,4.5270D-01,4.4365D-01,
     &4.3394D-01,4.2383D-01,4.1271D-01,4.0253D-01,3.9137D-01,3.7783D-01,
     &3.6325D-01,3.4810D-01,3.3163D-01,3.1674D-01,2.9988D-01,2.7922D-01,
     &2.5706D-01,2.3429D-01,2.1333D-01,1.9484D-01,1.7592D-01,1.5634D-01,
     &1.4028D-01,1.2985D-01,1.2692D-01,1.3218D-01,1.4678D-01,1.7535D-01,
     &2.1492D-01,2.4628D-01,2.7582D-01,2.9349D-01,3.0215D-01,2.9865D-01,
     &2.8479D-01,2.6176D-01,2.3025D-01,1.9073D-01,1.4372D-01,9.0030D-02,
     &3.1431D-02,0.0000D+00,0.0000D+00,9.8561D-02,6.8571D-02,4.5400D-02,
     &2.8439D-02,1.6650D-02,8.2414D-03,4.3377D-03,1.8226D-03,0.0000D+00,
     &0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,5.8660D-01,5.7912D-01,
     &5.7170D-01,5.6412D-01,5.5660D-01,5.4858D-01,5.4040D-01,5.3194D-01,
     &5.2336D-01,5.1383D-01,5.0381D-01,4.9326D-01,4.8220D-01,4.7515D-01,
     &4.6719D-01,4.5756D-01,4.4719D-01,4.3619D-01,4.2441D-01,4.1376D-01,
     &4.0188D-01,3.8750D-01,3.7220D-01,3.5617D-01,3.3884D-01,3.2317D-01/
      DATA (XDEF_L(K),K=  571,  684) /
     &3.0561D-01,2.8413D-01,2.6132D-01,2.3801D-01,2.1667D-01,1.9794D-01,
     &1.7898D-01,1.5951D-01,1.4381D-01,1.3395D-01,1.3154D-01,1.3722D-01,
     &1.5183D-01,1.7978D-01,2.1726D-01,2.4615D-01,2.7227D-01,2.8668D-01,
     &2.9185D-01,2.8560D-01,2.6981D-01,2.4566D-01,2.1405D-01,1.7560D-01,
     &1.3093D-01,8.1317D-02,2.8821D-02,0.0000D+00,0.0000D+00,8.9016D-02,
     &6.1335D-02,4.0241D-02,2.4960D-02,1.4451D-02,6.9787D-03,3.6912D-03,
     &1.5320D-03,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,
     &6.0621D-01,5.9821D-01,5.9043D-01,5.8253D-01,5.7470D-01,5.6625D-01,
     &5.5768D-01,5.4870D-01,5.3948D-01,5.2962D-01,5.1919D-01,5.0796D-01,
     &4.9620D-01,4.8867D-01,4.8027D-01,4.7003D-01,4.5907D-01,4.4740D-01,
     &4.3484D-01,4.2392D-01,4.1127D-01,3.9627D-01,3.8010D-01,3.6326D-01,
     &3.4524D-01,3.2900D-01,3.1064D-01,2.8853D-01,2.6510D-01,2.4135D-01,
     &2.1970D-01,2.0080D-01,1.8175D-01,1.6242D-01,1.4701D-01,1.3753D-01,
     &1.3572D-01,1.4160D-01,1.5623D-01,1.8343D-01,2.1902D-01,2.4571D-01,
     &2.6885D-01,2.8059D-01,2.8292D-01,2.7441D-01,2.5704D-01,2.3223D-01,
     &2.0062D-01,1.6317D-01,1.2079D-01,7.4733D-02,2.7461D-02,0.0000D+00,
     &0.0000D+00,8.1334D-02,5.5577D-02,3.6150D-02,2.2243D-02,1.2749D-02,
     &6.0264D-03,3.2009D-03,1.3143D-03,0.0000D+00,0.0000D+00,0.0000D+00,
     &0.0000D+00,0.0000D+00,6.2581D-01,6.1778D-01,6.0953D-01,6.0134D-01/
      DATA (XDEF_L(K),K=  685,  798) /
     &5.9310D-01,5.8428D-01,5.7523D-01,5.6587D-01,5.5625D-01,5.4565D-01,
     &5.3457D-01,5.2280D-01,5.1030D-01,5.0236D-01,4.9350D-01,4.8267D-01,
     &4.7104D-01,4.5899D-01,4.4560D-01,4.3381D-01,4.2066D-01,4.0485D-01,
     &3.8801D-01,3.7047D-01,3.5165D-01,3.3476D-01,3.1574D-01,2.9293D-01,
     &2.6889D-01,2.4469D-01,2.2279D-01,2.0369D-01,1.8458D-01,1.6537D-01,
     &1.5025D-01,1.4125D-01,1.3980D-01,1.4589D-01,1.6046D-01,1.8686D-01,
     &2.2052D-01,2.4502D-01,2.6530D-01,2.7444D-01,2.7406D-01,2.6361D-01,
     &2.4491D-01,2.1954D-01,1.8819D-01,1.5193D-01,1.1170D-01,6.9146D-02,
     &2.6829D-02,0.0000D+00,0.0000D+00,7.4387D-02,5.0398D-02,3.2529D-02,
     &1.9840D-02,1.1260D-02,5.2109D-03,2.7796D-03,1.1291D-03,0.0000D+00,
     &0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,6.4510D-01,6.3663D-01,
     &6.2809D-01,6.1948D-01,6.1090D-01,6.0165D-01,5.9256D-01,5.8263D-01,
     &5.7237D-01,5.6121D-01,5.4960D-01,5.3710D-01,5.2390D-01,5.1555D-01,
     &5.0615D-01,4.9474D-01,4.8273D-01,4.6980D-01,4.5603D-01,4.4343D-01,
     &4.2983D-01,4.1325D-01,3.9561D-01,3.7731D-01,3.5765D-01,3.4017D-01,
     &3.2063D-01,2.9709D-01,2.7258D-01,2.4795D-01,2.2572D-01,2.0647D-01,
     &1.8735D-01,1.6824D-01,1.5339D-01,1.4470D-01,1.4366D-01,1.4990D-01,
     &1.6437D-01,1.8986D-01,2.2169D-01,2.4408D-01,2.6175D-01,2.6863D-01,
     &2.6585D-01,2.5363D-01,2.3397D-01,2.0813D-01,1.7714D-01,1.4205D-01/
      DATA (XDEF_L(K),K=  799,  912) /
     &1.0396D-01,6.4602D-02,2.6785D-02,0.0000D+00,0.0000D+00,6.8343D-02,
     &4.5962D-02,2.9434D-02,1.7812D-02,1.0015D-02,4.5458D-03,2.4331D-03,
     &9.7866D-04,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,
     &6.6281D-01,6.5407D-01,6.4523D-01,6.3631D-01,6.2740D-01,6.1775D-01,
     &6.0821D-01,5.9770D-01,5.8724D-01,5.7535D-01,5.6321D-01,5.5021D-01,
     &5.3640D-01,5.2763D-01,5.1775D-01,5.0583D-01,4.9310D-01,4.7946D-01,
     &4.6520D-01,4.5225D-01,4.3811D-01,4.2074D-01,4.0247D-01,3.8355D-01,
     &3.6315D-01,3.4516D-01,3.2502D-01,3.0091D-01,2.7589D-01,2.5090D-01,
     &2.2842D-01,2.0903D-01,1.8987D-01,1.7087D-01,1.5631D-01,1.4790D-01,
     &1.4709D-01,1.5345D-01,1.6771D-01,1.9243D-01,2.2253D-01,2.4307D-01,
     &2.5846D-01,2.6327D-01,2.5857D-01,2.4493D-01,2.2441D-01,1.9832D-01,
     &1.6773D-01,1.3380D-01,9.7606D-02,6.1077D-02,2.7123D-02,4.1687D-04,
     &0.0000D+00,6.3316D-02,4.2290D-02,2.6899D-02,1.6166D-02,9.0143D-03,
     &4.0214D-03,2.1587D-03,8.6042D-04,0.0000D+00,0.0000D+00,0.0000D+00,
     &0.0000D+00,0.0000D+00,6.8558D-01,6.7623D-01,6.6716D-01,6.5776D-01,
     &6.4840D-01,6.3825D-01,6.2778D-01,6.1697D-01,6.0589D-01,5.9350D-01,
     &5.8071D-01,5.6677D-01,5.5220D-01,5.4293D-01,5.3246D-01,5.1980D-01,
     &5.0630D-01,4.9221D-01,4.7690D-01,4.6348D-01,4.4839D-01,4.3024D-01,
     &4.1112D-01,3.9125D-01,3.7016D-01,3.5134D-01,3.3054D-01,3.0571D-01/
      DATA (XDEF_L(K),K=  913, 1026) /
     &2.8005D-01,2.5463D-01,2.3186D-01,2.1230D-01,1.9311D-01,1.7422D-01,
     &1.5985D-01,1.5187D-01,1.5138D-01,1.5783D-01,1.7178D-01,1.9543D-01,
     &2.2331D-01,2.4162D-01,2.5415D-01,2.5666D-01,2.4964D-01,2.3438D-01,
     &2.1293D-01,1.8681D-01,1.5680D-01,1.2430D-01,9.0488D-02,5.7352D-02,
     &2.7942D-02,7.0995D-03,2.4780D-03,5.7612D-02,3.8138D-02,2.4057D-02,
     &1.4329D-02,7.9111D-03,3.4566D-03,1.8603D-03,7.3347D-04,0.0000D+00,
     &0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,7.0709D-01,6.9744D-01,
     &6.8784D-01,6.7803D-01,6.6830D-01,6.5763D-01,6.4678D-01,6.3540D-01,
     &6.2360D-01,6.1071D-01,5.9715D-01,5.8240D-01,5.6710D-01,5.5722D-01,
     &5.4625D-01,5.3291D-01,5.1856D-01,5.0380D-01,4.8797D-01,4.7363D-01,
     &4.5801D-01,4.3900D-01,4.1917D-01,3.9846D-01,3.7656D-01,3.5717D-01,
     &3.3564D-01,3.1017D-01,2.8397D-01,2.5816D-01,2.3508D-01,2.1538D-01,
     &1.9615D-01,1.7737D-01,1.6324D-01,1.5559D-01,1.5535D-01,1.6175D-01,
     &1.7537D-01,1.9793D-01,2.2384D-01,2.4005D-01,2.5009D-01,2.5051D-01,
     &2.4150D-01,2.2495D-01,2.0291D-01,1.7668D-01,1.4739D-01,1.1625D-01,
     &8.4583D-02,5.4470D-02,2.9013D-02,1.3147D-02,1.4553D-02,5.2777D-02,
     &3.4672D-02,2.1686D-02,1.2821D-02,7.0105D-03,3.0093D-03,1.6226D-03,
     &6.3321D-04,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,
     &7.2796D-01,7.1795D-01,7.0799D-01,6.9776D-01,6.8760D-01,6.7649D-01/
      DATA (XDEF_L(K),K= 1027, 1140) /
     &6.6523D-01,6.5299D-01,6.4099D-01,6.2720D-01,6.1289D-01,5.9763D-01,
     &5.8140D-01,5.7108D-01,5.5954D-01,5.4555D-01,5.3082D-01,5.1501D-01,
     &4.9841D-01,4.8352D-01,4.6718D-01,4.4758D-01,4.2678D-01,4.0543D-01,
     &3.8267D-01,3.6267D-01,3.4052D-01,3.1445D-01,2.8771D-01,2.6154D-01,
     &2.3817D-01,2.1835D-01,1.9910D-01,1.8043D-01,1.6662D-01,1.5905D-01,
     &1.5900D-01,1.6548D-01,1.7871D-01,2.0015D-01,2.2403D-01,2.3835D-01,
     &2.4610D-01,2.4469D-01,2.3394D-01,2.1634D-01,1.9372D-01,1.6761D-01,
     &1.3910D-01,1.0920D-01,7.9530D-02,5.2165D-02,3.0250D-02,1.8723D-02,
     &2.5275D-02,4.8575D-02,3.1676D-02,1.9677D-02,1.1540D-02,6.2533D-03,
     &2.6411D-03,1.4253D-03,5.5072D-04,0.0000D+00,0.0000D+00,0.0000D+00,
     &0.0000D+00,0.0000D+00,7.4788D-01,7.3751D-01,7.2708D-01,7.1644D-01,
     &7.0580D-01,6.9430D-01,6.8256D-01,6.6975D-01,6.5712D-01,6.4276D-01,
     &6.2791D-01,6.1180D-01,5.9490D-01,5.8409D-01,5.7199D-01,5.5739D-01,
     &5.4166D-01,5.2544D-01,5.0821D-01,4.9288D-01,4.7590D-01,4.5544D-01,
     &4.3393D-01,4.1178D-01,3.8837D-01,3.6775D-01,3.4513D-01,3.1844D-01,
     &2.9125D-01,2.6472D-01,2.4110D-01,2.2115D-01,2.0189D-01,1.8330D-01,
     &1.6955D-01,1.6237D-01,1.6243D-01,1.6875D-01,1.8164D-01,2.0201D-01,
     &2.2410D-01,2.3665D-01,2.4236D-01,2.3927D-01,2.2710D-01,2.0852D-01,
     &1.8563D-01,1.5962D-01,1.3170D-01,1.0314D-01,7.5292D-02,5.0347D-02/
      DATA (XDEF_L(K),K= 1141, 1254) /
     &3.1513D-02,2.3688D-02,3.4520D-02,4.4988D-02,2.9140D-02,1.7975D-02,
     &1.0472D-02,5.6268D-03,2.3442D-03,1.2646D-03,4.8432D-04,0.0000D+00,
     &0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,7.6812D-01,7.5731D-01,
     &7.4653D-01,7.3551D-01,7.2440D-01,7.1234D-01,6.9989D-01,6.8692D-01,
     &6.7357D-01,6.5855D-01,6.4312D-01,6.2624D-01,6.0850D-01,5.9719D-01,
     &5.8457D-01,5.6934D-01,5.5297D-01,5.3626D-01,5.1802D-01,5.0223D-01,
     &4.8440D-01,4.6329D-01,4.4109D-01,4.1826D-01,3.9408D-01,3.7291D-01,
     &3.4966D-01,3.2243D-01,2.9475D-01,2.6790D-01,2.4406D-01,2.2399D-01,
     &2.0470D-01,1.8621D-01,1.7262D-01,1.6558D-01,1.6576D-01,1.7201D-01,
     &1.8441D-01,2.0372D-01,2.2403D-01,2.3482D-01,2.3856D-01,2.3398D-01,
     &2.2040D-01,2.0103D-01,1.7782D-01,1.5205D-01,1.2492D-01,9.7540D-02,
     &7.1452D-02,4.8817D-02,3.2832D-02,2.8412D-02,4.3068D-02,4.1684D-02,
     &2.6819D-02,1.6431D-02,9.5049D-03,5.0674D-03,2.0840D-03,1.1231D-03,
     &4.2643D-04,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,
     &7.8709D-01,7.7617D-01,7.6509D-01,7.5353D-01,7.4210D-01,7.2955D-01,
     &7.1666D-01,7.0326D-01,6.8906D-01,6.7364D-01,6.5743D-01,6.3988D-01,
     &6.2140D-01,6.0962D-01,5.9645D-01,5.8083D-01,5.6382D-01,5.4630D-01,
     &5.2750D-01,5.1079D-01,4.9267D-01,4.7078D-01,4.4780D-01,4.2425D-01,
     &3.9948D-01,3.7773D-01,3.5398D-01,3.2619D-01,2.9811D-01,2.7093D-01/
      DATA (XDEF_L(K),K= 1255, 1368) /
     &2.4686D-01,2.2668D-01,2.0735D-01,1.8888D-01,1.7555D-01,1.6865D-01,
     &1.6887D-01,1.7500D-01,1.8693D-01,2.0522D-01,2.2377D-01,2.3300D-01,
     &2.3501D-01,2.2902D-01,2.1428D-01,1.9427D-01,1.7084D-01,1.4533D-01,
     &1.1889D-01,9.2655D-02,6.8174D-02,4.7575D-02,3.4123D-02,3.2605D-02,
     &5.0454D-02,3.8820D-02,2.4822D-02,1.5113D-02,8.6857D-03,4.5962D-03,
     &1.8704D-03,1.0050D-03,3.7856D-04,0.0000D+00,0.0000D+00,0.0000D+00,
     &0.0000D+00,0.0000D+00,8.0606D-01,7.9455D-01,7.8312D-01,7.7128D-01,
     &7.5940D-01,7.4610D-01,7.3287D-01,7.1917D-01,7.0456D-01,6.8825D-01,
     &6.7140D-01,6.5313D-01,6.3390D-01,6.2170D-01,6.0798D-01,5.9180D-01,
     &5.7419D-01,5.5596D-01,5.3636D-01,5.1934D-01,5.0050D-01,4.7790D-01,
     &4.5436D-01,4.3012D-01,4.0458D-01,3.8238D-01,3.5808D-01,3.2984D-01,
     &3.0133D-01,2.7388D-01,2.4957D-01,2.2930D-01,2.0996D-01,1.9168D-01,
     &1.7832D-01,1.7159D-01,1.7177D-01,1.7770D-01,1.8921D-01,2.0651D-01,
     &2.2344D-01,2.3117D-01,2.3152D-01,2.2426D-01,2.0844D-01,1.8790D-01,
     &1.6440D-01,1.3914D-01,1.1342D-01,8.8280D-02,6.5276D-02,4.6578D-02,
     &3.5360D-02,3.6411D-02,5.6986D-02,3.6256D-02,2.3040D-02,1.3948D-02,
     &7.9676D-03,4.1856D-03,1.6876D-03,9.0394D-04,3.3789D-04,0.0000D+00,
     &0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,8.2409D-01,8.1223D-01,
     &8.0027D-01,7.8810D-01,7.7580D-01,7.6250D-01,7.4852D-01,7.3383D-01/
      DATA (XDEF_L(K),K= 1369, 1482) /
     &7.1879D-01,7.0216D-01,6.8466D-01,6.6571D-01,6.4580D-01,6.3303D-01,
     &6.1887D-01,6.0161D-01,5.8362D-01,5.6485D-01,5.4490D-01,5.2736D-01,
     &5.0788D-01,4.8465D-01,4.6048D-01,4.3549D-01,4.0949D-01,3.8678D-01,
     &3.6198D-01,3.3325D-01,3.0435D-01,2.7667D-01,2.5212D-01,2.3179D-01,
     &2.1241D-01,1.9410D-01,1.8093D-01,1.7428D-01,1.7445D-01,1.8022D-01,
     &1.9133D-01,2.0758D-01,2.2299D-01,2.2941D-01,2.2823D-01,2.1990D-01,
     &2.0319D-01,1.8211D-01,1.5852D-01,1.3371D-01,1.0856D-01,8.4430D-02,
     &6.2776D-02,4.5758D-02,3.6514D-02,3.9756D-02,6.2597D-02,3.4019D-02,
     &2.1502D-02,1.2943D-02,7.3506D-03,3.8366D-03,1.5351D-03,8.1923D-04,
     &3.0383D-04,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,
     &8.4844D-01,8.3627D-01,8.2378D-01,8.1114D-01,7.9820D-01,7.8411D-01,
     &7.6977D-01,7.5436D-01,7.3871D-01,7.2101D-01,7.0269D-01,6.8280D-01,
     &6.6180D-01,6.4849D-01,6.3365D-01,6.1605D-01,5.9682D-01,5.7721D-01,
     &5.5628D-01,5.3805D-01,5.1772D-01,4.9378D-01,4.6868D-01,4.4295D-01,
     &4.1599D-01,3.9262D-01,3.6722D-01,3.3788D-01,3.0847D-01,2.8040D-01,
     &2.5562D-01,2.3513D-01,2.1572D-01,1.9746D-01,1.8447D-01,1.7787D-01,
     &1.7810D-01,1.8358D-01,1.9394D-01,2.0894D-01,2.2227D-01,2.2689D-01,
     &2.2385D-01,2.1408D-01,1.9620D-01,1.7461D-01,1.5108D-01,1.2667D-01,
     &1.0243D-01,7.9635D-02,5.9715D-02,4.4804D-02,3.7997D-02,4.3894D-02/
      DATA (XDEF_L(K),K= 1483, 1596) /
     &6.9391D-02,3.1240D-02,1.9603D-02,1.1712D-02,6.6036D-03,3.4150D-03,
     &1.3549D-03,7.1812D-04,2.6373D-04,0.0000D+00,0.0000D+00,0.0000D+00,
     &0.0000D+00,0.0000D+00,8.7089D-01,8.5819D-01,8.4535D-01,8.3207D-01,
     &8.1860D-01,8.0424D-01,7.8877D-01,7.7320D-01,7.5642D-01,7.3822D-01,
     &7.1895D-01,6.9816D-01,6.7640D-01,6.6244D-01,6.4701D-01,6.2817D-01,
     &6.0860D-01,5.8841D-01,5.6672D-01,5.4767D-01,5.2667D-01,5.0182D-01,
     &4.7599D-01,4.4955D-01,4.2190D-01,3.9787D-01,3.7196D-01,3.4199D-01,
     &3.1220D-01,2.8382D-01,2.5874D-01,2.3816D-01,2.1874D-01,2.0063D-01,
     &1.8770D-01,1.8107D-01,1.8121D-01,1.8638D-01,1.9622D-01,2.0994D-01,
     &2.2156D-01,2.2456D-01,2.1986D-01,2.0892D-01,1.9015D-01,1.6817D-01,
     &1.4465D-01,1.2070D-01,9.7309D-02,7.5665D-02,5.7234D-02,4.4095D-02,
     &3.9289D-02,4.7307D-02,7.4739D-02,2.8958D-02,1.8046D-02,1.0716D-02,
     &6.0010D-03,3.0801D-03,1.2145D-03,6.3833D-04,2.3251D-04,0.0000D+00,
     &0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,8.9366D-01,8.8058D-01,
     &8.6727D-01,8.5353D-01,8.3950D-01,8.2436D-01,8.0890D-01,7.9205D-01,
     &7.7476D-01,7.5566D-01,7.3557D-01,7.1393D-01,6.9120D-01,6.7672D-01,
     &6.6059D-01,6.4145D-01,6.2086D-01,5.9962D-01,5.7716D-01,5.5756D-01,
     &5.3584D-01,5.1022D-01,4.8344D-01,4.5615D-01,4.2780D-01,4.0320D-01,
     &3.7671D-01,3.4621D-01,3.1594D-01,2.8727D-01,2.6196D-01,2.4126D-01/
      DATA (XDEF_L(K),K= 1597, 1710) /
     &2.2177D-01,2.0361D-01,1.9078D-01,1.8427D-01,1.8432D-01,1.8918D-01,
     &1.9834D-01,2.1079D-01,2.2065D-01,2.2210D-01,2.1587D-01,2.0383D-01,
     &1.8424D-01,1.6197D-01,1.3849D-01,1.1505D-01,9.2463D-02,7.1949D-02,
     &5.4952D-02,4.3474D-02,4.0525D-02,5.0376D-02,7.9517D-02,2.6835D-02,
     &1.6616D-02,9.8004D-03,5.4489D-03,2.7768D-03,1.0900D-03,5.6728D-04,
     &2.0489D-04,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,
     &9.1643D-01,9.0298D-01,8.8901D-01,8.7472D-01,8.6030D-01,8.4449D-01,
     &8.2790D-01,8.1090D-01,7.9278D-01,7.7287D-01,7.5201D-01,7.2942D-01,
     &7.0580D-01,6.9067D-01,6.7395D-01,6.5357D-01,6.3264D-01,6.1082D-01,
     &5.8728D-01,5.6718D-01,5.4478D-01,5.1825D-01,4.9075D-01,4.6263D-01,
     &4.3360D-01,4.0844D-01,3.8138D-01,3.5032D-01,3.1963D-01,2.9065D-01,
     &2.6511D-01,2.4428D-01,2.2479D-01,2.0678D-01,1.9385D-01,1.8735D-01,
     &1.8722D-01,1.9179D-01,2.0029D-01,2.1158D-01,2.1961D-01,2.1971D-01,
     &2.1194D-01,1.9894D-01,1.7862D-01,1.5609D-01,1.3279D-01,1.0972D-01,
     &8.8007D-02,6.8578D-02,5.2905D-02,4.2942D-02,4.1624D-02,5.3065D-02,
     &8.3506D-02,2.4920D-02,1.5334D-02,8.9876D-03,4.9653D-03,2.5112D-03,
     &9.8300D-04,5.0629D-04,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,
     &0.0000D+00,0.0000D+00,9.3762D-01,9.2325D-01,9.0916D-01,8.9432D-01,
     &8.7930D-01,8.6312D-01,8.4579D-01,8.2807D-01,8.0954D-01,7.8866D-01/
      DATA (XDEF_L(K),K= 1711, 1824) /
     &7.6704D-01,7.4360D-01,7.1911D-01,7.0343D-01,6.8612D-01,6.6512D-01,
     &6.4349D-01,6.2048D-01,5.9676D-01,5.7574D-01,5.5261D-01,5.2556D-01,
     &4.9731D-01,4.6862D-01,4.3881D-01,4.1318D-01,3.8556D-01,3.5408D-01,
     &3.2299D-01,2.9375D-01,2.6794D-01,2.4706D-01,2.2744D-01,2.0939D-01,
     &1.9662D-01,1.9016D-01,1.8990D-01,1.9412D-01,2.0192D-01,2.1208D-01,
     &2.1863D-01,2.1745D-01,2.0845D-01,1.9458D-01,1.7365D-01,1.5094D-01,
     &1.2783D-01,1.0526D-01,8.4228D-02,6.5746D-02,5.1203D-02,4.2521D-02,
     &4.2531D-02,5.5238D-02,8.6619D-02,2.3321D-02,1.4266D-02,8.3142D-03,
     &4.5684D-03,2.2945D-03,8.9721D-04,4.5700D-04,0.0000D+00,0.0000D+00,
     &0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,9.5912D-01,9.4446D-01,
     &9.2967D-01,9.1446D-01,8.9890D-01,8.8176D-01,8.6424D-01,8.4567D-01,
     &8.2630D-01,8.0492D-01,7.8242D-01,7.5817D-01,7.3271D-01,7.1653D-01,
     &6.9849D-01,6.7725D-01,6.5433D-01,6.3091D-01,6.0625D-01,5.8456D-01,
     &5.6088D-01,5.3305D-01,5.0402D-01,4.7461D-01,4.4411D-01,4.1800D-01,
     &3.8988D-01,3.5790D-01,3.2644D-01,2.9690D-01,2.7087D-01,2.4987D-01,
     &2.3039D-01,2.1219D-01,1.9955D-01,1.9298D-01,1.9248D-01,1.9636D-01,
     &2.0355D-01,2.1258D-01,2.1752D-01,2.1512D-01,2.0490D-01,1.9021D-01,
     &1.6876D-01,1.4586D-01,1.2296D-01,1.0090D-01,8.0587D-02,6.3034D-02,
     &4.9591D-02,4.2122D-02,4.3355D-02,5.7203D-02,8.9336D-02,2.1802D-02/
      DATA (XDEF_L(K),K= 1825, 1836) /
     &1.3258D-02,7.6843D-03,4.1967D-03,2.0952D-03,8.1932D-04,4.1202D-04,
     &0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00,0.0000D+00/
      DATA (XUDF_L(K),K=    1,  114) /
     &1.8987D-02,1.9947D-02,2.0980D-02,2.2068D-02,2.3225D-02,2.4540D-02,
     &2.5957D-02,2.7526D-02,2.9229D-02,3.1232D-02,3.3453D-02,3.6003D-02,
     &3.8855D-02,4.0763D-02,4.2980D-02,4.5778D-02,4.8895D-02,5.2320D-02,
     &5.6174D-02,5.9765D-02,6.3980D-02,6.9315D-02,7.5299D-02,8.1888D-02,
     &8.9292D-02,9.6162D-02,1.0414D-01,1.1410D-01,1.2505D-01,1.3674D-01,
     &1.4937D-01,1.6060D-01,1.7296D-01,1.8730D-01,2.0166D-01,2.1531D-01,
     &2.2821D-01,2.3833D-01,2.4848D-01,2.6049D-01,2.7586D-01,2.9166D-01,
     &3.1456D-01,3.3942D-01,3.7230D-01,4.0597D-01,4.3921D-01,4.7071D-01,
     &4.9846D-01,5.2057D-01,5.3433D-01,5.3610D-01,5.2141D-01,4.8433D-01,
     &4.1719D-01,6.3794D-01,6.7411D-01,7.2040D-01,7.8812D-01,8.9495D-01,
     &1.0702D+00,1.3629D+00,1.8763D+00,2.8399D+00,4.8968D+00,1.0506D+01,
     &3.7793D+01,0.0000D+00,3.1111D-02,3.2336D-02,3.3580D-02,3.4906D-02,
     &3.6247D-02,3.7773D-02,3.9337D-02,4.1056D-02,4.2876D-02,4.5001D-02,
     &4.7299D-02,4.9897D-02,5.2761D-02,5.4666D-02,5.6867D-02,5.9620D-02,
     &6.2679D-02,6.6018D-02,6.9775D-02,7.3275D-02,7.7353D-02,8.2522D-02,
     &8.8327D-02,9.4694D-02,1.0184D-01,1.0846D-01,1.1615D-01,1.2575D-01,
     &1.3628D-01,1.4752D-01,1.5964D-01,1.7036D-01,1.8215D-01,1.9580D-01,
     &2.0933D-01,2.2213D-01,2.3411D-01,2.4341D-01,2.5275D-01,2.6387D-01,
     &2.7831D-01,2.9333D-01,3.1510D-01,3.3876D-01,3.6995D-01,4.0170D-01/
      DATA (XUDF_L(K),K=  115,  228) /
     &4.3298D-01,4.6172D-01,4.8742D-01,5.0700D-01,5.1856D-01,5.1873D-01,
     &5.0352D-01,4.6746D-01,4.0418D-01,6.1801D-01,6.5339D-01,6.9923D-01,
     &7.6627D-01,8.7125D-01,1.0408D+00,1.3199D+00,1.8020D+00,2.6920D+00,
     &4.5574D+00,9.5310D+00,3.2877D+01,0.0000D+00,5.1176D-02,5.2640D-02,
     &5.4100D-02,5.5603D-02,5.7095D-02,5.8737D-02,6.0416D-02,6.2154D-02,
     &6.4016D-02,6.6046D-02,6.8273D-02,7.0765D-02,7.3444D-02,7.5182D-02,
     &7.7263D-02,7.9781D-02,8.2626D-02,8.5707D-02,8.9176D-02,9.2402D-02,
     &9.6182D-02,1.0098D-01,1.0635D-01,1.1227D-01,1.1893D-01,1.2513D-01,
     &1.3230D-01,1.4128D-01,1.5115D-01,1.6164D-01,1.7300D-01,1.8301D-01,
     &1.9397D-01,2.0660D-01,2.1907D-01,2.3072D-01,2.4154D-01,2.4985D-01,
     &2.5817D-01,2.6810D-01,2.8136D-01,2.9535D-01,3.1585D-01,3.3824D-01,
     &3.6743D-01,3.9701D-01,4.2565D-01,4.5205D-01,4.7460D-01,4.9184D-01,
     &5.0110D-01,4.9954D-01,4.8363D-01,4.4878D-01,3.8940D-01,5.9452D-01,
     &6.2820D-01,6.7181D-01,7.3612D-01,8.3598D-01,9.9560D-01,1.2543D+00,
     &1.6953D+00,2.4947D+00,4.1415D+00,8.4275D+00,2.7797D+01,0.0000D+00,
     &8.6266D-02,8.7847D-02,8.9380D-02,9.0869D-02,9.2337D-02,9.3826D-02,
     &9.5315D-02,9.6842D-02,9.8333D-02,1.0003D-01,1.0178D-01,1.0370D-01,
     &1.0575D-01,1.0710D-01,1.0872D-01,1.1075D-01,1.1295D-01,1.1538D-01,
     &1.1821D-01,1.2088D-01,1.2396D-01,1.2796D-01,1.3252D-01,1.3756D-01/
      DATA (XUDF_L(K),K=  229,  342) /
     &1.4331D-01,1.4870D-01,1.5500D-01,1.6291D-01,1.7166D-01,1.8100D-01,
     &1.9111D-01,2.0002D-01,2.0977D-01,2.2095D-01,2.3189D-01,2.4200D-01,
     &2.5123D-01,2.5821D-01,2.6512D-01,2.7351D-01,2.8514D-01,2.9789D-01,
     &3.1683D-01,3.3731D-01,3.6424D-01,3.9124D-01,4.1697D-01,4.4030D-01,
     &4.6002D-01,4.7419D-01,4.8085D-01,4.7740D-01,4.6086D-01,4.2728D-01,
     &3.7241D-01,5.6656D-01,5.9684D-01,6.3694D-01,6.9622D-01,7.8804D-01,
     &9.3343D-01,1.1653D+00,1.5545D+00,2.2504D+00,3.6537D+00,7.2124D+00,
     &2.2653D+01,0.0000D+00,1.4838D-01,1.4960D-01,1.5068D-01,1.5161D-01,
     &1.5242D-01,1.5316D-01,1.5373D-01,1.5426D-01,1.5470D-01,1.5511D-01,
     &1.5554D-01,1.5602D-01,1.5660D-01,1.5698D-01,1.5750D-01,1.5830D-01,
     &1.5923D-01,1.6034D-01,1.6181D-01,1.6324D-01,1.6509D-01,1.6746D-01,
     &1.7054D-01,1.7402D-01,1.7811D-01,1.8208D-01,1.8687D-01,1.9296D-01,
     &1.9986D-01,2.0734D-01,2.1554D-01,2.2281D-01,2.3075D-01,2.3983D-01,
     &2.4863D-01,2.5660D-01,2.6366D-01,2.6883D-01,2.7387D-01,2.8026D-01,
     &2.8982D-01,3.0088D-01,3.1780D-01,3.3626D-01,3.6021D-01,3.8399D-01,
     &4.0666D-01,4.2682D-01,4.4278D-01,4.5386D-01,4.5774D-01,4.5230D-01,
     &4.3509D-01,4.0314D-01,3.5321D-01,5.3325D-01,5.5916D-01,5.9448D-01,
     &6.4707D-01,7.2797D-01,8.5557D-01,1.0563D+00,1.3882D+00,1.9717D+00,
     &3.1223D+00,5.9601D+00,1.7750D+01,0.0000D+00,2.3139D-01,2.3138D-01/
      DATA (XUDF_L(K),K=  343,  456) /
     &2.3120D-01,2.3076D-01,2.3006D-01,2.2907D-01,2.2788D-01,2.2645D-01,
     &2.2489D-01,2.2308D-01,2.2120D-01,2.1929D-01,2.1743D-01,2.1630D-01,
     &2.1526D-01,2.1411D-01,2.1311D-01,2.1231D-01,2.1171D-01,2.1148D-01,
     &2.1150D-01,2.1182D-01,2.1271D-01,2.1412D-01,2.1601D-01,2.1822D-01,
     &2.2096D-01,2.2496D-01,2.2961D-01,2.3481D-01,2.4086D-01,2.4622D-01,
     &2.5214D-01,2.5891D-01,2.6537D-01,2.7104D-01,2.7588D-01,2.7922D-01,
     &2.8235D-01,2.8664D-01,2.9413D-01,3.0352D-01,3.1845D-01,3.3481D-01,
     &3.5617D-01,3.7737D-01,3.9689D-01,4.1403D-01,4.2736D-01,4.3558D-01,
     &4.3712D-01,4.3016D-01,4.1245D-01,3.8197D-01,3.3645D-01,5.0322D-01,
     &5.2507D-01,5.5559D-01,6.0172D-01,6.7286D-01,7.8413D-01,9.5797D-01,
     &1.2422D+00,1.7341D+00,2.6883D+00,4.9868D+00,1.4177D+01,0.0000D+00,
     &3.6389D-01,3.6098D-01,3.5780D-01,3.5400D-01,3.5016D-01,3.4553D-01,
     &3.4044D-01,3.3521D-01,3.2971D-01,3.2369D-01,3.1755D-01,3.1120D-01,
     &3.0494D-01,3.0120D-01,2.9724D-01,2.9287D-01,2.8855D-01,2.8449D-01,
     &2.8072D-01,2.7770D-01,2.7469D-01,2.7175D-01,2.6933D-01,2.6740D-01,
     &2.6613D-01,2.6556D-01,2.6563D-01,2.6631D-01,2.6763D-01,2.6975D-01,
     &2.7268D-01,2.7539D-01,2.7857D-01,2.8224D-01,2.8565D-01,2.8841D-01,
     &2.9040D-01,2.9139D-01,2.9220D-01,2.9395D-01,2.9888D-01,3.0633D-01,
     &3.1877D-01,3.3296D-01,3.5147D-01,3.6947D-01,3.8604D-01,3.9986D-01/
      DATA (XUDF_L(K),K=  457,  570) /
     &4.1008D-01,4.1548D-01,4.1467D-01,4.0620D-01,3.8830D-01,3.5965D-01,
     &3.1902D-01,4.7020D-01,4.8772D-01,5.1303D-01,5.5185D-01,6.1224D-01,
     &7.0699D-01,8.5323D-01,1.0903D+00,1.4950D+00,2.2640D+00,4.0723D+00,
     &0.0000D+00,0.0000D+00,5.2666D-01,5.1909D-01,5.1100D-01,5.0238D-01,
     &4.9333D-01,4.8312D-01,4.7293D-01,4.6180D-01,4.5066D-01,4.3890D-01,
     &4.2692D-01,4.1467D-01,4.0262D-01,3.9542D-01,3.8784D-01,3.7925D-01,
     &3.7080D-01,3.6267D-01,3.5482D-01,3.4841D-01,3.4190D-01,3.3492D-01,
     &3.2852D-01,3.2287D-01,3.1768D-01,3.1409D-01,3.1066D-01,3.0785D-01,
     &3.0564D-01,3.0446D-01,3.0380D-01,3.0388D-01,3.0402D-01,3.0458D-01,
     &3.0488D-01,3.0475D-01,3.0386D-01,3.0263D-01,3.0116D-01,3.0045D-01,
     &3.0296D-01,3.0852D-01,3.1888D-01,3.3085D-01,3.4677D-01,3.6222D-01,
     &3.7600D-01,3.8707D-01,3.9488D-01,3.9799D-01,3.9530D-01,3.8568D-01,
     &3.6791D-01,3.4080D-01,3.0424D-01,4.4195D-01,4.5570D-01,4.7648D-01,
     &5.0935D-01,5.6099D-01,6.4225D-01,7.6680D-01,9.6736D-01,1.3053D+00,
     &1.9393D+00,3.3976D+00,0.0000D+00,0.0000D+00,7.4015D-01,7.2498D-01,
     &7.0940D-01,6.9297D-01,6.7620D-01,6.5800D-01,6.3935D-01,6.2047D-01,
     &6.0114D-01,5.8076D-01,5.6065D-01,5.4030D-01,5.2035D-01,5.0839D-01,
     &4.9583D-01,4.8167D-01,4.6773D-01,4.5434D-01,4.4113D-01,4.3035D-01,
     &4.1922D-01,4.0719D-01,3.9582D-01,3.8536D-01,3.7557D-01,3.6805D-01/
      DATA (XUDF_L(K),K=  571,  684) /
     &3.6079D-01,3.5336D-01,3.4710D-01,3.4173D-01,3.3719D-01,3.3400D-01,
     &3.3124D-01,3.2819D-01,3.2494D-01,3.2158D-01,3.1765D-01,3.1400D-01,
     &3.1011D-01,3.0684D-01,3.0682D-01,3.1046D-01,3.1856D-01,3.2861D-01,
     &3.4189D-01,3.5475D-01,3.6597D-01,3.7463D-01,3.8003D-01,3.8108D-01,
     &3.7681D-01,3.6631D-01,3.4865D-01,3.2327D-01,2.9078D-01,4.1488D-01,
     &4.2529D-01,4.4193D-01,4.6945D-01,5.1322D-01,5.8236D-01,6.8846D-01,
     &8.5739D-01,1.1394D+00,1.6617D+00,2.8395D+00,0.0000D+00,0.0000D+00,
     &9.8501D-01,9.5975D-01,9.3420D-01,9.0757D-01,8.8092D-01,8.5237D-01,
     &8.2383D-01,7.9445D-01,7.6556D-01,7.3524D-01,7.0484D-01,6.7495D-01,
     &6.4547D-01,6.2798D-01,6.0969D-01,5.8904D-01,5.6882D-01,5.4932D-01,
     &5.3014D-01,5.1443D-01,4.9826D-01,4.8058D-01,4.6380D-01,4.4815D-01,
     &4.3330D-01,4.2167D-01,4.1020D-01,3.9827D-01,3.8748D-01,3.7784D-01,
     &3.6931D-01,3.6303D-01,3.5669D-01,3.4992D-01,3.4358D-01,3.3710D-01,
     &3.3025D-01,3.2429D-01,3.1817D-01,3.1242D-01,3.1001D-01,3.1195D-01,
     &3.1802D-01,3.2610D-01,3.3719D-01,3.4770D-01,3.5674D-01,3.6357D-01,
     &3.6695D-01,3.6631D-01,3.6075D-01,3.4960D-01,3.3214D-01,3.0855D-01,
     &2.7931D-01,3.9198D-01,3.9931D-01,4.1263D-01,4.3550D-01,4.7310D-01,
     &5.3259D-01,6.2375D-01,7.6876D-01,1.0087D+00,1.4464D+00,2.4185D+00,
     &0.0000D+00,0.0000D+00,1.2917D+00,1.2523D+00,1.2128D+00,1.1722D+00/
      DATA (XUDF_L(K),K=  685,  798) /
     &1.1321D+00,1.0894D+00,1.0473D+00,1.0044D+00,9.6262D-01,9.1838D-01,
     &8.7565D-01,8.3283D-01,7.9186D-01,7.6734D-01,7.4146D-01,7.1300D-01,
     &6.8484D-01,6.5787D-01,6.3134D-01,6.0963D-01,5.8730D-01,5.6294D-01,
     &5.3947D-01,5.1767D-01,4.9689D-01,4.8039D-01,4.6398D-01,4.4675D-01,
     &4.3087D-01,4.1650D-01,4.0371D-01,3.9342D-01,3.8361D-01,3.7293D-01,
     &3.6284D-01,3.5305D-01,3.4307D-01,3.3468D-01,3.2613D-01,3.1788D-01,
     &3.1306D-01,3.1309D-01,3.1715D-01,3.2346D-01,3.3232D-01,3.4066D-01,
     &3.4779D-01,3.5251D-01,3.5401D-01,3.5184D-01,3.4519D-01,3.3347D-01,
     &3.1650D-01,2.9433D-01,2.6872D-01,3.6968D-01,3.7446D-01,3.8477D-01,
     &4.0368D-01,4.3551D-01,4.8654D-01,5.6457D-01,6.8832D-01,8.9135D-01,
     &1.2583D+00,2.0601D+00,0.0000D+00,0.0000D+00,1.6499D+00,1.5928D+00,
     &1.5356D+00,1.4773D+00,1.4202D+00,1.3601D+00,1.3009D+00,1.2413D+00,
     &1.1836D+00,1.1235D+00,1.0650D+00,1.0076D+00,9.5212D-01,9.1919D-01,
     &8.8569D-01,8.4733D-01,8.1006D-01,7.7436D-01,7.3955D-01,7.1104D-01,
     &6.8173D-01,6.4966D-01,6.1893D-01,5.9026D-01,5.6287D-01,5.4114D-01,
     &5.1941D-01,4.9621D-01,4.7490D-01,4.5564D-01,4.3786D-01,4.2408D-01,
     &4.1024D-01,3.9562D-01,3.8175D-01,3.6853D-01,3.5541D-01,3.4455D-01,
     &3.3366D-01,3.2286D-01,3.1565D-01,3.1397D-01,3.1618D-01,3.2069D-01,
     &3.2744D-01,3.3383D-01,3.3911D-01,3.4194D-01,3.4194D-01,3.3844D-01/
      DATA (XUDF_L(K),K=  799,  912) /
     &3.3088D-01,3.1887D-01,3.0224D-01,2.8177D-01,2.5901D-01,3.4945D-01,
     &3.5200D-01,3.5959D-01,3.7518D-01,4.0212D-01,4.4590D-01,5.1305D-01,
     &6.1934D-01,7.9273D-01,1.1025D+00,1.7693D+00,0.0000D+00,0.0000D+00,
     &2.0413D+00,1.9626D+00,1.8840D+00,1.8053D+00,1.7284D+00,1.6480D+00,
     &1.5697D+00,1.4911D+00,1.4157D+00,1.3375D+00,1.2620D+00,1.1875D+00,
     &1.1168D+00,1.0751D+00,1.0321D+00,9.8410D-01,9.3682D-01,8.9196D-01,
     &8.4816D-01,8.1245D-01,7.7582D-01,7.3576D-01,6.9745D-01,6.6154D-01,
     &6.2742D-01,6.0036D-01,5.7319D-01,5.4409D-01,5.1721D-01,4.9291D-01,
     &4.7049D-01,4.5284D-01,4.3541D-01,4.1671D-01,3.9926D-01,3.8274D-01,
     &3.6660D-01,3.5348D-01,3.4035D-01,3.2727D-01,3.1788D-01,3.1459D-01,
     &3.1499D-01,3.1792D-01,3.2291D-01,3.2764D-01,3.3124D-01,3.3250D-01,
     &3.3120D-01,3.2663D-01,3.1834D-01,3.0608D-01,2.8998D-01,2.7085D-01,
     &2.5085D-01,3.3191D-01,3.3258D-01,3.3808D-01,3.5072D-01,3.7379D-01,
     &4.1182D-01,4.7005D-01,5.6257D-01,7.1233D-01,9.7788D-01,1.5412D+00,
     &0.0000D+00,0.0000D+00,2.6325D+00,2.5188D+00,2.4060D+00,2.2942D+00,
     &2.1863D+00,2.0740D+00,1.9650D+00,1.8571D+00,1.7537D+00,1.6473D+00,
     &1.5453D+00,1.4458D+00,1.3515D+00,1.2965D+00,1.2394D+00,1.1767D+00,
     &1.1150D+00,1.0560D+00,9.9927D-01,9.5301D-01,9.0565D-01,8.5400D-01,
     &8.0462D-01,7.5858D-01,7.1481D-01,6.7994D-01,6.4502D-01,6.0799D-01/
      DATA (XUDF_L(K),K=  913, 1026) /
     &5.7349D-01,5.4206D-01,5.1299D-01,4.9028D-01,4.6789D-01,4.4387D-01,
     &4.2168D-01,4.0096D-01,3.8070D-01,3.6457D-01,3.4857D-01,3.3249D-01,
     &3.2026D-01,3.1503D-01,3.1326D-01,3.1423D-01,3.1703D-01,3.1974D-01,
     &3.2120D-01,3.2086D-01,3.1799D-01,3.1221D-01,3.0315D-01,2.9072D-01,
     &2.7522D-01,2.5796D-01,2.4114D-01,3.1079D-01,3.0956D-01,3.1267D-01,
     &3.2223D-01,3.4089D-01,3.7246D-01,4.2134D-01,4.9853D-01,6.2305D-01,
     &8.4191D-01,1.2983D+00,0.0000D+00,0.0000D+00,3.2997D+00,3.1427D+00,
     &2.9900D+00,2.8374D+00,2.6927D+00,2.5421D+00,2.3973D+00,2.2549D+00,
     &2.1191D+00,1.9809D+00,1.8488D+00,1.7209D+00,1.6001D+00,1.5300D+00,
     &1.4576D+00,1.3771D+00,1.2999D+00,1.2268D+00,1.1551D+00,1.0975D+00,
     &1.0385D+00,9.7437D-01,9.1327D-01,8.5649D-01,8.0236D-01,7.5952D-01,
     &7.1667D-01,6.7091D-01,6.2847D-01,5.9005D-01,5.5422D-01,5.2636D-01,
     &4.9890D-01,4.6976D-01,4.4269D-01,4.1752D-01,3.9377D-01,3.7477D-01,
     &3.5594D-01,3.3710D-01,3.2226D-01,3.1511D-01,3.1131D-01,3.1067D-01,
     &3.1132D-01,3.1227D-01,3.1198D-01,3.1021D-01,3.0606D-01,2.9926D-01,
     &2.8958D-01,2.7716D-01,2.6233D-01,2.4655D-01,2.3275D-01,2.9229D-01,
     &2.8941D-01,2.9061D-01,2.9753D-01,3.1273D-01,3.3909D-01,3.8034D-01,
     &4.4548D-01,5.5028D-01,7.3256D-01,1.1074D+00,0.0000D+00,0.0000D+00,
     &4.0557D+00,3.8486D+00,3.6460D+00,3.4480D+00,3.2579D+00,3.0626D+00/
      DATA (XUDF_L(K),K= 1027, 1140) /
     &2.8756D+00,2.6929D+00,2.5196D+00,2.3441D+00,2.1778D+00,2.0170D+00,
     &1.8670D+00,1.7797D+00,1.6902D+00,1.5909D+00,1.4960D+00,1.4058D+00,
     &1.3191D+00,1.2484D+00,1.1764D+00,1.0991D+00,1.0253D+00,9.5689D-01,
     &8.9197D-01,8.4046D-01,7.8904D-01,7.3442D-01,6.8367D-01,6.3780D-01,
     &5.9520D-01,5.6218D-01,5.2934D-01,4.9500D-01,4.6300D-01,4.3370D-01,
     &4.0611D-01,3.8431D-01,3.6284D-01,3.4121D-01,3.2389D-01,3.1494D-01,
     &3.0926D-01,3.0697D-01,3.0594D-01,3.0501D-01,3.0330D-01,3.0019D-01,
     &2.9492D-01,2.8734D-01,2.7718D-01,2.6476D-01,2.5057D-01,2.3646D-01,
     &2.2503D-01,2.7558D-01,2.7132D-01,2.7089D-01,2.7569D-01,2.8794D-01,
     &3.1000D-01,3.4491D-01,4.0016D-01,4.8886D-01,6.4191D-01,9.5232D-01,
     &0.0000D+00,0.0000D+00,4.8799D+00,4.6116D+00,4.3560D+00,4.1035D+00,
     &3.8608D+00,3.6163D+00,3.3822D+00,3.1557D+00,2.9412D+00,2.7247D+00,
     &2.5209D+00,2.3248D+00,2.1421D+00,2.0368D+00,1.9287D+00,1.8094D+00,
     &1.6955D+00,1.5877D+00,1.4841D+00,1.4003D+00,1.3154D+00,1.2237D+00,
     &1.1368D+00,1.0563D+00,9.8015D-01,9.2005D-01,8.5978D-01,7.9615D-01,
     &7.3715D-01,6.8369D-01,6.3441D-01,5.9609D-01,5.5830D-01,5.1865D-01,
     &4.8192D-01,4.4872D-01,4.1747D-01,3.9300D-01,3.6895D-01,3.4483D-01,
     &3.2508D-01,3.1459D-01,3.0709D-01,3.0328D-01,3.0056D-01,2.9840D-01,
     &2.9543D-01,2.9107D-01,2.8485D-01,2.7655D-01,2.6610D-01,2.5368D-01/
      DATA (XUDF_L(K),K= 1141, 1254) /
     &2.4019D-01,2.2736D-01,2.1837D-01,2.6080D-01,2.5542D-01,2.5362D-01,
     &2.5693D-01,2.6661D-01,2.8505D-01,3.1490D-01,3.6226D-01,4.3798D-01,
     &5.6769D-01,8.2836D-01,0.0000D+00,0.0000D+00,5.8340D+00,5.4940D+00,
     &5.1700D+00,4.8532D+00,4.5515D+00,4.2463D+00,3.9559D+00,3.6752D+00,
     &3.4138D+00,3.1496D+00,2.9022D+00,2.6648D+00,2.4450D+00,2.3189D+00,
     &2.1896D+00,2.0476D+00,1.9120D+00,1.7843D+00,1.6621D+00,1.5639D+00,
     &1.4648D+00,1.3569D+00,1.2556D+00,1.1618D+00,1.0734D+00,1.0037D+00,
     &9.3416D-01,8.6065D-01,7.9257D-01,7.3145D-01,6.7463D-01,6.3082D-01,
     &5.8786D-01,5.4262D-01,5.0118D-01,4.6374D-01,4.2883D-01,4.0146D-01,
     &3.7490D-01,3.4814D-01,3.2612D-01,3.1397D-01,3.0482D-01,2.9958D-01,
     &2.9536D-01,2.9178D-01,2.8756D-01,2.8208D-01,2.7504D-01,2.6611D-01,
     &2.5539D-01,2.4319D-01,2.3031D-01,2.1877D-01,2.1195D-01,2.4673D-01,
     &2.4036D-01,2.3746D-01,2.3912D-01,2.4677D-01,2.6223D-01,2.8748D-01,
     &3.2792D-01,3.9255D-01,5.0271D-01,7.2095D-01,0.0000D+00,0.0000D+00,
     &6.8578D+00,6.4388D+00,6.0380D+00,5.6501D+00,5.2825D+00,4.9103D+00,
     &4.5613D+00,4.2230D+00,3.9070D+00,3.5911D+00,3.2966D+00,3.0156D+00,
     &2.7567D+00,2.6078D+00,2.4563D+00,2.2905D+00,2.1319D+00,1.9837D+00,
     &1.8421D+00,1.7287D+00,1.6141D+00,1.4902D+00,1.3730D+00,1.2663D+00,
     &1.1652D+00,1.0858D+00,1.0067D+00,9.2337D-01,8.4648D-01,7.7710D-01/
      DATA (XUDF_L(K),K= 1255, 1368) /
     &7.1333D-01,6.6392D-01,6.1566D-01,5.6531D-01,5.1904D-01,4.7761D-01,
     &4.3908D-01,4.0927D-01,3.8022D-01,3.5109D-01,3.2686D-01,3.1318D-01,
     &3.0244D-01,2.9602D-01,2.9031D-01,2.8538D-01,2.8024D-01,2.7382D-01,
     &2.6607D-01,2.5668D-01,2.4571D-01,2.3364D-01,2.2155D-01,2.1116D-01,
     &2.0617D-01,2.3421D-01,2.2704D-01,2.2320D-01,2.2366D-01,2.2952D-01,
     &2.4241D-01,2.6402D-01,2.9884D-01,3.5437D-01,4.4860D-01,6.3331D-01,
     &0.0000D+00,0.0000D+00,7.9784D+00,7.4673D+00,6.9820D+00,6.5121D+00,
     &6.0712D+00,5.6250D+00,5.2080D+00,4.8065D+00,4.4309D+00,4.0590D+00,
     &3.7131D+00,3.3843D+00,3.0816D+00,2.9094D+00,2.7332D+00,2.5420D+00,
     &2.3595D+00,2.1895D+00,2.0271D+00,1.8966D+00,1.7658D+00,1.6248D+00,
     &1.4933D+00,1.3718D+00,1.2579D+00,1.1683D+00,1.0795D+00,9.8589D-01,
     &8.9996D-01,8.2253D-01,7.5153D-01,6.9648D-01,6.4287D-01,5.8736D-01,
     &5.3655D-01,4.9109D-01,4.4891D-01,4.1655D-01,3.8518D-01,3.5367D-01,
     &3.2738D-01,3.1221D-01,3.0006D-01,2.9246D-01,2.8544D-01,2.7940D-01,
     &2.7319D-01,2.6601D-01,2.5763D-01,2.4782D-01,2.3676D-01,2.2486D-01,
     &2.1329D-01,2.0405D-01,2.0083D-01,2.2267D-01,2.1489D-01,2.1027D-01,
     &2.0967D-01,2.1409D-01,2.2473D-01,2.4320D-01,2.7316D-01,3.2113D-01,
     &4.0209D-01,5.5899D-01,0.0000D+00,0.0000D+00,9.1575D+00,8.5458D+00,
     &7.9700D+00,7.4123D+00,6.8876D+00,6.3653D+00,5.8736D+00,5.4042D+00/
      DATA (XUDF_L(K),K= 1369, 1482) /
     &4.9684D+00,4.5359D+00,4.1366D+00,3.7576D+00,3.4110D+00,3.2138D+00,
     &3.0122D+00,2.7943D+00,2.5871D+00,2.3944D+00,2.2102D+00,2.0646D+00,
     &1.9163D+00,1.7581D+00,1.6109D+00,1.4753D+00,1.3483D+00,1.2486D+00,
     &1.1500D+00,1.0462D+00,9.5130D-01,8.6585D-01,7.8770D-01,7.2741D-01,
     &6.6891D-01,6.0781D-01,5.5266D-01,5.0342D-01,4.5788D-01,4.2322D-01,
     &3.8960D-01,3.5594D-01,3.2768D-01,3.1125D-01,2.9779D-01,2.8890D-01,
     &2.8091D-01,2.7385D-01,2.6670D-01,2.5886D-01,2.4989D-01,2.3976D-01,
     &2.2861D-01,2.1703D-01,2.0604D-01,1.9777D-01,1.9598D-01,2.1238D-01,
     &2.0408D-01,1.9879D-01,1.9735D-01,2.0048D-01,2.0933D-01,2.2523D-01,
     &2.5120D-01,2.9296D-01,3.6305D-01,4.9711D-01,0.0000D+00,0.0000D+00,
     &1.0956D+01,1.0188D+01,9.4660D+00,8.7704D+00,8.1209D+00,7.4727D+00,
     &6.8721D+00,6.2972D+00,5.7646D+00,5.2434D+00,4.7595D+00,4.3051D+00,
     &3.8911D+00,3.6559D+00,3.4174D+00,3.1598D+00,2.9153D+00,2.6889D+00,
     &2.4732D+00,2.3031D+00,2.1311D+00,1.9475D+00,1.7771D+00,1.6202D+00,
     &1.4748D+00,1.3609D+00,1.2481D+00,1.1301D+00,1.0222D+00,9.2549D-01,
     &8.3728D-01,7.6947D-01,7.0373D-01,6.3561D-01,5.7438D-01,5.1959D-01,
     &4.6984D-01,4.3187D-01,3.9529D-01,3.5864D-01,3.2783D-01,3.0967D-01,
     &2.9444D-01,2.8428D-01,2.7469D-01,2.6638D-01,2.5813D-01,2.4942D-01,
     &2.3986D-01,2.2937D-01,2.1819D-01,2.0682D-01,1.9665D-01,1.8966D-01/
      DATA (XUDF_L(K),K= 1483, 1596) /
     &1.8971D-01,1.9926D-01,1.9036D-01,1.8442D-01,1.8192D-01,1.8362D-01,
     &1.9037D-01,2.0318D-01,2.2459D-01,2.5904D-01,3.1665D-01,4.2407D-01,
     &0.0000D+00,0.0000D+00,1.2798D+01,1.1861D+01,1.0986D+01,1.0144D+01,
     &9.3643D+00,8.5887D+00,7.8706D+00,7.1866D+00,6.5568D+00,5.9419D+00,
     &5.3754D+00,4.8419D+00,4.3593D+00,4.0864D+00,3.8109D+00,3.5127D+00,
     &3.2315D+00,2.9714D+00,2.7252D+00,2.5309D+00,2.3356D+00,2.1269D+00,
     &1.9338D+00,1.7578D+00,1.5939D+00,1.4656D+00,1.3394D+00,1.2075D+00,
     &1.0875D+00,9.8023D-01,8.8256D-01,8.0772D-01,7.3533D-01,6.6054D-01,
     &5.9364D-01,5.3423D-01,4.8009D-01,4.3930D-01,4.0003D-01,3.6079D-01,
     &3.2768D-01,3.0809D-01,2.9130D-01,2.7993D-01,2.6898D-01,2.5976D-01,
     &2.5062D-01,2.4123D-01,2.3116D-01,2.2040D-01,2.0917D-01,1.9814D-01,
     &1.8865D-01,1.8272D-01,1.8428D-01,1.8820D-01,1.7883D-01,1.7238D-01,
     &1.6914D-01,1.6979D-01,1.7482D-01,1.8534D-01,2.0325D-01,2.3214D-01,
     &2.8022D-01,3.6659D-01,0.0000D+00,0.0000D+00,1.4900D+01,1.3767D+01,
     &1.2708D+01,1.1700D+01,1.0766D+01,9.8403D+00,8.9832D+00,8.1757D+00,
     &7.4366D+00,6.7121D+00,6.0486D+00,5.4300D+00,4.8704D+00,4.5555D+00,
     &4.2371D+00,3.8955D+00,3.5734D+00,3.2760D+00,2.9952D+00,2.7738D+00,
     &2.5528D+00,2.3175D+00,2.1001D+00,1.9012D+00,1.7176D+00,1.5750D+00,
     &1.4344D+00,1.2880D+00,1.1547D+00,1.0364D+00,9.2859D-01,8.4652D-01/
      DATA (XUDF_L(K),K= 1597, 1710) /
     &7.6723D-01,6.8578D-01,6.1255D-01,5.4848D-01,4.9034D-01,4.4649D-01,
     &4.0456D-01,3.6275D-01,3.2738D-01,3.0624D-01,2.8805D-01,2.7544D-01,
     &2.6343D-01,2.5315D-01,2.4318D-01,2.3314D-01,2.2263D-01,2.1166D-01,
     &2.0051D-01,1.8983D-01,1.8102D-01,1.7610D-01,1.7901D-01,1.7764D-01,
     &1.6791D-01,1.6102D-01,1.5715D-01,1.5684D-01,1.6056D-01,1.6899D-01,
     &1.8376D-01,2.0786D-01,2.4776D-01,3.1470D-01,0.0000D+00,0.0000D+00,
     &1.7212D+01,1.5853D+01,1.4590D+01,1.3390D+01,1.2283D+01,1.1191D+01,
     &1.0185D+01,9.2395D+00,8.3762D+00,7.5315D+00,6.7670D+00,6.0503D+00,
     &5.4086D+00,5.0481D+00,4.6843D+00,4.2940D+00,3.9280D+00,3.5917D+00,
     &3.2752D+00,3.0252D+00,2.7768D+00,2.5132D+00,2.2690D+00,2.0490D+00,
     &1.8445D+00,1.6857D+00,1.5301D+00,1.3685D+00,1.2219D+00,1.0920D+00,
     &9.7438D-01,8.8478D-01,7.9825D-01,7.1007D-01,6.3111D-01,5.6196D-01,
     &5.0016D-01,4.5321D-01,4.0867D-01,3.6435D-01,3.2686D-01,3.0431D-01,
     &2.8470D-01,2.7109D-01,2.5789D-01,2.4674D-01,2.3605D-01,2.2547D-01,
     &2.1459D-01,2.0348D-01,1.9237D-01,1.8201D-01,1.7376D-01,1.6982D-01,
     &1.7398D-01,1.6789D-01,1.5795D-01,1.5065D-01,1.4630D-01,1.4521D-01,
     &1.4773D-01,1.5443D-01,1.6659D-01,1.8664D-01,2.1966D-01,2.6878D-01,
     &0.0000D+00,0.0000D+00,1.9526D+01,1.7951D+01,1.6470D+01,1.5074D+01,
     &1.3790D+01,1.2527D+01,1.1370D+01,1.0282D+01,9.2958D+00,8.3330D+00/
      DATA (XUDF_L(K),K= 1711, 1824) /
     &7.4603D+00,6.6536D+00,5.9285D+00,5.5219D+00,5.1141D+00,4.6768D+00,
     &4.2681D+00,3.8926D+00,3.5402D+00,3.2626D+00,2.9882D+00,2.6963D+00,
     &2.4284D+00,2.1851D+00,1.9619D+00,1.7885D+00,1.6187D+00,1.4429D+00,
     &1.2838D+00,1.1431D+00,1.0159D+00,9.1924D-01,8.2663D-01,7.3180D-01,
     &6.4793D-01,5.7429D-01,5.0828D-01,4.5904D-01,4.1215D-01,3.6558D-01,
     &3.2620D-01,3.0238D-01,2.8167D-01,2.6700D-01,2.5302D-01,2.4098D-01,
     &2.2975D-01,2.1873D-01,2.0756D-01,1.9633D-01,1.8532D-01,1.7533D-01,
     &1.6763D-01,1.6450D-01,1.6959D-01,1.5953D-01,1.4943D-01,1.4185D-01,
     &1.3716D-01,1.3545D-01,1.3705D-01,1.4238D-01,1.5258D-01,1.6945D-01,
     &1.9705D-01,2.3049D-01,0.0000D+00,0.0000D+00,2.2141D+01,2.0286D+01,
     &1.8570D+01,1.6948D+01,1.5466D+01,1.4010D+01,1.2679D+01,1.1431D+01,
     &1.0303D+01,9.2106D+00,8.2239D+00,7.3077D+00,6.4926D+00,6.0348D+00,
     &5.5765D+00,5.0879D+00,4.6321D+00,4.2138D+00,3.8233D+00,3.5162D+00,
     &3.2122D+00,2.8907D+00,2.5960D+00,2.3300D+00,2.0856D+00,1.8954D+00,
     &1.7110D+00,1.5199D+00,1.3476D+00,1.1955D+00,1.0584D+00,9.5478D-01,
     &8.5531D-01,7.5417D-01,6.6439D-01,5.8623D-01,5.1682D-01,4.6468D-01,
     &4.1541D-01,3.6662D-01,3.2538D-01,3.0035D-01,2.7843D-01,2.6291D-01,
     &2.4798D-01,2.3522D-01,2.2346D-01,2.1203D-01,2.0062D-01,1.8935D-01,
     &1.7843D-01,1.6874D-01,1.6163D-01,1.5920D-01,1.6520D-01,1.5147D-01/
      DATA (XUDF_L(K),K= 1825, 1836) /
     &1.4120D-01,1.3349D-01,1.2844D-01,1.2620D-01,1.2701D-01,1.3118D-01,
     &1.3954D-01,1.5369D-01,1.7631D-01,1.9416D-01,0.0000D+00,0.0000D+00/
      DATA (XSF_L(K),K=    1,  114) /
     &8.9277D-03,9.2838D-03,9.6380D-03,9.9960D-03,1.0349D-02,1.0719D-02,
     &1.1082D-02,1.1442D-02,1.1792D-02,1.2148D-02,1.2489D-02,1.2817D-02,
     &1.3124D-02,1.3295D-02,1.3474D-02,1.3661D-02,1.3835D-02,1.3985D-02,
     &1.4121D-02,1.4217D-02,1.4303D-02,1.4379D-02,1.4419D-02,1.4434D-02,
     &1.4412D-02,1.4366D-02,1.4286D-02,1.4158D-02,1.3991D-02,1.3790D-02,
     &1.3553D-02,1.3335D-02,1.3094D-02,1.2821D-02,1.2580D-02,1.2410D-02,
     &1.2357D-02,1.2459D-02,1.2790D-02,1.3571D-02,1.5018D-02,1.6665D-02,
     &1.9113D-02,2.1832D-02,2.5587D-02,2.9818D-02,3.4535D-02,3.9813D-02,
     &4.5737D-02,5.2358D-02,5.9765D-02,6.8021D-02,7.7185D-02,8.7258D-02,
     &9.8198D-02,1.1073D-01,1.4216D-01,1.8364D-01,2.3959D-01,3.1758D-01,
     &4.3050D-01,6.0203D-01,8.8214D-01,1.3845D+00,2.4294D+00,5.2463D+00,
     &1.8903D+01,0.0000D+00,1.4987D-02,1.5468D-02,1.5936D-02,1.6403D-02,
     &1.6855D-02,1.7319D-02,1.7760D-02,1.8194D-02,1.8600D-02,1.9008D-02,
     &1.9382D-02,1.9730D-02,2.0033D-02,2.0199D-02,2.0359D-02,2.0523D-02,
     &2.0654D-02,2.0760D-02,2.0831D-02,2.0870D-02,2.0886D-02,2.0858D-02,
     &2.0798D-02,2.0680D-02,2.0523D-02,2.0363D-02,2.0127D-02,1.9825D-02,
     &1.9464D-02,1.9060D-02,1.8607D-02,1.8200D-02,1.7750D-02,1.7240D-02,
     &1.6759D-02,1.6362D-02,1.6103D-02,1.6050D-02,1.6240D-02,1.6916D-02,
     &1.8336D-02,2.0030D-02,2.2586D-02,2.5447D-02,2.9418D-02,3.3874D-02/
      DATA (XSF_L(K),K=  115,  228) /
     &3.8821D-02,4.4375D-02,5.0509D-02,5.7343D-02,6.4974D-02,7.3385D-02,
     &8.2640D-02,9.2732D-02,1.0354D-01,1.1667D-01,1.4809D-01,1.8910D-01,
     &2.4387D-01,3.1940D-01,4.2764D-01,5.9054D-01,8.5228D-01,1.3150D+00,
     &2.2623D+00,4.7596D+00,1.6445D+01,0.0000D+00,2.5010D-02,2.5616D-02,
     &2.6180D-02,2.6758D-02,2.7279D-02,2.7792D-02,2.8274D-02,2.8729D-02,
     &2.9134D-02,2.9513D-02,2.9836D-02,3.0110D-02,3.0324D-02,3.0417D-02,
     &3.0492D-02,3.0537D-02,3.0551D-02,3.0517D-02,3.0432D-02,3.0326D-02,
     &3.0181D-02,2.9954D-02,2.9663D-02,2.9316D-02,2.8913D-02,2.8508D-02,
     &2.8021D-02,2.7422D-02,2.6741D-02,2.5997D-02,2.5204D-02,2.4500D-02,
     &2.3734D-02,2.2858D-02,2.2019D-02,2.1281D-02,2.0698D-02,2.0402D-02,
     &2.0365D-02,2.0844D-02,2.2137D-02,2.3807D-02,2.6404D-02,2.9338D-02,
     &3.3433D-02,3.8036D-02,4.3135D-02,4.8799D-02,5.5061D-02,6.1999D-02,
     &6.9633D-02,7.8024D-02,8.7156D-02,9.6998D-02,1.0742D-01,1.2099D-01,
     &1.5162D-01,1.9121D-01,2.4363D-01,3.1510D-01,4.1638D-01,5.6669D-01,
     &8.0557D-01,1.2216D+00,2.0572D+00,4.2084D+00,1.3911D+01,0.0000D+00,
     &4.2554D-02,4.3210D-02,4.3820D-02,4.4379D-02,4.4862D-02,4.5317D-02,
     &4.5708D-02,4.6037D-02,4.6300D-02,4.6434D-02,4.6540D-02,4.6530D-02,
     &4.6426D-02,4.6317D-02,4.6155D-02,4.5919D-02,4.5622D-02,4.5267D-02,
     &4.4833D-02,4.4425D-02,4.3932D-02,4.3298D-02,4.2582D-02,4.1785D-02/
      DATA (XSF_L(K),K=  229,  342) /
     &4.0903D-02,4.0097D-02,3.9179D-02,3.8047D-02,3.6815D-02,3.5547D-02,
     &3.4199D-02,3.3020D-02,3.1748D-02,3.0298D-02,2.8905D-02,2.7644D-02,
     &2.6563D-02,2.5882D-02,2.5485D-02,2.5614D-02,2.6651D-02,2.8199D-02,
     &3.0731D-02,3.3652D-02,3.7768D-02,4.2390D-02,4.7530D-02,5.3188D-02,
     &5.9436D-02,6.6257D-02,7.3734D-02,8.1918D-02,9.0696D-02,1.0004D-01,
     &1.0978D-01,1.2357D-01,1.5274D-01,1.8999D-01,2.3888D-01,3.0452D-01,
     &3.9656D-01,5.3136D-01,7.4246D-01,1.1043D+00,1.8158D+00,3.6023D+00,
     &0.0000D+00,0.0000D+00,7.3602D-02,7.4085D-02,7.4460D-02,7.4729D-02,
     &7.4904D-02,7.4982D-02,7.4902D-02,7.4713D-02,7.4446D-02,7.3972D-02,
     &7.3397D-02,7.2626D-02,7.1803D-02,7.1200D-02,7.0479D-02,6.9610D-02,
     &6.8654D-02,6.7624D-02,6.6495D-02,6.5467D-02,6.4313D-02,6.2898D-02,
     &6.1380D-02,5.9788D-02,5.8079D-02,5.6557D-02,5.4876D-02,5.2866D-02,
     &5.0733D-02,4.8592D-02,4.6341D-02,4.4415D-02,4.2370D-02,4.0073D-02,
     &3.7825D-02,3.5778D-02,3.3956D-02,3.2702D-02,3.1749D-02,3.1334D-02,
     &3.1922D-02,3.3216D-02,3.5534D-02,3.8322D-02,4.2321D-02,4.6830D-02,
     &5.1816D-02,5.7335D-02,6.3369D-02,6.9947D-02,7.7109D-02,8.4752D-02,
     &9.2948D-02,1.0153D-01,1.1031D-01,1.2405D-01,1.5100D-01,1.8509D-01,
     &2.2905D-01,2.8761D-01,3.6847D-01,4.8537D-01,6.6543D-01,9.6831D-01,
     &1.5524D+00,2.9766D+00,0.0000D+00,0.0000D+00,1.1509D-01,1.1500D-01/
      DATA (XSF_L(K),K=  343,  456) /
     &1.1474D-01,1.1430D-01,1.1371D-01,1.1292D-01,1.1196D-01,1.1079D-01,
     &1.0948D-01,1.0791D-01,1.0620D-01,1.0426D-01,1.0215D-01,1.0076D-01,
     &9.9224D-02,9.7466D-02,9.5472D-02,9.3507D-02,9.1346D-02,8.9460D-02,
     &8.7382D-02,8.4914D-02,8.2326D-02,7.9663D-02,7.6874D-02,7.4459D-02,
     &7.1794D-02,6.8694D-02,6.5489D-02,6.2266D-02,5.8964D-02,5.6164D-02,
     &5.3226D-02,4.9916D-02,4.6721D-02,4.3794D-02,4.1128D-02,3.9225D-02,
     &3.7654D-02,3.6613D-02,3.6666D-02,3.7626D-02,3.9655D-02,4.2227D-02,
     &4.6000D-02,5.0288D-02,5.5044D-02,6.0308D-02,6.6020D-02,7.2218D-02,
     &7.8943D-02,8.6079D-02,9.3611D-02,1.0141D-01,1.0925D-01,1.2274D-01,
     &1.4748D-01,1.7840D-01,2.1791D-01,2.6997D-01,3.4109D-01,4.4280D-01,
     &5.9706D-01,8.5325D-01,1.3371D+00,2.4909D+00,0.0000D+00,0.0000D+00,
     &1.8131D-01,1.7986D-01,1.7802D-01,1.7597D-01,1.7372D-01,1.7110D-01,
     &1.6825D-01,1.6515D-01,1.6187D-01,1.5820D-01,1.5428D-01,1.5016D-01,
     &1.4582D-01,1.4314D-01,1.4017D-01,1.3677D-01,1.3315D-01,1.2951D-01,
     &1.2571D-01,1.2248D-01,1.1891D-01,1.1472D-01,1.1045D-01,1.0615D-01,
     &1.0173D-01,9.7944D-02,9.3854D-02,8.9131D-02,8.4347D-02,7.9597D-02,
     &7.4799D-02,7.0788D-02,6.6599D-02,6.1932D-02,5.7438D-02,5.3307D-02,
     &4.9546D-02,4.6816D-02,4.4417D-02,4.2536D-02,4.1862D-02,4.2361D-02,
     &4.3960D-02,4.6198D-02,4.9612D-02,5.3553D-02,5.7974D-02,6.2830D-02/
      DATA (XSF_L(K),K=  457,  570) /
     &6.8141D-02,7.3865D-02,7.9970D-02,8.6422D-02,9.3160D-02,1.0006D-01,
     &1.0685D-01,1.1989D-01,1.4199D-01,1.6937D-01,2.0407D-01,2.4925D-01,
     &3.1029D-01,3.9635D-01,5.2529D-01,7.3579D-01,1.1263D+00,2.0347D+00,
     &0.0000D+00,0.0000D+00,2.6278D-01,2.5883D-01,2.5460D-01,2.5007D-01,
     &2.4526D-01,2.3995D-01,2.3437D-01,2.2848D-01,2.2242D-01,2.1578D-01,
     &2.0894D-01,2.0181D-01,1.9465D-01,1.9018D-01,1.8540D-01,1.7984D-01,
     &1.7415D-01,1.6846D-01,1.6261D-01,1.5768D-01,1.5234D-01,1.4615D-01,
     &1.3987D-01,1.3368D-01,1.2736D-01,1.2199D-01,1.1628D-01,1.0975D-01,
     &1.0321D-01,9.6788D-02,9.0380D-02,8.5059D-02,7.9532D-02,7.3436D-02,
     &6.7594D-02,6.2243D-02,5.7363D-02,5.3720D-02,5.0502D-02,4.7772D-02,
     &4.6346D-02,4.6358D-02,4.7497D-02,4.9377D-02,5.2401D-02,5.5965D-02,
     &6.0009D-02,6.4489D-02,6.9334D-02,7.4546D-02,8.0117D-02,8.5936D-02,
     &9.1972D-02,9.8056D-02,1.0398D-01,1.1644D-01,1.3628D-01,1.6068D-01,
     &1.9127D-01,2.3085D-01,2.8377D-01,3.5756D-01,4.6698D-01,6.4315D-01,
     &9.6485D-01,1.6969D+00,0.0000D+00,0.0000D+00,3.6944D-01,3.6187D-01,
     &3.5380D-01,3.4525D-01,3.3659D-01,3.2716D-01,3.1761D-01,3.0767D-01,
     &2.9759D-01,2.8675D-01,2.7586D-01,2.6462D-01,2.5339D-01,2.4660D-01,
     &2.3933D-01,2.3101D-01,2.2257D-01,2.1415D-01,2.0571D-01,1.9854D-01,
     &1.9083D-01,1.8216D-01,1.7338D-01,1.6480D-01,1.5613D-01,1.4885D-01/
      DATA (XSF_L(K),K=  571,  684) /
     &1.4115D-01,1.3244D-01,1.2380D-01,1.1542D-01,1.0713D-01,1.0031D-01,
     &9.3226D-02,8.5515D-02,7.8171D-02,7.1449D-02,6.5307D-02,6.0723D-02,
     &5.6523D-02,5.2878D-02,5.0622D-02,5.0109D-02,5.0720D-02,5.2187D-02,
     &5.4770D-02,5.7950D-02,6.1582D-02,6.5595D-02,6.9997D-02,7.4716D-02,
     &7.9677D-02,8.4886D-02,9.0221D-02,9.5543D-02,1.0065D-01,1.1245D-01,
     &1.3012D-01,1.5166D-01,1.7859D-01,2.1305D-01,2.5881D-01,3.2188D-01,
     &4.1454D-01,5.6186D-01,8.2718D-01,1.4188D+00,0.0000D+00,0.0000D+00,
     &4.9195D-01,4.7916D-01,4.6620D-01,4.5277D-01,4.3908D-01,4.2463D-01,
     &4.0985D-01,3.9491D-01,3.7975D-01,3.6377D-01,3.4790D-01,3.3178D-01,
     &3.1592D-01,3.0640D-01,2.9622D-01,2.8462D-01,2.7303D-01,2.6160D-01,
     &2.5012D-01,2.4047D-01,2.3023D-01,2.1867D-01,2.0717D-01,1.9597D-01,
     &1.8477D-01,1.7546D-01,1.6568D-01,1.5468D-01,1.4387D-01,1.3343D-01,
     &1.2319D-01,1.1482D-01,1.0622D-01,9.6828D-02,8.7978D-02,7.9884D-02,
     &7.2526D-02,6.6973D-02,6.1948D-02,5.7359D-02,5.4304D-02,5.3263D-02,
     &5.3381D-02,5.4456D-02,5.6601D-02,5.9380D-02,6.2613D-02,6.6252D-02,
     &7.0174D-02,7.4432D-02,7.8943D-02,8.3559D-02,8.8282D-02,9.2963D-02,
     &9.7382D-02,1.0858D-01,1.2441D-01,1.4363D-01,1.6745D-01,1.9778D-01,
     &2.3771D-01,2.9246D-01,3.7200D-01,4.9738D-01,7.2010D-01,1.2083D+00,
     &0.0000D+00,0.0000D+00,6.4521D-01,6.2534D-01,6.0540D-01,5.8499D-01/
      DATA (XSF_L(K),K=  685,  798) /
     &5.6467D-01,5.4301D-01,5.2143D-01,4.9951D-01,4.7813D-01,4.5538D-01,
     &4.3325D-01,4.1083D-01,3.8899D-01,3.7591D-01,3.6210D-01,3.4648D-01,
     &3.3091D-01,3.1578D-01,3.0062D-01,2.8797D-01,2.7469D-01,2.5979D-01,
     &2.4501D-01,2.3066D-01,2.1649D-01,2.0481D-01,1.9252D-01,1.7884D-01,
     &1.6549D-01,1.5274D-01,1.4029D-01,1.3018D-01,1.1985D-01,1.0865D-01,
     &9.8135D-02,8.8550D-02,7.9829D-02,7.3318D-02,6.7269D-02,6.1748D-02,
     &5.7838D-02,5.6250D-02,5.5826D-02,5.6474D-02,5.8181D-02,6.0533D-02,
     &6.3373D-02,6.6563D-02,7.0085D-02,7.3865D-02,7.7842D-02,8.1937D-02,
     &8.6092D-02,9.0169D-02,9.3962D-02,1.0448D-01,1.1858D-01,1.3561D-01,
     &1.5663D-01,1.8318D-01,2.1803D-01,2.6529D-01,3.3349D-01,4.3985D-01,
     &6.2661D-01,1.0291D+00,0.0000D+00,0.0000D+00,8.2462D-01,7.9558D-01,
     &7.6680D-01,7.3764D-01,7.0860D-01,6.7834D-01,6.4822D-01,6.1798D-01,
     &5.8880D-01,5.5792D-01,5.2800D-01,4.9801D-01,4.6912D-01,4.5197D-01,
     &4.3393D-01,4.1360D-01,3.9348D-01,3.7394D-01,3.5462D-01,3.3856D-01,
     &3.2180D-01,3.0303D-01,2.8460D-01,2.6681D-01,2.4932D-01,2.3502D-01,
     &2.2005D-01,2.0359D-01,1.8747D-01,1.7224D-01,1.5746D-01,1.4551D-01,
     &1.3337D-01,1.2028D-01,1.0805D-01,9.6986D-02,8.6877D-02,7.9334D-02,
     &7.2326D-02,6.5799D-02,6.1060D-02,5.8911D-02,5.7957D-02,5.8189D-02,
     &5.9441D-02,6.1387D-02,6.3834D-02,6.6632D-02,6.9732D-02,7.3070D-02/
      DATA (XSF_L(K),K=  799,  912) /
     &7.6595D-02,8.0190D-02,8.3816D-02,8.7358D-02,9.0631D-02,1.0046D-01,
     &1.1304D-01,1.2815D-01,1.4670D-01,1.7006D-01,2.0049D-01,2.4154D-01,
     &3.0039D-01,3.9121D-01,5.4894D-01,8.8378D-01,0.0000D+00,0.0000D+00,
     &1.0199D+00,9.8025D-01,9.4100D-01,9.0151D-01,8.6283D-01,8.2243D-01,
     &7.8262D-01,7.4321D-01,7.0465D-01,6.6494D-01,6.2647D-01,5.8811D-01,
     &5.5152D-01,5.2985D-01,5.0721D-01,4.8183D-01,4.5681D-01,4.3274D-01,
     &4.0883D-01,3.8916D-01,3.6878D-01,3.4589D-01,3.2366D-01,3.0238D-01,
     &2.8152D-01,2.6437D-01,2.4685D-01,2.2733D-01,2.0858D-01,1.9085D-01,
     &1.7375D-01,1.6000D-01,1.4607D-01,1.3115D-01,1.1722D-01,1.0469D-01,
     &9.3284D-02,8.4739D-02,7.6803D-02,6.9420D-02,6.3844D-02,6.1178D-02,
     &5.9720D-02,5.9561D-02,6.0398D-02,6.1984D-02,6.4051D-02,6.6494D-02,
     &6.9202D-02,7.2161D-02,7.5274D-02,7.8453D-02,8.1651D-02,8.4728D-02,
     &8.7564D-02,9.6777D-02,1.0806D-01,1.2157D-01,1.3806D-01,1.5882D-01,
     &1.8566D-01,2.2170D-01,2.7301D-01,3.5168D-01,4.8696D-01,7.7010D-01,
     &0.0000D+00,0.0000D+00,1.3158D+00,1.2585D+00,1.2024D+00,1.1462D+00,
     &1.0919D+00,1.0352D+00,9.8042D-01,9.2608D-01,8.7345D-01,8.1987D-01,
     &7.6814D-01,7.1724D-01,6.6882D-01,6.4053D-01,6.1093D-01,5.7796D-01,
     &5.4572D-01,5.1470D-01,4.8433D-01,4.5934D-01,4.3358D-01,4.0495D-01,
     &3.7717D-01,3.5082D-01,3.2513D-01,3.0408D-01,2.8258D-01,2.5918D-01/
      DATA (XSF_L(K),K=  913, 1026) /
     &2.3648D-01,2.1538D-01,1.9510D-01,1.7888D-01,1.6255D-01,1.4508D-01,
     &1.2895D-01,1.1443D-01,1.0131D-01,9.1507D-02,8.2387D-02,7.3778D-02,
     &6.7147D-02,6.3813D-02,6.1721D-02,6.1065D-02,6.1373D-02,6.2475D-02,
     &6.4105D-02,6.6079D-02,6.8362D-02,7.0856D-02,7.3440D-02,7.6143D-02,
     &7.8812D-02,8.1388D-02,8.3726D-02,9.2167D-02,1.0190D-01,1.1355D-01,
     &1.2780D-01,1.4554D-01,1.6841D-01,1.9900D-01,2.4223D-01,3.0775D-01,
     &4.1920D-01,6.4849D-01,0.0000D+00,0.0000D+00,1.6483D+00,1.5703D+00,
     &1.4940D+00,1.4180D+00,1.3449D+00,1.2694D+00,1.1966D+00,1.1250D+00,
     &1.0566D+00,9.8644D-01,9.1985D-01,8.5482D-01,7.9312D-01,7.5722D-01,
     &7.1986D-01,6.7849D-01,6.3821D-01,5.9972D-01,5.6214D-01,5.3143D-01,
     &4.9987D-01,4.6500D-01,4.3136D-01,3.9956D-01,3.6875D-01,3.4379D-01,
     &3.1832D-01,2.9044D-01,2.6397D-01,2.3923D-01,2.1580D-01,1.9706D-01,
     &1.7829D-01,1.5838D-01,1.3999D-01,1.2356D-01,1.0875D-01,9.7664D-02,
     &8.7392D-02,7.7645D-02,7.0035D-02,6.6062D-02,6.3365D-02,6.2239D-02,
     &6.2062D-02,6.2731D-02,6.3942D-02,6.5526D-02,6.7390D-02,6.9436D-02,
     &7.1635D-02,7.3891D-02,7.6122D-02,7.8246D-02,8.0196D-02,8.7884D-02,
     &9.6357D-02,1.0648D-01,1.1880D-01,1.3413D-01,1.5386D-01,1.7993D-01,
     &2.1655D-01,2.7189D-01,3.6486D-01,5.5332D-01,0.0000D+00,0.0000D+00,
     &2.0271D+00,1.9234D+00,1.8224D+00,1.7226D+00,1.6272D+00,1.5293D+00/
      DATA (XSF_L(K),K= 1027, 1140) /
     &1.4356D+00,1.3438D+00,1.2568D+00,1.1682D+00,1.0841D+00,1.0026D+00,
     &9.2625D-01,8.8207D-01,8.3568D-01,7.8523D-01,7.3607D-01,6.8926D-01,
     &6.4385D-01,6.0685D-01,5.6892D-01,5.2730D-01,4.8731D-01,4.4961D-01,
     &4.1331D-01,3.8417D-01,3.5441D-01,3.2210D-01,2.9168D-01,2.6323D-01,
     &2.3631D-01,2.1500D-01,1.9374D-01,1.7129D-01,1.5067D-01,1.3231D-01,
     &1.1579D-01,1.0349D-01,9.2080D-02,8.1205D-02,7.2626D-02,6.8039D-02,
     &6.4761D-02,6.3188D-02,6.2549D-02,6.2795D-02,6.3617D-02,6.4835D-02,
     &6.6329D-02,6.8017D-02,6.9809D-02,7.1667D-02,7.3520D-02,7.5270D-02,
     &7.6864D-02,8.3899D-02,9.1206D-02,1.0002D-01,1.1070D-01,1.2399D-01,
     &1.4094D-01,1.6341D-01,1.9474D-01,2.4163D-01,3.1971D-01,4.7587D-01,
     &0.0000D+00,0.0000D+00,2.4392D+00,2.3049D+00,2.1760D+00,2.0502D+00,
     &1.9296D+00,1.8065D+00,1.6895D+00,1.5750D+00,1.4674D+00,1.3585D+00,
     &1.2554D+00,1.1565D+00,1.0638D+00,1.0103D+00,9.5527D-01,8.9449D-01,
     &8.3572D-01,7.8018D-01,7.2635D-01,6.8280D-01,6.3819D-01,5.8948D-01,
     &5.4299D-01,4.9923D-01,4.5740D-01,4.2371D-01,3.8978D-01,3.5296D-01,
     &3.1832D-01,2.8629D-01,2.5599D-01,2.3212D-01,2.0840D-01,1.8346D-01,
     &1.6065D-01,1.4043D-01,1.2229D-01,1.0880D-01,9.6294D-02,8.4335D-02,
     &7.4905D-02,6.9717D-02,6.5897D-02,6.3914D-02,6.2851D-02,6.2731D-02,
     &6.3183D-02,6.4075D-02,6.5225D-02,6.6597D-02,6.8048D-02,6.9577D-02/
      DATA (XSF_L(K),K= 1141, 1254) /
     &7.1093D-02,7.2525D-02,7.3842D-02,8.0241D-02,8.6615D-02,9.4292D-02,
     &1.0360D-01,1.1517D-01,1.2992D-01,1.4936D-01,1.7633D-01,2.1652D-01,
     &2.8294D-01,4.1389D-01,0.0000D+00,0.0000D+00,2.9162D+00,2.7470D+00,
     &2.5840D+00,2.4244D+00,2.2743D+00,2.1215D+00,1.9764D+00,1.8358D+00,
     &1.7035D+00,1.5708D+00,1.4463D+00,1.3268D+00,1.2152D+00,1.1514D+00,
     &1.0857D+00,1.0132D+00,9.4449D-01,8.7867D-01,8.1556D-01,7.6453D-01,
     &7.1252D-01,6.5602D-01,6.0218D-01,5.5192D-01,5.0387D-01,4.6545D-01,
     &4.2679D-01,3.8521D-01,3.4602D-01,3.1005D-01,2.7623D-01,2.4962D-01,
     &2.2332D-01,1.9577D-01,1.7070D-01,1.4856D-01,1.2874D-01,1.1402D-01,
     &1.0040D-01,8.7343D-02,7.6984D-02,7.1254D-02,6.6892D-02,6.4508D-02,
     &6.3019D-02,6.2518D-02,6.2667D-02,6.3211D-02,6.4031D-02,6.5064D-02,
     &6.6243D-02,6.7458D-02,6.8679D-02,6.9830D-02,7.0885D-02,7.6672D-02,
     &8.2192D-02,8.8844D-02,9.6930D-02,1.0696D-01,1.1972D-01,1.3654D-01,
     &1.5978D-01,1.9411D-01,2.5048D-01,3.6023D-01,0.0000D+00,0.0000D+00,
     &3.4281D+00,3.2194D+00,3.0180D+00,2.8239D+00,2.6400D+00,2.4537D+00,
     &2.2781D+00,2.1087D+00,1.9503D+00,1.7915D+00,1.6433D+00,1.5021D+00,
     &1.3711D+00,1.2958D+00,1.2191D+00,1.1350D+00,1.0536D+00,9.7846D-01,
     &9.0526D-01,8.4668D-01,7.8697D-01,7.2243D-01,6.6110D-01,6.0402D-01,
     &5.4971D-01,5.0652D-01,4.6307D-01,4.1647D-01,3.7287D-01,3.3288D-01/
      DATA (XSF_L(K),K= 1255, 1368) /
     &2.9545D-01,2.6636D-01,2.3751D-01,2.0740D-01,1.8012D-01,1.5611D-01,
     &1.3467D-01,1.1881D-01,1.0414D-01,9.0105D-02,7.8839D-02,7.2563D-02,
     &6.7703D-02,6.4930D-02,6.3070D-02,6.2241D-02,6.2071D-02,6.2347D-02,
     &6.2882D-02,6.3645D-02,6.4526D-02,6.5473D-02,6.6427D-02,6.7333D-02,
     &6.8194D-02,7.3430D-02,7.8217D-02,8.3974D-02,9.1017D-02,9.9745D-02,
     &1.1088D-01,1.2552D-01,1.4563D-01,1.7528D-01,2.2351D-01,3.1636D-01,
     &0.0000D+00,0.0000D+00,3.9892D+00,3.7328D+00,3.4900D+00,3.2549D+00,
     &3.0344D+00,2.8108D+00,2.6014D+00,2.4001D+00,2.2123D+00,2.0253D+00,
     &1.8518D+00,1.6860D+00,1.5339D+00,1.4463D+00,1.3575D+00,1.2608D+00,
     &1.1678D+00,1.0809D+00,9.9767D-01,9.3087D-01,8.6314D-01,7.8996D-01,
     &7.2083D-01,6.5671D-01,5.9602D-01,5.4775D-01,4.9935D-01,4.4773D-01,
     &3.9951D-01,3.5571D-01,3.1467D-01,2.8272D-01,2.5135D-01,2.1871D-01,
     &1.8923D-01,1.6331D-01,1.4031D-01,1.2332D-01,1.0762D-01,9.2560D-02,
     &8.0473D-02,7.3714D-02,6.8385D-02,6.5246D-02,6.3019D-02,6.1878D-02,
     &6.1420D-02,6.1413D-02,6.1734D-02,6.2226D-02,6.2861D-02,6.3564D-02,
     &6.4288D-02,6.4985D-02,6.5657D-02,7.0367D-02,7.4522D-02,7.9506D-02,
     &8.5651D-02,9.3297D-02,1.0298D-01,1.1572D-01,1.3323D-01,1.5884D-01,
     &2.0039D-01,2.7925D-01,0.0000D+00,0.0000D+00,4.5788D+00,4.2729D+00,
     &3.9840D+00,3.7039D+00,3.4438D+00,3.1812D+00,2.9349D+00,2.6996D+00/
      DATA (XSF_L(K),K= 1369, 1482) /
     &2.4810D+00,2.2644D+00,2.0633D+00,1.8732D+00,1.6979D+00,1.5988D+00,
     &1.4974D+00,1.3865D+00,1.2812D+00,1.1834D+00,1.0891D+00,1.0143D+00,
     &9.3839D-01,8.5662D-01,7.7948D-01,7.0838D-01,6.4106D-01,5.8780D-01,
     &5.3454D-01,4.7781D-01,4.2528D-01,3.7737D-01,3.3289D-01,2.9818D-01,
     &2.6446D-01,2.2932D-01,1.9770D-01,1.7005D-01,1.4552D-01,1.2746D-01,
     &1.1078D-01,9.4770D-02,8.1957D-02,7.4689D-02,6.8915D-02,6.5457D-02,
     &6.2902D-02,6.1493D-02,6.0768D-02,6.0515D-02,6.0585D-02,6.0863D-02,
     &6.1298D-02,6.1789D-02,6.2311D-02,6.2835D-02,6.3340D-02,6.7601D-02,
     &7.1162D-02,7.5516D-02,8.0878D-02,8.7566D-02,9.6095D-02,1.0725D-01,
     &1.2258D-01,1.4495D-01,1.8090D-01,2.4841D-01,0.0000D+00,0.0000D+00,
     &5.4774D+00,5.0929D+00,4.7320D+00,4.3841D+00,4.0592D+00,3.7350D+00,
     &3.4329D+00,3.1454D+00,2.8799D+00,2.6172D+00,2.3747D+00,2.1466D+00,
     &1.9383D+00,1.8195D+00,1.6996D+00,1.5689D+00,1.4457D+00,1.3301D+00,
     &1.2211D+00,1.1339D+00,1.0456D+00,9.5119D-01,8.6259D-01,7.8097D-01,
     &7.0419D-01,6.4380D-01,5.8358D-01,5.1955D-01,4.6051D-01,4.0719D-01,
     &3.5768D-01,3.1962D-01,2.8220D-01,2.4360D-01,2.0909D-01,1.7895D-01,
     &1.5240D-01,1.3282D-01,1.1484D-01,9.7655D-02,8.3739D-02,7.5857D-02,
     &6.9509D-02,6.5616D-02,6.2633D-02,6.0853D-02,5.9819D-02,5.9271D-02,
     &5.9038D-02,5.9046D-02,5.9192D-02,5.9432D-02,5.9709D-02,6.0008D-02/
      DATA (XSF_L(K),K= 1483, 1596) /
     &6.0340D-02,6.4032D-02,6.6851D-02,7.0446D-02,7.4870D-02,8.0457D-02,
     &8.7554D-02,9.6862D-02,1.0964D-01,1.2821D-01,1.5779D-01,2.1189D-01,
     &0.0000D+00,0.0000D+00,6.3982D+00,5.9307D+00,5.4920D+00,5.0710D+00,
     &4.6822D+00,4.2915D+00,3.9337D+00,3.5898D+00,3.2756D+00,2.9660D+00,
     &2.6817D+00,2.4150D+00,2.1724D+00,2.0348D+00,1.8961D+00,1.7457D+00,
     &1.6034D+00,1.4714D+00,1.3471D+00,1.2473D+00,1.1476D+00,1.0408D+00,
     &9.4083D-01,8.4932D-01,7.6350D-01,6.9606D-01,6.2897D-01,5.5833D-01,
     &4.9315D-01,4.3444D-01,3.8044D-01,3.3861D-01,2.9817D-01,2.5642D-01,
     &2.1917D-01,1.8685D-01,1.5838D-01,1.3752D-01,1.1831D-01,9.9987D-02,
     &8.5224D-02,7.6762D-02,6.9910D-02,6.5655D-02,6.2297D-02,6.0213D-02,
     &5.8897D-02,5.8096D-02,5.7624D-02,5.7400D-02,5.7322D-02,5.7351D-02,
     &5.7432D-02,5.7560D-02,5.7758D-02,6.0939D-02,6.3212D-02,6.6167D-02,
     &6.9884D-02,7.4560D-02,8.0552D-02,8.8432D-02,9.9242D-02,1.1491D-01,
     &1.3966D-01,1.8320D-01,0.0000D+00,0.0000D+00,7.4490D+00,6.8826D+00,
     &6.3540D+00,5.8477D+00,5.3805D+00,4.9187D+00,4.4884D+00,4.0843D+00,
     &3.7147D+00,3.3516D+00,3.0193D+00,2.7088D+00,2.4279D+00,2.2696D+00,
     &2.1091D+00,1.9368D+00,1.7739D+00,1.6237D+00,1.4821D+00,1.3692D+00,
     &1.2557D+00,1.1358D+00,1.0238D+00,9.2133D-01,8.2567D-01,7.5070D-01,
     &6.7656D-01,5.9850D-01,5.2688D-01,4.6263D-01,4.0371D-01,3.5842D-01/
      DATA (XSF_L(K),K= 1597, 1710) /
     &3.1427D-01,2.6933D-01,2.2930D-01,1.9466D-01,1.6427D-01,1.4208D-01,
     &1.2168D-01,1.0226D-01,8.6560D-02,7.7553D-02,7.0202D-02,6.5576D-02,
     &6.1860D-02,5.9487D-02,5.7920D-02,5.6852D-02,5.6166D-02,5.5736D-02,
     &5.5458D-02,5.5289D-02,5.5193D-02,5.5163D-02,5.5243D-02,5.7935D-02,
     &5.9740D-02,6.2111D-02,6.5158D-02,6.9050D-02,7.4078D-02,8.0683D-02,
     &8.9776D-02,1.0288D-01,1.2351D-01,1.5725D-01,0.0000D+00,0.0000D+00,
     &8.6044D+00,7.9255D+00,7.2940D+00,6.6940D+00,6.1391D+00,5.5940D+00,
     &5.0907D+00,4.6180D+00,4.1841D+00,3.7622D+00,3.3775D+00,3.0195D+00,
     &2.6967D+00,2.5153D+00,2.3331D+00,2.1364D+00,1.9521D+00,1.7815D+00,
     &1.6211D+00,1.4944D+00,1.3683D+00,1.2334D+00,1.1084D+00,9.9465D-01,
     &8.8864D-01,8.0585D-01,7.2432D-01,6.3866D-01,5.6038D-01,4.9058D-01,
     &4.2648D-01,3.7768D-01,3.3036D-01,2.8189D-01,2.3907D-01,2.0214D-01,
     &1.6987D-01,1.4635D-01,1.2479D-01,1.0428D-01,8.7748D-02,7.8203D-02,
     &7.0386D-02,6.5431D-02,6.1373D-02,5.8719D-02,5.6916D-02,5.5642D-02,
     &5.4751D-02,5.4118D-02,5.3653D-02,5.3314D-02,5.3067D-02,5.2897D-02,
     &5.2861D-02,5.5140D-02,5.6493D-02,5.8378D-02,6.0860D-02,6.4090D-02,
     &6.8261D-02,7.3828D-02,8.1439D-02,9.2423D-02,1.0952D-01,1.3424D-01,
     &0.0000D+00,0.0000D+00,9.7645D+00,8.9701D+00,8.2340D+00,7.5357D+00,
     &6.8926D+00,6.2607D+00,5.6834D+00,5.1374D+00,4.6459D+00,4.1625D+00/
      DATA (XSF_L(K),K= 1711, 1824) /
     &3.7261D+00,3.3206D+00,2.9567D+00,2.7529D+00,2.5476D+00,2.3274D+00,
     &2.1217D+00,1.9320D+00,1.7541D+00,1.6131D+00,1.4740D+00,1.3257D+00,
     &1.1879D+00,1.0631D+00,9.4732D-01,8.5726D-01,7.6844D-01,6.7586D-01,
     &5.9131D-01,5.1597D-01,4.4748D-01,3.9504D-01,3.4470D-01,2.9317D-01,
     &2.4779D-01,2.0880D-01,1.7478D-01,1.5007D-01,1.2748D-01,1.0600D-01,
     &8.8713D-02,7.8704D-02,7.0472D-02,6.5220D-02,6.0885D-02,5.7993D-02,
     &5.5967D-02,5.4536D-02,5.3470D-02,5.2665D-02,5.2054D-02,5.1577D-02,
     &5.1203D-02,5.0930D-02,5.0809D-02,5.2731D-02,5.3716D-02,5.5192D-02,
     &5.7203D-02,5.9902D-02,6.3412D-02,6.8123D-02,7.4602D-02,8.3905D-02,
     &9.8185D-02,1.1515D-01,0.0000D+00,0.0000D+00,1.1069D+01,1.0141D+01,
     &9.2840D+00,8.4741D+00,7.7316D+00,7.0038D+00,6.3364D+00,5.7137D+00,
     &5.1475D+00,4.6031D+00,4.1059D+00,3.6477D+00,3.2381D+00,3.0086D+00,
     &2.7788D+00,2.5333D+00,2.3033D+00,2.0926D+00,1.8951D+00,1.7404D+00,
     &1.5854D+00,1.4229D+00,1.2715D+00,1.1352D+00,1.0089D+00,9.1089D-01,
     &8.1457D-01,7.1424D-01,6.2332D-01,5.4229D-01,4.6872D-01,4.1295D-01,
     &3.5903D-01,3.0454D-01,2.5654D-01,2.1539D-01,1.7965D-01,1.5373D-01,
     &1.3011D-01,1.0766D-01,8.9530D-02,7.9108D-02,7.0483D-02,6.4943D-02,
     &6.0331D-02,5.7203D-02,5.4990D-02,5.3395D-02,5.2144D-02,5.1206D-02,
     &5.0454D-02,4.9840D-02,4.9351D-02,4.8978D-02,4.8801D-02,5.0351D-02/
      DATA (XSF_L(K),K= 1825, 1836) /
     &5.1017D-02,5.2127D-02,5.3737D-02,5.5934D-02,5.8835D-02,6.2800D-02,
     &6.8260D-02,7.6135D-02,8.7873D-02,0.0000D+00,0.0000D+00,0.0000D+00/
      DATA (XGF_L(K),K=    1,  114) /
     &1.0646D+00,1.0934D+00,1.1214D+00,1.1484D+00,1.1741D+00,1.1999D+00,
     &1.2242D+00,1.2466D+00,1.2676D+00,1.2873D+00,1.3042D+00,1.3194D+00,
     &1.3313D+00,1.3376D+00,1.3430D+00,1.3472D+00,1.3502D+00,1.3504D+00,
     &1.3501D+00,1.3478D+00,1.3430D+00,1.3356D+00,1.3267D+00,1.3149D+00,
     &1.3003D+00,1.2857D+00,1.2680D+00,1.2451D+00,1.2189D+00,1.1899D+00,
     &1.1575D+00,1.1282D+00,1.0947D+00,1.0543D+00,1.0121D+00,9.6983D-01,
     &9.2809D-01,8.9556D-01,8.6663D-01,8.4606D-01,8.4971D-01,8.7714D-01,
     &9.3569D-01,1.0140D+00,1.1325D+00,1.2706D+00,1.4268D+00,1.6005D+00,
     &1.7918D+00,2.0014D+00,2.2301D+00,2.4791D+00,2.7490D+00,3.0404D+00,
     &3.3541D+00,3.5718D+00,4.2579D+00,5.0478D+00,5.9674D+00,7.0458D+00,
     &8.3375D+00,9.9284D+00,1.1949D+01,1.4650D+01,1.8560D+01,2.5096D+01,
     &4.0067D+01,0.0000D+00,1.6404D+00,1.6723D+00,1.7014D+00,1.7287D+00,
     &1.7533D+00,1.7768D+00,1.7973D+00,1.8152D+00,1.8297D+00,1.8417D+00,
     &1.8498D+00,1.8540D+00,1.8544D+00,1.8526D+00,1.8489D+00,1.8424D+00,
     &1.8335D+00,1.8221D+00,1.8091D+00,1.7949D+00,1.7784D+00,1.7555D+00,
     &1.7310D+00,1.7034D+00,1.6713D+00,1.6428D+00,1.6093D+00,1.5680D+00,
     &1.5230D+00,1.4754D+00,1.4241D+00,1.3785D+00,1.3278D+00,1.2681D+00,
     &1.2068D+00,1.1462D+00,1.0867D+00,1.0400D+00,9.9665D-01,9.6041D-01,
     &9.4923D-01,9.6563D-01,1.0117D+00,1.0781D+00,1.1816D+00,1.3028D+00/
      DATA (XGF_L(K),K=  115,  228) /
     &1.4397D+00,1.5912D+00,1.7573D+00,1.9376D+00,2.1326D+00,2.3425D+00,
     &2.5677D+00,2.8078D+00,3.0611D+00,3.2398D+00,3.7904D+00,4.4126D+00,
     &5.1162D+00,5.9322D+00,6.8841D+00,8.0278D+00,9.4403D+00,1.1276D+01,
     &1.3844D+01,1.7948D+01,2.6821D+01,0.0000D+00,2.5295D+00,2.5563D+00,
     &2.5800D+00,2.5995D+00,2.6174D+00,2.6286D+00,2.6363D+00,2.6395D+00,
     &2.6379D+00,2.6306D+00,2.6184D+00,2.6000D+00,2.5768D+00,2.5598D+00,
     &2.5397D+00,2.5137D+00,2.4839D+00,2.4516D+00,2.4161D+00,2.3833D+00,
     &2.3459D+00,2.3000D+00,2.2499D+00,2.1966D+00,2.1407D+00,2.0900D+00,
     &2.0320D+00,1.9647D+00,1.8929D+00,1.8190D+00,1.7411D+00,1.6734D+00,
     &1.5997D+00,1.5142D+00,1.4279D+00,1.3438D+00,1.2617D+00,1.1967D+00,
     &1.1353D+00,1.0800D+00,1.0501D+00,1.0526D+00,1.0849D+00,1.1369D+00,
     &1.2228D+00,1.3250D+00,1.4410D+00,1.5691D+00,1.7085D+00,1.8587D+00,
     &2.0200D+00,2.1915D+00,2.3728D+00,2.5633D+00,2.7603D+00,2.9047D+00,
     &3.3315D+00,3.8026D+00,4.3243D+00,4.9121D+00,5.5828D+00,6.3648D+00,
     &7.3038D+00,8.4817D+00,1.0068D+01,1.2484D+01,1.7398D+01,0.0000D+00,
     &3.9781D+00,3.9859D+00,3.9880D+00,3.9845D+00,3.9763D+00,3.9582D+00,
     &3.9337D+00,3.9028D+00,3.8636D+00,3.8159D+00,3.7613D+00,3.6984D+00,
     &3.6287D+00,3.5836D+00,3.5326D+00,3.4703D+00,3.4046D+00,3.3350D+00,
     &3.2612D+00,3.1962D+00,3.1248D+00,3.0388D+00,2.9485D+00,2.8565D+00/
      DATA (XGF_L(K),K=  229,  342) /
     &2.7591D+00,2.6752D+00,2.5823D+00,2.4756D+00,2.3627D+00,2.2510D+00,
     &2.1352D+00,2.0365D+00,1.9308D+00,1.8097D+00,1.6896D+00,1.5737D+00,
     &1.4618D+00,1.3735D+00,1.2886D+00,1.2087D+00,1.1551D+00,1.1411D+00,
     &1.1545D+00,1.1903D+00,1.2550D+00,1.3356D+00,1.4282D+00,1.5306D+00,
     &1.6419D+00,1.7606D+00,1.8869D+00,2.0194D+00,2.1574D+00,2.2992D+00,
     &2.4432D+00,2.5568D+00,2.8674D+00,3.2008D+00,3.5626D+00,3.9572D+00,
     &4.3932D+00,4.8857D+00,5.4544D+00,6.1386D+00,7.0188D+00,8.2895D+00,
     &1.0709D+01,0.0000D+00,6.3697D+00,6.3265D+00,6.2740D+00,6.2091D+00,
     &6.1391D+00,6.0517D+00,5.9560D+00,5.8525D+00,5.7367D+00,5.6106D+00,
     &5.4709D+00,5.3235D+00,5.1695D+00,5.0724D+00,4.9662D+00,4.8411D+00,
     &4.7105D+00,4.5784D+00,4.4412D+00,4.3226D+00,4.1943D+00,4.0442D+00,
     &3.8903D+00,3.7360D+00,3.5773D+00,3.4420D+00,3.2967D+00,3.1301D+00,
     &2.9593D+00,2.7916D+00,2.6229D+00,2.4802D+00,2.3301D+00,2.1613D+00,
     &1.9957D+00,1.8382D+00,1.6875D+00,1.5691D+00,1.4545D+00,1.3433D+00,
     &1.2614D+00,1.2264D+00,1.2177D+00,1.2342D+00,1.2749D+00,1.3313D+00,
     &1.3987D+00,1.4740D+00,1.5559D+00,1.6431D+00,1.7346D+00,1.8295D+00,
     &1.9260D+00,2.0232D+00,2.1174D+00,2.2034D+00,2.4118D+00,2.6289D+00,
     &2.8563D+00,3.0948D+00,3.3486D+00,3.6231D+00,3.9250D+00,4.2677D+00,
     &4.6847D+00,5.2492D+00,6.2650D+00,0.0000D+00,9.3778D+00,9.2428D+00/
      DATA (XGF_L(K),K=  343,  456) /
     &9.0960D+00,8.9365D+00,8.7665D+00,8.5746D+00,8.3714D+00,8.1544D+00,
     &7.9343D+00,7.6882D+00,7.4352D+00,7.1724D+00,6.9027D+00,6.7360D+00,
     &6.5571D+00,6.3494D+00,6.1374D+00,5.9260D+00,5.7093D+00,5.5249D+00,
     &5.3270D+00,5.0995D+00,4.8700D+00,4.6419D+00,4.4114D+00,4.2173D+00,
     &4.0129D+00,3.7786D+00,3.5451D+00,3.3173D+00,3.0900D+00,2.9004D+00,
     &2.7040D+00,2.4853D+00,2.2734D+00,2.0742D+00,1.8851D+00,1.7372D+00,
     &1.5941D+00,1.4536D+00,1.3433D+00,1.2893D+00,1.2607D+00,1.2587D+00,
     &1.2792D+00,1.3153D+00,1.3616D+00,1.4149D+00,1.4736D+00,1.5361D+00,
     &1.6012D+00,1.6677D+00,1.7344D+00,1.7990D+00,1.8589D+00,1.9261D+00,
     &2.0646D+00,2.2044D+00,2.3456D+00,2.4882D+00,2.6342D+00,2.7823D+00,
     &2.9370D+00,3.1022D+00,3.2902D+00,3.5288D+00,3.9528D+00,0.0000D+00,
     &1.3926D+01,1.3617D+01,1.3298D+01,1.2959D+01,1.2612D+01,1.2230D+01,
     &1.1845D+01,1.1442D+01,1.1036D+01,1.0599D+01,1.0158D+01,9.7041D+00,
     &9.2562D+00,8.9827D+00,8.6974D+00,8.3632D+00,8.0255D+00,7.6946D+00,
     &7.3614D+00,7.0802D+00,6.7814D+00,6.4439D+00,6.1064D+00,5.7775D+00,
     &5.4468D+00,5.1723D+00,4.8858D+00,4.5617D+00,4.2425D+00,3.9361D+00,
     &3.6353D+00,3.3874D+00,3.1301D+00,2.8506D+00,2.5816D+00,2.3318D+00,
     &2.0965D+00,1.9136D+00,1.7368D+00,1.5622D+00,1.4211D+00,1.3452D+00,
     &1.2937D+00,1.2737D+00,1.2719D+00,1.2868D+00,1.3119D+00,1.3437D+00/
      DATA (XGF_L(K),K=  457,  570) /
     &1.3799D+00,1.4189D+00,1.4596D+00,1.5003D+00,1.5401D+00,1.5761D+00,
     &1.6073D+00,1.6574D+00,1.7377D+00,1.8158D+00,1.8902D+00,1.9601D+00,
     &2.0263D+00,2.0884D+00,2.1452D+00,2.1990D+00,2.2512D+00,2.3118D+00,
     &2.4354D+00,0.0000D+00,1.9256D+01,1.8699D+01,1.8142D+01,1.7563D+01,
     &1.6980D+01,1.6355D+01,1.5725D+01,1.5081D+01,1.4443D+01,1.3769D+01,
     &1.3097D+01,1.2422D+01,1.1755D+01,1.1358D+01,1.0937D+01,1.0454D+01,
     &9.9818D+00,9.5167D+00,9.0465D+00,8.6570D+00,8.2473D+00,7.7870D+00,
     &7.3320D+00,6.8911D+00,6.4569D+00,6.0969D+00,5.7223D+00,5.3051D+00,
     &4.8992D+00,4.5131D+00,4.1351D+00,3.8285D+00,3.5148D+00,3.1749D+00,
     &2.8517D+00,2.5534D+00,2.2748D+00,2.0598D+00,1.8527D+00,1.6465D+00,
     &1.4780D+00,1.3832D+00,1.3129D+00,1.2758D+00,1.2566D+00,1.2544D+00,
     &1.2628D+00,1.2778D+00,1.2971D+00,1.3186D+00,1.3412D+00,1.3637D+00,
     &1.3845D+00,1.4021D+00,1.4142D+00,1.4518D+00,1.4945D+00,1.5327D+00,
     &1.5661D+00,1.5941D+00,1.6160D+00,1.6309D+00,1.6386D+00,1.6381D+00,
     &1.6291D+00,1.6176D+00,1.6271D+00,0.0000D+00,2.5945D+01,2.5063D+01,
     &2.4160D+01,2.3234D+01,2.2336D+01,2.1370D+01,2.0417D+01,1.9450D+01,
     &1.8508D+01,1.7517D+01,1.6548D+01,1.5580D+01,1.4645D+01,1.4085D+01,
     &1.3496D+01,1.2836D+01,1.2181D+01,1.1547D+01,1.0921D+01,1.0404D+01,
     &9.8614D+00,9.2547D+00,8.6616D+00,8.0926D+00,7.5352D+00,7.0774D+00/
      DATA (XGF_L(K),K=  571,  684) /
     &6.6043D+00,6.0842D+00,5.5816D+00,5.1040D+00,4.6450D+00,4.2749D+00,
     &3.8995D+00,3.4941D+00,3.1134D+00,2.7651D+00,2.4423D+00,2.1941D+00,
     &1.9564D+00,1.7198D+00,1.5241D+00,1.4112D+00,1.3220D+00,1.2705D+00,
     &1.2348D+00,1.2175D+00,1.2113D+00,1.2119D+00,1.2167D+00,1.2238D+00,
     &1.2321D+00,1.2398D+00,1.2460D+00,1.2491D+00,1.2470D+00,1.2752D+00,
     &1.2894D+00,1.2998D+00,1.3055D+00,1.3049D+00,1.2991D+00,1.2860D+00,
     &1.2655D+00,1.2370D+00,1.1998D+00,1.1564D+00,1.1181D+00,0.0000D+00,
     &3.3362D+01,3.2051D+01,3.0740D+01,2.9429D+01,2.8133D+01,2.6758D+01,
     &2.5422D+01,2.4082D+01,2.2784D+01,2.1435D+01,2.0130D+01,1.8839D+01,
     &1.7597D+01,1.6865D+01,1.6098D+01,1.5241D+01,1.4397D+01,1.3587D+01,
     &1.2791D+01,1.2130D+01,1.1444D+01,1.0687D+01,9.9507D+00,9.2501D+00,
     &8.5659D+00,8.0104D+00,7.4390D+00,6.8118D+00,6.2125D+00,5.6506D+00,
     &5.1096D+00,4.6780D+00,4.2434D+00,3.7769D+00,3.3424D+00,2.9475D+00,
     &2.5842D+00,2.3061D+00,2.0409D+00,1.7770D+00,1.5572D+00,1.4290D+00,
     &1.3248D+00,1.2609D+00,1.2112D+00,1.1814D+00,1.1636D+00,1.1530D+00,
     &1.1469D+00,1.1433D+00,1.1407D+00,1.1378D+00,1.1337D+00,1.1269D+00,
     &1.1152D+00,1.1360D+00,1.1320D+00,1.1243D+00,1.1127D+00,1.0960D+00,
     &1.0739D+00,1.0461D+00,1.0122D+00,9.7100D-01,9.2292D-01,8.6909D-01,
     &8.1432D-01,0.0000D+00,4.2364D+01,4.0483D+01,3.8640D+01,3.6792D+01/
      DATA (XGF_L(K),K=  685,  798) /
     &3.4991D+01,3.3112D+01,3.1295D+01,2.9487D+01,2.7748D+01,2.5953D+01,
     &2.4235D+01,2.2543D+01,2.0935D+01,1.9990D+01,1.9011D+01,1.7921D+01,
     &1.6852D+01,1.5830D+01,1.4831D+01,1.4013D+01,1.3165D+01,1.2236D+01,
     &1.1337D+01,1.0485D+01,9.6616D+00,8.9943D+00,8.3137D+00,7.5711D+00,
     &6.8670D+00,6.2090D+00,5.5842D+00,5.0866D+00,4.5873D+00,4.0564D+00,
     &3.5646D+00,3.1234D+00,2.7185D+00,2.4107D+00,2.1172D+00,1.8273D+00,
     &1.5836D+00,1.4407D+00,1.3211D+00,1.2459D+00,1.1839D+00,1.1433D+00,
     &1.1153D+00,1.0949D+00,1.0794D+00,1.0667D+00,1.0555D+00,1.0443D+00,
     &1.0317D+00,1.0172D+00,9.9883D-01,1.0131D+00,9.9503D-01,9.7446D-01,
     &9.5064D-01,9.2316D-01,8.9156D-01,8.5528D-01,8.1439D-01,7.6837D-01,
     &7.1718D-01,6.6210D-01,6.0243D-01,0.0000D+00,5.2603D+01,5.0038D+01,
     &4.7540D+01,4.5053D+01,4.2652D+01,4.0175D+01,3.7784D+01,3.5407D+01,
     &3.3154D+01,3.0851D+01,2.8651D+01,2.6507D+01,2.4488D+01,2.3310D+01,
     &2.2084D+01,2.0735D+01,1.9418D+01,1.8166D+01,1.6951D+01,1.5960D+01,
     &1.4935D+01,1.3817D+01,1.2742D+01,1.1732D+01,1.0759D+01,9.9749D+00,
     &9.1794D+00,8.3186D+00,7.5044D+00,6.7510D+00,6.0386D+00,5.4762D+00,
     &4.9137D+00,4.3200D+00,3.7728D+00,3.2842D+00,2.8391D+00,2.5026D+00,
     &2.1835D+00,1.8677D+00,1.6033D+00,1.4461D+00,1.3138D+00,1.2277D+00,
     &1.1557D+00,1.1057D+00,1.0689D+00,1.0407D+00,1.0176D+00,9.9768D-01/
      DATA (XGF_L(K),K=  799,  912) /
     &9.7951D-01,9.6199D-01,9.4331D-01,9.2359D-01,9.0058D-01,9.0921D-01,
     &8.8156D-01,8.5244D-01,8.2081D-01,7.8702D-01,7.5025D-01,7.1005D-01,
     &6.6667D-01,6.1984D-01,5.6969D-01,5.1748D-01,4.5895D-01,0.0000D+00,
     &6.3459D+01,6.0127D+01,5.6900D+01,5.3695D+01,5.0615D+01,4.7464D+01,
     &4.4440D+01,4.1483D+01,3.8684D+01,3.5826D+01,3.3122D+01,3.0500D+01,
     &2.8040D+01,2.6617D+01,2.5143D+01,2.3518D+01,2.1950D+01,2.0455D+01,
     &1.9011D+01,1.7842D+01,1.6646D+01,1.5337D+01,1.4094D+01,1.2920D+01,
     &1.1799D+01,1.0903D+01,9.9940D+00,9.0166D+00,8.0967D+00,7.2512D+00,
     &6.4551D+00,5.8279D+00,5.2081D+00,4.5519D+00,3.9568D+00,3.4237D+00,
     &2.9425D+00,2.5798D+00,2.2371D+00,1.8995D+00,1.6161D+00,1.4477D+00,
     &1.3046D+00,1.2096D+00,1.1285D+00,1.0709D+00,1.0274D+00,9.9290D-01,
     &9.6399D-01,9.3860D-01,9.1550D-01,8.9324D-01,8.7036D-01,8.4674D-01,
     &8.2129D-01,8.2506D-01,7.9094D-01,7.5633D-01,7.2031D-01,6.8307D-01,
     &6.4387D-01,6.0237D-01,5.5907D-01,5.1344D-01,4.6618D-01,4.1810D-01,
     &3.6329D-01,0.0000D+00,7.9498D+01,7.4941D+01,7.0580D+01,6.6266D+01,
     &6.2169D+01,5.8002D+01,5.4045D+01,5.0164D+01,4.6539D+01,4.2847D+01,
     &3.9386D+01,3.6065D+01,3.2968D+01,3.1180D+01,2.9347D+01,2.7330D+01,
     &2.5394D+01,2.3566D+01,2.1811D+01,2.0388D+01,1.8944D+01,1.7368D+01,
     &1.5877D+01,1.4488D+01,1.3164D+01,1.2111D+01,1.1051D+01,9.9162D+00/
      DATA (XGF_L(K),K=  913, 1026) /
     &8.8542D+00,7.8839D+00,6.9777D+00,6.2689D+00,5.5695D+00,4.8410D+00,
     &4.1789D+00,3.5909D+00,3.0635D+00,2.6689D+00,2.2973D+00,1.9324D+00,
     &1.6270D+00,1.4446D+00,1.2882D+00,1.1839D+00,1.0926D+00,1.0266D+00,
     &9.7585D-01,9.3473D-01,8.9976D-01,8.6898D-01,8.4068D-01,8.1374D-01,
     &7.8714D-01,7.6011D-01,7.3262D-01,7.3148D-01,6.9170D-01,6.5270D-01,
     &6.1357D-01,5.7426D-01,5.3417D-01,4.9316D-01,4.5166D-01,4.0914D-01,
     &3.6649D-01,3.2429D-01,2.7651D-01,0.0000D+00,9.7091D+01,9.1127D+01,
     &8.5440D+01,7.9869D+01,7.4603D+01,6.9275D+01,6.4220D+01,5.9343D+01,
     &5.4780D+01,5.0195D+01,4.5912D+01,4.1816D+01,3.8028D+01,3.5857D+01,
     &3.3637D+01,3.1205D+01,2.8880D+01,2.6695D+01,2.4601D+01,2.2923D+01,
     &2.1219D+01,1.9374D+01,1.7634D+01,1.6009D+01,1.4488D+01,1.3276D+01,
     &1.2064D+01,1.0772D+01,9.5709D+00,8.4795D+00,7.4649D+00,6.6775D+00,
     &5.9046D+00,5.1015D+00,4.3733D+00,3.7372D+00,3.1677D+00,2.7434D+00,
     &2.3459D+00,1.9566D+00,1.6317D+00,1.4368D+00,1.2699D+00,1.1572D+00,
     &1.0581D+00,9.8558D-01,9.2913D-01,8.8297D-01,8.4349D-01,8.0862D-01,
     &7.7667D-01,7.4686D-01,7.1760D-01,6.8906D-01,6.6005D-01,6.5493D-01,
     &6.1209D-01,5.7080D-01,5.3038D-01,4.9085D-01,4.5137D-01,4.1231D-01,
     &3.7316D-01,3.3442D-01,2.9613D-01,2.5928D-01,2.1912D-01,0.0000D+00,
     &1.1660D+02,1.0899D+02,1.0178D+02,9.4752D+01,8.8142D+01,8.1480D+01/
      DATA (XGF_L(K),K= 1027, 1140) /
     &7.5219D+01,6.9198D+01,6.3578D+01,5.7986D+01,5.2800D+01,4.7867D+01,
     &4.3328D+01,4.0736D+01,3.8088D+01,3.5213D+01,3.2469D+01,2.9907D+01,
     &2.7451D+01,2.5501D+01,2.3516D+01,2.1392D+01,1.9391D+01,1.7546D+01,
     &1.5800D+01,1.4426D+01,1.3057D+01,1.1607D+01,1.0266D+01,9.0517D+00,
     &7.9294D+00,7.0617D+00,6.2165D+00,5.3397D+00,4.5572D+00,3.8687D+00,
     &3.2598D+00,2.8078D+00,2.3859D+00,1.9745D+00,1.6317D+00,1.4267D+00,
     &1.2497D+00,1.1305D+00,1.0247D+00,9.4657D-01,8.8556D-01,8.3542D-01,
     &7.9253D-01,7.5465D-01,7.2037D-01,6.8840D-01,6.5775D-01,6.2793D-01,
     &5.9852D-01,5.9015D-01,5.4553D-01,5.0339D-01,4.6306D-01,4.2411D-01,
     &3.8622D-01,3.4909D-01,3.1294D-01,2.7773D-01,2.4373D-01,2.1150D-01,
     &1.7848D-01,0.0000D+00,1.3738D+02,1.2796D+02,1.1904D+02,1.1042D+02,
     &1.0233D+02,9.4222D+01,8.6662D+01,7.9409D+01,7.2655D+01,6.6001D+01,
     &5.9833D+01,5.4007D+01,4.8672D+01,4.5642D+01,4.2552D+01,3.9214D+01,
     &3.6040D+01,3.3082D+01,3.0272D+01,2.8026D+01,2.5779D+01,2.3361D+01,
     &2.1093D+01,1.9009D+01,1.7062D+01,1.5526D+01,1.4003D+01,1.2396D+01,
     &1.0916D+01,9.5845D+00,8.3611D+00,7.4188D+00,6.5021D+00,5.5589D+00,
     &4.7169D+00,3.9865D+00,3.3389D+00,2.8617D+00,2.4178D+00,1.9872D+00,
     &1.6283D+00,1.4143D+00,1.2296D+00,1.1049D+00,9.9315D-01,9.1079D-01,
     &8.4623D-01,7.9317D-01,7.4768D-01,7.0802D-01,6.7178D-01,6.3836D-01/
      DATA (XGF_L(K),K= 1141, 1254) /
     &6.0703D-01,5.7658D-01,5.4733D-01,5.3630D-01,4.9100D-01,4.4879D-01,
     &4.0920D-01,3.7138D-01,3.3521D-01,3.0054D-01,2.6721D-01,2.3523D-01,
     &2.0485D-01,1.7634D-01,1.4852D-01,0.0000D+00,1.6103D+02,1.4938D+02,
     &1.3848D+02,1.2798D+02,1.1818D+02,1.0840D+02,9.9309D+01,9.0651D+01,
     &8.2647D+01,7.4733D+01,6.7469D+01,6.0672D+01,5.4433D+01,5.0913D+01,
     &4.7343D+01,4.3482D+01,3.9833D+01,3.6452D+01,3.3242D+01,3.0689D+01,
     &2.8134D+01,2.5404D+01,2.2863D+01,2.0531D+01,1.8362D+01,1.6652D+01,
     &1.4967D+01,1.3197D+01,1.1573D+01,1.0120D+01,8.7877D+00,7.7679D+00,
     &6.7819D+00,5.7685D+00,4.8731D+00,4.0967D+00,3.4122D+00,2.9097D+00,
     &2.4451D+00,1.9953D+00,1.6222D+00,1.3995D+00,1.2076D+00,1.0771D+00,
     &9.6151D-01,8.7563D-01,8.0819D-01,7.5269D-01,7.0548D-01,6.6395D-01,
     &6.2666D-01,5.9253D-01,5.6034D-01,5.3005D-01,5.0122D-01,4.8790D-01,
     &4.4273D-01,4.0115D-01,3.6251D-01,3.2632D-01,2.9224D-01,2.5988D-01,
     &2.2931D-01,2.0039D-01,1.7324D-01,1.4805D-01,1.2201D-01,0.0000D+00,
     &1.8591D+02,1.7193D+02,1.5886D+02,1.4632D+02,1.3469D+02,1.2310D+02,
     &1.1237D+02,1.0218D+02,9.2839D+01,8.3643D+01,7.5256D+01,6.7382D+01,
     &6.0231D+01,5.6204D+01,5.2127D+01,4.7743D+01,4.3601D+01,3.9784D+01,
     &3.6172D+01,3.3310D+01,3.0455D+01,2.7410D+01,2.4579D+01,2.2009D+01,
     &1.9599D+01,1.7727D+01,1.5886D+01,1.3956D+01,1.2193D+01,1.0620D+01/
      DATA (XGF_L(K),K= 1255, 1368) /
     &9.1866D+00,8.0925D+00,7.0383D+00,5.9623D+00,5.0119D+00,4.1917D+00,
     &3.4750D+00,2.9503D+00,2.4663D+00,1.9999D+00,1.6141D+00,1.3840D+00,
     &1.1856D+00,1.0518D+00,9.3192D-01,8.4324D-01,7.7348D-01,7.1642D-01,
     &6.6779D-01,6.2531D-01,5.8732D-01,5.5231D-01,5.2039D-01,4.9037D-01,
     &4.6218D-01,4.4711D-01,4.0225D-01,3.6159D-01,3.2438D-01,2.8982D-01,
     &2.5765D-01,2.2765D-01,1.9954D-01,1.7331D-01,1.4889D-01,1.2621D-01,
     &9.6984D-02,0.0000D+00,2.1269D+02,1.9609D+02,1.8060D+02,1.6582D+02,
     &1.5214D+02,1.3863D+02,1.2613D+02,1.1431D+02,1.0351D+02,9.2957D+01,
     &8.3294D+01,7.4318D+01,6.6188D+01,6.1617D+01,5.7019D+01,5.2073D+01,
     &4.7428D+01,4.3153D+01,3.9122D+01,3.5941D+01,3.2764D+01,2.9404D+01,
     &2.6282D+01,2.3458D+01,2.0836D+01,1.8796D+01,1.6786D+01,1.4693D+01,
     &1.2792D+01,1.1101D+01,9.5678D+00,8.4010D+00,7.2773D+00,6.1402D+00,
     &5.1403D+00,4.2791D+00,3.5311D+00,2.9851D+00,2.4835D+00,2.0017D+00,
     &1.6039D+00,1.3677D+00,1.1646D+00,1.0265D+00,9.0375D-01,8.1271D-01,
     &7.4135D-01,6.8280D-01,6.3328D-01,5.9018D-01,5.5184D-01,5.1677D-01,
     &4.8494D-01,4.5537D-01,4.2797D-01,4.1146D-01,3.6736D-01,3.2788D-01,
     &2.9207D-01,2.5923D-01,2.2901D-01,2.0110D-01,1.7527D-01,1.5131D-01,
     &1.2926D-01,1.0839D-01,6.9776D-02,0.0000D+00,2.4043D+02,2.2104D+02,
     &2.0300D+02,1.8582D+02,1.7003D+02,1.5443D+02,1.4007D+02,1.2658D+02/
      DATA (XGF_L(K),K= 1369, 1482) /
     &1.1426D+02,1.0227D+02,9.1332D+01,8.1197D+01,7.2119D+01,6.6989D+01,
     &6.1846D+01,5.6342D+01,5.1188D+01,4.6448D+01,4.2002D+01,3.8498D+01,
     &3.5016D+01,3.1335D+01,2.7931D+01,2.4848D+01,2.2009D+01,1.9797D+01,
     &1.7637D+01,1.5389D+01,1.3354D+01,1.1550D+01,9.9187D+00,8.6824D+00,
     &7.4988D+00,6.3022D+00,5.2549D+00,4.3589D+00,3.5788D+00,3.0139D+00,
     &2.4962D+00,2.0005D+00,1.5931D+00,1.3514D+00,1.1435D+00,1.0028D+00,
     &8.7751D-01,7.8479D-01,7.1218D-01,6.5272D-01,6.0250D-01,5.5920D-01,
     &5.2061D-01,4.8590D-01,4.5422D-01,4.2519D-01,3.9858D-01,3.8094D-01,
     &3.3789D-01,2.9975D-01,2.6524D-01,2.3401D-01,2.0560D-01,1.7956D-01,
     &1.5565D-01,1.3374D-01,1.1354D-01,9.4096D-02,3.9275D-02,0.0000D+00,
     &2.8195D+02,2.5830D+02,2.3640D+02,2.1554D+02,1.9645D+02,1.7774D+02,
     &1.6058D+02,1.4448D+02,1.2990D+02,1.1575D+02,1.0299D+02,9.1121D+01,
     &8.0574D+01,7.4642D+01,6.8724D+01,6.2402D+01,5.6498D+01,5.1101D+01,
     &4.6042D+01,4.2081D+01,3.8152D+01,3.4014D+01,3.0201D+01,2.6780D+01,
     &2.3611D+01,2.1171D+01,1.8789D+01,1.6329D+01,1.4107D+01,1.2148D+01,
     &1.0386D+01,9.0557D+00,7.7874D+00,6.5118D+00,5.4006D+00,4.4539D+00,
     &3.6370D+00,3.0467D+00,2.5088D+00,1.9959D+00,1.5762D+00,1.3274D+00,
     &1.1142D+00,9.7065D-01,8.4265D-01,7.4825D-01,6.7451D-01,6.1445D-01,
     &5.6374D-01,5.2024D-01,4.8166D-01,4.4741D-01,4.1643D-01,3.8830D-01/
      DATA (XGF_L(K),K= 1483, 1596) /
     &3.6282D-01,3.4411D-01,3.0249D-01,2.6607D-01,2.3369D-01,2.0474D-01,
     &1.7852D-01,1.5489D-01,1.3341D-01,1.1384D-01,9.5862D-02,7.7509D-02,
     &0.0000D+00,0.0000D+00,3.2379D+02,2.9556D+02,2.6960D+02,2.4513D+02,
     &2.2265D+02,2.0073D+02,1.8071D+02,1.6202D+02,1.4515D+02,1.2887D+02,
     &1.1419D+02,1.0071D+02,8.8650D+01,8.1931D+01,7.5233D+01,6.8140D+01,
     &6.1510D+01,5.5467D+01,4.9832D+01,4.5419D+01,4.1070D+01,3.6493D+01,
     &3.2295D+01,2.8536D+01,2.5086D+01,2.2426D+01,1.9846D+01,1.7175D+01,
     &1.4781D+01,1.2681D+01,1.0797D+01,9.3831D+00,8.0380D+00,6.6897D+00,
     &5.5221D+00,4.5337D+00,3.6831D+00,3.0714D+00,2.5159D+00,1.9884D+00,
     &1.5586D+00,1.3048D+00,1.0886D+00,9.4191D-01,8.1217D-01,7.1679D-01,
     &6.4238D-01,5.8194D-01,5.3136D-01,4.8766D-01,4.4965D-01,4.1594D-01,
     &3.8570D-01,3.5847D-01,3.3403D-01,3.1456D-01,2.7454D-01,2.3977D-01,
     &2.0922D-01,1.8216D-01,1.5795D-01,1.3622D-01,1.1669D-01,9.9012D-02,
     &8.2668D-02,6.4604D-02,0.0000D+00,0.0000D+00,3.7071D+02,3.3727D+02,
     &3.0660D+02,2.7790D+02,2.5169D+02,2.2608D+02,2.0283D+02,1.8123D+02,
     &1.6179D+02,1.4311D+02,1.2635D+02,1.1097D+02,9.7357D+01,8.9759D+01,
     &8.2263D+01,7.4239D+01,6.6821D+01,6.0073D+01,5.3813D+01,4.8927D+01,
     &4.4114D+01,3.9072D+01,3.4471D+01,3.0351D+01,2.6592D+01,2.3699D+01,
     &2.0903D+01,1.8031D+01,1.5459D+01,1.3211D+01,1.1204D+01,9.7024D+00/
      DATA (XGF_L(K),K= 1597, 1710) /
     &8.2828D+00,6.8644D+00,5.6367D+00,4.6059D+00,3.7241D+00,3.0915D+00,
     &2.5189D+00,1.9786D+00,1.5396D+00,1.2816D+00,1.0611D+00,9.1306D-01,
     &7.8207D-01,6.8594D-01,6.1118D-01,5.5075D-01,5.0031D-01,4.5732D-01,
     &4.1996D-01,3.8671D-01,3.5732D-01,3.3101D-01,3.0775D-01,2.8769D-01,
     &2.4931D-01,2.1637D-01,1.8763D-01,1.6241D-01,1.4002D-01,1.2013D-01,
     &1.0238D-01,8.6311D-02,7.1348D-02,5.2982D-02,0.0000D+00,0.0000D+00,
     &4.2142D+02,3.8237D+02,3.4660D+02,3.1292D+02,2.8259D+02,2.5300D+02,
     &2.2626D+02,2.0148D+02,1.7927D+02,1.5797D+02,1.3896D+02,1.2163D+02,
     &1.0632D+02,9.7858D+01,8.9366D+01,8.0488D+01,7.2234D+01,6.4771D+01,
     &5.7843D+01,5.2468D+01,4.7182D+01,4.1663D+01,3.6633D+01,3.2165D+01,
     &2.8082D+01,2.4971D+01,2.1960D+01,1.8866D+01,1.6118D+01,1.3723D+01,
     &1.1595D+01,1.0008D+01,8.5101D+00,7.0232D+00,5.7443D+00,4.6705D+00,
     &3.7584D+00,3.1066D+00,2.5189D+00,1.9659D+00,1.5193D+00,1.2575D+00,
     &1.0346D+00,8.8517D-01,7.5338D-01,6.5695D-01,5.8219D-01,5.2200D-01,
     &4.7218D-01,4.2954D-01,3.9258D-01,3.6043D-01,3.3190D-01,3.0663D-01,
     &2.8431D-01,2.6413D-01,2.2746D-01,1.9612D-01,1.6912D-01,1.4557D-01,
     &1.2488D-01,1.0660D-01,9.0362D-02,7.5731D-02,6.1890D-02,4.2720D-02,
     &0.0000D+00,0.0000D+00,4.7166D+02,4.2676D+02,3.8580D+02,3.4749D+02,
     &3.1273D+02,2.7927D+02,2.4899D+02,2.2108D+02,1.9611D+02,1.7230D+02/
      DATA (XGF_L(K),K= 1711, 1824) /
     &1.5107D+02,1.3178D+02,1.1483D+02,1.0548D+02,9.6179D+01,8.6383D+01,
     &7.7331D+01,6.9156D+01,6.1613D+01,5.5763D+01,5.0019D+01,4.4056D+01,
     &3.8633D+01,3.3819D+01,2.9446D+01,2.6108D+01,2.2889D+01,1.9617D+01,
     &1.6706D+01,1.4179D+01,1.1938D+01,1.0276D+01,8.7112D+00,7.1630D+00,
     &5.8345D+00,4.7275D+00,3.7856D+00,3.1171D+00,2.5164D+00,1.9532D+00,
     &1.4997D+00,1.2350D+00,1.0108D+00,8.6027D-01,7.2804D-01,6.3166D-01,
     &5.5726D-01,4.9745D-01,4.4802D-01,4.0623D-01,3.7002D-01,3.3850D-01,
     &3.1081D-01,2.8644D-01,2.6509D-01,2.4476D-01,2.0951D-01,1.7979D-01,
     &1.5426D-01,1.3217D-01,1.1290D-01,9.5951D-02,8.0975D-02,6.7483D-02,
     &5.4483D-02,3.4309D-02,0.0000D+00,0.0000D+00,5.2745D+02,4.7595D+02,
     &4.2900D+02,3.8543D+02,3.4589D+02,3.0795D+02,2.7377D+02,2.4235D+02,
     &2.1434D+02,1.8771D+02,1.6408D+02,1.4266D+02,1.2392D+02,1.1358D+02,
     &1.0335D+02,9.2593D+01,8.2702D+01,7.3780D+01,6.5553D+01,5.9207D+01,
     &5.2983D+01,4.6535D+01,4.0700D+01,3.5531D+01,3.0842D+01,2.7278D+01,
     &2.3855D+01,2.0386D+01,1.7301D+01,1.4635D+01,1.2282D+01,1.0538D+01,
     &8.9065D+00,7.2932D+00,5.9178D+00,4.7769D+00,3.8086D+00,3.1240D+00,
     &2.5114D+00,1.9387D+00,1.4794D+00,1.2125D+00,9.8604D-01,8.3538D-01,
     &7.0309D-01,6.0683D-01,5.3289D-01,4.7378D-01,4.2493D-01,3.8387D-01,
     &3.4846D-01,3.1778D-01,2.9097D-01,2.6744D-01,2.4699D-01,2.2688D-01/
      DATA (XGF_L(K),K= 1825, 1836) /
     &1.9308D-01,1.6489D-01,1.4079D-01,1.2009D-01,1.0214D-01,8.6447D-02,
     &7.2603D-02,6.0131D-02,4.7893D-02,2.6613D-02,0.0000D+00,0.0000D+00/

*
      X = Xinp
*...CHECK OF X AND Q2 VALUES :
      IF ( (X.LT.0.99D-09) .OR. (X.GT.1.D+00) ) THEN
*        WRITE(LO,91) X
* 91     FORMAT (2X,'GRV98: x out of range',1p,E12.4)
         X = 0.99D-09
*        STOP
      ENDIF

      Q2 = Q2inp
      IF ( (Q2.LT.0.799D+00) .OR. (Q2.GT.1.D+06) ) THEN
*        WRITE(LO,92) Q2
* 92     FORMAT (2X,'GRV98: Q2 out of range',1p,E12.4)
         Q2 = 0.99D+06
*        STOP
      ENDIF

*
*...INTERPOLATION :
      NA(1) = NX
      NA(2) = NQ
      XT(1) = LOG(X)
      XT(2) = LOG(Q2)
      X1 = 1.D+00- X
      XV = X**0.5D+00
      XS = X**(-0.2D+00)
      UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
      DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
      DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
      UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
      US = 0.5 * (UD - DE)
      DS = 0.5 * (UD + DE)
      SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF)  * X1**7 * XS
      GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF)  * X1**5 * XS

      END


 
 


CDECK  ID>, PHO_DOR98SC
      SUBROUTINE PHO_DOR98SC (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
C***********************************************************************
C
C   GRV98 parton densities, leading order set
C
C                  For a detailed explanation see
C                   M. Glueck, E. Reya, A. Vogt :
C        hep-ph/9806404  =  DO-TH 98/07  =  WUE-ITP-98-019
C                  (To appear in Eur. Phys. J. C)
C
C   interpolation routine based on the original GRV98PA routine,
C   adapted to define interpolation table as DATA statements
C
C                                                   (R.Engel, 09/98)
C
C   CAUTION: this is a version with gluon shadowing corrections
C                                                   (R.Engel, 09/99)
C
C
C   INPUT:   X  =  Bjorken-x        (between  1.E-9 and 1.)
C            Q2 =  scale in GeV**2  (between  0.8 and 1.E6)
C
C   OUTPUT:  UV = u - u(bar),  DV = d - d(bar),  US = u(bar),
C            DS = d(bar),  SS = s = s(bar),  GL = gluon.
C            Always x times the distribution is returned.
C
C******************************************************i****************
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

      PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
      DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
     1          XSF(NX,NQ), XGF(NX,NQ),
     2          XT(NARG), NA(NARG), ARRF(NX+NQ)

      DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
     &  XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)

      EQUIVALENCE (XUVF(1,1),XUVF_L(1))
      EQUIVALENCE (XDVF(1,1),XDVF_L(1))
      EQUIVALENCE (XDEF(1,1),XDEF_L(1))
      EQUIVALENCE (XUDF(1,1),XUDF_L(1))
      EQUIVALENCE (XSF(1,1),XSF_L(1))
      EQUIVALENCE (XGF(1,1),XGF_L(1))

*#################### data statements for shadowed LO PDF ##############
C  ... deleted ...
*#######################################################################

      X = Xinp
*...CHECK OF X AND Q2 VALUES :
      IF ( (X.LT.0.99D-09) .OR. (X.GT.1.D+00) ) THEN
*        WRITE(LO,91) X
* 91     FORMAT (2X,'PHO_DOR98SC: x out of range',1p,E12.4)
         X = 0.99D-09
*        STOP
      ENDIF

      Q2 = Q2inp
      IF ( (Q2.LT.0.799D+00) .OR. (Q2.GT.1.D+06) ) THEN
*        WRITE(LO,92) Q2
* 92     FORMAT (2X,'PHO_DOR98SC: Q2 out of range',1p,E12.4)
         Q2 = 0.99D+06
*        STOP
      ENDIF

*
*...INTERPOLATION :
      NA(1) = NX
      NA(2) = NQ
      XT(1) = LOG(X)
      XT(2) = LOG(Q2)
      X1 = 1.D+00- X
      XV = X**0.5D+00
      XS = X**(-0.2D+00)
      UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
      DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
      DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
      UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
      US = 0.5 * (UD - DE)
      DS = 0.5 * (UD + DE)
      SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF)  * X1**7 * XS
      GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF)  * X1**5 * XS

      END


 
 


CDECK  ID>, PHO_DORFGP
      DOUBLE PRECISION FUNCTION PHO_DORFGP(X,S,AL,BE,AK,BK,AG,
     &                                    BG,C,D,E,ES)
      IMPLICIT DOUBLE PRECISION (A - Z)
      SAVE

       DX = SQRT (X)
       LX = LOG (1./X)
       PHO_DORFGP = (X**AK * (AG + BG*DX + C*X) * LX**BK + S**AL
     1       * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D

      END


 
 


CDECK  ID>, PHO_DORFQP
      DOUBLE PRECISION FUNCTION PHO_DORFQP(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
      IMPLICIT DOUBLE PRECISION (A - Z)
      SAVE

       DX = SQRT (X)
       LX = LOG (1./X)
       IF (S .LE. ST) THEN
          PHO_DORFQP = 0.0
       ELSE
          PHO_DORFQP = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
     1           * EXP (-E + SQRT (ES * S**BE * LX))

       END IF
      END


 
 


CDECK  ID>, PHO_DORFVP
      DOUBLE PRECISION FUNCTION PHO_DORFVP(X,N,AK,AG,D)
      IMPLICIT DOUBLE PRECISION (A - Z)
      SAVE

       DX = SQRT (X)
       PHO_DORFVP = N * X**AK * (1.+ AG*DX) * (1.- X)**D

      END


 
 


CDECK  ID>, PHO_DORGF
      DOUBLE PRECISION FUNCTION PHO_DORGF(X,S,AL,BE,AK,BK,
     &                                   AG,BG,C,D,E,ES)
      IMPLICIT DOUBLE PRECISION (A - Z)
      SAVE

       SX = SQRT (X)
       LX = LOG (1./X)
       PHO_DORGF  = (X**AK * (AG + BG * SX + C * X**BK)  +  S**AL
     1       * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D

      END


 
 


CDECK  ID>, PHO_DORGFS
      DOUBLE PRECISION FUNCTION PHO_DORGFS(X,S,SF,AL,BE,AK,BK,AG,BG,
     &                                     C,D,E,ES)
      IMPLICIT DOUBLE PRECISION (A - Z)
      SAVE

       IF (S .LE. SF) THEN
          PHO_DORGFS = 0.0
       ELSE
          SX = SQRT (X)
          LX = LOG (1./X)
          DS = S - SF
          PHO_DORGFS = (DS * X**AK * (AG + BG * SX + C * X**BK) + DS**AL
     1         * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D

       END IF
      END


 
 


CDECK  ID>, PHO_DORGH0
      SUBROUTINE PHO_DORGH0 (X, Q2, U0, D0, S0, C0, B0, G0)

      IMPLICIT DOUBLE PRECISION (A - Z)
      SAVE

       MU2  = 0.3
       LAM2 = 0.248 * 0.248
       S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
       SS = SQRT (S)
       S2 = S * S
C...X * U = X * UBAR :
       AL =  1.447
       BE =  0.848
       AK =  0.527 + 0.200 * S  - 0.107 * S2
       BK =  7.106 - 0.310 * SS - 0.786 * S2
       AG =  0.197 + 0.533 * S
       BG =  0.062 - 0.398 * S  + 0.109 * S2
       C  =          0.755 * S  - 0.112 * S2
       D  =  0.318 - 0.059 * S
       E  =  4.225 + 1.708 * S
       ES =  1.752 + 0.866 * S
       U0 =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
C...X * D = X * DBAR :
       AL =  1.424
       BE =  0.770
       AK =  0.500 + 0.067 * SS - 0.055 * S2
       BK =  0.376 - 0.453 * SS + 0.405 * S2
       AG =  0.156 + 0.184 * S
       BG =   0.0  - 0.528 * S  + 0.146 * S2
       C  =  0.121 + 0.092 * S
       D  =  0.379 - 0.301 * S  + 0.081 * S2
       E  =  4.346 + 1.638 * S
       ES =  1.645 + 1.016 * S
       D0  =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
C...X * G :
       AL =  0.661
       BE =  0.793
       AK =  0.537 - 0.600 * SS
       BK =  6.389              - 0.953 * S2
       AG =  0.558 - 0.383 * SS + 0.261 * S2
       BG =   0.0  - 0.305 * S
       C  = -0.222              + 0.078 * S2
       D  =  0.153 + 0.978 * S  - 0.209 * S2
       E  =  1.429 + 1.772 * S
       ES =  3.331 + 0.806 * S
       G0 =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
C...X * S = X * SBAR :
       SF =   0.0
       AL =  1.578
       BE =  0.863
       AK =  0.622 + 0.332 * S  - 0.300 * S2
       BK =  2.469
       AG =  0.211 - 0.064 * SS - 0.018 * S2
       BG = -0.215 + 0.122 * S
       C  =  0.153
       D  =   0.0  + 0.253 * S  - 0.081 * S2
       E  =  3.990 + 2.014 * S
       ES =  1.720 + 0.986 * S
       S0 =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
C...X * C = X * CBAR :
       SF =  0.820
       AL =  0.929
       BE =  0.381
       AK =  1.228 - 0.231 * S
       BK =  3.806             - 0.337 * S2
       AG =  0.932 + 0.150 * S
       BG = -0.906
       C  =  1.133
       D  =   0.0  + 0.138 * S  - 0.028 * S2
       E  =  5.588 + 0.628 * S
       ES =  2.665 + 1.054 * S
       C0 =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
C...X * B = X * BBAR :
       SF =  1.297
       AL =  0.970
       BE =  0.207
       AK =  1.719 - 0.292 * S
       BK =  0.928 + 0.096 * S
       AG =  0.845 + 0.178 * S
       BG = -2.310
       C  =  1.558
       D  = -0.191 + 0.151 * S
       E  =  6.089 + 0.282 * S
       ES =  3.379 + 1.062 * S
       B0 =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)

      END


 
 


CDECK  ID>, PHO_DORGHO
      SUBROUTINE PHO_DORGHO (X, Q2, UH, DH, SH, CH, BH, GH)

      IMPLICIT DOUBLE PRECISION (A - Z)
      SAVE

       MU2  = 0.3
       LAM2 = 0.248 * 0.248
       S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
       SS = SQRT (S)
       S2 = S * S
C...X * U = X * UBAR :
       AL =  0.583
       BE =  0.688
       AK =  0.449 - 0.025 * S  - 0.071 * S2
       BK =  5.060 - 1.116 * SS
       AG =  0.103
       BG =  0.319 + 0.422 * S
       C  =  1.508 + 4.792 * S  - 1.963 * S2
       D  =  1.075 + 0.222 * SS - 0.193 * S2
       E  =  4.147 + 1.131 * S
       ES =  1.661 + 0.874 * S
       UH =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
C...X * D = X * DBAR :
       AL =  0.591
       BE =  0.698
       AK =  0.442 - 0.132 * S  - 0.058 * S2
       BK =  5.437 - 1.916 * SS
       AG =  0.099
       BG =  0.311 - 0.059 * S
       C  =  0.800 + 0.078 * S  - 0.100 * S2
       D  =  0.862 + 0.294 * SS - 0.184 * S2
       E  =  4.202 + 1.352 * S
       ES =  1.841 + 0.990 * S
       DH  =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
C...X * G :
       AL =  1.161
       BE =  1.591
       AK =  0.530 - 0.742 * SS + 0.025 * S2
       BK =  5.662
       AG =  0.533 - 0.281 * SS + 0.218 * S2
       BG =  0.025 - 0.518 * S  + 0.156 * S2
       C  = -0.282              + 0.209 * S2
       D  =  0.107 + 1.058 * S  - 0.218 * S2
       E  =   0.0  + 2.704 * S
       ES =  3.071 - 0.378 * S
       GH =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
C...X * S = X * SBAR :
       SF =   0.0
       AL =  0.635
       BE =  0.456
       AK =  1.770 - 0.735 * SS - 0.079 * S2
       BK =  3.832
       AG =  0.084 - 0.023 * S
       BG =  0.136
       C  =  2.119 - 0.942 * S  + 0.063 * S2
       D  =  1.271 + 0.076 * S  - 0.190 * S2
       E  =  4.604 + 0.737 * S
       ES =  1.641 + 0.976 * S
       SH =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
C...X * C = X * CBAR :
       SF =  0.820
       AL =  0.926
       BE =  0.152
       AK =  1.142 - 0.175 * S
       BK =  3.276
       AG =  0.504 + 0.317 * S
       BG = -0.433
       C  =  3.334
       D  =  0.398 + 0.326 * S  - 0.107 * S2
       E  =  5.493 + 0.408 * S
       ES =  2.426 + 1.277 * S
       CH =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
C...X * B = X * BBAR :
       SF =  1.297
       AL =  0.969
       BE =  0.266
       AK =  1.953 - 0.391 * S
       BK =  1.657 - 0.161 * S
       AG =  1.076 + 0.034 * S
       BG = -2.015
       C  =  1.662
       D  =  0.353 + 0.016 * S
       E  =  5.713 + 0.249 * S
       ES =  3.456 + 0.673 * S
       BH =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)

      END


 
 


CDECK  ID>, PHO_DORGLO
      SUBROUTINE PHO_DORGLO (X, Q2, UL, DL, SL, CL, BL, GL)
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*                                                                 *
*      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      *
*                                                                 *
*                 FOR A DETAILED EXPLANATION SEE :                *
*              M. GLUECK, E.REYA, A.VOGT: DO-TH 91/31             *
*                                                                 *
*    THE OUTPUT IS ALWAYS   1./ ALPHA(EM) * X * PARTON DENSITY    *
*                                                                 *
*   THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS   *
*   FOR Q ** 2 BETWEEN MU ** 2 (=  0.25 / 0.30  GEV ** 2  IN LO   *
*   / HO) AND  1.E6 GEV ** 2  AND FOR X BETWEEN  1.E-5  AND  1.   *
*                                                                 *
*              HEAVY QUARK THRESHOLDS  Q(H) = M(H) :              *
*         M(C)  =  1.5,  M(B)  =  4.5,  M(T)  =  100  GEV         *
*                                                                 *
*      CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS :     *
*      LO :   LAMBDA(3)  =  0.232,   LAMBDA(4)  =  0.200,         *
*             LAMBDA(5)  =  0.153,   LAMBDA(6)  =  0.082  GEV     *
*      HO :   LAMBDA(3)  =  0.248,   LAMBDA(4)  =  0.200,         *
*             LAMBDA(5)  =  0.131,   LAMBDA(6)  =  0.053  GEV     *
*                                                                 *
*      HO DISTRIBUTIONS REFER TO THE DIS(GAMMA) SCHEME, SEE :     *
*              M. GLUECK, E.REYA, A.VOGT: DO-TH 91/26             *
*                                                                 *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

      IMPLICIT DOUBLE PRECISION (A - Z)
      SAVE

       MU2  = 0.25
       LAM2 = 0.232 * 0.232
       S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
       SS = SQRT (S)
       S2 = S * S
C...X * U = X * UBAR :
       AL =  1.717
       BE =  0.641
       AK =  0.500 - 0.176 * S
       BK = 15.00  - 5.687 * SS - 0.552 * S2
       AG =  0.235 + 0.046 * SS
       BG =  0.082 - 0.051 * S  + 0.168 * S2
       C  =   0.0  + 0.459 * S
       D  =  0.354 - 0.061 * S
       E  =  4.899 + 1.678 * S
       ES =  2.046 + 1.389 * S
       UL =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
C...X * D = X * DBAR :
       AL =  1.549
       BE =  0.782
       AK =  0.496 + 0.026 * S
       BK =  0.685 - 0.580 * SS + 0.608 * S2
       AG =  0.233 + 0.302 * S
       BG =   0.0  - 0.818 * S  + 0.198 * S2
       C  =  0.114 + 0.154 * S
       D  =  0.405 - 0.195 * S  + 0.046 * S2
       E  =  4.807 + 1.226 * S
       ES =  2.166 + 0.664 * S
       DL  =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
C...X * G :
       AL =  0.676
       BE =  1.089
       AK =  0.462 - 0.524 * SS
       BK =  5.451              - 0.804 * S2
       AG =  0.535 - 0.504 * SS + 0.288 * S2
       BG =  0.364 - 0.520 * S
       C  = -0.323              + 0.115 * S2
       D  =  0.233 + 0.790 * S  - 0.139 * S2
       E  =  0.893 + 1.968 * S
       ES =  3.432 + 0.392 * S
       GL =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
C...X * S = X * SBAR :
       SF =   0.0
       AL =  1.609
       BE =  0.962
       AK =  0.470              - 0.099 * S2
       BK =  3.246
       AG =  0.121 - 0.068 * SS
       BG = -0.090 + 0.074 * S
       C  =  0.062 + 0.034 * S
       D  =   0.0  + 0.226 * S  - 0.060 * S2
       E  =  4.288 + 1.707 * S
       ES =  2.122 + 0.656 * S
       SL =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
C...X * C = X * CBAR :
       SF =  0.888
       AL =  0.970
       BE =  0.545
       AK =  1.254 - 0.251 * S
       BK =  3.932              - 0.327 * S2
       AG =  0.658 + 0.202 * S
       BG = -0.699
       C  =  0.965
       D  =   0.0  + 0.141 * S  - 0.027 * S2
       E  =  4.911 + 0.969 * S
       ES =  2.796 + 0.952 * S
       CL =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
C...X * B = X * BBAR :
       SF =  1.351
       AL =  1.016
       BE =  0.338
       AK =  1.961 - 0.370 * S
       BK =  0.923 + 0.119 * S
       AG =  0.815 + 0.207 * S
       BG = -2.275
       C  =  1.480
       D  = -0.223 + 0.173 * S
       E  =  5.426 + 0.623 * S
       ES =  3.819 + 0.901 * S
       BL =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)

       END


 
 


CDECK  ID>, PHO_DORGLV
*     subroutine grspar(x,q2,p2,ugam,dgam,sgam,ggam)
      SUBROUTINE PHO_DORGLV(x,q2,p2,ugam,dgam,sgam,ggam)
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*                                                                 *
*           G R S - LO - VIRTUAL PHOTON PARAMETRIZATIONS          *
*                                                                 *
*                 FOR A DETAILED EXPLANATION SEE                  *
*                M. GLUECK, E.REYA, M. STRATMANN :                *
*                    PHYS. REV. D51 (1995) 3220                   *
*                                                                 *
*   THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR    *
*        Q**2 / GEV**2  BETWEEN   0.6   AND  5.E4                 *
*                       AND (!)  Q**2 > 5 P**2                    *
*        P**2 / GEV**2  BETWEEN   0.0   AND  10.                  *
*                       P**2 = 0  <=> REAL PHOTON                 *
*             X         BETWEEN  1.E-4  AND   1.                  *
*                                                                 *
*   HEAVY QUARK THRESHOLDS  Q(H) = M(H)  IN THE BETA FUNCTION :   *
*                   M(C)  =  1.5,  M(B)  =  4.5                   *
*   CORRESPONDING LAMBDA(F) VALUES IN GEV FOR  Q**2 > M(H)**2 :   *
*      LO :   LAMBDA(3)  =  0.232,   LAMBDA(4)  =  0.200,         *
*             LAMBDA(5)  =  0.153,                                *
*   THE NUMBER OF ACTIVE QUARK FLAVOURS IS  NF = 3  EVERYWHERE    *
*   EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,...    *
*   ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION.               *
*                                                                 *
*   PLEASE REPORT ANY STRANGE BEHAVIOUR TO :                      *
*                  Marco.Stratmann@durham.ac.uk                   *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*
*...INPUT PARAMETERS :
*
*    X   = MOMENTUM FRACTION
*    Q2  = SCALE Q**2 IN GEV**2
*    P2  = VIRTUALITY OF THE PHOTON IN GEV**2
*
*...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION DIVIDED BY ALPHA_EM) :
*
*******************************************************************

      IMPLICIT DOUBLE PRECISION (a-z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

      INTEGER check
c
c     check limits :
c
      check=0
      if(x.lt.0.0001d0) check=1
      if((q2.lt.0.6d0).or.(q2.gt.50000.d0))  check=1
      if(q2.lt.5.d0*p2) check=1
c
c     calculate distributions
c
      if(check.eq.0) then
         CALL PHO_GRSCALC(x,q2,p2,ugam,dgam,sgam,ggam)
      else
         IF (LPRI.GT.4)
     &   WRITE(LO,*) 'PHO_DORGLV parametrization: ',
     &               'x/q2/p2 limits exceeded'
         IF (LPRI.GT.4)
     &   WRITE(LO,'(1X,A,1P,3E12.3)') 'current X, Q2, P2:',x,q2,p2
      endif

      end


 
 


CDECK  ID>, PHO_DORPHO
      SUBROUTINE PHO_DORPHO (X, Q2, VAP, GLP, QBP, CBP, BBP)

      IMPLICIT DOUBLE PRECISION (A - Z)
      SAVE

       MU2  = 0.3
       LAM2 = 0.248 * 0.248
       S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
       DS = SQRT (S)
       S2 = S * S
C...X * VALENCE :
       NV  =  0.456 + 0.150 * DS + 0.112 * S - 0.019 * S2
       AKV =  0.505 - 0.033 * S
       AGV =  0.748 - 0.669 * DS - 0.133 * S
       DV  =  0.365 + 0.197 * DS + 0.394 * S
       VAP =  PHO_DORFVP (X, NV, AKV, AGV, DV)
C...X * GLUON :
       ALG =  1.096
       BEG =  1.371
       AKG =  0.437 - 0.689 * DS
       BKG = -0.631
       AGG =  1.324 - 0.441 * DS - 0.130 * S
       BGG = -0.955 + 0.259 * S
       CG  =  1.075 - 0.302 * S
       DG  =  1.158 + 1.229 * S
       EG  =   0.0  + 2.510 * S
       ESG =  2.604 + 0.165 * S
       GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
C...X * QBAR (SU(3)-SYMMETRIC SEA) :
       SL  =   0.0
       ALS =   0.85
       BES =   0.96
       AKS = -0.350 + 0.806 * S
       AGS = -1.663
       BS  =  3.148
       DS  =  2.273 + 1.438 * S
       EST =  3.214 + 1.545 * S
       ESS =  1.341 + 1.938 * S
       QBP =  PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
C...X * CBAR = X * C :
       SC  =  0.820
       ALC =   0.98
       BEC =   0.0
       AKC =   0.0  - 0.457 * S
       AGC =   0.0
       BC  =  -1.00 +  1.40 * S
       DC  =  1.318 + 0.584 * S
       EC  =   4.45 + 1.235 * S
       ESC =  1.496 + 1.010 * S
       CBP =  PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
C...X * BBAR = X * B :
       SBO =  1.297
       ALB =   0.99
       BEB =   0.0
       AKB =   0.0  - 0.172 * S
       AGB =   0.0
       BBO =   0.0
       DB  =  1.447 + 0.485 * S
       EB  =   4.79 + 1.164 * S
       ESB =  1.724 + 2.121 * S
       BBP =  PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)

      END


 
 


CDECK  ID>, PHO_DORPLO
*
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*                                                                 *
*         G R V - P I O N - P A R A M E T R I Z A T I O N S       *
*                                                                 *
*                 FOR A DETAILED EXPLANATION SEE :                *
*              M. GLUECK, E.REYA, A.VOGT: DO-TH 91/16             *
*                                                                 *
*   THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS   *
*   FOR Q ** 2 BETWEEN MU ** 2 (=  0.25 / 0.30  GEV ** 2  IN LO   *
*   / HO) AND  1.E8 GEV ** 2  AND FOR X BETWEEN  1.E-5  AND  1.   *
*   REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG-   *
*   LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT.  *
*                                                                 *
*              HEAVY QUARK THRESHOLDS  Q(H) = M(H) :              *
*         M(C)  =  1.5,  M(B)  =  4.5,  M(T)  =  100  GEV         *
*                                                                 *
*      CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS :     *
*      LO :   LAMBDA(3)  =  0.232,   LAMBDA(4)  =  0.200,         *
*             LAMBDA(5)  =  0.153,   LAMBDA(6)  =  0.082  GEV     *
*      HO :   LAMBDA(3)  =  0.248,   LAMBDA(4)  =  0.200,         *
*             LAMBDA(5)  =  0.131,   LAMBDA(6)  =  0.053  GEV     *
*                                                                 *
*   HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL.  *
*                                                                 *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
      SUBROUTINE PHO_DORPLO (X, Q2, VAP, GLP, QBP, CBP, BBP)

      IMPLICIT DOUBLE PRECISION (A - Z)
      SAVE

       MU2  = 0.25
       LAM2 = 0.232 * 0.232
       S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
       DS = SQRT (S)
       S2 = S * S
C...X * VALENCE :
       NV  =  0.519 + 0.180 * S - 0.011 * S2
       AKV =  0.499 - 0.027 * S
       AGV =  0.381 - 0.419 * S
       DV  =  0.367 + 0.563 * S
       VAP =  PHO_DORFVP (X, NV, AKV, AGV, DV)
C...X * GLUON :
       ALG =  0.599
       BEG =  1.263
       AKG =  0.482 + 0.341 * DS
       BKG =   0.0
       AGG =  0.678 + 0.877 * S  - 0.175 * S2
       BGG =  0.338 - 1.597 * S
       CG  =   0.0  - 0.233 * S  + 0.406 * S2
       DG  =  0.390 + 1.053 * S
       EG  =  0.618 + 2.070 * S
       ESG =  3.676
       GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
C...X * QBAR (SU(3)-SYMMETRIC SEA) :
       SL  =   0.0
       ALS =   0.55
       BES =   0.56
       AKS =  2.538 - 0.763 * S
       AGS = -0.748
       BS  =  0.313 + 0.935 * S
       DS  =  3.359
       EST =  4.433 + 1.301 * S
       ESS =   9.30 - 0.887 * S
       QBP =  PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
C...X * CBAR = X * C :
       SC  =  0.888
       ALC =   1.02
       BEC =   0.39
       AKC =   0.0
       AGC =   0.0
       BC  =  1.008
       DC  =  1.208 + 0.771 * S
       EC  =   4.40 + 1.493 * S
       ESC =  2.032 + 1.901 * S
       CBP =  PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
C...X * BBAR = X * B :
       SBO =  1.351
       ALB =   1.03
       BEB =   0.39
       AKB =   0.0
       AGB =   0.0
       BBO =   0.0
       DB  =  0.697 + 0.855 * S
       EB  =   4.51 + 1.490 * S
       ESB =  3.056 + 1.694 * S
       BBP =  PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)

       END


 
 


CDECK  ID>, PHO_DQMASS
      SUBROUTINE PHO_DQMASS(I,J,K,L,AM82,AM102)
C**********************************************************************
C
C     determine minimal masses corresponding to the input flavours
C     (diquark a-diquark string system)
C
C     input: I,J,K,L   quark flavours (PDG convention)
C
C     output: AM82     mass of two octett baryons
C             AM102    mass of two decuplett baryons
C
C**********************************************************************

      IMPLICIT NONE

      SAVE

      INTEGER I,J,K,L
      DOUBLE PRECISION AM82,AM102

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  general particle data
      DOUBLE PRECISION xm_list,tau_list,gam_list,
     &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
     &  xm_bb82_list,xm_bb102_list
      INTEGER          ich3_list,iba3_list,iq_list,
     &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
      COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
     &  xm_psm2_list(6,6),xm_vem2_list(6,6),
     &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
     &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
     &  ich3_list(300),iba3_list(300),iq_list(3,300),
     &  id_psm_list(6,6),id_vem_list(6,6),
     &  id_b8_list(6,6,6),id_b10_list(6,6,6)

C  local variables
      INTEGER ii,jj,kk,ll

      ii = abs(i)
      kk = abs(k)
      jj = abs(j)
      ll = abs(l)

      AM82  = xm_bb82_list(ii,jj,kk,ll)
      AM102 = xm_bb102_list(ii,jj,kk,ll)

      END


 
 


CDECK  ID>, PHO_DSIGDM
      SUBROUTINE PHO_DSIGDM(RMA,XMA,NSTEP)
C**********************************************************************
C
C     differential cross section DSIG/DM of low mass enhancement
C
C     input:   RMA(4,NTABM)   mass values
C     output:  XMA(4,NTABM)   DSIG/DM of resonances
C                  1          rho production
C                  2          omega production
C                  3          phi production
C                  4          pi-pi continuum
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( EPS  = 1.D-10 )

      PARAMETER(NTABM=50)
      DIMENSION XMA(4,NTABM),RMA(4,NTABM)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  parameters of the "simple" Vector Dominance Model
      DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
      COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)


      PIMASS = 0.135
C  rho meson shape (mass dependent width)
      QRES = SQRT(VMAS(1)**2 - 4.D0*PIMASS**2)
      DO 100 I=1,NSTEP
        XMASS = RMA(1,I)
        QQ = SQRT(XMASS**2 - 4.D0*PIMASS**2)
        GAMMA = GAMM(1)*(QQ/QRES)**3
        XMA(1,I) = XMASS*GAMMA*(VMAS(1)/XMASS)**PARMDL(170)
     &             /((VMAS(1)**2-XMASS**2)**2+VMAS(1)**2*GAMMA**2)
 100  CONTINUE
C  omega/phi meson (constant width)
      DO 200 K=2,3
        DO 300 I=1,NSTEP
          XMASS = RMA(K,I)
          XMA(K,I) = XMASS*GAMM(K)
     &               /((VMAS(K)**2-XMASS**2)**2+VMAS(K)**2*GAMM(K)**2)
 300    CONTINUE
 200  CONTINUE
C  pi-pi continuum
      DO 400 I=1,NSTEP
        XMASS = RMA(4,I)
        XMA(4,I) = (XMASS-0.29D0)**2/XMASS
 400  CONTINUE

      END


 
 


CDECK  ID>, PHO_DSIGDT
      SUBROUTINE PHO_DSIGDT(EE,XTA,NFILL)
C*********************************************************************
C
C     calculation of unitarized amplitude
C                    and differential cross section
C
C     input:   EE       cm energy (GeV)
C              XTA(1,*) t values (GeV**2)
C              NFILL    entries in t table
C
C     output:  XTA(2,*)  DSIG/DT  g p --> g h/V (mub/GeV**2)
C              XTA(3,*)  DSIG/DT  g p --> rho0 h/V
C              XTA(4,*)  DSIG/DT  g p --> omega0 h/V
C              XTA(5,*)  DSIG/DT  g p --> phi h/V
C              XTA(6,*)  DSIG/DT  g p --> pi+ pi- h/V (continuum)
C
C*********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER(ITWO=2,
     &        ITHREE=3,
     &         THOUS=1.D3,
     &          DEPS=1.D-20)

      DIMENSION XTA(6,NFILL)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

C  integration precision for hard cross sections (obsolete)
      INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
      COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  global event kinematics and particle IDs
      INTEGER IFPAP,IFPAB
      DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
      COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)

C  complex Born graph amplitudes used for unitarization
      COMPLEX*16      AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
     &                AMHMDD,AMPDP
      COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
     &                AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)

      COMPLEX*16   XT,AMP,CZERO
      DIMENSION    AMP(5),XPNT(96),WGHT(96),XT(5,100)
      CHARACTER*12 FNA


      CZERO=DCMPLX(0.D0,0.D0)

      ETMP = ECM
      ECM  = EE

      IF(NFILL.GT.100) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I4)')
     &    'PHO_DSIGDT:ERROR: too many entries in table',NFILL
        STOP
      ENDIF
C
      DO 100 K=1,NFILL
        DO 150 L=1,5
          XT(L,K)=CZERO
 150    CONTINUE
 100  CONTINUE
C
C  impact parameter integration
C     BMAX=12.D0*SQRT(MAX(BPOM,BREG))
      BMAX=10.D0
      CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
      IAMP = 5
      IF((IFPAP(1).EQ.22).AND.(IFPAP(2).NE.22)) THEN
        I1 = 1
        I2 = 0
      ELSE IF((IFPAP(1).NE.22).AND.(IFPAP(2).EQ.22)) THEN
        I1 = 0
        I2 = 1
      ELSE IF((IFPAP(1).EQ.22).AND.(IFPAP(2).EQ.22)) THEN
        I1 = 1
        I2 = 1
      ELSE
        I1 = 0
        I2 = 0
        IAMP = 1
      ENDIF
      J1 = I1*2
      K1 = I1*3
      L1 = I1*4
      J2 = I2*2
      K2 = I2*3
      L2 = I2*4
C
      DO 200 I=1,NGAUSO
        WG=WGHT(I)*XPNT(I)
C  calculate amplitudes
        IF(I.EQ.1) THEN
          CALL PHO_EIKON(1,-1,XPNT(I))
        ELSE
          CALL PHO_EIKON(1,1,XPNT(I))
        ENDIF
        AMP(1) = AMPEL
        AMP(2) = AMPVM(I1,I2)
        AMP(3) = AMPVM(J1,J2)
        AMP(4) = AMPVM(K1,K2)
        AMP(5) = AMPVM(L1,L2)
C
        DO 400 J=1,NFILL
          XX=XPNT(I)*SQRT(XTA(1,J)/GEV2MB)
          FAC = PHO_BESSJ0(XX)*WG
          DO 500 K=1,IAMP
            XT(1,J)=XT(1,J)+AMP(K)*FAC
 500      CONTINUE
 400    CONTINUE
 200  CONTINUE
C
C  change units to mb/GeV**2
      FAC = 4.D0*PI/GEV2MB
      FNA = '(mb/GeV**2) '
      IF(I1+I2.EQ.1) THEN
        FAC = FAC*THOUS
        FNA = '(mub/GeV**2)'
      ELSE IF(I1+I2.EQ.2) THEN
        FAC = FAC*THOUS*THOUS
        FNA = '(nb/GeV**2) '
      ENDIF
      IF(IDEB(56).GE.5) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,A12,/1X,A)') 'table:  -T (GeV**2)   DSIG/DT ',
     &    FNA,'------------------------------------------'
      ENDIF
      DO 600 J=1,NFILL
        DO 700 K=1,IAMP
          XTA(K+1,J)=ABS(XT(K,J))**2*FAC
 700    CONTINUE
        IF(IDEB(56).GE.5) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,6E12.3)') (XTA(I,J),I=1,IAMP+1)
        ENDIF
 600  CONTINUE

      ECM = ETMP
      END


 
 


CDECK  ID>, PHO_DZEROX
      DOUBLE PRECISION FUNCTION PHO_DZEROX(A0,B0,EPS,MAXF,F,MODE)
C**********************************************************************
C
C     Based on
C
C        J.C.P. Bus and T.J. Dekker, Two Efficient Algorithms with
C        Guaranteed Convergence for Finding a Zero of a Function,
C        ACM Trans. Math. Software 1 (1975) 330-345.
C
C        (MODE = 1: Algorithm M;    MODE = 2: Algorithm R)
C
C        CERNLIB C200
C
C***********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

      CHARACTER NAME*(*)
      PARAMETER (NAME = 'PHO_DZEROX')
      LOGICAL LMT
      DIMENSION IM1(2),IM2(2),LMT(2)
      EXTERNAL F

      PARAMETER (Z1 = 1, HALF = Z1/2)

      DATA IM1 /2,3/, IM2 /-1,3/

      IF(MODE .NE. 1 .AND. MODE .NE. 2) THEN
       C=-2D+10
       IF (LPRI.GT.4)
     . WRITE(LO,100) NAME,MODE
       GO TO 99
      ENDIF
      FA=F(B0)
      FB=F(A0)
      IF(FA*FB .GT. 0) THEN
       C=-3D+10
       IF (LPRI.GT.4)
     & WRITE(LO,101) NAME
       GO TO 99
      ENDIF
      ATL=ABS(EPS)
      B=A0
      A=B0
      LMT(2)=.TRUE.
      MF=2
    1 C=A
      FC=FA
    2 IE=0
    3 IF(ABS(FC) .LT. ABS(FB)) THEN
       IF(C .NE. A) THEN
        D=A
        FD=FA
       END IF
       A=B
       B=C
       C=A
       FA=FB
       FB=FC
       FC=FA
      END IF
      TOL=ATL*(1+ABS(C))
      H=HALF*(C+B)
      HB=H-B
      IF(ABS(HB) .GT. TOL) THEN
       IF(IE .GT. IM1(MODE)) THEN
        W=HB
       ELSE
        TOL=TOL*SIGN(Z1,HB)
        P=(B-A)*FB
        LMT(1)=IE .LE. 1
        IF(LMT(MODE)) THEN
         Q=FA-FB
         LMT(2)=.FALSE.
        ELSE
         FDB=(FD-FB)/(D-B)
         FDA=(FD-FA)/(D-A)
         P=FDA*P
         Q=FDB*FA-FDA*FB
        END IF
        IF(P .LT. 0) THEN
         P=-P
         Q=-Q
        END IF
        IF(IE .EQ. IM2(MODE)) P=P+P
        IF(P .EQ. 0 .OR. P .LE. Q*TOL) THEN
         W=TOL
        ELSEIF(P .LT. HB*Q) THEN
         W=P/Q
        ELSE
         W=HB
        END IF
       END IF
       D=A
       A=B
       FD=FA
       FA=FB
       B=B+W
       MF=MF+1
       IF(MF .GT. MAXF) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,102) NAME
        GO TO 99
       ENDIF
       FB=F(B)
       IF(FB .EQ. 0 .OR. SIGN(Z1,FC) .EQ. SIGN(Z1,FB)) GO TO 1
       IF(W .EQ. HB) GO TO 2
       IE=IE+1
       GO TO 3
      END IF
   99 CONTINUE
      PHO_DZEROX=C
      RETURN
  100 FORMAT(1X,A,': mode = ',I3,' illegal')
  101 FORMAT(1X,A,': F(A) and F(B) have the same sign')
  102 FORMAT(1X,A,': too many function calls')

      END


 
 


CDECK  ID>, PHO_EIKON
      SUBROUTINE PHO_EIKON(IP,IFHARD,B)
C*********************************************************************
C
C     calculation of unitarized amplitudes
C
C     input: IP               particle combination
C            IFHARD           -1  ignore previously calculated Born
C                                 cross sections
C                             0   calculate hard Born cross sections or
C                                 take them from interpolation table
C                                 (if available)
C                             1   take hard cross sections from /POSBRN/
C            B                impact parameter (mb**(1/2))
C                   /POSBRN/  input cross sections
C                   /GLOCMS/  cm energy
C                   /POPREG/  soft and hard parameters
C
C     output: /POINT4/
C             AMPEL           purely elastic amplitude
C             AMPVM           quasi-elastically vectormeson prod.
C             AMLMSD(2)       amplitudes of low mass sing. diffr.
C             AMHMSD(2)       amplitudes of high mass sing. diffr.
C             AMLMDD          amplitude of low mass double diffr.
C             AMHMDD          amplitude of high mass double diffr.
C
C*********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER(ITWO=2,
     &        ITHREE=3,
     &         IFOUR=4,
     &         IFIVE=5,
     &          ISIX=6,
     &          FIVE=5.D0,
     &         THOUS=1.D3,
     &        EXPMAX=70.D0,
     &          DEPS=1.D-20)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  current beam selection
      INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN
      INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL
      DOUBLE PRECISION SQSGLOBMAX
      PARAMETER (MPARMAX=40)
      PARAMETER (MAXMAPPS=40)
      PARAMETER (IKNOWN=9)
      DIMENSION IPAVAIL(IKNOWN)
      DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/
      COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS),
     &           MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP

C  complex Born graph amplitudes used for unitarization
      COMPLEX*16      AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
     &                AMHMDD,AMPDP
      COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
     &                AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)

C  cross sections
      INTEGER IPFIL,IFAFIL,IFBFIL
      DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
     &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
     &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
     &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
     &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
      COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
     &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
     &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
     &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
     &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
     &                IPFIL,IFAFIL,IFBFIL

C  Born graph cross sections and slopes
      INTEGER Max_pro_3
      PARAMETER ( Max_pro_3 = 16 )
      COMPLEX*16      SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
     &                SIGD1,SIGD2,DSIGH
      COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
     &                SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)

C  scaled cross sections and slopes
      COMPLEX*16      ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1,ZIGT2,ZIGL,ZIGDP,
     &                ZIGD1,ZIGD2,
     &                BPOM,BREG,BHAR,BHAD,BTR1,BTR2,BLOO,BDP,BD1,BD2
      COMMON /POZBRN/ ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1(2),ZIGT2(2),ZIGL,
     &                ZIGDP(4),ZIGD1(2),ZIGD2(2),
     &                BPOM,BREG,BHAR,BHAD,BTR1(2),BTR2(2),BLOO,BDP(4),
     &                BD1(2),BD2(2)

C  Born graph cross sections after applying diffraction model
      DOUBLE PRECISION SBOPOM,SBOREG,SBOHAR,SBOHAD,SBOTR1,SBOTR2,
     &                 SBOLPO,SBODPO
      COMMON /POINT1/ SBOPOM(0:4),SBOREG(0:4),SBOHAR(0:4),SBOHAD(0:4),
     &                SBOTR1(0:4,2),SBOTR2(0:4,2),SBOLPO(0:4),
     &                SBODPO(0:4,4)

C  global event kinematics and particle IDs
      INTEGER IFPAP,IFPAB
      DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
      COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)

C  data of c.m. system of Pomeron / Reggeon exchange
      INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
      DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
     &                 SIDP,CODP,SIFP,COFP
      COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
     &                SIDP,CODP,SIFP,COFP,NPOSP(2),
     &                IDPDG1,IDBAM1,IDPDG2,IDBAM2

C  Reggeon phenomenology parameters
      DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
     &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
      COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
     &                ALREG,ALREGP,GR(2),B0REG(2),
     &                GPPP,GPPR,B0PPP,B0PPR,
     &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC

C  parameters of 2x2 channel model
      DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
      COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  unitarized amplitudes for different diffraction channels
      DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
     &                 ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
     &                 ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
     &                 ZXL,BXL
      COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
     &                ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
     &                ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
     &                ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
     &                ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
     &                ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
     &                ZXL(4,4),BXL(4,4)

      COMPLEX*16      CZERO,CONE,B24,AUXP,AUXR,AUXH,AUXD,AUXT1,AUXT2,
     &                AUXL,AMPR,AMPO,AMPP,AMPQ

      DIMENSION PVOLD(2)

      DATA  ELAST / 0.D0 /
      DATA  IPOLD / -1 /
      DATA  IDXMOLD/ -1 /
      DATA  PVOLD / -1.D0, -1.D0 /
      DATA  XMPOM / 0.766D0 /
      DATA  XMVDM / 0.766D0 /

C  calculation of scaled cross sections and slopes

C  test for redundant calculation
      IF((ECM.NE.ELAST).OR.(IFHARD.EQ.-1).OR.(PVIRT(1).NE.PVOLD(1))
     &   .OR.(PVIRT(2).NE.PVOLD(2)).OR.(IP.NE.IPOLD)
     &   .OR.(IDXMPAR .NE. IDXMOLD)) THEN
C  effective particle masses, VDM assumption
        XMASS1 = PMASS(1)
        XMASS2 = PMASS(2)
        RMASS1 = RMASS(1)
        RMASS2 = RMASS(2)
        IF(IFPAP(1).EQ.22) THEN
          XMASS1 = XMVDM
        ELSE IF(IFPAP(1).EQ.990) THEN
          XMASS1 = XMPOM
        ENDIF
        IF(IFPAP(2).EQ.22) THEN
          XMASS2 = XMVDM
        ELSE IF(IFPAP(2).EQ.990) THEN
          XMASS2 = XMPOM
        ENDIF
C  different particle combinations
        IF(IP.EQ.3) THEN
          XMASS1 = XMASS2
          RMASS1 = RMASS2
        ELSE IF(IP.EQ.4) THEN
          XMASS1 = XMPOM
          RMASS1 = XMASS1
        ENDIF
        IF(IP.GT.1) THEN
          XMASS2 = XMPOM
          RMASS2 = XMASS2
        ENDIF
C  update pomeron CM system
        PMASSP(1) = XMASS1
        PMASSP(2) = XMASS2
        ECMP = ECM

        CZERO    = DCMPLX(0.D0,0.D0)
        CONE     = DCMPLX(1.D0,0.D0)
        ELAST    = ECM
        PVOLD(1) = PVIRT(1)
        PVOLD(2) = PVIRT(2)
        IPOLD    = IP
        idxmold = idxmpar

C  purely elastic scattering
        CALL PHO_BORNCS(IP,IFHARD,XMASS1,XMASS2,XMASS1,XMASS2)
          ZXP(1,1) = ZIGP
          BXP(1,1) = BPOM
          ZXR(1,1) = ZIGR
          BXR(1,1) = BREG
          ZXH(1,1) = ZIGHR
          BXH(1,1) = BHAR
          ZXD(1,1) = ZIGHD
          BXD(1,1) = BHAD
          ZXT1A(1,1) = ZIGT1(1)
          BXT1A(1,1) = BTR1(1)
          ZXT1B(1,1) = ZIGT1(2)
          BXT1B(1,1) = BTR1(2)
          ZXT2A(1,1) = ZIGT2(1)
          BXT2A(1,1) = BTR2(1)
          ZXT2B(1,1) = ZIGT2(2)
          BXT2B(1,1) = BTR2(2)
          ZXL(1,1) = ZIGL
          BXL(1,1) = BLOO
          ZXDPE(1,1) = ZIGDP(1)
          BXDPE(1,1) = BDP(1)
          ZXDPA(1,1) = ZIGDP(2)
          BXDPA(1,1) = BDP(2)
          ZXDPB(1,1) = ZIGDP(3)
          BXDPB(1,1) = BDP(3)
          ZXDPD(1,1) = ZIGDP(4)
          BXDPD(1,1) = BDP(4)
          SBOPOM(1) = SIGP
          SBOREG(1) = SIGR
          SBOHAR(1) = SIGHR
          SBOHAD(1) = SIGHD
          SBOTR1(1,1) = SIGT1(1)
          SBOTR1(1,2) = SIGT1(2)
          SBOTR2(1,1) = SIGT2(1)
          SBOTR2(1,2) = SIGT2(2)
          SBOLPO(1) = SIGL
          SBODPO(1,1) = SIGDP(1)
          SBODPO(1,2) = SIGDP(2)
          SBODPO(1,3) = SIGDP(3)
          SBODPO(1,4) = SIGDP(4)

C  low mass single diffractive scattering 1
        CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,RMASS1,XMASS2)
          ZXP(1,2) = ZIGP
          BXP(1,2) = BPOM
          ZXR(1,2) = ZIGR
          BXR(1,2) = BREG
          ZXH(1,2) = ZIGHR
          BXH(1,2) = BHAR
          ZXD(1,2) = ZIGHD
          BXD(1,2) = BHAD
          ZXT1A(1,2) = ZIGT1(1)
          BXT1A(1,2) = BTR1(1)
          ZXT1B(1,2) = ZIGT1(2)
          BXT1B(1,2) = BTR1(2)
          ZXT2A(1,2) = ZIGT2(1)
          BXT2A(1,2) = BTR2(1)
          ZXT2B(1,2) = ZIGT2(2)
          BXT2B(1,2) = BTR2(2)
          ZXL(1,2) = ZIGL
          BXL(1,2) = BLOO
          ZXDPE(1,2) = ZIGDP(1)
          BXDPE(1,2) = BDP(1)
          ZXDPA(1,2) = ZIGDP(2)
          BXDPA(1,2) = BDP(2)
          ZXDPB(1,2) = ZIGDP(3)
          BXDPB(1,2) = BDP(3)
          ZXDPD(1,2) = ZIGDP(4)
          BXDPD(1,2) = BDP(4)
          SBOPOM(2) = SIGP
          SBOREG(2) = SIGR
          SBOHAR(2) = SIGHR
          SBOHAD(2) = 0.D0
          SBOTR1(2,1) = SIGT1(1)
          SBOTR1(2,2) = SIGT1(2)
          SBOTR2(2,1) = SIGT2(1)
          SBOTR2(2,2) = SIGT2(2)
          SBOLPO(2) = SIGL
          SBODPO(2,1) = SIGDP(1)
          SBODPO(2,2) = SIGDP(2)
          SBODPO(2,3) = SIGDP(3)
          SBODPO(2,4) = SIGDP(4)

C  low mass single diffractive scattering 2
        CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,XMASS1,RMASS2)
          ZXP(1,3) = ZIGP
          BXP(1,3) = BPOM
          ZXR(1,3) = ZIGR
          BXR(1,3) = BREG
          ZXH(1,3) = ZIGHR
          BXH(1,3) = BHAR
          ZXD(1,3) = ZIGHD
          BXD(1,3) = BHAD
          ZXT1A(1,3) = ZIGT1(1)
          BXT1A(1,3) = BTR1(1)
          ZXT1B(1,3) = ZIGT1(2)
          BXT1B(1,3) = BTR1(2)
          ZXT2A(1,3) = ZIGT2(1)
          BXT2A(1,3) = BTR2(1)
          ZXT2B(1,3) = ZIGT2(2)
          BXT2B(1,3) = BTR2(2)
          ZXL(1,3) = ZIGL
          BXL(1,3) = BLOO
          ZXDPE(1,3) = ZIGDP(1)
          BXDPE(1,3) = BDP(1)
          ZXDPA(1,3) = ZIGDP(2)
          BXDPA(1,3) = BDP(2)
          ZXDPB(1,3) = ZIGDP(3)
          BXDPB(1,3) = BDP(3)
          ZXDPD(1,3) = ZIGDP(4)
          BXDPD(1,3) = BDP(4)
          SBOPOM(3) = SIGP
          SBOREG(3) = SIGR
          SBOHAR(3) = SIGHR
          SBOHAD(3) = 0.D0
          SBOTR1(3,1) = SIGT1(1)
          SBOTR1(3,2) = SIGT1(2)
          SBOTR2(3,1) = SIGT2(1)
          SBOTR2(3,2) = SIGT2(2)
          SBOLPO(3) = SIGL
          SBODPO(3,1) = SIGDP(1)
          SBODPO(3,2) = SIGDP(2)
          SBODPO(3,3) = SIGDP(3)
          SBODPO(3,4) = SIGDP(4)

C  low mass double diffractive scattering
        CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,RMASS1,RMASS2)
          ZXP(1,4) = ZIGP
          BXP(1,4) = BPOM
          ZXR(1,4) = ZIGR
          BXR(1,4) = BREG
          ZXH(1,4) = ZIGHR
          BXH(1,4) = BHAR
          ZXD(1,4) = ZIGHD
          BXD(1,4) = BHAD
          ZXT1A(1,4) = ZIGT1(1)
          BXT1A(1,4) = BTR1(1)
          ZXT1B(1,4) = ZIGT1(2)
          BXT1B(1,4) = BTR1(2)
          ZXT2A(1,4) = ZIGT2(1)
          BXT2A(1,4) = BTR2(1)
          ZXT2B(1,4) = ZIGT2(2)
          BXT2B(1,4) = BTR2(2)
          ZXL(1,4) = ZIGL
          BXL(1,4) = BLOO
          ZXDPE(1,4) = ZIGDP(1)
          BXDPE(1,4) = BDP(1)
          ZXDPA(1,4) = ZIGDP(2)
          BXDPA(1,4) = BDP(2)
          ZXDPB(1,4) = ZIGDP(3)
          BXDPB(1,4) = BDP(3)
          ZXDPD(1,4) = ZIGDP(4)
          BXDPD(1,4) = BDP(4)
          SBOPOM(4) = SIGP
          SBOREG(4) = SIGR
          SBOHAR(4) = SIGHR
          SBOHAD(4) = 0.D0
          SBOTR1(4,1) = SIGT1(1)
          SBOTR1(4,2) = SIGT1(2)
          SBOTR2(4,1) = SIGT2(1)
          SBOTR2(4,2) = SIGT2(2)
          SBOLPO(4) = SIGL
          SBODPO(4,1) = SIGDP(1)
          SBODPO(4,2) = SIGDP(2)
          SBODPO(4,3) = SIGDP(3)
          SBODPO(4,4) = SIGDP(4)

C  calculate Born graph cross sections
        SBOPOM(0) = 0.D0
        SBOREG(0) = 0.D0
        SBOHAR(0) = 0.D0
        SBOHAD(0) = 0.D0
        SBOTR1(0,1) = 0.D0
        SBOTR1(0,2) = 0.D0
        SBOTR2(0,1) = 0.D0
        SBOTR2(0,2) = 0.D0
        SBOLPO(0) = 0.D0
        SBODPO(0,1) = 0.D0
        SBODPO(0,2) = 0.D0
        SBODPO(0,3) = 0.D0
        SBODPO(0,4) = 0.D0
        DO 150 I=1,4
          SBOPOM(0) = SBOPOM(0) + ELAFAC(I)*SBOPOM(I)
          SBOREG(0) = SBOREG(0) + ELAFAC(I)*SBOREG(I)
          SBOHAR(0) = SBOHAR(0) + ELAFAC(I)*SBOHAR(I)
          SBOHAD(0) = SBOHAD(0) + ELAFAC(I)*SBOHAD(I)
          SBOTR1(0,1) = SBOTR1(0,1) + ELAFAC(I)*SBOTR1(I,1)
          SBOTR1(0,2) = SBOTR1(0,2) + ELAFAC(I)*SBOTR1(I,2)
          SBOTR2(0,1) = SBOTR2(0,1) + ELAFAC(I)*SBOTR2(I,1)
          SBOTR2(0,2) = SBOTR2(0,2) + ELAFAC(I)*SBOTR2(I,2)
          SBOLPO(0) = SBOLPO(0) + ELAFAC(I)*SBOLPO(I)
          SBODPO(0,1) = SBODPO(0,1) + ELAFAC(I)*SBODPO(I,1)
          SBODPO(0,2) = SBODPO(0,2) + ELAFAC(I)*SBODPO(I,2)
          SBODPO(0,3) = SBODPO(0,3) + ELAFAC(I)*SBODPO(I,3)
          SBODPO(0,4) = SBODPO(0,4) + ELAFAC(I)*SBODPO(I,4)
 150    CONTINUE

        SIGPOM = SBOPOM(0)
        SIGREG = SBOREG(0)
        SIGTR1(1) = SBOTR1(0,1)
        SIGTR1(2) = SBOTR1(0,2)
        SIGTR2(1) = SBOTR2(0,1)
        SIGTR2(2) = SBOTR2(0,2)
        SIGLOO = SBOLPO(0)
        SIGDPO(1) = SBODPO(0,1)
        SIGDPO(2) = SBODPO(0,2)
        SIGDPO(3) = SBODPO(0,3)
        SIGDPO(4) = SBODPO(0,4)
        SIGHAR = SBOHAR(0)
        SIGDIR = SBOHAD(0)
      ENDIF

      B24=DCMPLX(B**2,0.D0)/4.D0

      AMPEL     = CZERO
      AMPR      = CZERO
      AMPO      = CZERO
      AMPP      = CZERO
      AMPQ      = CZERO
      AMLMSD(1) = CZERO
      AMLMSD(2) = CZERO
      AMHMSD(1) = CZERO
      AMHMSD(2) = CZERO
      AMLMDD    = CZERO
      AMHMDD    = CZERO

C  different models

      IF(ISWMDL(1).LT.3) THEN
C  pomeron
        AUXP  = ZXP(1,1)*EXP(-B24/BXP(1,1))
C  reggeon
        AUXR  = ZXR(1,1)*EXP(-B24/BXR(1,1))
C  hard resolved processes
        AUXH  = ZXH(1,1)*EXP(-B24/BXH(1,1))
C  hard direct processes
        AUXD  = ZXD(1,1)*EXP(-B24/BXD(1,1))
C  triple-Pomeron: baryon high mass diffraction
        AUXT1 = ZXT1A(1,1)*EXP(-B24/BXT1A(1,1))
     &        + ZXT1B(1,1)*EXP(-B24/BXT1B(1,1))
C  triple-Pomeron: photon/meson high mass diffraction
        AUXT2 = ZXT2A(1,1)*EXP(-B24/BXT2A(1,1))
     &        + ZXT2B(1,1)*EXP(-B24/BXT2B(1,1))
C  loop-Pomeron
        AUXL  = ZXL(1,1)*EXP(-B24/BXL(1,1))
      ENDIF

      IF(ISWMDL(1).EQ.0) THEN
        AMPEL = 0.5D0*((VDMQ2F(1)+VDMQ2F(2)+VDMQ2F(3)+VDMQ2F(4))
     &                 *(CONE-EXP(-AUXR-AUXP-AUXH+AUXT1+AUXT2+AUXL))
     &        +(CONE-(VDMQ2F(1)-VDMQ2F(2)-VDMQ2F(3)-VDMQ2F(4)))*AUXD
     &               )
        AMPR = 0.5D0*SQRT(VDMQ2F(1))*(CONE-EXP(-AUXR-AUXP-AUXH
     &                                      +AUXT1+AUXT2+AUXL))
        AMPO = 0.5D0*SQRT(VDMQ2F(2))*(CONE-EXP(-AUXR-AUXP-AUXH
     &                                      +AUXT1+AUXT2+AUXL))
        AMPP = 0.5D0*SQRT(VDMQ2F(3))*(CONE-EXP(-AUXR-AUXP-AUXH
     &                                      +AUXT1+AUXT2+AUXL))
        AMPQ = 0.5D0*SQRT(VDMQ2F(4))*(CONE-EXP(-AUXR-AUXP-AUXH
     &                                      +AUXT1+AUXT2+AUXL))

      ELSE IF(ISWMDL(1).EQ.1) THEN
        AMPR = 0.5D0*SQRT(VDMQ2F(1))*
     &         ( CONE-EXP(-AUXR-AUXP-AUXH*VDMQ2F(1)) )
        AMPO = 0.5D0*SQRT(VDMQ2F(2))*
     &         ( CONE-EXP(-3.D0*AUXR-AUXP-AUXH*VDMQ2F(2)) )
        AMPP = 0.5D0*SQRT(VDMQ2F(3))*
     &         ( CONE-EXP(-AUXP-AUXH*VDMQ2F(3)) )
        AMPQ = 0.5D0*SQRT(VDMQ2F(4))*
     &         ( CONE-EXP(-AUXR-AUXP-AUXH*VDMQ2F(4)) )
        AMPEL = SQRT(VDMQ2F(1))*AMPR
     &         + SQRT(VDMQ2F(2))*AMPO
     &         + SQRT(VDMQ2F(3))*AMPP
     &         + SQRT(VDMQ2F(4))*AMPQ
     &         + AUXD/2.D0

C  simple analytic two channel model (version A)
      ELSE IF(ISWMDL(1).EQ.3) THEN
        CALL PHO_CHAN2A(B)

      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I2)')
     &       'PHO_EIKON: ERROR: unsupported model ISWMDL(1) ',ISWMDL(1)
        STOP
      ENDIF

      END


 
 


CDECK  ID>, PHO_EVEINI
      SUBROUTINE PHO_EVEINI(IMODE,P1,P2,IP1,IP2)
C********************************************************************
C
C     prepare /POEVT1/ for new event
C
C     first subroutine called for each event
C
C     input:   P1(4)  particle 1
C              P2(4)  particle 2
C              IMODE  0    general initialization
C                     1    initialization of particles and kinematics
C                     2    initialization after internal rejection
C
C     output:  IP1,IP2  index of interacting particles
C
C********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      DIMENSION P1(4),P2(4)

      PARAMETER ( EPS    =  1.D-5,
     &            DEPS   =  1.D-15 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  general process information
      INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
      COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)

C  gamma-lepton or gamma-hadron vertex information
      INTEGER IGHEL,IDPSRC,IDBSRC
      DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
     &                 RADSRC,AMSRC,GAMSRC
      COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
     &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
     &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)

C  global event kinematics and particle IDs
      INTEGER IFPAP,IFPAB
      DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
      COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)

C**anfe COMMON not needed here      
C  energy-interpolation table
C       include 'inc/potabl'
C  cross sections
      INTEGER IPFIL,IFAFIL,IFBFIL
      DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
     &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
     &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
     &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
     &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
      COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
     &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
     &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
     &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
     &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
     &                IPFIL,IFAFIL,IFBFIL

C  color string configurations including collapsed strings and hadrons
      INTEGER MSTR
      PARAMETER (MSTR=2000)
      INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
      COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
     &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
     &                NNCH(MSTR),IBHAD(MSTR),ISTR

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

C  table of particle indices for recursive PHOJET calls
      INTEGER MAXIPX
      PARAMETER ( MAXIPX = 500 )
      INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
      COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
     &                IPOIX1,IPOIX2,IPOIX3

C  event weights and generated cross section
      INTEGER IPOWGC,ISWCUT,IVWGHT
      DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
      COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
     &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)

      DIMENSION IM(2)

C  reset debug variables
      KSPOM  = 0
      KHPOM  = 0
      KSREG  = 0
      KHDIR  = 0
      KSTRG  = 0
      KHTRG  = 0
      KSLOO  = 0
      KHLOO  = 0
      KSDPO  = 0
      KSOFT  = 0
      KHARD  = 0
C
      IDNODF = 0
      IDIFR1 = 0
      IDIFR2 = 0
      IDDPOM = 0
      ISTR   = 0
      IPOIX1 = 0
      IF(ISWMDL(14).GT.0) IPOIX1 = 1
      IPOIX2 = 0
      IPOIX3 = 0
C  reset /POEVT1/ and /POEVT2/
      CALL PHO_REGPAR(0,0,0,0,0,0.D0,0.D0,0.D0,0.D0,
     &            0,0,0,0,IPOS,0)
      CALL PHO_SELCOL(0,0,0,0,0,0,0)
      DO 15 I=0,10
        IPOWGC(I) = 0
 15   CONTINUE

C  initialization of particle kinematics
C  Initialize elastic scattering with initial kinematics
      IF (ISWMDL(13).EQ.0) THEN
        IPCOMB = 0
        IF (ABS(IFPAP(1)).EQ.2212 .AND. 
     &      IFPAP(1).EQ.IFPAP(2)) THEN
          IPCOMB=1
        ELSE IF (ABS(IFPAP(1)).EQ.2212 .AND. 
     &           IFPAP(1).EQ.-IFPAP(2)) THEN
          IPCOMB=2
        ELSE
          IF (LPRI.GT.4)
     &       WRITE(LO,*) "PHO_EVEINI: Unsupported particle", 
     &       "combination for JLL elastic scattering model."
          CALL PHO_ABORT
        END IF
** FLUKA has a separate version of this model.        
c         CALL JLL_SET(ECM**2, IPCOMB, 1)
      END IF
C  lepton-photon/hadron-photon vertex and initial particles
      IM(1) = 0
      IM(2) = 0
      IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
        CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),0,0,PINI(1,1),PINI(2,1),
     &      PINI(3,1),PINI(4,1),0,0,0,0,IM(1),1)
      ELSE
        CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
     &      P1(4),0,0,0,0,IP1,1)
      ENDIF
      IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
        CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),0,0,PINI(1,2),PINI(2,2),
     &      PINI(3,2),PINI(4,2),0,0,0,0,IM(2),1)
      ELSE
        CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
     &      P2(4),0,0,0,0,IP2,1)
      ENDIF
      IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
        CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),IM(1),0,PFIN(1,1),
     &      PFIN(2,1),PFIN(3,1),PFIN(4,1),0,10,0,0,IPOS,1)
        CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
     &      P1(4),0,0,0,0,IP1,1)
      ENDIF
      IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
        CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),IM(2),0,PFIN(1,2),
     &      PFIN(2,2),PFIN(3,2),PFIN(4,2),0,10,0,0,IPOS,1)
        CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
     &      P2(4),0,0,0,0,IP2,1)
      ENDIF
      NEVHEP = KACCEP

      IF(IMODE.LE.1) THEN
C  CMS energy
        ECM = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
     &           -(P1(3)+P2(3))**2)
*       CALL PHO_PECMS(1,PMASS(1),PMASS(2),ECM,PCM,EE)
        PMASS(1) = PHEP(5,IP1)
        PVIRT(1) = 0.D0
        IF(IFPAP(1).EQ.22) PVIRT(1) = PMASS(1)**2
        PMASS(2) = PHEP(5,IP2)
        PVIRT(2) = 0.D0
        IF(IFPAP(2).EQ.22) PVIRT(2) = PMASS(2)**2
      ENDIF

C  cross section calculations

      IF(IMODE.NE.1) THEN
        IP = 1
        CALL PHO_CSINT(IP,IFPAP(1),IFPAP(2),IGHEL(1),IGHEL(2),
     &              ECM,PVIRT(1),PVIRT(2))
      ENDIF

      IF(IMODE.LE.0) THEN
C  effective cross section
        SIGGEN(3) = 0.D0
        IF(ISWMDL(2).ge.1) THEN
          IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGTOT-SIGELA-SIGVM(0,0)
     &      -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)-SIGLDD
     &      -SIGHDD-SIGDIR
          IF(IPRON(2,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGELA
          IF(IPRON(3,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGVM(0,0)
          IF(IPRON(4,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGCDF(0)
          IF(IPRON(5,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(1)+SIGHSD(1)
          IF(IPRON(6,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(2)+SIGHSD(2)
          IF(IPRON(7,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLDD+SIGHDD
          IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
C  simulate only hard scatterings
        ELSE
          IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGHAR
          IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
        ENDIF

      ENDIF

C  reset of mother/daughter relations only (IMODE = 2)

C  debug output
      IF(IDEB(63).GE.15) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,2A,I12,I3)') 'PHO_EVEINI: ',
     &    '/POEVT1/ initialized (event/mode)',KEVENT,IMODE
        IF(IMODE.LE.0) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)') 'PHO_EVEINI: ',
     &      'current suppression factors total-1/2 hard-1/2 diff-1/2:',
     &      FSUP,FSUH,FSUD
          ONEM = -1.D0
          ITMP = IDEB(57)
          IDEB(57) = MAX(5,ITMP)
          CALL PHO_XSECT(1,0,ONEM)
          IDEB(57) = ITMP
        ENDIF
        CALL PHO_PREVNT(0)
      ENDIF

      END


 
 


CDECK  ID>, PHO_EVENT
      SUBROUTINE PHO_EVENT(NEV,P1,P2,FAC,IREJ)
C********************************************************************
C
C     main subroutine to manage simulation processes
C
C     input: NEV       -1   initialization
C                       1   generation of events
C                       2   generation of events without rejection
C                           due to energy dependent cross section
C                       3   generation of events without rejection
C                           using initialization energy
C                      -2   output of event generation statistics
C            P1(4)     momentum of particle 1 (internal TARGET)
C            P2(4)     momentum of particle 2 (internal PROJECTILE)
C            FAC       used for initialization:
C                      contains cross section the events corresponds to
C                      during generation: current cross section
C
C     output: IREJ     0: event accepted
C                      1: event rejected
C
C********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( TINY   =  1.D-10 )

      DIMENSION P1(4),P2(4)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  current beam selection
      INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN
      INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL
      DOUBLE PRECISION SQSGLOBMAX
      PARAMETER (MPARMAX=40)
      PARAMETER (MAXMAPPS=40)
      PARAMETER (IKNOWN=9)
      DIMENSION IPAVAIL(IKNOWN)
      DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/
      COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS),
     &           MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP

C  general process information
      INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
      COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)

C  internal rejection counters
      INTEGER NMXJ
      PARAMETER (NMXJ=60)
      CHARACTER*10 REJTIT
      INTEGER IFAIL
      COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)

C  gamma-lepton or gamma-hadron vertex information
      INTEGER IGHEL,IDPSRC,IDBSRC
      DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
     &                 RADSRC,AMSRC,GAMSRC
      COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
     &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
     &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)

C  global event kinematics and particle IDs
      INTEGER IFPAP,IFPAB
      DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
      COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)

C  cross sections
      INTEGER IPFIL,IFAFIL,IFBFIL
      DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
     &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
     &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
     &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
     &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
      COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
     &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
     &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
     &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
     &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
     &                IPFIL,IFAFIL,IFBFIL

C  event weights and generated cross section
      INTEGER IPOWGC,ISWCUT,IVWGHT
      DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
      COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
     &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)

C  names of hard scattering processes
      INTEGER Max_pro_1
      PARAMETER ( Max_pro_1 = 16 )
      CHARACTER*18 PROC
      COMMON /POHPRO/ PROC(0:Max_pro_1)

C  hard cross sections and MC selection weights
      INTEGER Max_pro_2
      PARAMETER ( Max_pro_2 = 16 )
      INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
     &  MH_acc_1,MH_acc_2
      DOUBLE PRECISION HFAC, HWGX, HSIG, HDPT, HECM_LAST, 
     &   HQ2A_LAST, HQ2B_LAST
      COMMON /POHRCS/HFAC(-1:MAX_PRO_2, MPARMAX), 
     &   HWGX(-1:MAX_PRO_2, MPARMAX),
     &   HSIG(-1:MAX_PRO_2, MPARMAX), HDPT(-1:MAX_PRO_2, MPARMAX), 
     &   HECM_LAST, HQ2A_LAST, HQ2B_LAST, IHA_LAST, IHB_LAST, 
     &   MH_PRO_ON(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_TRIED(-1:MAX_PRO_2, 0:4, MPARMAX), 
     &   MH_ACC_1(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_ACC_2(-1:MAX_PRO_2, 0:4, MPARMAX) 

C  table of particle indices for recursive PHOJET calls
      INTEGER MAXIPX
      PARAMETER ( MAXIPX = 500 )
      INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
      COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
     &                IPOIX1,IPOIX2,IPOIX3

cf2py intent(out) fac, irej

      DIMENSION IPRSAM(10),IPRACC(10),IENACC(10),IDNS(4),IDNA(4)

      PARAMETER (deps=1.D-14)
      LOGICAL INIT
      SAVE
      DATA INIT /.False./
      

      IREJ = 0
      FAC = 0.D0
C  initializations
      IF(NEV.EQ.-1) THEN
cdh  ############  
        IF (INIT) THEN
          WRITE(LO, '(/1X,2A)') 'PHO_EVENT: Error, initialzation',
     &     ' (-1) called twice.'
          CALL PHO_ABORT
        END IF
cdh  ############
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/3(/1X,A))')
     &    '=======================================================',
     &    '  ------- initialization of event generation --------',
     &    '======================================================='

c**anfe Safety margin for initialization energy is 20%
        SQSGLOBMAX = 1.2D0*SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2-
     &     (P1(2)+P2(2))**2-(P1(3)+P2(3))**2)

        CALL PHO_SETMDL(0, 0, -2)

        CALL PHO_REJSTA(-1)
C  cross section
        FAC = SIGGEN(4)
        DO 20 I=1,10
          IPRSAM(I) = 0
          IPRACC(I) = 0
          IENACC(I) = 0
 20     CONTINUE
        ISPS = 0
        ISPA = 0
        ISRS = 0
        ISRA = 0
        IHPS = 0
        IHPA = 0
        ISTS = 0
        ISTA = 0
        ISLS = 0
        ISLA = 0
        IDIS = 0
        IDIA = 0
        IDPS = 0
        IDPA = 0
        IDNS(1) = 0
        IDNS(2) = 0
        IDNS(3) = 0
        IDNS(4) = 0
        IDNA(1) = 0
        IDNA(2) = 0
        IDNA(3) = 0
        IDNA(4) = 0
        KACCEP = 0
        KEVENT = 0
        KEVGEN = 0
        ECMSUM = 0.D0

        INIT = .TRUE.

      ELSE IF(NEV.GT.0) THEN
        nevhep = kaccep
        SQS = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2-
     &     (P1(2)+P2(2))**2-(P1(3)+P2(3))**2)
        IF ((SQS > DEPS).AND.(SQS >= SQSGLOBMAX)) THEN
          WRITE(LO,*) 
     &     'PHO_EVENT: Error: Higher energy requested then sqsglobmax.',
     &     SQS,'>', SQSGLOBMAX
          CALL PHO_ABORT
        END IF
C
C  -------------- begin event generation ---------------
C
        IPAMDL(13) = 0
        IF(NEV.EQ.3) IPAMDL(13) = 1
        KEVENT = KEVENT+1
C  enable debugging
        CALL PHO_TRACE(0,0,0)
        IF(IDEB(68).GE.2) THEN
          IF((MOD(KEVENT,50).EQ.0).OR.(IDEB(68).GE.3) .AND. LPRI.GT.4)
     &      WRITE(LO,'(1X,A,2I12)') 'call to PHO_EVENT no',KEVENT,KACCEP
        ENDIF
C  initialize MC package
        CALL PHO_SETPCOMB
        CALL PHO_EVEINI(0,P1,P2,JM1,JM2)
C  cross section calculation
        FAC = SIGGEN(3)
        IF(NEV.EQ.1) THEN
          IF(IVWGHT(1).EQ.1) THEN
            WG = EVWGHT(1)*SIGGEN(3)/SIGGEN(4)
          ELSE
            WG = SIGGEN(3)/SIGGEN(4)
          ENDIF
          IF(DT_RNDM(FAC).GT.WG) THEN
            IREJ = 1
            IF(IDEB(68).GE.6) THEN
              IF (LPRI.GT.4)
     &        WRITE(LO,'(1X,2A,/5X,2I10,6X,1P3E10.3)')
     &          'PHO_EVENT: rejection due to cross section',
     &          ' (CALL/ACC/EVWGHT(1)/SIG/SIGMAX)',
     &          KEVENT,KACCEP,EVWGHT(1),SIGGEN(3),SIGGEN(4)
              CALL PHO_PREVNT(-1)
            ENDIF
            RETURN
          ENDIF
        ENDIF
        KEVGEN = KEVGEN+1
        SIGGEN(1) = SIGGEN(4)*DBLE(KEVGEN)/DBLE(KEVENT)
        HSWGHT(0) = MAX(1.D0,WG)

        ITRY1 = 0
 50     CONTINUE
          ITRY1 = ITRY1+1
          IF(ITRY1.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)

C  sample process
          IPROCE = 0
          CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
     &      1.D0,IPROCE)
          IF(IPROCE.EQ.0) THEN
            IF (LPRI.GT.4 .AND. IDEB(68).GE.4)
     &      WRITE(LO,'(1X,A)') 'PHO_EVENT: ',
     &        'rejection by PHO_SAMPRO (call,Ecm)',KEVENT,ECM
            IREJ = 50
            RETURN
          ENDIF
C  sampling statistics
          IPRSAM(IPROCE) = IPRSAM(IPROCE)+1

          ITRY2 = 0
 60       CONTINUE
            ITRY2 = ITRY2+1
            IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
C  sample number of cut graphs according to IPROCE and
C  generate parton configurations+strings
            CALL PHO_PARTON(IPROCE,JM1,JM2,P1,P2,IREJ)
C  collect statistics
            ISPS = ISPS+KSPOM
            IHPS = IHPS+KHPOM
            ISRS = ISRS+KSREG
            ISTS = ISTS+KSTRG+KHTRG
            ISLS = ISLS+KSLOO+KHLOO
            IDIS = IDIS+MIN(KHDIR,1)
            IDPS = IDPS+KHDPO+KSDPO
            IF((IDIFR1+IDIFR2+IDDPOM.EQ.0).AND.(KHDIR.GT.0))
     &        IDNS(KHDIR) = IDNS(KHDIR)+1
C  rejection?
          IF(IREJ.NE.0) THEN
            IF(IDEB(68).GE.4) THEN
              IF (LPRI.GT.4)
     &        WRITE(LO,'(/1X,A,2I5)')
     &          'PHO_EVENT: rejection by PHO_PARTON',ITRY2,IREJ
              CALL PHO_PREVNT(-1)
            ENDIF
            IF((IREJ.EQ.50).AND.(NEV.EQ.1)) THEN
              RETURN
            ENDIF
            IFAIL(1) = IFAIL(1)+1
            IF(ITRY1.GT.5) RETURN
            IF(IREJ.GE.5) THEN
              IF(ISWMDL(2).EQ.0) RETURN
              GOTO 50
            ENDIF
            IF(ITRY2.LT.5) GOTO 60
            GOTO 50
          ENDIF
C  fragmentation of strings

C  fragmentation of strings
C  In DPMJET case FSR and string fragmentation is done separately
        IF (IPAMDL(13)==0) THEN 
           CALL PHO_STRFRA(IREJ)
           IF (IREJ/=0) THEN
             IFAIL(23) = IFAIL(23) + 1
             IF ((LPRI.GT.4).AND.(IDEB(68)>=4)) THEN
               WRITE (lo, '(/1X,A,2I5)') 
     &           'PHO_EVENT: rejection by PHO_STRFRA',
     &           itry2, irej
               CALL PHO_PREVNT(-1)
             END IF
             GO TO 50
           END IF
        END IF

C  check of conservation of quantum numbers
          IF(IDEB(68).GE.-5) THEN
            CALL PHO_CHECK(-1,IREJ)
            IF(IREJ.NE.0) GOTO 50
          ENDIF
C  event now completely processed and accepted
C  acceptance statistics
          IPRACC(IPROCE) = IPRACC(IPROCE)+1
          ISPA = ISPA+KSPOM
          IHPA = IHPA+KHPOM
          ISRA = ISRA+KSREG
          ISTA = ISTA+(KSTRG+KHTRG)
          ISLA = ISLA+(KSLOO+KHLOO)
          IDIA = IDIA+MIN(KHDIR,1)
          IDPA = IDPA+KHDPO+KSDPO
          IF((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GT.0))
     &      IDNA(KHDIR) = IDNA(KHDIR)+1
          DO 55 I=1,IPOIX2
            If (IPORES(I).EQ.0) Then
               If ((LPRI.GT.4).AND.(IDEB(67).GE.10))
     &          Write(6,*) 'PHO_EVENT: diffraction statistics problem'
               Go To 55
            End IF
            IENACC(IPORES(I)) = IENACC(IPORES(I))+1
 55       CONTINUE
          KACCEP = KACCEP+1

C  debug output (partial / full event listing)
          if((IDEB(68).eq.1).and.(MOD(KACCEP,50).EQ.0)
     &       .AND. LPRI.GT.4)
     &      WRITE(LO,'(1X,A,2I12)') 'call to PHO_EVENT no',KEVENT,KACCEP
          IF(IDEB(67).GE.10) THEN
            IF(IDEB(67).LE.15) THEN
              CALL PHO_PREVNT(-1)
            ELSE IF(IDEB(67).LE.20) THEN
              CALL PHO_PREVNT(0)
            ELSE IF(IDEB(67).LE.25) THEN
              CALL PHO_PREVNT(1)
            ELSE
              CALL PHO_PREVNT(2)
            ENDIF
          ENDIF
C
C  effective weight
          DO 65 I=1,10
            IF(IPOWGC(I).GT.0) THEN
              HSWGHT(0) = HSWGHT(0)*HSWGHT(I)
            ENDIF
 65       CONTINUE
          IF(IVWGHT(1).EQ.1) THEN
            WG = HSWGHT(0)
            IF(WG.GT.1.01D0) THEN
              IF(EVWGHT(1).LT.1.01D0) THEN
                IF (LPRI.GT.4)
     &          WRITE(LO,'(1X,A,2I12,1PE12.3)')
     &            'PHO_EVENT: cross section weight > 1',
     &            KEVENT,KACCEP,WG
                IF (LPRI.GT.4)
     &          WRITE(LO,'(5X,A,1P3E11.3)') 'SIGCUR,SIGMAX,EVWGHT(1):',
     &            SIGGEN(3),SIGGEN(4),EVWGHT(1)
              ENDIF
              EVWGHT(1) = HSWGHT(0)
              HSWGHT(0) = 1.D0
            ELSE
              EVWGHT(1) = 1.D0
            ENDIF
          ENDIF

C  effective cross section
          SIGGEN(2) = SIGGEN(4)*DBLE(KACCEP)/DBLE(KEVENT)
          ECMSUM = ECMSUM+ECM
          SIGGEN(3) = SIGGEN(3)*HSWGHT(0)
      ELSE IF(NEV.EQ.-2) THEN

C  ---------------- end of event generation ----------------------

        IF (LPRI.GT.4)
     &  WRITE(LO,'(/3(/1X,A),//1X,A,3I12,/1X,A,F12.1)')
     &    '====================================================',
     &    '  --------- summary of event generation ----------',
     &    '====================================================',
     &    'called,generated,accepted events:',KEVENT,KEVGEN,KACCEP,
     &    'average CMS energy:',ECMSUM/DBLE(MAX(1,KACCEP))

C  write out statistics
        IF(KACCEP.GT.0) THEN

          FAC1 = SIGGEN(4)/DBLE(KEVENT)
          FAC2 = FAC/DBLE(KACCEP)
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,/1X,A)')
     &      'PHO_EVENT: generated and accepted events',
     &      '----------------------------------------'
          IF (LPRI.GT.4)
     &    WRITE(LO,'(3X,A)')
     &   'process, sampled, accepted, cross section (internal/external)'
          IF (LPRI.GT.4)
     &    WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'non.diff.',IPRSAM(1),
     &      IPRACC(1),DBLE(IPRACC(1))*FAC1,DBLE(IPRACC(1))*FAC2
          IF (LPRI.GT.4)
     &    WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'elas sca.',IPRSAM(2),
     &      IPRACC(2),DBLE(IPRACC(2))*FAC1,DBLE(IPRACC(2))*FAC2
          IF (LPRI.GT.4)
     &    WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'qela sca.',IPRSAM(3),
     &      IPRACC(3),DBLE(IPRACC(3))*FAC1,DBLE(IPRACC(3))*FAC2
          IF (LPRI.GT.4)
     &    WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.pom.',IPRSAM(4),
     &      IPRACC(4),DBLE(IPRACC(4))*FAC1,DBLE(IPRACC(4))*FAC2
          IF (LPRI.GT.4)
     &    WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'diff.par1',IPRSAM(5),
     &      IPRACC(5),DBLE(IPRACC(5))*FAC1,DBLE(IPRACC(5))*FAC2
          IF (LPRI.GT.4)
     &    WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'diff.par2',IPRSAM(6),
     &      IPRACC(6),DBLE(IPRACC(6))*FAC1,DBLE(IPRACC(6))*FAC2
          IF (LPRI.GT.4)
     &    WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.dif.',IPRSAM(7),
     &      IPRACC(7),DBLE(IPRACC(7))*FAC1,DBLE(IPRACC(7))*FAC2
          IF (LPRI.GT.4)
     &    WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir all  ',IPRSAM(8),
     &      IPRACC(8),DBLE(IPRACC(8))*FAC1,DBLE(IPRACC(8))*FAC2
          IF (LPRI.GT.4)
     &    WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir X res',IDNS(1),IDNA(1),
     &      DBLE(IDNA(1))*FAC1,DBLE(IDNA(1))*FAC2
          IF (LPRI.GT.4)
     &    WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'res X dir',IDNS(2),IDNA(2),
     &      DBLE(IDNA(2))*FAC1,DBLE(IDNA(2))*FAC2
          IF (LPRI.GT.4)
     &    WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir X dir',IDNS(3),IDNA(3),
     &      DBLE(IDNA(3))*FAC1,DBLE(IDNA(3))*FAC2
          IF (LPRI.GT.4)
     &    WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'soft pom.',ISPS,ISPA,
     &      DBLE(ISPA)*FAC1,DBLE(ISPA)*FAC2
          IF (LPRI.GT.4)
     &    WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'hard pom.',IHPS,IHPA,
     &      DBLE(IHPA)*FAC1,DBLE(IHPA)*FAC2
          IF (LPRI.GT.4)
     &    WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'soft reg.',ISRS,ISRA,
     &      DBLE(ISRA)*FAC1,DBLE(ISRA)*FAC2
          IF (LPRI.GT.4)
     &    WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'enh. trg.',ISTS,ISTA,
     &      DBLE(ISTA)*FAC1,DBLE(ISTA)*FAC2
          IF (LPRI.GT.4)
     .    WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'enh. log.',ISLS,ISLA,
     &      DBLE(ISLA)*FAC1,DBLE(ISLA)*FAC2
          IF (LPRI.GT.4)
     &    WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.pom.',IDPS,IDPA,
     &      DBLE(IDPA)*FAC1,DBLE(IDPA)*FAC2
          IF(ISWMDL(14).GT.0) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(3X,A,I3)') 'recursive pomeron splitting:',
     &        ISWMDL(14)
            IF (LPRI.GT.4)
     &      WRITE(LO,'(5X,A,I12)') '1->2pom-cut :',IENACC(8)
            IF (LPRI.GT.4)
     &      WRITE(LO,'(5X,A,I12)') '1->doub-pom :',IENACC(4)
            IF (LPRI.GT.4)
     &      WRITE(LO,'(5X,A,I12)') '1->diff-dis1:',IENACC(5)
            IF (LPRI.GT.4)
     &      WRITE(LO,'(5X,A,I12)') '1->diff-dis2:',IENACC(6)
            IF (LPRI.GT.4)
     &      WRITE(LO,'(5X,A,I12)') '1->doub-diff:',IENACC(7)
          ENDIF
          IF (LPRI.GT.4)
     &    WRITE(LO,'(2(/1X,A,1PE12.3)/)') ' sampled cross section (mb)',
     &      SIGGEN(1),'accepted cross section (mb)',SIGGEN(2)

          CALL PHO_REJSTA(-2)
          CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
     &      0.D0,-2)
          CALL PHO_PARTON(-2,0,0,P1,P2,IREJ)
C  statistics of hard scattering processes
          IF (LPRI.GT.4)
     &    WRITE(LO,'(2(/1X,A))')
     &      'PHO_EVENT: statistics of hard scattering processes',
     &      '--------------------------------------------------'
          DO 43 K=1,4
            IF(MH_tried(0,K,IDXMPAR).GT.0) THEN
              IF (LPRI.GT.4)
     &        WRITE(LO,'(/5X,A,I3)')
     &      'process (accepted,x-section internal/external) for IP:',K
              DO 47 M=0,Max_pro_2
                IF (LPRI.GT.4)
     &          WRITE(LO,'(1X,I3,1X,A,2X,2I12,1P2E13.3)') M,PROC(M),
     &            MH_tried(M,K,IDXMPAR),MH_acc_1(M,K,IDXMPAR),
     &            DBLE(MH_acc_1(M,K,IDXMPAR))*FAC1,
     &            DBLE(MH_acc_2(M,K,IDXMPAR))*FAC2
 47           CONTINUE
            ENDIF
 43       CONTINUE

        ELSE
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,I4,/)') 'no output of statistics',KEVENT
        ENDIF
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/3(/1X,A)/)')
     &    '======================================================',
     &    '   ------- end of event generation summary --------',
     &    '======================================================'
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,I7)') 'PHO_EVENT:ERROR: unsupported NEV',NEV
      ENDIF

      END


 
 


CDECK  ID>, pho_ExpBessI0
      DOUBLE PRECISION FUNCTION PHO_EXPBESSI0(X)
C**********************************************************************
C
C     Bessel Function I0 times exponential function from neg. arg.
C     (defined for pos. arguments only)
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      AX = ABS(X)
      IF (AX .LT. 3.75D0) THEN
        Y = (X/3.75D0)**2
        PHO_EXPBESSI0 =
     &    (1.0D0+Y*(3.5156229D0+Y*(3.0899424D0+Y*(1.2067492D0
     &    +Y*(0.2659732D0+Y*(0.360768D-1+Y*0.45813D-2))))))*EXP(-AX)
      ELSE
        Y = 3.75D0/AX
        pHO_EXPBESSI0 =
     &    (1.D0/SQRT(AX))*(0.39894228D0+Y*(0.1328592D-1
     &    +Y*(0.225319D-2+Y*(-0.157565D-2+Y*(0.916281D-2
     &    +Y*(-0.2057706D-1+Y*(0.2635537D-1+Y*(-0.1647633D-1
     &    +Y*0.392377D-2))))))))
      ENDIF

      END


 
 


CDECK  ID>, PHO_EXPINT
      DOUBLE PRECISION FUNCTION PHO_EXPINT(RXM)
C***********************************************************************
C
C     function to calculate  E_i(x) = -E_1(-x)
C
C     based on CERNLIB C337   (changed by R.Engel 10/1993)
C
C***********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

      DOUBLE PRECISION P1(5),Q1(5),P2(7),Q2(7),P3(6),Q3(6),P4(8),Q4(8)
      DOUBLE PRECISION A1(8),B1(8),A2(8),B2(8),A3(6),B3(6),XL(6)
      DOUBLE PRECISION X,Y,AP,BP,DP,AQ,BQ,DQ,X0,V

      DATA  X0 /0.37250 74107 8137D0/
      DATA XL /-24.0D0,-12.0D0,-6.0D0,0.0D0,1.0D0,4.0D0/
      DATA P1
     1/+4.29312 52343 210D+0, +3.98941 53870 321D+1,
     2 +2.92525 18866 921D+2, +4.25696 82638 592D+2,
     3 -4.34981 43832 952D+2/
      DATA Q1
     1/+1.00000 00000 000D+0, +1.88992 88395 003D+1,
     2 +1.50950 38744 251D+2, +5.68052 52718 987D+2,
     3 +7.53585 64359 843D+2/
      DATA P2
     1/+4.30967 83946 939D-1, +6.90522 52278 444D+0,
     2 +2.30192 55939 133D+1, +2.43784 08879 132D+1,
     3 +9.04161 55694 633D+0, +9.99979 57705 159D-1,
     4 +4.65627 10797 510D-7/
      DATA Q2
     1/+1.03400 13040 487D-1, +3.31909 21359 330D+0,
     2 +2.04494 78501 379D+1, +4.12807 84189 142D+1,
     3 +3.24264 21069 514D+1, +1.00411 64382 905D+1,
     4 +1.00000 00000 000D+0/
      DATA P3
     1/-2.39099 64453 136D+0, -1.47982 19500 504D+2,
     2 -2.54376 33976 890D+2, -1.19557 61038 372D+2,
     3 -1.96304 08535 939D+1, -9.99999 99990 360D-1/
      DATA Q3
     1/+1.77600 70940 351D+2, +5.30685 09610 812D+2,
     2 +4.62230 27156 148D+2, +1.56818 43364 539D+2,
     3 +2.16304 08494 238D+1, +1.00000 00000 000D+0/
      DATA P4
     1/-8.66937 33995 107D+0, -5.49142 26552 109D+2,
     2 -4.21001 61535 707D+3, -2.49301 39345 865D+5,
     3 -1.19623 66934 925D+5, -2.21744 62775 885D+7,
     4 +3.89280 42131 120D+6, -3.91546 07380 910D+8/
      DATA Q4
     1/+3.41718 75000 000D+1, -1.60708 92658 722D+3,
     2 +3.57300 29805 851D+4, -4.83547 43616 216D+5,
     3 +4.28559 62461 175D+6, -2.49033 37574 054D+7,
     4 +8.91925 76757 561D+7, -1.65254 29972 521D+8/
      DATA A1
     1/-2.18086 38152 072D+0, -2.19010 23385 488D+1,
     2 +9.30816 38566 217D+0, +2.50762 81129 356D+1,
     3 -3.31842 53199 722D+1, +6.01217 99083 008D+1,
     4 -4.32531 13287 813D+1, +1.00443 10922 808D+0/
      DATA B1
     1/+0.00000 00000 000D+0, +3.93707 70185 272D+0,
     2 +3.00892 64837 292D+2, -6.25041 16167 188D+0,
     3 +1.00367 43951 673D+3, +1.43256 73812 194D+1,
     4 +2.73624 11988 933D+3, +5.27468 85196 291D-1/
      DATA A2
     1/-3.48334 65360 285D+0, -1.86545 45488 340D+1,
     2 -8.28561 99414 064D+0, -3.23467 33030 540D+1,
     3 +1.79601 68876 925D+1, +1.75656 31546 961D+0,
     4 -1.95022 32128 966D+0, +9.99994 29607 471D-1/
      DATA B2
     1/+0.00000 00000 000D+0, +6.95000 65588 743D+1,
     2 +5.72837 19383 732D+1, +2.57776 38423 844D+1,
     3 +7.60761 14800 773D+2, +2.89516 72792 514D+1,
     4 -3.43942 26689 987D+0, +1.00083 86740 264D+0/
      DATA A3
     1/-2.77809 28934 438D+1, -1.01047 90815 760D+1,
     2 -9.14830 08216 736D+0, -5.02233 17461 851D+0,
     3 -3.00000 77799 358D+0, +1.00000 00000 704D+0/
      DATA B3
     1/+0.00000 00000 000D+0, +1.22399 93926 823D+2,
     2 +2.72761 00778 779D+0, -7.18975 18395 045D+0,
     3 -2.99901 18065 262D+0, +1.99999 99428 260D+0/
C
C  conversion to E_i function
      X = -RXM
C
      IF(X .LE. XL(1)) THEN
       AP=A3(1)-X
       DO 1 I = 2,5
    1  AP=A3(I)-X+B3(I)/AP
       Y=(EXP(-X)/X)*(1.D0-(A3(6)+B3(6)/AP)/X)
      ELSEIF(X .LE. XL(2)) THEN
       AP=A2(1)-X
       DO 2 I = 2,7
    2     AP=A2(I)-X+B2(I)/AP
       Y=(EXP(-X)/X)*(A2(8)+B2(8)/AP)
      ELSEIF(X .LE. XL(3)) THEN
       AP=A1(1)-X
       DO 3 I = 2,7
    3     AP=A1(I)-X+B1(I)/AP
       Y=(EXP(-X)/X)*(A1(8)+B1(8)/AP)
      ELSEIF(X .LT. XL(4)) THEN
       V=-2.D0*(X/3.D0+1.D0)
       BP=0.D0
       DP=P4(1)
       DO 4 I = 2,8
          AP=BP
          BP=DP
    4     DP=P4(I)-AP+V*BP
       BQ=0.D0
       DQ=Q4(1)
       DO 14 I = 2,8
          AQ=BQ
          BQ=DQ
   14     DQ=Q4(I)-AQ+V*BQ
       Y=-LOG(-X/X0)+(X+X0)*(DP-AP)/(DQ-AQ)
      ELSEIF(X .EQ. XL(4)) THEN
*      CALL KERMTR('C337.1',LGFILE,MFLAG,RFLAG)
*      IF(MFLAG) THEN
*       IF(LGFILE .EQ. 0) THEN
*        WRITE(LO,100) ENAME
*       ELSE
*        WRITE(LGFILE,100) ENAME
*       ENDIF
*      ENDIF
*      IF(.NOT.RFLAG) CALL ABEND
       PHO_EXPINT=0.D0
       RETURN
      ELSEIF(X .LT. XL(5)) THEN
       AP=P1(1)
       AQ=Q1(1)
       DO 5 I = 2,5
          AP=P1(I)+X*AP
    5     AQ=Q1(I)+X*AQ
       Y=-LOG(X)+AP/AQ
      ELSEIF(X .LE. XL(6)) THEN
       Y=1.D0/X
       AP=P2(1)
       AQ=Q2(1)
       DO 6 I = 2,7
          AP=P2(I)+Y*AP
    6     AQ=Q2(I)+Y*AQ
       Y=EXP(-X)*AP/AQ
      ELSE
       Y=1.D0/X
       AP=P3(1)
       AQ=Q3(1)
       DO 7 I = 2,6
          AP=P3(I)+Y*AP
    7     AQ=Q3(I)+Y*AQ
       Y=EXP(-X)*Y*(1.D0+Y*AP/AQ)
      ENDIF
C  sign conversion to E_i
      PHO_EXPINT=-Y

      END


      SUBROUTINE PHO_OPENLOGFILE(fname, opunit)

        CHARACTER (Len=300) :: fname
        INTEGER :: opunit
        SAVE

        If (opunit==0) Then
          opunit = 66
        End If

        OPEN (opunit, File=fname)
      END




      SUBROUTINE PHO_CLOSELOGFILE(opunit)

        INTEGER :: opunit
        SAVE

        If (opunit/=0 .And. opunit/=6) Then
          CLOSE (Unit=opunit, Iostat=ios)
          If (ios/=0) Stop 'Error closing file unit opunit'
        Else
          CALL PHO_ABORT()
        End If

      END


 
 


CDECK  ID>, PHO_FITPAR
      SUBROUTINE PHO_FITPAR(IOUTP)
C**********************************************************************
C
C     read input parameters according to PDFs
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( DEFA=-99999.D0,
     &            DEFB=-100000.D0,
     &            THOUS=1.D3)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  global event kinematics and particle IDs
      INTEGER IFPAP,IFPAB
      DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
      COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)

C  currently activated parton density parametrizations
      CHARACTER*8 PDFNAM
      INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
      DOUBLE PRECISION PDFLAM,PDFQ2M
      COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
     &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD

C  Reggeon phenomenology parameters
      DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
     &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
      COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
     &                ALREG,ALREGP,GR(2),B0REG(2),
     &                GPPP,GPPR,B0PPP,B0PPR,
     &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC

C  parameters of 2x2 channel model
      DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
      COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC

cdh  datadir for path to the data sets to be read in by dpmjet/phojet
      COMMON /DATADIR/ DATADIR
      CHARACTER*132    DATADIR

C  current beam selection
      INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN
      INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL
      DOUBLE PRECISION SQSGLOBMAX
      PARAMETER (MPARMAX=40)
      PARAMETER (MAXMAPPS=40)
      PARAMETER (IKNOWN=9)
      DIMENSION IPAVAIL(IKNOWN)
      DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/
      COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS),
     &           MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP

      DIMENSION   INUM(3),IFPAS(2)
      CHARACTER*8 CNAME8,PDFNA1,PDFNA2
      CHARACTER*10 CNAM10

      PARAMETER ( Max_tab = 23 )
      DIMENSION XDPtab(27,Max_tab),IDPtab(8,Max_tab)
      REAL XDPtab
      INTEGER IDPtab
      DOUBLE PRECISION  PHO_ALPHAS
      EXTERNAL          PHO_ALPHAS

C  parameter set for   2212 (GRV94 LO)     2212 (GRV94 LO)
      DATA (IDPtab(k,  1),k=1,8) /
     &    2212,     5,     6,     0,  2212,     5,     6,     0 /
      DATA (XDPtab(k,  1),k=1,27) /
     &1.1000E+00,2.5000E-01,6.3870E+00,6.3870E+00,1.1610E+00,1.1610E+00,
     &4.5000E-01,9.0000E-01,1.0263E+01,1.0263E+01,1.1710E+00,1.1710E+00,
     &1.5600E-01,5.0000E-01,6.1200E-01,3.0000E-01,
     &1.0000E+00,0.0000E+00,1.0000E+00,0.0000E+00,3.5000E+00,2.0000E+00,
     &6.0000E-01,6.0000E-01,1.1000E+00,1.1000E+00,3.000E+00 /

C  parameter set for   2212 (GRV94 LO)    -2212 (GRV94 LO)
      DATA (IDPtab(k,  2),k=1,8) /
     &    2212,     5,     6,     0, -2212,     5,     6,     0 /
      DATA (XDPtab(k,  2),k=1,27) /
     &1.1000E+00,2.5000E-01,6.3870E+00,6.3870E+00,1.1610E+00,1.1610E+00,
     &4.5000E-01,9.0000E-01,1.5174E+01,1.5174E+01,1.5400E+00,1.5400E+00,
     &1.5600E-01,5.0000E-01,6.1200E-01,3.0000E-01,
     &1.0000E+00,0.0000E+00,1.0000E+00,0.0000E+00,3.5000E+00,2.0000E+00,
     &6.0000E-01,6.0000E-01,1.1000E+00,1.1000E+00,3.000E+00 /

C  parameter set for     22 (GRV-G LO)     2212 (GRV94 LO)
      DATA (IDPtab(k,  3),k=1,8) /
     &      22,     5,     3,     0,  2212,     5,     6,     0 /
      DATA (XDPtab(k,  3),k=1,27) /
     &1.0970E+00,2.5000E-01,2.7450E+00,6.8270E+00,1.2250E+00,1.1360E+00,
     &5.0000E-01,1.0000E+00,4.7210E+00,1.1740E+01,4.6200E-01,4.2800E-01,
     &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
     &4.3100E-03,8.0000E-05,1.0000E+00,0.0000E+00,3.2000E+00,1.0000E+00,
     &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /

C  parameter set for     22 (GRV-G LO)       22 (GRV-G LO)
      DATA (IDPtab(k,  4),k=1,8) /
     &      22,     5,     3,     0,    22,     5,     3,     0 /
      DATA (XDPtab(k,  4),k=1,27) /
     &1.0970E+00,2.5000E-01,2.7450E+00,2.7450E+00,1.2250E+00,1.2250E+00,
     &5.0000E-01,1.0000E+00,4.7210E+00,4.7210E+00,4.6200E-01,4.6200E-01,
     &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
     &4.3100E-03,8.0000E-05,4.3100E-03,8.0000E-05,3.2000E+00,1.0000E+00,
     &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /

C  parameter set for     22 (GRS-G LO)     2212 (GRV94 LO)
      DATA (IDPtab(k,  5),k=1,8) /
     &      22,     5,     4,     4,  2212,     5,     6,     0 /
      DATA (XDPtab(k,  5),k=1,27) /
     &1.0970E+00,2.5000E-01,2.7450E+00,6.8270E+00,1.2250E+00,1.1360E+00,
     &5.0000E-01,1.0000E+00,4.7210E+00,1.1740E+01,4.6200E-01,4.2800E-01,
     &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
     &4.3100E-03,8.0000E-05,1.0000E+00,0.0000E+00,3.2000E+00,1.0000E+00,
     &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /

C  parameter set for     22 (GRS-G LO)       22 (GRS-G LO)
      DATA (IDPtab(k,  6),k=1,8) /
     &      22,     5,     4,     4,    22,     5,     4,     4 /
      DATA (XDPtab(k,  6),k=1,27) /
     &1.0970E+00,2.5000E-01,2.7450E+00,2.7450E+00,1.2250E+00,1.2250E+00,
     &5.0000E-01,1.0000E+00,4.7210E+00,4.7210E+00,4.6200E-01,4.6200E-01,
     &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
     &4.3100E-03,8.0000E-05,4.3100E-03,8.0000E-05,3.2000E+00,1.0000E+00,
     &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /

C  parameter set for     22 (SaS-1D  )       22 (SaS-1D  )
      DATA (IDPtab(k,  7),k=1,8) /
     &      22,     1,     1,     4,    22,     1,     1,     4 /
      DATA (XDPtab(k,  7),k=1,27) /
     &1.0970E+00,2.5000E-01,3.1170E+00,3.1170E+00,1.3450E+00,1.3450E+00,
     &3.0200E-01,1.0000E+00,6.6050E+00,6.6050E+00,1.7500E-01,1.7500E-01,
     &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
     &4.0900E-03,9.0000E-05,4.0900E-03,9.0000E-05,3.2000E+00,1.0000E+00,
     &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /

C  parameter set for     22 (SaS-1M  )       22 (SaS-1M  )
      DATA (IDPtab(k,  8),k=1,8) /
     &      22,     1,     2,     4,    22,     1,     2,     4 /
      DATA (XDPtab(k,  8),k=1,27) /
     &1.0970E+00,2.5000E-01,2.5540E+00,2.5540E+00,1.0910E+00,1.0910E+00,
     &5.0000E-01,1.0000E+00,4.2580E+00,4.2580E+00,4.9000E-01,4.9000E-01,
     &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
     &4.5700E-03,1.0000E-04,4.5700E-03,1.0000E-04,3.2000E+00,1.0000E+00,
     &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /

C  parameter set for     22 (SaS-2D  )       22 (SaS-2D  )
      DATA (IDPtab(k,  9),k=1,8) /
     &      22,     1,     3,     4,    22,     1,     3,     4 /
      DATA (XDPtab(k,  9),k=1,27) /
     &1.0970E+00,2.5000E-01,2.5330E+00,2.5330E+00,1.1340E+00,1.1340E+00,
     &5.0100E-01,1.0000E+00,4.2300E+00,4.2300E+00,4.9300E-01,4.9300E-01,
     &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
     &4.5900E-03,1.0000E-04,4.5900E-03,1.0000E-04,3.2000E+00,1.0000E+00,
     &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /

C  parameter set for     22 (SaS-2M  )       22 (SaS-2M  )
      DATA (IDPtab(k, 10),k=1,8) /
     &      22,     1,     4,     4,    22,     1,     4,     4 /
      DATA (XDPtab(k, 10),k=1,27) /
     &1.0970E+00,2.5000E-01,2.8220E+00,2.8220E+00,1.0910E+00,1.0910E+00,
     &4.9100E-01,1.0000E+00,4.6870E+00,4.6870E+00,4.5800E-01,4.5800E-01,
     &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
     &4.6600E-03,3.0000E-05,4.6600E-03,3.0000E-05,3.2000E+00,1.0000E+00,
     &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /

C  parameter set for     22 (LAC     )     2212 (GRV94 LO)
      DATA (IDPtab(k, 11),k=1,8) /
     &      22,     3,     1,     3,  2212,     5,     6,     0 /
      DATA (XDPtab(k, 11),k=1,27) /
     &1.0970E+00,2.5000E-01,3.3050E+00,6.8270E+00,9.4500E-01,1.1360E+00,
     &4.5000E-01,1.0000E+00,6.7120E+00,1.1740E+01,2.5800E-01,4.6200E-01,
     &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
     &3.3400E-03,2.4000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
     &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /

C  parameter set for     22 (PDFLIB2 )     2212 (GRV94 LO)
      DATA (IDPtab(k, 12),k=1,8) /
     &      22,     3,     1,     2,  2212,     5,     6,     0 /
      DATA (XDPtab(k, 12),k=1,27) /
     &1.0970E+00,2.5000E-01,3.3050E+00,6.8270E+00,9.4500E-01,1.1360E+00,
     &4.5000E-01,1.0000E+00,6.7120E+00,1.1740E+01,2.5800E-01,4.6200E-01,
     &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
     &3.3400E-03,2.4000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
     &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /

C  parameter set for     22 (LAC     )       22 (LAC     )
      DATA (IDPtab(k, 13),k=1,8) /
     &      22,     3,     1,     3,    22,     3,     1,     3 /
      DATA (XDPtab(k, 13),k=1,27) /
     &1.0970E+00,2.5000E-01,3.3050E+00,3.3050E+00,9.4500E-01,9.4500E-01,
     &4.5000E-01,1.0000E+00,6.7120E+00,6.7120E+00,2.5800E-01,2.5800E-01,
     &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
     &3.3400E-03,2.4000E-04,3.3400E-03,2.4000E-04,2.0000E+00,1.0000E+00,
     &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /

C  parameter set for     22 (PDFLIB2 )       22 (PDFLIB2 )
      DATA (IDPtab(k, 14),k=1,8) /
     &      22,     3,     1,     2,    22,     3,     1,     2 /
      DATA (XDPtab(k, 14),k=1,27) /
     &1.0970E+00,2.5000E-01,3.3050E+00,3.3050E+00,9.4500E-01,9.4500E-01,
     &4.5000E-01,1.0000E+00,6.7120E+00,6.7120E+00,2.5800E-01,2.5800E-01,
     &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
     &3.3400E-03,2.4000E-04,3.3400E-03,2.4000E-04,2.0000E+00,1.0000E+00,
     &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /

C  parameter set for     22 (LAC     )     2212 (GRV94 LO)
      DATA (IDPtab(k, 15),k=1,8) /
     &      22,     3,     2,     3,  2212,     5,     6,     0 /
      DATA (XDPtab(k, 15),k=1,27) /
     &1.0970E+00,2.5000E-01,3.1450E+00,6.8270E+00,1.0490E+00,1.1360E+00,
     &4.5000E-01,1.0000E+00,6.3680E+00,1.1740E+01,1.4700E-01,4.6200E-01,
     &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
     &3.8700E-03,1.1000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
     &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /

C  parameter set for     22 (PDFLIB2 )     2212 (GRV94 LO)
      DATA (IDPtab(k, 16),k=1,8) /
     &      22,     3,     2,     2,  2212,     5,     6,     0 /
      DATA (XDPtab(k, 16),k=1,27) /
     &1.0970E+00,2.5000E-01,3.1450E+00,6.8270E+00,1.0490E+00,1.1360E+00,
     &4.5000E-01,1.0000E+00,6.3680E+00,1.1740E+01,1.4700E-01,4.6200E-01,
     &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
     &3.8700E-03,1.1000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
     &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /

C  parameter set for     22 (LAC     )       22 (LAC     )
      DATA (IDPtab(k, 17),k=1,8) /
     &      22,     3,     2,     3,    22,     3,     2,     3 /
      DATA (XDPtab(k, 17),k=1,27) /
     &1.0970E+00,2.5000E-01,3.1450E+00,3.1450E+00,1.0490E+00,1.0490E+00,
     &4.5000E-01,1.0000E+00,6.3680E+00,6.3680E+00,1.4700E-01,1.4700E-01,
     &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
     &3.8700E-03,1.1000E-04,3.8700E-03,1.0000E-04,2.0000E+00,1.0000E+00,
     &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /

C  parameter set for     22 (PDFLIB2 )       22 (PDFLIB2 )
      DATA (IDPtab(k, 18),k=1,8) /
     &      22,     3,     2,     2,    22,     3,     2,     2 /
      DATA (XDPtab(k, 18),k=1,27) /
     &1.0970E+00,2.5000E-01,3.1450E+00,3.1450E+00,1.0490E+00,1.0490E+00,
     &4.5000E-01,1.0000E+00,6.3680E+00,6.3680E+00,1.4700E-01,1.4700E-01,
     &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
     &3.8700E-03,1.1000E-04,3.8700E-03,1.0000E-04,2.0000E+00,1.0000E+00,
     &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /

C  parameter set for     22 (LAC     )     2212 (GRV94 LO)
      DATA (IDPtab(k, 19),k=1,8) /
     &      22,     3,     3,     3,  2212,     5,     6,     0 /
      DATA (XDPtab(k, 19),k=1,27) /
     &1.0970E+00,2.5000E-01,3.0510E+00,6.8270E+00,1.0500E+00,1.1360E+00,
     &4.5000E-01,1.0000E+00,6.0060E+00,1.1740E+01,2.0500E-01,4.6200E-01,
     &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
     &4.0200E-03,1.0000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
     &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /

C  parameter set for     22 (PDFLIB2 )     2212 (GRV94 LO)
      DATA (IDPtab(k, 20),k=1,8) /
     &      22,     3,     3,     2,  2212,     5,     6,     0 /
      DATA (XDPtab(k, 20),k=1,27) /
     &1.0970E+00,2.5000E-01,3.0510E+00,6.8270E+00,1.0500E+00,1.1360E+00,
     &4.5000E-01,1.0000E+00,6.0060E+00,1.1740E+01,2.0500E-01,4.6200E-01,
     &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
     &4.0200E-03,1.0000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
     &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /

C  parameter set for     22 (LAC     )       22 (LAC     )
      DATA (IDPtab(k, 21),k=1,8) /
     &      22,     3,     3,     3,    22,     3,     3,     3 /
      DATA (XDPtab(k, 21),k=1,27) /
     &1.0970E+00,2.5000E-01,3.0510E+00,3.0510E+00,1.0500E+00,1.0500E+00,
     &4.5000E-01,1.0000E+00,6.0060E+00,6.0060E+00,2.0500E-01,2.0500E-01,
     &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
     &4.0200E-03,1.0000E-04,4.0200E-03,1.0000E-04,2.0000E+00,1.0000E+00,
     &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /

C  parameter set for     22 (PDFLIB2 )       22 (PDFLIB2 )
      DATA (IDPtab(k, 22),k=1,8) /
     &      22,     3,     3,     2,    22,     3,     3,     2 /
      DATA (XDPtab(k, 22),k=1,27) /
     &1.0970E+00,2.5000E-01,3.0510E+00,3.0510E+00,1.0500E+00,1.0500E+00,
     &4.5000E-01,1.0000E+00,6.0060E+00,6.0060E+00,2.0500E-01,2.0500E-01,
     &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
     &4.0200E-03,1.0000E-04,4.0200E-03,1.0000E-04,2.0000E+00,1.0000E+00,
     &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /

**anfe 12.01.2016 fix for gamma nucleus
C  parameter set for     22 (GRV-G LO)     2112 (GRV94 LO)
      DATA (IDPtab(k,  23),k=1,8) /
     &      22,     5,     3,     0,  2112,     5,     6,     0 /
      DATA (XDPtab(k,  23),k=1,27) /
     &1.0970E+00,2.5000E-01,2.7450E+00,6.8270E+00,1.2250E+00,1.1360E+00,
     &5.0000E-01,1.0000E+00,4.7210E+00,1.1740E+01,4.6200E-01,4.2800E-01,
     &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
     &4.3100E-03,8.0000E-05,1.0000E+00,0.0000E+00,3.2000E+00,1.0000E+00,
     &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /

      DATA CNAME8 /'        '/
      DATA CNAM10 /'          '/
      DATA INIT / 0 /
      DATA IFPAS / 0, 0 /

      IF((INIT.EQ.1).AND.
     &   (IFPAP(1).EQ.IFPAS(1)).AND.(IFPAP(2).EQ.IFPAS(2))) GOTO 1300

      INIT=1

C  parton distribution functions
      CALL PHO_ACTPDF(IFPAP(1),1)
      CALL PHO_GETPDF(1,PDFNA1,ALAM2,Q2MIN,Q2MAX,XMIN,XMAX)
      CALL PHO_ACTPDF(IFPAP(2),2)
      CALL PHO_GETPDF(2,PDFNA2,ALAM2,Q2MIN,Q2MAX,XMIN,XMAX)
C  initialize alpha_s calculation
      DUMMY = PHO_ALPHAS(0.D0,-4)

      IF(IDEB(54).GE.0) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,I7,2X,A,3I7)') 'PHO_FITPAR: looking for PDF',
     &    IFPAP(1),PDFNA1,IGRP(1),ISET(1),IEXT(1)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I7,2X,A,3I7)') 'PHO_FITPAR: looking for PDF',
     &    IFPAP(2),PDFNA2,IGRP(2),ISET(2),IEXT(2)
      ENDIF

      IFOUND = 0

C  load parameter set from internal tables
      I1 = 1
      I2 = 2
 110  CONTINUE

      DO I=1,Max_tab
        IF((IFPAP(I1).EQ.IDPtab(1,I))
     &     .AND.(IGRP(I1).EQ.IDPtab(2,I))
     &     .AND.(ISET(I1).EQ.IDPtab(3,I))
     &     .AND.(IEXT(I1).EQ.IDPtab(4,I))) THEN
          IF((IFPAP(I2).EQ.IDPtab(5,I))
     &       .AND.(IGRP(I2).EQ.IDPtab(6,I))
     &       .AND.(ISET(I2).EQ.IDPtab(7,I))
     &       .AND.(IEXT(I2).EQ.IDPtab(8,I))) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(/1X,A)')
     &        'PHO_FITPAR: parameter set found in internal table'
            ALPOM    = XDPtab(1,I)
            ALPOMP   = XDPtab(2,I)
            GP(I1)   = XDPtab(3,I)
            GP(I2)   = XDPtab(4,I)
            B0POM(I1) = XDPtab(5,I)
            B0POM(I2) = XDPtab(6,I)
            ALREG    = XDPtab(7,I)
            ALREGP   = XDPtab(8,I)
            GR(I1)   = XDPtab(9,I)
            GR(I2)   = XDPtab(10,I)
            B0REG(I1) = XDPtab(11,I)
            B0REG(I2) = XDPtab(12,I)
            GPPP     = XDPtab(13,I)
            B0PPP    = XDPtab(14,I)
            GPPR     = XDPtab(15,I)
            B0PPR    = XDPtab(16,I)
            VDMFAC(2*I1-1) = XDPtab(17,I)
            VDMFAC(2*I1)   = XDPtab(18,I)
            VDMFAC(2*I2-1) = XDPtab(19,I)
            VDMFAC(2*I2)   = XDPtab(20,I)
            B0HAR    = XDPtab(21,I)
            AKFAC    = XDPtab(22,I)
            PHISUP(I1) = XDPtab(23,I)
            PHISUP(I2) = XDPtab(24,I)
            RMASS(I1) = XDPtab(25,I)
            RMASS(I2) = XDPtab(26,I)
            VAR      = XDPtab(27,I)
            IFOUND = 1
            GOTO 1200
          ENDIF
        ENDIF
      ENDDO

      IF(I1.EQ.1) THEN
        I1 = 2
        I2 = 1
        GOTO 110
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A)')
     &    'PHO_FITPAR: parameter set not found in internal table'
      ENDIF

 1200 CONTINUE

C  get parameters of soft cross sections from dpmjpar.dat
      IF(IPAMDL(99).GT.IFOUND) THEN

        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A)')
     &    'PHO_FITPAR: loading parameter set from file dpmjpar.dat'
c         CALL OAUXFI('dpmjpar.dat', 1,'OLD',IERR)
c         IF (IERR.GT.0) GOTO 1010
cdh     OPEN(12,FILE='dpmjpar.dat',ERR=1010,STATUS='OLD')
c  modification for use with corsika using path to data file in DATADIR
        OPEN(12,ERR=1010,STATUS='OLD',
     &    FILE=DATADIR(1:INDEX(DATADIR,' ')-1)//'dpmjpar.dat')

 100    CONTINUE
          READ(12,'(A8)',ERR=1020,END=1010) CNAME8
          IF(CNAME8.EQ.'STOP') GOTO 1010
          IF(CNAME8.EQ.'NEXTDATA') THEN
            READ(12,'(I8,2X,A8,3I6)',ERR=1020,END=1010)
     &        IDPA1,CNAME8,INUM
            IF((IDPA1.EQ.IFPAP(1)).AND.(CNAME8.EQ.PDFNA1)
     &         .AND.(INUM(1).EQ.IGRP(1)).AND.(INUM(2).EQ.ISET(1))) THEN
              READ(12,'(I8,2X,A8,3I6)',ERR=1020,END=1010)
     &          IDPA2,CNAME8,INUM
              IF((IDPA2.EQ.IFPAP(2)).AND.(CNAME8.EQ.PDFNA2).AND.
     &           (INUM(1).EQ.IGRP(2)).AND.(INUM(2).EQ.ISET(2))) THEN
                IF (LPRI.GT.4)
     &          WRITE(LO,'(/1X,A)') 'PHO_FITPAR: parameter set found'
                READ(12,*) ALPOM,ALPOMP,GP,B0POM
                READ(12,*) ALREG,ALREGP,GR,B0REG
                READ(12,*) GPPP,B0PPP,GPPR,B0PPR
                READ(12,*) VDMFAC(1),VDMFAC(2),VDMFAC(3),VDMFAC(4)
                READ(12,*) B0HAR
                READ(12,*) AKFAC
                READ(12,*) PHISUP
                READ(12,*) RMASS,VAR
                IFOUND = 1
                GOTO 1100
              ENDIF
            ENDIF
          ENDIF
        GOTO 100
        
 1020 CONTINUE
cc     --------------- conditional added (mar'04)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/A)') ' PHO_FITPAR: cannot read file dpmjpar.dat'
cc     --------------- conditional added (mar'04)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,A10,A8)') ' last data card: ',CNAM10,CNAME8
 1010 CONTINUE
cc     --------------- conditional added (mar'04)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/A)')
     &    ' PHO_FITPAR: cannot find parameter set in file dpmjpar.dat'

 1100   CONTINUE
        CLOSE(12)

      ENDIF

C  nothing found
      IF (IFOUND.EQ.0) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/A)') ' PHO_FITPAR: could not find parameter set'
        IF (LPRI.GT.4)
     &  WRITE(LO,'(3(10X,A,/))')
     &    '(copy dpmjpar.dat into the working directory and/or',
     &    ' request the missing parameter set via e-mail from',
     &    ' eng@lepton.bartol.udel.edu)'
        STOP
      ENDIF

 1300 CONTINUE

C  overwrite parameters with user settings
      IF(PARMDL(301).GT.DEFA) THEN
        ALPOM     = PARMDL(301)
        PARMDL(301) = DEFB
      ENDIF
      IF(PARMDL(302).GT.DEFA) THEN
        ALPOMP    = PARMDL(302)
        PARMDL(302) = DEFB
      ENDIF
      IF(PARMDL(303).GT.DEFA) THEN
        GP(1)     = PARMDL(303)
        PARMDL(303) = DEFB
      ENDIF
      IF(PARMDL(304).GT.DEFA) THEN
        GP(2)     = PARMDL(304)
        PARMDL(304) = DEFB
      ENDIF
      IF(PARMDL(305).GT.DEFA) THEN
        B0POM(1)  = PARMDL(305)
        PARMDL(305) = DEFB
      ENDIF
      IF(PARMDL(306).GT.DEFA) THEN
        B0POM(2)  = PARMDL(306)
        PARMDL(306) = DEFB
      ENDIF
      IF(PARMDL(307).GT.DEFA) THEN
        ALREG     = PARMDL(307)
        PARMDL(307) = DEFB
      ENDIF
      IF(PARMDL(308).GT.DEFA) THEN
        ALREGP    = PARMDL(308)
        PARMDL(308) = DEFB
      ENDIF
      IF(PARMDL(309).GT.DEFA) THEN
        GR(1)     = PARMDL(309)
        PARMDL(309) = DEFB
      ENDIF
      IF(PARMDL(310).GT.DEFA) THEN
        GR(2)      = PARMDL(310)
        PARMDL(310) = DEFB
      ENDIF
      IF(PARMDL(311).GT.DEFA) THEN
        B0REG(1)  = PARMDL(311)
        PARMDL(311) = DEFB
      ENDIF
      IF(PARMDL(312).GT.DEFA) THEN
        B0REG(2)  = PARMDL(312)
        PARMDL(312) = DEFB
      ENDIF
      IF(PARMDL(313).GT.DEFA) THEN
        GPPP      = PARMDL(313)
        PARMDL(313) = DEFB
      ENDIF
      IF(PARMDL(314).GT.DEFA) THEN
        B0PPP     = PARMDL(314)
        PARMDL(314)= DEFB
      ENDIF
      IF(PARMDL(315).GT.DEFA) THEN
        VDMFAC(1) = PARMDL(315)
        PARMDL(315)= DEFB
      ENDIF
      IF(PARMDL(316).GT.DEFA) THEN
        VDMFAC(2) = PARMDL(316)
        PARMDL(316)= DEFB
      ENDIF
      IF(PARMDL(317).GT.DEFA) THEN
        VDMFAC(3) = PARMDL(317)
        PARMDL(317)= DEFB
      ENDIF
      IF(PARMDL(318).GT.DEFA) THEN
        VDMFAC(4) = PARMDL(318)
        PARMDL(318)= DEFB
      ENDIF
      IF(PARMDL(319).GT.DEFA) THEN
        B0HAR     = PARMDL(319)
        PARMDL(319)= DEFB
      ENDIF
      IF(PARMDL(320).GT.DEFA) THEN
        AKFAC     = PARMDL(320)
        PARMDL(320)= DEFB
      ENDIF
      IF(PARMDL(321).GT.DEFA) THEN
        PHISUP(1) = PARMDL(321)
        PARMDL(321)= DEFB
      ENDIF
      IF(PARMDL(322).GT.DEFA) THEN
        PHISUP(2) = PARMDL(322)
        PARMDL(322)= DEFB
      ENDIF
      IF(PARMDL(323).GT.DEFA) THEN
        RMASS(1)  = PARMDL(323)
        PARMDL(323)= DEFB
      ENDIF
      IF(PARMDL(324).GT.DEFA) THEN
        RMASS(2)  = PARMDL(324)
        PARMDL(324)= DEFB
      ENDIF
      IF(PARMDL(325).GT.DEFA) THEN
        VAR       = PARMDL(325)
        PARMDL(325)= DEFB
      ENDIF
      IF(PARMDL(327).GT.DEFA) THEN
        GPPR      = PARMDL(327)
        PARMDL(327)= DEFB
      ENDIF
      IF(PARMDL(328).GT.DEFA) THEN
        B0PPR     = PARMDL(328)
        PARMDL(328)= DEFB
      ENDIF

      VDMQ2F(1) = VDMFAC(1)
      VDMQ2F(2) = VDMFAC(2)
      VDMQ2F(3) = VDMFAC(3)
      VDMQ2F(4) = VDMFAC(4)

C  output of parameter set
      IF((IDEB(54).GE.5).OR.(IOUTP.GT.0)) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/,A,/,A)') ' PHO_FITPAR: parameter set',
     &                       ' -------------------------'
        IF (LPRI.GT.4)
     &  WRITE(LO,'(2(A,F7.3),2(A,2F9.3))')
     &  '  ALPOM:',ALPOM,' ALPOMP:',ALPOMP,' GP:',GP,' B0POM:',
     &  B0POM
        IF (LPRI.GT.4)
     &  WRITE(LO,'(2(A,F7.3),2(A,2F9.3))')
     &  '  ALREG:',ALREG,' ALREGP:',ALREGP,' GR:',GR,' B0REG:',
     &  B0REG
        IF (LPRI.GT.4)
     &  WRITE(LO,'(4(A,F7.3))')
     &  '  GPPP :',GPPP,' B0PPP:',B0PPP,' GPPR :',GPPR,' B0PPR:',B0PPR
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,4F10.5)') ' VDMFAC:',VDMFAC
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,4F10.5)') ' VDMQ2F:',VDMQ2F
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,F8.3)')  '  B0HAR:',B0HAR
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,F8.3)')  '  AKFAC:',AKFAC
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,2F8.3)') ' PHISUP:',PHISUP
        IF (LPRI.GT.4)
     &  WRITE(LO,'(A,3F8.3)') '  RMASS:',RMASS,VAR
      ENDIF

      CALL PHO_HARINI(1,IFPAP(1),IFPAP(2),PVIRT(1),PVIRT(2),6,IOUTP-1)

      END


 
 


CDECK  ID>, PHO_FIXCOL
      SUBROUTINE PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
C**********************************************************************
C
C     interface to call PHOJET (fixed energy run) with
C     collider kinematics
C
C     equivalen photon approximation to get photon flux
C
C     input:     NEV     number of events to generate
C                THETA   azimuthal angle (micro radians)
C                PHI     beam crossing angle
C                        (with respect to x, in degrees)
C                E1      energy of particle 1 (+z direction, GeV)
C                E2      energy of particle 2 (-z direction, GeV)
C
C     note: particle types have to be specified before
C           with PHO_SETPAR
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER(TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  general process information
      INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
      COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)

C  global event kinematics and particle IDs
      INTEGER IFPAP,IFPAB
      DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
      COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
      INTEGER IDEQP,IDEQB,IHFLD,IHFLS
      DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
      COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
     &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)

C  integration precision for hard cross sections (obsolete)
      INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
      COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO

C  event weights and generated cross section
      INTEGER IPOWGC,ISWCUT,IVWGHT
      DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
      COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
     &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
      DOUBLE PRECISION PHO_PMASS
      EXTERNAL         PHO_PMASS

      DIMENSION P1(4),P2(4)

C  remnant initialization (only needed for DPMJET)
      ISAVP1 = IFPAP(1)
      ISAVB1 = IFPAB(1)
      IF(IFPAP(1).EQ.81) THEN
        IFPAP(1) = IDEQP(1)
        IFPAB(1) = IDEQB(1)
      ENDIF
      ISAVP2 = IFPAP(2)
      ISAVB2 = IFPAB(2)
      IF(IFPAP(2).EQ.82) THEN
        IFPAP(2) = IDEQP(2)
        IFPAB(2) = IDEQB(2)
      ENDIF
      PMASS1 = PHO_PMASS(IFPAB(1),0)-SQRT(PVIRT(1))
      PMASS2 = PHO_PMASS(IFPAB(2),0)-SQRT(PVIRT(2))
      PP1 = SQRT(E1**2-PMASS1**2)
      PP2 = SQRT(E2**2-PMASS2**2)
C  beam crossing angle
      TH = 1.D-6*THETA/2.D0
      PH = PHI*BOG
      P1(1) = PP1*SIN(TH)*COS(PH)
      P1(2) = PP1*SIN(TH)*SIN(PH)
      P1(3) = PP1*COS(TH)
      P1(4) = E1
      P2(1) = PP2*SIN(TH)*COS(PH)
      P2(2) = PP2*SIN(TH)*SIN(PH)
      P2(3) = -PP2*COS(TH)
      P2(4) = E2
      CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
      IFPAP(1) = ISAVP1
      IFPAB(1) = ISAVB1
      IFPAP(2) = ISAVP2
      IFPAB(2) = ISAVB2
      ITRY = 0
      CALL PHO_PHIST(-1,SIGMAX)
      CALL PHO_LHIST(-1,SIGMAX)
C  test of DPMJET interface (default is IPAMDL(13)=0)
      if(IPAMDL(13).gt.0) then
        MODE = IPAMDL(13)
        IPAMDL(13) = 0
      else
        MODE = 1
      endif
C  main generation loop
      DO 50 I=1,NEV
 55     CONTINUE
        ITRY = ITRY+1
        CALL PHO_EVENT(MODE,P1,P2,SIGCUR,IREJ)
        IF(IREJ.NE.0) GOTO 55
        CALL PHO_PHIST(1,HSWGHT(0))
        CALL PHO_LHIST(1,HSWGHT(0))
 50   CONTINUE

      IF(NEV.GT.0) THEN
        SIGMAX = SIGMAX*DBLE(NEV)/DBLE(ITRY)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
     &  '=========================================================',
     &  ' *****   simulated cross section: ',SIGMAX,' mb  *****',
     &  '========================================================='
        CALL PHO_EVENT(-2,P1,P2,SIGCUR,IREJ)
        CALL PHO_PHIST(-2,SIGMAX)
        CALL PHO_LHIST(-2,SIGMAX)
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I5)') 'PHO_FIXCOL: no events simulated',NEV
      ENDIF

      END


 
 


CDECK  ID>, PHO_FIXLAB
      SUBROUTINE PHO_FIXLAB(PLAB,NEV)
C**********************************************************************
C
C     interface to call PHOJET (fixed energy run) with
C     LAB kinematics (second particle as target)
C
C     equivalent photon approximation to get photon flux
C
C     input:     NEV     number of events to generate
C                PLAB    LAB momentum of particle 1
C
C     note: particle types have to be specified before
C           with PHO_SETPAR
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  general process information
      INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
      COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)

C  global event kinematics and particle IDs
      INTEGER IFPAP,IFPAB
      DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
      COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
      INTEGER IDEQP,IDEQB,IHFLD,IHFLS
      DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
      COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
     &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)

C  integration precision for hard cross sections (obsolete)
      INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
      COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO

C  event weights and generated cross section
      INTEGER IPOWGC,ISWCUT,IVWGHT
      DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
      COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
     &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
      DOUBLE PRECISION PHO_PMASS
      EXTERNAL         PHO_PMASS

      DIMENSION P1(4),P2(4)

C  remnant initialization (only needed for DPMJET)
      SPCM = PLAB
      ISAVP1 = IFPAP(1)
      ISAVB1 = IFPAB(1)
      IF(IFPAP(1).EQ.81) THEN
        IFPAP(1) = IDEQP(1)
        IFPAB(1) = IDEQB(1)
      ENDIF
      ISAVP2 = IFPAP(2)
      ISAVB2 = IFPAB(2)
      IF(IFPAP(2).EQ.82) THEN
        IFPAP(2) = IDEQP(2)
        IFPAB(2) = IDEQB(2)
      ENDIF
C  get momenta in LAB system
      PMASS1 = PHO_PMASS(IFPAB(1),0)**2-PVIRT(1)
      PMASS2 = PHO_PMASS(IFPAB(2),0)**2-PVIRT(2)
      IF(PMASS2.LT.0.1D0) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,2A,2I7)') 'PHO_FIXLAB:ERROR: ',
     &    'no LAB system possible',IFPAB(1),IFPAB(2)
      ELSE
        P1(1) = 0.D0
        P1(2) = 0.D0
        P1(3) = PLAB
        P1(4) = SQRT(PMASS1+PLAB**2)
        P2(1) = 0.D0
        P2(2) = 0.D0
        P2(3) = 0.D0
        P2(4) = SQRT(PMASS2)
        CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
        IFPAP(1) = ISAVP1
        IFPAB(1) = ISAVB1
        IFPAP(2) = ISAVP2
        IFPAB(2) = ISAVB2
        ITRY = 0
        CALL PHO_PHIST(-1,SIGMAX)
        CALL PHO_LHIST(-1,SIGMAX)
C  event generation loop
        DO 40 I=1,NEV
 45       CONTINUE
          ITRY = ITRY+1
          CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
          IF(IREJ.NE.0) GOTO 45
          CALL PHO_LHIST(1,HSWGHT(0))

          CALL PHO_PHIST(10,HSWGHT(0))

 40     CONTINUE
        IF(NEV.GT.0) THEN
          SIGMAX = SIGMAX*DBLE(NEV)/DBLE(ITRY)
          IF (LPRI.GT.4)
     &    WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
     &    '=========================================================',
     &    ' *****   simulated cross section: ',SIGMAX,' mb  *****',
     &    '========================================================='
          CALL PHO_EVENT(-2,P1,P2,SIGCUR,IREJ)
          CALL PHO_PHIST(-2,SIGMAX)
          CALL PHO_LHIST(-2,SIGMAX)
        ELSE
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,I5)')
     &      'PHO_FIXLAB: no events simulated',NEV
        ENDIF
      ENDIF

      END


 
 


CDECK  ID>, PHO_FLAUX
      SUBROUTINE PHO_FLAUX(EQUARK,K)
C***********************************************************************
C
C    auxiliary subroutine to select flavours
C
C********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( DEPS   =  1.D-14 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  some hadron information, will be deleted in future versions
      INTEGER NFS
      DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
      COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS

      DIMENSION WGHT(9)

C  calculate weights for given energy
      IF(EQUARK.LT.QMASS(1)) THEN
        IF(IDEB(16).GE.5 .AND. LPRI.GT.4)
     &    WRITE(LO,'(1X,A,E12.3)') 'PHO_FLAUX: VERY SMALL MASS',
     &      EQUARK
        WGHT(1) = 0.5D0
        WGHT(2) = 0.5D0
        WGHT(3) = 0.D0
        WGHT(4) = 0.D0
        SUM = 1.D0
      ELSE
        SUM = 0.D0
        DO 305 K=1,NFS
          IF(EQUARK.GT.QMASS(K)) THEN
            WGHT(K) = PHO_BETAF(EQUARK,QMASS(K),BET)
          ELSE
            WGHT(K) = 0.D0
          ENDIF
          SUM = SUM + WGHT(K)
 305    CONTINUE
      ENDIF
C  sample flavours
      XI = SUM*(DT_RNDM(SUM)-DEPS)
      K = 0
      SUM = 0.D0
 400  CONTINUE
        K = K+1
        SUM = SUM + WGHT(K)
      IF(XI.GT.SUM) GOTO 400
C  debug output
      IF(IDEB(16).GE.20) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I5)') 'PHO_FLAUX: selected flavour',K
      ENDIF
      END


 
 


CDECK  ID>, PHO_FRAINI
      SUBROUTINE PHO_FRAINI(IDEFAU)
C***********************************************************************
C
C     initialization of fragmentation packages
C      (currently LUND JETSET)
C
C     initialization for JETSET call in DTUNUC 1.04 (J.R. 6/93)
C                      changed to work in PHOJET   (R.E. 1/94)
C
C     input:  IDEFAU    0  no hadronization at all
C                       1  do not touch any parameter of JETSET
C                       2  default parameters kept, decay length 10mm to
C                          define stable particles
C                       3  load tuned parameters for JETSET 7.3
C             neg. value:  prevent strange/charm hadrons from decaying
C
C***********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER (EPS=1.D-10)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

      INTEGER MAXLND, N,NPAD,K
      DOUBLE PRECISION P,V
      PARAMETER (MAXLND=12000)
      COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
      SAVE /PYJETS/

      INTEGER MSTU,MSTJ
      DOUBLE PRECISION PARU,PARJ
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      SAVE /PYDAT1/

      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      SAVE /PYDAT2/

      COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
      SAVE /PYDAT3/

      INTEGER PYCOMP

      IDEFAB = ABS(IDEFAU)

      IF(IDEFAB.EQ.0) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A)') 'PHO_FRAINI: hadronization switched off'
        RETURN
      ENDIF
C  defaults
      DEF2  = PARJ(2)
      IDEF12 = MSTJ(12)
      DEF19 = PARJ(19)
      DEF41 = PARJ(41)
      DEF42 = PARJ(42)
      DEF21 = PARJ(21)

C  declare stable particles
      IF(IDEFAB.GE.2) MSTJ(22) = 2

C  load optimized parameters
**anfe try PYTHIA default
      IF(IDEFAB.GE.3.AND..FALSE.) THEN

*       PARJ(19)=0.19
C  Lund a-parameter
C  (default=0.3)
        PARJ(41)=0.3D0
C  Lund b-parameter
C  (default=1.0)
        PARJ(42)=1.0D0
C  Lund sigma parameter in pt distribution
C  (default=0.36)
**anfe 26.08.2015 fragmentation parameters        
        PARJ(1) = 0.09D0
        PARJ(2) = 0.22D0
        PARJ(3) = 0.9D0
        PARJ(5) = 0.1D0
        PARJ(7) = 0.95D0
        PARJ(21)=0.42D0
      ENDIF
C
C  prevent particles decaying
      IF(IDEFAU.LT.0) THEN
C                 K0S
        KC=PYCOMP(310)
        MDCY(KC,1)=0
C                 PI0
        KC=PYCOMP(111)
        MDCY(KC,1)=0
C                 LAMBDA
        KC=PYCOMP(3122)
        MDCY(KC,1)=0
C                 ALAMBDA
        KC=PYCOMP(-3122)
        MDCY(KC,1)=0
C                 SIG+
        KC=PYCOMP(3222)
        MDCY(KC,1)=0
C                 ASIG+
        KC=PYCOMP(-3222)
        MDCY(KC,1)=0
C                 SIG-
        KC=PYCOMP(3112)
        MDCY(KC,1)=0
C                 ASIG-
        KC=PYCOMP(-3112)
        MDCY(KC,1)=0
C                 SIG0
        KC=PYCOMP(3212)
        MDCY(KC,1)=0
C                 ASIG0
        KC=PYCOMP(-3212)
        MDCY(KC,1)=0
C                 TET0   ( = Xi(0) )
        KC=PYCOMP(3322)
        MDCY(KC,1)=0
C                 ATET0  ( = anti-Xi(0) )
        KC=PYCOMP(-3322)
        MDCY(KC,1)=0
C                 TET-   ( = Xi(-) )
        KC=PYCOMP(3312)
        MDCY(KC,1)=0
C                 ATET-  ( = anti-Xi(-) )
        KC=PYCOMP(-3312)
        MDCY(KC,1)=0
C                 OMEGA-
        KC=PYCOMP(3334)
        MDCY(KC,1)=0
C                 AOMEGA-
        KC=PYCOMP(-3334)
        MDCY(KC,1)=0
C                 D+
        KC=PYCOMP(411)
        MDCY(KC,1)=0
C                 D-
        KC=PYCOMP(-411)
        MDCY(KC,1)=0
C                 D0
        KC=PYCOMP(421)
        MDCY(KC,1)=0
C                 A-D0
        KC=PYCOMP(-421)
        MDCY(KC,1)=0
C                 DS+
        KC=PYCOMP(431)
        MDCY(KC,1)=0
C                 A-DS+
        KC=PYCOMP(-431)
        MDCY(KC,1)=0
C                ETAC
        KC=PYCOMP(441)
        MDCY(KC,1)=0
C                LAMBDAC+
        KC=PYCOMP(4122)
        MDCY(KC,1)=0
C                A-LAMBDAC+
        KC=PYCOMP(-4122)
        MDCY(KC,1)=0
C                SIGMAC++
        KC=PYCOMP(4222)
        MDCY(KC,1)=0
C                SIGMAC+
        KC=PYCOMP(4212)
        MDCY(KC,1)=0
C                SIGMAC0
        KC=PYCOMP(4112)
        MDCY(KC,1)=0
C                A-SIGMAC++
        KC=PYCOMP(-4222)
        MDCY(KC,1)=0
C                A-SIGMAC+
        KC=PYCOMP(-4212)
        MDCY(KC,1)=0
C                A-SIGMAC0
        KC=PYCOMP(-4112)
        MDCY(KC,1)=0
C                KSIC+     ( = Xi_C(+) )
        KC=PYCOMP(4232)
        MDCY(KC,1)=0
C                KSIC0     ( = Xi_C(0) )
        KC=PYCOMP(4132)
        MDCY(KC,1)=0
C                A-KSIC+   ( = anti-Xi_C(+) )
        KC=PYCOMP(-4232)
        MDCY(KC,1)=0
C                A-KSIC0   ( = anti-Xi_C(0) )
        KC=PYCOMP(-4132)
        MDCY(KC,1)=0
      ENDIF

      IF (LPRI.GT.4)
     &WRITE(LO,2355) IDEFAU,DEF2,PARJ(2),IDEF12,MSTJ(12),
     &  DEF19,PARJ(19),DEF41,PARJ(41),DEF42,PARJ(42),DEF21,PARJ(21)
 2355 FORMAT(/' PHO_FRAINI: fragmentation initialization ISWMDL(6)',I3/,
     &        ' --------------------------------------------------',/,
     & 5X,'parameter description               default / current',/,
     & 5X,'PARJ( 2) strangeness suppression : ',2F7.3,/,
     & 5X,'MSTJ(12) popcorn                 : ',2I7,/,
     & 5X,'PARJ(19) popcorn                 : ',2F7.3,/,
     & 5X,'PARJ(41) Lund a                  : ',2F7.3,/,
     & 5X,'PARJ(42) Lund b                  : ',2F7.3,/,
     & 5X,'PARJ(21) sigma in pt distribution: ',2F7.3,/)

      END


 
 


CDECK  ID>, PHO_GAUDAT
      SUBROUTINE PHO_GAUDAT
C*********************************************************************
C
C     store big arrays needed for Gauss integral, CERNLIB D106BD
C     (arrays A,X,ITAB copied on B,Y,LTAB)
C
C*********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      COMMON /POGDAT/ B(273),Y(273),LTAB(96)

      DIMENSION       A(273),X(273),KTAB(96)

C-----TABLE OF INITIAL SUBSCRIPTS FOR N=2(1)16(4)96
      DATA KTAB(2)/1/
      DATA KTAB(3)/2/
      DATA KTAB(4)/4/
      DATA KTAB(5)/6/
      DATA KTAB(6)/9/
      DATA KTAB(7)/12/
      DATA KTAB(8)/16/
      DATA KTAB(9)/20/
      DATA KTAB(10)/25/
      DATA KTAB(11)/30/
      DATA KTAB(12)/36/
      DATA KTAB(13)/42/
      DATA KTAB(14)/49/
      DATA KTAB(15)/56/
      DATA KTAB(16)/64/
      DATA KTAB(20)/72/
      DATA KTAB(24)/82/
      DATA KTAB(28)/82/
      DATA KTAB(32)/94/
      DATA KTAB(36)/94/
      DATA KTAB(40)/110/
      DATA KTAB(44)/110/
      DATA KTAB(48)/130/
      DATA KTAB(52)/130/
      DATA KTAB(56)/130/
      DATA KTAB(60)/130/
      DATA KTAB(64)/154/
      DATA KTAB(68)/154/
      DATA KTAB(72)/154/
      DATA KTAB(76)/154/
      DATA KTAB(80)/186/
      DATA KTAB(84)/186/
      DATA KTAB(88)/186/
      DATA KTAB(92)/186/
      DATA KTAB(96)/226/
C
C-----TABLE OF ABSCISSAE (X) AND WEIGHTS (A) FOR INTERVAL (-1,+1).
C
C-----N=2
      DATA X(1)/0.577350269189626D0  /, A(1)/1.000000000000000D0  /
C-----N=3
      DATA X(2)/0.774596669241483D0  /, A(2)/0.555555555555556D0  /
      DATA X(3)/0.000000000000000D0  /, A(3)/0.888888888888889D0  /
C-----N=4
      DATA X(4)/0.861136311594053D0  /, A(4)/0.347854845137454D0  /
      DATA X(5)/0.339981043584856D0  /, A(5)/0.652145154862546D0  /
C-----N=5
      DATA X(6)/0.906179845938664D0  /, A(6)/0.236926885056189D0  /
      DATA X(7)/0.538469310105683D0  /, A(7)/0.478628670499366D0  /
      DATA X(8)/0.000000000000000D0  /, A(8)/0.568888888888889D0  /
C-----N=6
      DATA X(9)/0.932469514203152D0  /, A(9)/0.171324492379170D0  /
      DATA X(10)/0.661209386466265D0 /, A(10)/0.360761573048139D0 /
      DATA X(11)/0.238619186083197D0 /, A(11)/0.467913934572691D0 /
C-----N=7
      DATA X(12)/0.949107912342759D0 /, A(12)/0.129484966168870D0 /
      DATA X(13)/0.741531185599394D0 /, A(13)/0.279705391489277D0 /
      DATA X(14)/0.405845151377397D0 /, A(14)/0.381830050505119D0 /
      DATA X(15)/0.000000000000000D0 /, A(15)/0.417959183673469D0 /
C-----N=8
      DATA X(16)/0.960289856497536D0 /, A(16)/0.101228536290376D0 /
      DATA X(17)/0.796666477413627D0 /, A(17)/0.222381034453374D0 /
      DATA X(18)/0.525532409916329D0 /, A(18)/0.313706645877887D0 /
      DATA X(19)/0.183434642495650D0 /, A(19)/0.362683783378362D0 /
C-----N=9
      DATA X(20)/0.968160239507626D0 /, A(20)/0.081274388361574D0 /
      DATA X(21)/0.836031107326636D0 /, A(21)/0.180648160694857D0 /
      DATA X(22)/0.613371432700590D0 /, A(22)/0.260610696402935D0 /
      DATA X(23)/0.324253423403809D0 /, A(23)/0.312347077040003D0 /
      DATA X(24)/0.000000000000000D0 /, A(24)/0.330239355001260D0 /
C-----N=10
      DATA X(25)/0.973906528517172D0 /, A(25)/0.066671344308688D0 /
      DATA X(26)/0.865063366688985D0 /, A(26)/0.149451349150581D0 /
      DATA X(27)/0.679409568299024D0 /, A(27)/0.219086362515982D0 /
      DATA X(28)/0.433395394129247D0 /, A(28)/0.269266719309996D0 /
      DATA X(29)/0.148874338981631D0 /, A(29)/0.295524224714753D0 /
C-----N=11
      DATA X(30)/0.978228658146057D0 /, A(30)/0.055668567116174D0 /
      DATA X(31)/0.887062599768095D0 /, A(31)/0.125580369464905D0 /
      DATA X(32)/0.730152005574049D0 /, A(32)/0.186290210927734D0 /
      DATA X(33)/0.519096129206812D0 /, A(33)/0.233193764591990D0 /
      DATA X(34)/0.269543155952345D0 /, A(34)/0.262804544510247D0 /
      DATA X(35)/0.000000000000000D0 /, A(35)/0.272925086777901D0 /
C-----N=12
      DATA X(36)/0.981560634246719D0 /, A(36)/0.047175336386512D0 /
      DATA X(37)/0.904117256370475D0 /, A(37)/0.106939325995318D0 /
      DATA X(38)/0.769902674194305D0 /, A(38)/0.160078328543346D0 /
      DATA X(39)/0.587317954286617D0 /, A(39)/0.203167426723066D0 /
      DATA X(40)/0.367831498998180D0 /, A(40)/0.233492536538355D0 /
      DATA X(41)/0.125233408511469D0 /, A(41)/0.249147045813403D0 /
C-----N=13
      DATA X(42)/0.984183054718588D0 /, A(42)/0.040484004765316D0 /
      DATA X(43)/0.917598399222978D0 /, A(43)/0.092121499837728D0 /
      DATA X(44)/0.801578090733310D0 /, A(44)/0.138873510219787D0 /
      DATA X(45)/0.642349339440340D0 /, A(45)/0.178145980761946D0 /
      DATA X(46)/0.448492751036447D0 /, A(46)/0.207816047536889D0 /
      DATA X(47)/0.230458315955135D0 /, A(47)/0.226283180262897D0 /
      DATA X(48)/0.000000000000000D0 /, A(48)/0.232551553230874D0 /
C-----N=14
      DATA X(49)/0.986283808696812D0 /, A(49)/0.035119460331752D0 /
      DATA X(50)/0.928434883663574D0 /, A(50)/0.080158087159760D0 /
      DATA X(51)/0.827201315069765D0 /, A(51)/0.121518570687903D0 /
      DATA X(52)/0.687292904811685D0 /, A(52)/0.157203167158194D0 /
      DATA X(53)/0.515248636358154D0 /, A(53)/0.185538397477938D0 /
      DATA X(54)/0.319112368927890D0 /, A(54)/0.205198463721296D0 /
      DATA X(55)/0.108054948707344D0 /, A(55)/0.215263853463158D0 /
C-----N=15
      DATA X(56)/0.987992518020485D0 /, A(56)/0.030753241996117D0 /
      DATA X(57)/0.937273392400706D0 /, A(57)/0.070366047488108D0 /
      DATA X(58)/0.848206583410427D0 /, A(58)/0.107159220467172D0 /
      DATA X(59)/0.724417731360170D0 /, A(59)/0.139570677926154D0 /
      DATA X(60)/0.570972172608539D0 /, A(60)/0.166269205816994D0 /
      DATA X(61)/0.394151347077563D0 /, A(61)/0.186161000015562D0 /
      DATA X(62)/0.201194093997435D0 /, A(62)/0.198431485327111D0 /
      DATA X(63)/0.000000000000000D0 /, A(63)/0.202578241925561D0 /
C-----N=16
      DATA X(64)/0.989400934991650D0 /, A(64)/0.027152459411754D0 /
      DATA X(65)/0.944575023073233D0 /, A(65)/0.062253523938648D0 /
      DATA X(66)/0.865631202387832D0 /, A(66)/0.095158511682493D0 /
      DATA X(67)/0.755404408355003D0 /, A(67)/0.124628971255534D0 /
      DATA X(68)/0.617876244402644D0 /, A(68)/0.149595988816577D0 /
      DATA X(69)/0.458016777657227D0 /, A(69)/0.169156519395003D0 /
      DATA X(70)/0.281603550779259D0 /, A(70)/0.182603415044924D0 /
      DATA X(71)/0.095012509837637D0 /, A(71)/0.189450610455069D0 /
C-----N=20
      DATA X(72)/0.993128599185094D0 /, A(72)/0.017614007139152D0 /
      DATA X(73)/0.963971927277913D0 /, A(73)/0.040601429800386D0 /
      DATA X(74)/0.912234428251325D0 /, A(74)/0.062672048334109D0 /
      DATA X(75)/0.839116971822218D0 /, A(75)/0.083276741576704D0 /
      DATA X(76)/0.746331906460150D0 /, A(76)/0.101930119817240D0 /
      DATA X(77)/0.636053680726515D0 /, A(77)/0.118194531961518D0 /
      DATA X(78)/0.510867001950827D0 /, A(78)/0.131688638449176D0 /
      DATA X(79)/0.373706088715419D0 /, A(79)/0.142096109318382D0 /
      DATA X(80)/0.227785851141645D0 /, A(80)/0.149172986472603D0 /
      DATA X(81)/0.076526521133497D0 /, A(81)/0.152753387130725D0 /
C-----N=24
      DATA X(82)/0.995187219997021D0 /, A(82)/0.012341229799987D0 /
      DATA X(83)/0.974728555971309D0 /, A(83)/0.028531388628933D0 /
      DATA X(84)/0.938274552002732D0 /, A(84)/0.044277438817419D0 /
      DATA X(85)/0.886415527004401D0 /, A(85)/0.059298584915436D0 /
      DATA X(86)/0.820001985973902D0 /, A(86)/0.073346481411080D0 /
      DATA X(87)/0.740124191578554D0 /, A(87)/0.086190161531953D0 /
      DATA X(88)/0.648093651936975D0 /, A(88)/0.097618652104113D0 /
      DATA X(89)/0.545421471388839D0 /, A(89)/0.107444270115965D0 /
      DATA X(90)/0.433793507626045D0 /, A(90)/0.115505668053725D0 /
      DATA X(91)/0.315042679696163D0 /, A(91)/0.121670472927803D0 /
      DATA X(92)/0.191118867473616D0 /, A(92)/0.125837456346828D0 /
      DATA X(93)/0.064056892862605D0 /, A(93)/0.127938195346752D0 /
C-----N=32
      DATA X(94)/0.997263861849481D0 /, A(94)/0.007018610009470D0 /
      DATA X(95)/0.985611511545268D0 /, A(95)/0.016274394730905D0 /
      DATA X(96)/0.964762255587506D0 /, A(96)/0.025392065309262D0 /
      DATA X(97)/0.934906075937739D0 /, A(97)/0.034273862913021D0 /
      DATA X(98)/0.896321155766052D0 /, A(98)/0.042835898022226D0 /
      DATA X(99)/0.849367613732569D0 /, A(99)/0.050998059262376D0 /
      DATA X(100)/0.794483795967942D0/, A(100)/0.058684093478535D0/
      DATA X(101)/0.732182118740289D0/, A(101)/0.065822222776361D0/
      DATA X(102)/0.663044266930215D0/, A(102)/0.072345794108848D0/
      DATA X(103)/0.587715757240762D0/, A(103)/0.078193895787070D0/
      DATA X(104)/0.506899908932229D0/, A(104)/0.083311924226946D0/
      DATA X(105)/0.421351276130635D0/, A(105)/0.087652093004403D0/
      DATA X(106)/0.331868602282127D0/, A(106)/0.091173878695763D0/
      DATA X(107)/0.239287362252137D0/, A(107)/0.093844399080804D0/
      DATA X(108)/0.144471961582796D0/, A(108)/0.095638720079274D0/
      DATA X(109)/0.048307665687738D0/, A(109)/0.096540088514727D0/
C-----N=40
      DATA X(110)/0.998237709710559D0/, A(110)/0.004521277098533D0/
      DATA X(111)/0.990726238699457D0/, A(111)/0.010498284531152D0/
      DATA X(112)/0.977259949983774D0/, A(112)/0.016421058381907D0/
      DATA X(113)/0.957916819213791D0/, A(113)/0.022245849194166D0/
      DATA X(114)/0.932812808278676D0/, A(114)/0.027937006980023D0/
      DATA X(115)/0.902098806968874D0/, A(115)/0.033460195282547D0/
      DATA X(116)/0.865959503212259D0/, A(116)/0.038782167974472D0/
      DATA X(117)/0.824612230833311D0/, A(117)/0.043870908185673D0/
      DATA X(118)/0.778305651426519D0/, A(118)/0.048695807635072D0/
      DATA X(119)/0.727318255189927D0/, A(119)/0.053227846983936D0/
      DATA X(120)/0.671956684614179D0/, A(120)/0.057439769099391D0/
      DATA X(121)/0.612553889667980D0/, A(121)/0.061306242492928D0/
      DATA X(122)/0.549467125095128D0/, A(122)/0.064804013456601D0/
      DATA X(123)/0.483075801686178D0/, A(123)/0.067912045815233D0/
      DATA X(124)/0.413779204371605D0/, A(124)/0.070611647391286D0/
      DATA X(125)/0.341994090825758D0/, A(125)/0.072886582395804D0/
      DATA X(126)/0.268152185007253D0/, A(126)/0.074723169057968D0/
      DATA X(127)/0.192697580701371D0/, A(127)/0.076110361900626D0/
      DATA X(128)/0.116084070675255D0/, A(128)/0.077039818164247D0/
      DATA X(129)/0.038772417506050D0/, A(129)/0.077505947978424D0/
C-----N=48
      DATA X(130)/0.998771007252426D0/, A(130)/0.003153346052305D0/
      DATA X(131)/0.993530172266350D0/, A(131)/0.007327553901276D0/
      DATA X(132)/0.984124583722826D0/, A(132)/0.011477234579234D0/
      DATA X(133)/0.970591592546247D0/, A(133)/0.015579315722943D0/
      DATA X(134)/0.952987703160430D0/, A(134)/0.019616160457355D0/
      DATA X(135)/0.931386690706554D0/, A(135)/0.023570760839324D0/
      DATA X(136)/0.905879136715569D0/, A(136)/0.027426509708356D0/
      DATA X(137)/0.876572020274247D0/, A(137)/0.031167227832798D0/
      DATA X(138)/0.843588261624393D0/, A(138)/0.034777222564770D0/
      DATA X(139)/0.807066204029442D0/, A(139)/0.038241351065830D0/
      DATA X(140)/0.767159032515740D0/, A(140)/0.041545082943464D0/
      DATA X(141)/0.724034130923814D0/, A(141)/0.044674560856694D0/
      DATA X(142)/0.677872379632663D0/, A(142)/0.047616658492490D0/
      DATA X(143)/0.628867396776513D0/, A(143)/0.050359035553854D0/
      DATA X(144)/0.577224726083972D0/, A(144)/0.052890189485193D0/
      DATA X(145)/0.523160974722233D0/, A(145)/0.055199503699984D0/
      DATA X(146)/0.466902904750958D0/, A(146)/0.057277292100403D0/
      DATA X(147)/0.408686481990716D0/, A(147)/0.059114839698395D0/
      DATA X(148)/0.348755886292160D0/, A(148)/0.060704439165893D0/
      DATA X(149)/0.287362487355455D0/, A(149)/0.062039423159892D0/
      DATA X(150)/0.224763790394689D0/, A(150)/0.063114192286254D0/
      DATA X(151)/0.161222356068891D0/, A(151)/0.063924238584648D0/
      DATA X(152)/0.097004699209462D0/, A(152)/0.064466164435950D0/
      DATA X(153)/0.032380170962869D0/, A(153)/0.064737696812683D0/
C-----N=64
      DATA X(154)/0.999305041735772D0/, A(154)/0.001783280721696D0/
      DATA X(155)/0.996340116771955D0/, A(155)/0.004147033260562D0/
      DATA X(156)/0.991013371476744D0/, A(156)/0.006504457968978D0/
      DATA X(157)/0.983336253884625D0/, A(157)/0.008846759826363D0/
      DATA X(158)/0.973326827789910D0/, A(158)/0.011168139460131D0/
      DATA X(159)/0.961008799652053D0/, A(159)/0.013463047896718D0/
      DATA X(160)/0.946411374858402D0/, A(160)/0.015726030476024D0/
      DATA X(161)/0.929569172131939D0/, A(161)/0.017951715775697D0/
      DATA X(162)/0.910522137078502D0/, A(162)/0.020134823153530D0/
      DATA X(163)/0.889315445995114D0/, A(163)/0.022270173808383D0/
      DATA X(164)/0.865999398154092D0/, A(164)/0.024352702568710D0/
      DATA X(165)/0.840629296252580D0/, A(165)/0.026377469715054D0/
      DATA X(166)/0.813265315122797D0/, A(166)/0.028339672614259D0/
      DATA X(167)/0.783972358943341D0/, A(167)/0.030234657072402D0/
      DATA X(168)/0.752819907260531D0/, A(168)/0.032057928354851D0/
      DATA X(169)/0.719881850171610D0/, A(169)/0.033805161837141D0/
      DATA X(170)/0.685236313054233D0/, A(170)/0.035472213256882D0/
      DATA X(171)/0.648965471254657D0/, A(171)/0.037055128540240D0/
      DATA X(172)/0.611155355172393D0/, A(172)/0.038550153178615D0/
      DATA X(173)/0.571895646202634D0/, A(173)/0.039953741132720D0/
      DATA X(174)/0.531279464019894D0/, A(174)/0.041262563242623D0/
      DATA X(175)/0.489403145707052D0/, A(175)/0.042473515123653D0/
      DATA X(176)/0.446366017253464D0/, A(176)/0.043583724529323D0/
      DATA X(177)/0.402270157963991D0/, A(177)/0.044590558163756D0/
      DATA X(178)/0.357220158337668D0/, A(178)/0.045491627927418D0/
      DATA X(179)/0.311322871990210D0/, A(179)/0.046284796581314D0/
      DATA X(180)/0.264687162208767D0/, A(180)/0.046968182816210D0/
      DATA X(181)/0.217423643740007D0/, A(181)/0.047540165714830D0/
      DATA X(182)/0.169644420423992D0/, A(182)/0.047999388596458D0/
      DATA X(183)/0.121462819296120D0/, A(183)/0.048344762234802D0/
      DATA X(184)/0.072993121787799D0/, A(184)/0.048575467441503D0/
      DATA X(185)/0.024350292663424D0/, A(185)/0.048690957009139D0/
C-----N=80
      DATA X(186)/0.999553822651630D0/, A(186)/0.001144950003186D0/
      DATA X(187)/0.997649864398237D0/, A(187)/0.002663533589512D0/
      DATA X(188)/0.994227540965688D0/, A(188)/0.004180313124694D0/
      DATA X(189)/0.989291302499755D0/, A(189)/0.005690922451403D0/
      DATA X(190)/0.982848572738629D0/, A(190)/0.007192904768117D0/
      DATA X(191)/0.974909140585727D0/, A(191)/0.008683945269260D0/
      DATA X(192)/0.965485089043799D0/, A(192)/0.010161766041103D0/
      DATA X(193)/0.954590766343634D0/, A(193)/0.011624114120797D0/
      DATA X(194)/0.942242761309872D0/, A(194)/0.013068761592401D0/
      DATA X(195)/0.928459877172445D0/, A(195)/0.014493508040509D0/
      DATA X(196)/0.913263102571757D0/, A(196)/0.015896183583725D0/
      DATA X(197)/0.896675579438770D0/, A(197)/0.017274652056269D0/
      DATA X(198)/0.878722567678213D0/, A(198)/0.018626814208299D0/
      DATA X(199)/0.859431406663111D0/, A(199)/0.019950610878141D0/
      DATA X(200)/0.838831473580255D0/, A(200)/0.021244026115782D0/
      DATA X(201)/0.816954138681463D0/, A(201)/0.022505090246332D0/
      DATA X(202)/0.793832717504605D0/, A(202)/0.023731882865930D0/
      DATA X(203)/0.769502420135041D0/, A(203)/0.024922535764115D0/
      DATA X(204)/0.744000297583597D0/, A(204)/0.026075235767565D0/
      DATA X(205)/0.717365185362099D0/, A(205)/0.027188227500486D0/
      DATA X(206)/0.689637644342027D0/, A(206)/0.028259816057276D0/
      DATA X(207)/0.660859898986119D0/, A(207)/0.029288369583267D0/
      DATA X(208)/0.631075773046871D0/, A(208)/0.030272321759557D0/
      DATA X(209)/0.600330622829751D0/, A(209)/0.031210174188114D0/
      DATA X(210)/0.568671268122709D0/, A(210)/0.032100498673487D0/
      DATA X(211)/0.536145920897131D0/, A(211)/0.032941939397645D0/
      DATA X(212)/0.502804111888784D0/, A(212)/0.033733214984611D0/
      DATA X(213)/0.468696615170544D0/, A(213)/0.034473120451753D0/
      DATA X(214)/0.433875370831756D0/, A(214)/0.035160529044747D0/
      DATA X(215)/0.398393405881969D0/, A(215)/0.035794393953416D0/
      DATA X(216)/0.362304753499487D0/, A(216)/0.036373749905835D0/
      DATA X(217)/0.325664370747701D0/, A(217)/0.036897714638276D0/
      DATA X(218)/0.288528054884511D0/, A(218)/0.037365490238730D0/
      DATA X(219)/0.250952358392272D0/, A(219)/0.037776364362001D0/
      DATA X(220)/0.212994502857666D0/, A(220)/0.038129711314477D0/
      DATA X(221)/0.174712291832646D0/, A(221)/0.038424993006959D0/
      DATA X(222)/0.136164022809143D0/, A(222)/0.038661759774076D0/
      DATA X(223)/0.097408398441584D0/, A(223)/0.038839651059051D0/
      DATA X(224)/0.058504437152420D0/, A(224)/0.038958395962769D0/
      DATA X(225)/0.019511383256793D0/, A(225)/0.039017813656306D0/
C-----N=96
      DATA X(226)/0.999689503883230D0/, A(226)/0.000796792065552D0/
      DATA X(227)/0.998364375863181D0/, A(227)/0.001853960788946D0/
      DATA X(228)/0.995981842987209D0/, A(228)/0.002910731817934D0/
      DATA X(229)/0.992543900323762D0/, A(229)/0.003964554338444D0/
      DATA X(230)/0.988054126329623D0/, A(230)/0.005014202742927D0/
      DATA X(231)/0.982517263563014D0/, A(231)/0.006058545504235D0/
      DATA X(232)/0.975939174585136D0/, A(232)/0.007096470791153D0/
      DATA X(233)/0.968326828463264D0/, A(233)/0.008126876925698D0/
      DATA X(234)/0.959688291448742D0/, A(234)/0.009148671230783D0/
      DATA X(235)/0.950032717784437D0/, A(235)/0.010160770535008D0/
      DATA X(236)/0.939370339752755D0/, A(236)/0.011162102099838D0/
      DATA X(237)/0.927712456722308D0/, A(237)/0.012151604671088D0/
      DATA X(238)/0.915071423120898D0/, A(238)/0.013128229566961D0/
      DATA X(239)/0.901460635315852D0/, A(239)/0.014090941772314D0/
      DATA X(240)/0.886894517402420D0/, A(240)/0.015038721026994D0/
      DATA X(241)/0.871388505909296D0/, A(241)/0.015970562902562D0/
      DATA X(242)/0.854959033434601D0/, A(242)/0.016885479864245D0/
      DATA X(243)/0.837623511228187D0/, A(243)/0.017782502316045D0/
      DATA X(244)/0.819400310737931D0/, A(244)/0.018660679627411D0/
      DATA X(245)/0.800308744139140D0/, A(245)/0.019519081140145D0/
      DATA X(246)/0.780369043867433D0/, A(246)/0.020356797154333D0/
      DATA X(247)/0.759602341176647D0/, A(247)/0.021172939892191D0/
      DATA X(248)/0.738030643744400D0/, A(248)/0.021966644438744D0/
      DATA X(249)/0.715676812348967D0/, A(249)/0.022737069658329D0/
      DATA X(250)/0.692564536642171D0/, A(250)/0.023483399085926D0/
      DATA X(251)/0.668718310043916D0/, A(251)/0.024204841792364D0/
      DATA X(252)/0.644163403784967D0/, A(252)/0.024900633222483D0/
      DATA X(253)/0.618925840125468D0/, A(253)/0.025570036005349D0/
      DATA X(254)/0.593032364777572D0/, A(254)/0.026212340735672D0/
      DATA X(255)/0.566510418561397D0/, A(255)/0.026826866725591D0/
      DATA X(256)/0.539388108324357D0/, A(256)/0.027412962726029D0/
      DATA X(257)/0.511694177154667D0/, A(257)/0.027970007616848D0/
      DATA X(258)/0.483457973920596D0/, A(258)/0.028497411065085D0/
      DATA X(259)/0.454709422167743D0/, A(259)/0.028994614150555D0/
      DATA X(260)/0.425478988407300D0/, A(260)/0.029461089958167D0/
      DATA X(261)/0.395797649828908D0/, A(261)/0.029896344136328D0/
      DATA X(262)/0.365696861472313D0/, A(262)/0.030299915420827D0/
      DATA X(263)/0.335208522892625D0/, A(263)/0.030671376123669D0/
      DATA X(264)/0.304364944354496D0/, A(264)/0.031010332586313D0/
      DATA X(265)/0.273198812591049D0/, A(265)/0.031316425596861D0/
      DATA X(266)/0.241743156163840D0/, A(266)/0.031589330770727D0/
      DATA X(267)/0.210031310460567D0/, A(267)/0.031828758894411D0/
      DATA X(268)/0.178096882367618D0/, A(268)/0.032034456231992D0/
      DATA X(269)/0.145973714654896D0/, A(269)/0.032206204794030D0/
      DATA X(270)/0.113695850110665D0/, A(270)/0.032343822568575D0/
      DATA X(271)/0.081297495464425D0/, A(271)/0.032447163714064D0/
      DATA X(272)/0.048812985136049D0/, A(272)/0.032516118713868D0/
      DATA X(273)/0.016276744849602D0/, A(273)/0.032550614492363D0/
      DATA IBD/0/

      IF(IBD.NE.0) RETURN
      IBD=1
      DO 10 I=1,273
        B(I) = A(I)
        Y(I) = X(I)
 10   CONTINUE
      DO 20 I=1,96
        LTAB(I) = KTAB(I)
 20   CONTINUE
      END


 
 


CDECK  ID>, PHO_GAUSET
      SUBROUTINE PHO_GAUSET(AX,BX,NX,Z,W)
C********************************************************************
C
C     N-point gauss zeros and weights for the interval (AX,BX) are
C           stored in  arrays Z and W respectively.
C
C*********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      COMMON /POGDAT/ a(273),x(273),ktab(96)

      DIMENSION Z(NX),W(NX)

      ALPHA=0.5D+00*(BX+AX)
      BETA=0.5D+00*(BX-AX)
      N=NX

C  the N=1 case:
      IF(N.NE.1) GO TO 1
      Z(1)=ALPHA
      W(1)=BX-AX
      RETURN

C  the Gauss cases:
    1 CONTINUE
      IF((N.LE.16).AND.(N.GT.1)) GO TO 2
      IF(N.EQ.20) GO TO 2
      IF(N.EQ.24) GO TO 2
      IF(N.EQ.32) GO TO 2
      IF(N.EQ.40) GO TO 2
      IF(N.EQ.48) GO TO 2
      IF(N.EQ.64) GO TO 2
      IF(N.EQ.80) GO TO 2

C  the extended Gauss cases:
      IF(N.EQ.96) GO TO 2

C  jump to center of intervall intrgration:
      IF((N/96)*96.EQ.N) GO TO 3
      GO TO 100

C  get Gauss point array

    2 CONTINUE
      CALL PHO_GAUDAT
C  extract real points
      K=KTAB(N)
      M=N/2
      DO 21 J=1,M
C       extract values from big array
        JTAB=K-1+J
        WTEMP=BETA*A(JTAB)
        DELTA=BETA*X(JTAB)
C       store them backward
        Z(J)=ALPHA-DELTA
        W(J)=WTEMP
C       store them forward
        JP=N+1-J
        Z(JP)=ALPHA+DELTA
        W(JP)=WTEMP
   21 CONTINUE
C     store central point (odd N)
      IF((N-M-M).EQ.0) RETURN
      Z(M+1)=ALPHA
      JMID=K+M
      W(M+1)=BETA*A(JMID)
      RETURN

C  get ND96 times chained 96 Gauss point array

    3 CONTINUE
      CALL PHO_GAUDAT
C  print out message
C     -extract real points
      K=KTAB(96)
      ND96=N/96
      DO 31 J=1,48
C       extract values from big array
        JTAB=K-1+J
        WTEMP=BETA*A(JTAB)
        DELTA=BETA*X(JTAB)
        WTeMP=WTEMP/ND96
        DeLTA=DELTA/ND96
        DO 32 JD96=0,ND96-1
          ZCNTR= (ALPHA-BETA)+ BETA*DBLE(2*JD96+1)/DBLE(ND96)
C         store them backward
          Z(J+JD96*96)=ZCNTR-DELTA
          W(J+JD96*96)=WTEMP
C         store them forward
          JP=96+1-J
          Z(JP+JD96*96)=ZCNTR+DELTA
          W(JP+JD96*96)=WTEMP
   32   CONTINUE
   31 CONTINUE
      RETURN

C  the center of intervall cases:
  100 CONTINUE
C  put in constant weight and equally spaced central points
      N=ABS(N)
      DO 111 IN=1,N
        WIN=(BX-AX)/DBLE(N)
        Z(IN)=AX  + (DBLE(IN)-.5D+00)*WIN
        W(IN)=WIN
 111  CONTINUE

      END


      SUBROUTINE PHO_GET4VECTORS(IPDGS1, IPDGS2, SQS, P1, P2)
c*********************************************************************
c
c     Generates two 4-vectors p1/2 in center of mass frame 
c
c     input:   ipdgs1   PDG particle code side 1
c              ipdgs2   PDG particle code side 2
c              sqs      center of mass energy
c                   
c     output:  p1       particle 4-vector side 1
c              p2       particle 4-vector side 2
c
c*********************************************************************
      IMPLICIT NONE
      SAVE

      DOUBLE PRECISION SQS, S, EE, PCM, P1(4), P2(4), PM1, PM2,
     &                  PHO_PMASS
      INTEGER IPDGS1, IPDGS2
      EXTERNAL PHO_PMASS

      S = SQS**2
      PM1 = PHO_PMASS(IPDGS1, 1)**2
      PM2 = PHO_PMASS(IPDGS2, 1)**2
      PCM = SQRT(S**2-2.D0*PM1*S-2.D0*PM2*S-2.D0*PM1*PM2+PM1**2+PM2**2)/
     &   (2.D0*SQS)
      EE = SQRT(PM1+PCM**2)
      P1(1) = 0.0D0
      P1(2) = 0.0D0
      P1(3) = PCM
      P1(4) = EE
      P2(1) = 0.0D0
      P2(2) = 0.0D0
      P2(3) = -PCM
      P2(4) = SQS - EE

      END


 
 


CDECK  ID>, PHO_GETLTR
      SUBROUTINE PHO_GETLTR(P1,P2,GAM,GAMB,DELE,IREJ)
C********************************************************************
C
C     calculate Lorentz boots for arbitrary Lorentz transformation
C
C     input:   P1    initial 4 vector
C              P2    final 4 vector
C
C     output:  GAM(3),GAMB(3)
C              DELE   energy deviation
C              IREJ   0 success
C                     1 failure
C
C********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( DREL = 0.001D0 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

      DIMENSION P1(4),P2(4),GAM(3),GAMB(3),PA(4),PP(4)

      IREJ = 1
      DO 50 K=1,4
        PA(K) = P1(K)
        PP(K) = P1(K)
 50   CONTINUE
      PM1 = P1(4)**2-P1(1)**2-P1(2)**2-P1(3)**2
      DO 100 I=1,3
        PP(I) = P2(I)
        PP(4) = PM1+PP(1)**2+PP(2)**2+PP(3)**2
        IF(PP(4).LE.0.D0) RETURN
        PP(4) = SQRT(PP(4))
        GAMB(I) = (SQRT(PA(4)**2-PA(I)**2+PP(I)**2)*PP(I)
     &             -PA(4)*PA(I))/(PA(4)**2+PP(I)**2)
        GAM(I) = 1.D0/SQRT(1.D0-GAMB(I)**2)
        GAMB(I) = GAMB(I)*GAM(I)
        DO 150 K=1,4
          PA(K) = PP(K)
 150    CONTINUE
 100  CONTINUE
      DELE = P2(4)-PP(4)
      IREJ = 0
C  consistency check
*     IF(ABS(P2(4)-PP(4))/MAX(P2(4),PP(4)).GT.DREL) THEN
*       PM2 = P2(4)**2-P2(1)**2-P2(2)**2-P2(3)**2
*       WRITE(LO,'(/1X,A,2E12.5)')
*    &    'PHO_GETLTR: INCONSISTENT ENERGIES',P2(4),PP(4)
*       WRITE(LO,'(1X,A,2E12.4)') 'INPUT MASSES',PM1,PM2
*       WRITE(LO,'(1X,A,4E12.4)') 'INPUT ',P1
*       WRITE(LO,'(1X,A,4E12.4)') 'OUTPUT',P2
*       WRITE(LO,'(1X,A,4E12.4)') 'INTERN',PP
*     ENDIF
      END


 
 


CDECK  ID>, PHO_GETPDF
      SUBROUTINE PHO_GETPDF(NPAR,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
C***************************************************************
C
C     get PDF information
C
C     input:      NPAR     1  first PDF in /POPPDF/
C                          2  second PDF in /POPPDF/
C
C     output:     PDFNA    name of PDf parametrization
C                 ALA      QCD LAMBDA (4 flavours, in GeV)
C                 Q2MI     minimal Q2
C                 Q2MA     maximal Q2
C                 XMI      minimal X
C                 XMA      maximal X
C
C***************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      CHARACTER*8 PDFNA
cdh  prolongate FNAME to contain the directory path
      CHARACTER*250 FNAME
C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  PHOLIB 4.15 common
      COMMON/W50512/QCDL4,QCDL5
      DOUBLE PRECISION QCDL4,QCDL5
      SAVE /w50512/

      COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
      DOUBLE PRECISION XMIN,XMAX,Q2MIN,Q2MAX
      SAVE /W50513/

C  PHOPDF version 2.0 common
      PARAMETER (MAXS=6,MAXP=10)
      CHARACTER*4 CHPAR
      COMMON/PHCOM1/ XLIM(MAXP,0:MAXS,2), Q2LIM(MAXP,0:MAXS,2),
     & NSET(MAXP,2),NFL(MAXP)

      COMMON/PHCOM2/ ALM(MAXP,0:MAXS),CHPAR(MAXP),IORD(MAXP,-MAXS:MAXS)

C  currently activated parton density parametrizations
      CHARACTER*8 PDFNAM
      INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
      DOUBLE PRECISION PDFLAM,PDFQ2M
      COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
     &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD

cdh  datadir for path to the data sets to be read in by dpmjet/phojet
      COMMON /DATADIR/ DATADIR
      CHARACTER*132    DATADIR
      
      LOGICAL ct14init(3)
      DATA ct14init / .False., .False., .False. /

      DIMENSION PARAM(20),VALUE(20)
      CHARACTER*20 PARAM

      IF((NPAR.NE.1).AND.(NPAR.NE.2)) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,I6)')
     &    'PHO_GETPDF:ERROR: invalid PDF number (1,2)',NPAR
        CALL PHO_ABORT
      ENDIF
      ALA = 0.D0

      IF(IEXT(NPAR).EQ.0) THEN

C  internal parametrizations
        If (igrp(npar)==2) Then
            If (iset(npar)==1) Then
              If (.Not.ct14init(1)) Then
cdh             FNAME = 'CT14LL.pds'
c  modification for use with corsika using path to data file in DATADIR
                FNAME=DATADIR(1:INDEX(DATADIR,' ')-1)//'dpmCT14LL.pds'
                CALL PHO_SETCT14(FNAME)
                ct14init(1) = .True.
                ct14init(2) = .False.
                ct14init(3) = .False.
              End If
              pdfna = 'CT14-LO'
            Else If (iset(npar)==2) Then
              If (.Not.ct14init(2)) Then
cdh             FNAME = 'CT14LN.pds'
c  modification for use with corsika using path to data file in DATADIR
                FNAME=DATADIR(1:INDEX(DATADIR,' ')-1)//'dpmCT14LN.pds'
                CALL PHO_SETCT14(FNAME)
                ct14init(2) = .True.
                ct14init(1) = .False.
                ct14init(3) = .False.
              End If
              pdfna = 'CT14-LLO'
            Else If (iset(npar)==3) Then
              If (.Not.ct14init(3)) Then
cdh             FNAME = 'CT14nlo_NF4.pds'
c  modification for use with corsika using path to data file in DATADIR
             FNAME=DATADIR(1:INDEX(DATADIR,' ')-1)//'dpmCT14nlo_NF4.pds'
                CALL PHO_SETCT14(FNAME)
                ct14init(3) = .True.
                ct14init(1) = .False.
                ct14init(2) = .False.
              End If
              pdfna = 'CT14-NLO'
            End If  
            CALL PHO_CT14GETPARS(xmin,Qini,Qmax,Nloops,Nflav)
            ala = 0.2807
            xmi = xmin
            q2mi = Qini**2
            q2ma = Qmax**2
        Else IF(ITYPE(NPAR).EQ.1) THEN
C  proton PDFs
          IF(IGRP(NPAR).EQ.5) THEN
            IF(ISET(NPAR).EQ.3) THEN
              ALA    = 0.2D0
              Q2MI   = 0.3D0
              PDFNA  = 'GRV92 HO'
            ELSE IF(ISET(NPAR).EQ.4) THEN
              ALA    = 0.2D0
              Q2MI   = 0.25D0
              PDFNA  = 'GRV92 LO'
            ELSE IF(ISET(NPAR).EQ.5) THEN
              ALA    = 0.2D0
              Q2MI   = 0.4D0
              PDFNA  = 'GRV94 HO'
            ELSE IF(ISET(NPAR).EQ.6) THEN
              ALA    = 0.2D0
              Q2MI   = 0.4D0
              PDFNA  = 'GRV94 LO'
            ELSE IF(ISET(NPAR).EQ.7) THEN
              ALA    = 0.2D0
              Q2MI   = 0.4D0
              PDFNA  = 'GRV94 DI'
            ELSE IF(ISET(NPAR).EQ.8) THEN
              ALA    = 0.175D0
              Q2MI   = 0.8D0
              PDFNA  = 'GRV98 LO'
            ELSE IF(ISET(NPAR).EQ.9) THEN
              ALA    = 0.175D0
              Q2MI   = 0.8D0
              PDFNA  = 'GRV98 SC'
            ENDIF
          ENDIF
        ELSE IF(ITYPE(NPAR).EQ.2) THEN
C  pion PDFs
          IF(IGRP(NPAR).EQ.5) THEN
            IF(ISET(NPAR).EQ.1) THEN
              ALA    = 0.2D0
              Q2MI   = 0.3D0
              PDFNA  = 'GRV-P HO'
            ELSE IF(ISET(NPAR).EQ.2) THEN
              ALA    = 0.2D0
              Q2MI   = 0.25D0
              PDFNA  = 'GRV-PiLO'
            ENDIF
          ENDIF
        ELSE IF(ITYPE(NPAR).EQ.3) THEN
C  photon PDFs
          IF(IGRP(NPAR).EQ.5) THEN
            IF(ISET(NPAR).EQ.1) THEN
              ALA    = 0.2D0
              Q2MI   = 0.3D0
              PDFNA  = 'GRV-G LH'
            ELSE IF(ISET(NPAR).EQ.2) THEN
              ALA    = 0.2D0
              Q2MI   = 0.3D0
              PDFNA  = 'GRV-G HO'
            ELSE IF(ISET(NPAR).EQ.3) THEN
              ALA    = 0.2D0
              Q2MI   = 0.25D0
              PDFNA  = 'GRV-G LO'
            ENDIF
          ELSE IF(IGRP(NPAR).EQ.8) THEN
            IF(ISET(NPAR).EQ.1) THEN
              ALA    = 0.2D0
              Q2MI   = 4.D0
              PDFNA  = 'AGL-G LO'
            ENDIF
          ENDIF
        ELSE IF(ITYPE(NPAR).EQ.20) THEN
C  pomeron PDFs
          IF(IGRP(NPAR).EQ.4) THEN
            CALL PHO_CKMTPA(990,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
          ELSE
            ALA    = 0.3D0
            Q2MI   = 2.D0
            PDFNA  = 'POM-PDF1'
          ENDIF
        ENDIF

C  external parametrizations

      ELSE IF(IEXT(NPAR).EQ.1) THEN
C  PDFLIB call: old numbering
        PARAM(1) = 'MODE'
        PARAM(2) = ' '
        VALUE(1) = IGRP(NPAR)
        CALL PDFSET(PARAM,VALUE)
        Q2MI = Q2MIN
        Q2MA = Q2MAX
        XMI  = XMIN
        XMA  = XMAX
        ALA  = QCDL4
        PDFNA = 'PDFLIB1'
      ELSE IF(IEXT(NPAR).EQ.2) THEN
C  PDFLIB call: new numbering
        PARAM(1) = 'NPTYPE'
        PARAM(2) = 'NGROUP'
        PARAM(3) = 'NSET'
        PARAM(4) = ' '
        VALUE(1) = ITYPE(NPAR)
        VALUE(2) = IGRP(NPAR)
        VALUE(3) = ISET(NPAR)
        CALL PDFSET(PARAM,VALUE)
        Q2MI = Q2MIN
        Q2MA = Q2MAX
        XMI  = XMIN
        XMA  = XMAX
        ALA  = QCDL4
        PDFNA = 'PDFLIB2'
      ELSE IF(IEXT(NPAR).EQ.3) THEN
C  PHOLIB interface
        ALA  = ALM(IGRP(NPAR),ISET(NPAR))
        Q2MI = 2.D0
        PDFNA = CHPAR(IGRP(NPAR))

C  some special internal parametrizations

      ELSE IF(IEXT(NPAR).EQ.4) THEN
C  photon PDFs depending on virtualities
        IF(IGRP(NPAR).EQ.1) THEN
C  Schuler/Sjostrand parametrization
          ALA = 0.2D0
          IF(ISET(NPAR).EQ.1) THEN
            Q2MI = 0.2D0
            PDFNA = 'SaS-1D  '
          ELSE IF(ISET(NPAR).EQ.2) THEN
            Q2MI = 0.2D0
            PDFNA = 'SaS-1M  '
          ELSE IF(ISET(NPAR).EQ.3) THEN
            Q2MI = 2.D0
            PDFNA = 'SaS-2D  '
          ELSE IF(ISET(NPAR).EQ.4) THEN
            Q2MI = 2.D0
            PDFNA = 'SaS-2M  '
          ENDIF
        ELSE IF(IGRP(NPAR).EQ.5) THEN
C  Gluck/Reya/Stratmann parametrization
          IF(ISET(NPAR).EQ.4) THEN
            ALA = 0.2D0
            Q2MI = 0.6D0
            PDFNA = 'GRS-G LO'
          ENDIF
        ENDIF
      ELSE IF(IEXT(NPAR).EQ.5) THEN
C  Schuler/Sjostrand anomalous only
        ALA   = 0.2D0
        Q2MI  = 0.2D0
        PDFNA = 'SaS anom'
      ENDIF
      IF(ALA.LT.0.01D0) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,2A,/10X,5I6)')
     &    'PHO_GETPDF:ERROR: ',
     &    'unsupported PDF (NPAR,IEXT,ITYPE,IGRP,ISET)',
     &    NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
        CALL PHO_ABORT
      ENDIF

      END


 
 


CDECK  ID>, PHO_GGBEAM
      SUBROUTINE PHO_GGBEAM(NEVENT,EE,YPSI,SIGX,SIGY,SIGZ,AEB)
C**********************************************************************
C
C     interface to call PHOJET (variable energy run) for
C     gamma-gamma collisions via beamstrahlung
C
C     input:     EE      LAB system energy of electron/positron
C                YPSI    beamstrahlung parameter
C                SIGX,Y  transverse bunch dimensions
C                SIGZ    longitudinal bunch dimension
C                AEB     number of electrons/positrons in a bunch
C                NEVENT  number of events to generate
C            from /LEPCUT/:
C                YMIN1   lower limit of Y
C                        (energy fraction taken by photon from electron)
C                YMAX1   upper cutoff for Y, necessary to avoid
C                        underflows
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( DEPS = 1.D-20,
     &            PI   = 3.141592653589793238462643383279D+00 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  photon flux kinematics and cuts
      DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
     &                 YMIN1,YMAX1,YMIN2,YMAX2,
     &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
     &                 THMIN1,THMAX1,THMIN2,THMAX2
      INTEGER          ITAG1,ITAG2
      COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
     &                YMIN1,YMAX1,YMIN2,YMAX2,
     &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
     &                THMIN1,THMAX1,THMIN2,THMAX2,
     &                ITAG1,ITAG2

C  gamma-lepton or gamma-hadron vertex information
      INTEGER IGHEL,IDPSRC,IDBSRC
      DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
     &                 RADSRC,AMSRC,GAMSRC
      COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
     &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
     &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)

C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
      INTEGER IDEQP,IDEQB,IHFLD,IHFLS
      DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
      COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
     &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)

C  event weights and generated cross section
      INTEGER IPOWGC,ISWCUT,IVWGHT
      DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
      COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
     &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)

      PARAMETER (Max_tab=100)
      DIMENSION P1(4),P2(4),TABCU(0:Max_tab),TABYL(0:Max_tab)

C
      IF (LPRI.GT.4)
     &WRITE(LO,'(//1X,A,I10)') 'PHO_GGBEAM: events to process',NEVENT
C  electron data
      RE = 2.818D-12
      ELEM = 0.512D-03
      IDPSRC(1) = 0
      IDBSRC(1) = 0
      IDPSRC(2) = 0
      IDBSRC(2) = 0
C  table of flux function, log interpolation
      IF(YPSI.LE.0.D0) THEN
        YPSI  = 5.D0*RE**2*EE*AEB*137.D0/(6.D0*SIGZ*(SIGX+SIGY)*ELEM)
      ENDIF
      IF (LPRI.GT.4)
     &WRITE(LO,'(/1X,A,E12.4)')
     &  'PHO_GGBEAM: beamstrahlung parameter:',YPSI
      IF (LPRI.GT.4)
     &WRITE(LO,'(/1X,A,2E12.4)')
     &  'PHO_GGBEAM: sigma-z,ne-bunch:',SIGZ,AEB
      TT    = 2.D0/3.D0
      OT    = 1.D0/3.D0
C     GAOT  = DGAMMA(OT)
      GAOT  = 2.6789385347D0
      AKAP  = TT/YPSI
      WW    = 1.D0/(6.D0*SQRT(AKAP))
      ANGAM = 5.D0*SIGZ*ELEM/(137.D0**2*2.D0*RE*EE)
     &       *YPSI/SQRT(1.D0+YPSI**TT)

      YMIN = YMIN1
      YMAX = MIN(YMAX1,0.9D0)
      TABCU(0) = 0.D0
      TABYL(0) = LOG(YMIN)
      DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
      FLUX = 0.D0
      IF (LPRI.GT.4 .AND. IDEB(30).GE.1)
     &WRITE(LO,'(1X,A,I5)')
     &  'PHO_GGBEAM: table of photon flux',Max_tab
      DO 100 I=1,Max_tab
        Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
        GG = 1.D0-0.5D0*(1-Y)**TT*(1.D0-Y+(1.D0+Y)*SQRT(1.D0+YPSI**TT))
        FF = AKAP**OT/GAOT/Y**TT/(1.D0-Y)**OT*EXP(-AKAP*Y/(1.D0-Y))
     &      *((1.D0-WW)/GG*(1.D0-(1.D0-EXP(-ANGAM*GG))/(ANGAM*GG))
     &      +WW*(1.D0-(1.D0-EXP(-ANGAM))/ANGAM))
        TABCU(I) = TABCU(I-1)+FF*Y
        TABYL(I) = LOG(Y)
        FLUX = FLUX+Y*FF
        IF (LPRI.GT.4 .AND. IDEB(30).GE.1)
     &  WRITE(LO,'(5X,2E15.4)') Y,FF
 100  CONTINUE
      FLUX = FLUX*DELLY
      IF (LPRI.GT.4 .AND. IDEB(30).GE.1)
     &WRITE(LO,'(1X,A,E12.4)')
     &  'PHO_GGBEAM: integrated flux (one side):',FLUX

      EE1 = EE
      EE2 = EE
C  photon 1
      EGAM = YMAX*EE
      P1(1) = 0.D0
      P1(2) = 0.D0
      P1(3) = EGAM
      P1(4) = EGAM
C  photon 2
      EGAM = YMAX*EE
      P2(1) = 0.D0
      P2(2) = 0.D0
      P2(3) = -EGAM
      P2(4) = EGAM
      CALL PHO_SETPAR(1,22,0,0.D0)
      CALL PHO_SETPAR(2,22,0,0.D0)
      CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
      CALL PHO_PHIST(-1,SIGMAX)
      CALL PHO_LHIST(-1,SIGMAX)

C  generation of events

      AY1  = 0.D0
      AY2  = 0.D0
      AYS1 = 0.D0
      AYS2 = 0.D0
      NITER = NEVENT
      ITRY = 0
      ITRW = 0
      DO 200 I=1,NITER
 150    CONTINUE
        ITRY = ITRY+1
 175    CONTINUE
        ITRW = ITRW+1
        XI = DT_RNDM(AY1)*TABCU(Max_tab)
        DO 110 K=1,Max_tab
          IF(TABCU(K).GE.XI) THEN
            Y1 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
            Y1 = EXP(Y1)
            GOTO 120
          ENDIF
 110    CONTINUE
        Y1 = YMAX
 120    CONTINUE
        XI = DT_RNDM(AY2)*TABCU(Max_tab)
        DO 130 K=1,Max_tab
          IF(TABCU(K).GE.XI) THEN
            Y2 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
            Y2 = EXP(Y2)
            GOTO 140
          ENDIF
 130    CONTINUE
        Y2 = YMAX
 140    CONTINUE

        Q2P1 = 0.D0
        Q2P2 = 0.D0
        GYY(1) = Y1
        GQ2(1) = Q2P1
        GYY(2) = Y2
        GQ2(2) = Q2P2
C  incoming electron 1
        PINI(1,1) = 0.D0
        PINI(2,1) = 0.D0
        PINI(3,1) = EE1
        PINI(4,1) = EE1
        PINI(5,1) = 0.D0
C  outgoing electron 1
        YQ2 = SQRT((1.D0-Y1)*Q2P2)
        Q2E = Q2P1/(4.D0*EE1)
        E1Y = EE1*(1.D0-Y1)
        CALL PHO_SFECFE(SIF,COF)
        PFIN(1,1) = YQ2*COF
        PFIN(2,1) = YQ2*SIF
        PFIN(3,1) = E1Y-Q2E
        PFIN(4,1) = E1Y+Q2E
        PFIN(5,1) = 0.D0
C  photon 1
        P1(1) = -PFIN(1,1)
        P1(2) = -PFIN(2,1)
        P1(3) = PINI(3,1)-PFIN(3,1)
        P1(4) = PINI(4,1)-PFIN(4,1)
C  incoming electron 2
        PINI(1,2) = 0.D0
        PINI(2,2) = 0.D0
        PINI(3,2) = -EE2
        PINI(4,2) = EE2
        PINI(5,2) = 0.D0
C  outgoing electron 2
        YQ2 = SQRT((1.D0-Y2)*Q2P2)
        Q2E = Q2P2/(4.D0*EE2)
        E1Y = EE2*(1.D0-Y2)
        CALL PHO_SFECFE(SIF,COF)
        PFIN(1,2) = YQ2*COF
        PFIN(2,2) = YQ2*SIF
        PFIN(3,2) = -E1Y+Q2E
        PFIN(4,2) = E1Y+Q2E
        PFIN(5,2) = 0.D0
C  photon 2
        P2(1) = -PFIN(1,2)
        P2(2) = -PFIN(2,2)
        P2(3) = PINI(3,2)-PFIN(3,2)
        P2(4) = PINI(4,2)-PFIN(4,2)
C  ECMS cut
        GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
     &         -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
        IF(GGECM.LT.0.1D0) GOTO 175
        GGECM = SQRT(GGECM)
        IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
C
        PGAM(1,1) = P1(1)
        PGAM(2,1) = P1(2)
        PGAM(3,1) = P1(3)
        PGAM(4,1) = P1(4)
        PGAM(5,1) = 0.D0
        PGAM(1,2) = P2(1)
        PGAM(2,2) = P2(2)
        PGAM(3,2) = P2(3)
        PGAM(4,2) = P2(4)
        PGAM(5,2) = 0.D0
C  photon helicities
        IGHEL(1) = 1
        IGHEL(2) = 1
C  cut given by user
        CALL PHO_PRESEL(5,IREJ)
        IF(IREJ.NE.0) GOTO 175
C  event generation
        CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
        IF(IREJ.NE.0) GOTO 150
        GGECML = LOG(GGECM)

C  statistics
        AY1  = AY1+Y1
        AYS1 = AYS1+Y1*Y1
        AY2  = AY2+Y2
        AYS2 = AYS2+Y2*Y2
C  histograms
        CALL PHO_PHIST(1,HSWGHT(0))
        CALL PHO_LHIST(1,HSWGHT(0))
 200  CONTINUE
C
      WGY  = FLUX**2*DBLE(ITRY)/DBLE(ITRW)
      AY1  = AY1/DBLE(NITER)
      AYS1 = AYS1/DBLE(NITER)
      DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
      AY2  = AY2/DBLE(NITER)
      AYS2 = AYS2/DBLE(NITER)
      DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
      WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
C  output of statistics, histograms
      IF (LPRI.GT.4)
     &WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
     &'=========================================================',
     &' *****   simulated cross section: ',WEIGHT,' mb  *****',
     &'========================================================='
      IF (LPRI.GT.4)
     &WRITE(LO,'(//1X,A,2I10)')
     &  'PHO_GGBEAM:SUMMARY:NITER,ITRY',NITER,ITRY
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
     &  WGY,WEIGHT
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBEAM:AVERAGE Y1,DY1 ',AY1,DAY1
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBEAM:AVERAGE Y2,DY2 ',AY2,DAY2
C
      CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
      IF(NITER.GT.1) THEN
        CALL PHO_PHIST(-2,WEIGHT)
        CALL PHO_LHIST(-2,WEIGHT)
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I4)') 'PHO_GGBEAM:NO OUTPUT OF HISTOGRAMS',NITER
      ENDIF

      END


 
 


CDECK  ID>, PHO_GGBLSR
      SUBROUTINE PHO_GGBLSR(NEVENT,EE1,EE2,
     &                      Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A)
C***********************************************************************
C
C     interface to call PHOJET (variable energy run) for
C     gamma-gamma collisions via laser backscattering
C
C     input:     EE1         lab. system energy of electron/positron 1
C                EE2         lab. system energy of electron/positron 2
C                NEVENT      number of events to generate
C                Pl_lam_1/2  product of electron and photon pol.
C                X_1/2       standard X parameter
C                rho         ratio of distance to conversion point and
C                            transverse beam size
C                A           ellipticity of electon beam
C
C                (see Ginzburg & Kotkin hep-ph/9905462)
C
C            from /LEPCUT/:
C                YMIN1   lower limit of Y1
C                        (energy fraction taken by photon from electron)
C                YMAX1   upper limit of Y1
C                YMIN2   lower limit of Y2
C                        (energy fraction taken by photon from electron)
C                YMAX2   upper limit of Y2
C
C***********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( PI   = 3.141592653589793238462643383279D+00 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  photon flux kinematics and cuts
      DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
     &                 YMIN1,YMAX1,YMIN2,YMAX2,
     &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
     &                 THMIN1,THMAX1,THMIN2,THMAX2
      INTEGER          ITAG1,ITAG2
      COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
     &                YMIN1,YMAX1,YMIN2,YMAX2,
     &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
     &                THMIN1,THMAX1,THMIN2,THMAX2,
     &                ITAG1,ITAG2

C  gamma-lepton or gamma-hadron vertex information
      INTEGER IGHEL,IDPSRC,IDBSRC
      DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
     &                 RADSRC,AMSRC,GAMSRC
      COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
     &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
     &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)

C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
      INTEGER IDEQP,IDEQB,IHFLD,IHFLS
      DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
      COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
     &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)

C  event weights and generated cross section
      INTEGER IPOWGC,ISWCUT,IVWGHT
      DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
      COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
     &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)

      parameter (N_dim=100)
      dimension X_inp_1(N_dim),F_inp_1(N_dim),F_int_1(N_dim),
     &          X_inp_2(N_dim),F_inp_2(N_dim),F_int_2(N_dim),
     &          Xgrid(96),Wgrid(96)

      DIMENSION P1(4),P2(4)

      Pi2 = 2.D0*Pi

      IF (LPRI.GT.4)
     &WRITE(LO,'(//1X,A,I10)') 'PHO_GGBLSR: events to process',NEVENT

      YMAX1 = MIN(X_1/(1.D0+X_1),YMAX1)
      YMAX2 = MIN(X_2/(1.D0+X_2),YMAX2)
      IF((YMIN1.GT.YMAX1).OR.(YMIN2.GT.YMAX2)) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,2A,2E12.4)') 'PHO_GGBLSR:ERROR: ',
     &    'invalid Ymin1,Ymin2',YMIN1,YMIN2
        RETURN
      ENDIF
      IDPSRC(1) = 0
      IDBSRC(1) = 0
      IDPSRC(2) = 0
      IDBSRC(2) = 0

C  initialize sampling

      Max_tab = 50
      DELY1 = (YMAX1-YMIN1)/DBLE(Max_tab-1)
      DELY2 = (YMAX2-YMIN2)/DBLE(Max_tab-1)

      IF (LPRI.GT.4 .AND. IDEB(30).GE.1)
     &WRITE(LO,'(1X,A,I5)')
     &  'PHO_GGBLSR: table of photon flux ',Max_tab

      DO 100 I=1,Max_tab

        y1 = YMIN1+DELY1*DBLE(I-1)
        r1 = y1/(X_1*(1.D0-y1))
        X_inp_1(i) = y1
        F_inp_1(i) = 1.D0/(1.D0-y1)-y1+(2.D0*r1-1.D0)**2
     &            -Pl_lam_1*X_1*r1*(2.D0*r1-1.D0)*(2.D0-y1)

        y2 = YMIN2+DELY2*DBLE(I-1)
        r2 = y2/(X_2*(1.D0-y2))
        X_inp_2(i) = y2
        F_inp_2(i) = 1.D0/(1.D0-y2)-y2+(2.D0*r2-1.D0)**2
     &            -Pl_lam_2*X_2*r2*(2.D0*r2-1.D0)*(2.D0-y2)

        IF (LPRI.GT.4 .AND. IDEB(30).GE.1)
     .  WRITE(LO,'(5X,1p,2E13.4,5x,2E13.4)')
     &    y1,F_inp_1(i),y2,F_inp_2(i)

 100  CONTINUE

      CALL PHO_SAMP1D(-1,X_inp_1,F_inp_1,F_int_1,Max_tab,X_out_1)
      CALL PHO_SAMP1D(-1,X_inp_2,F_inp_2,F_int_2,Max_tab,X_out_2)

C  initialize event generator

C  photon 1
      EGAM = YMAX1*EE1
      P1(1) = 0.D0
      P1(2) = 0.D0
      P1(3) = EGAM
      P1(4) = EGAM
C  photon 2
      EGAM = YMAX2*EE2
      P2(1) = 0.D0
      P2(2) = 0.D0
      P2(3) = -EGAM
      P2(4) = EGAM
      CALL PHO_SETPAR(1,22,0,0.D0)
      CALL PHO_SETPAR(2,22,0,0.D0)
      CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
      CALL PHO_PHIST(-1,SIGMAX)
      CALL PHO_LHIST(-1,SIGMAX)

C  generation of events

      AY1  = 0.D0
      AY2  = 0.D0
      AYS1 = 0.D0
      AYS2 = 0.D0
      NITER = NEVENT
      ITRY = 0
      ITRW = 0
      DO 200 I=1,NITER
 150    CONTINUE
        ITRY = ITRY+1
 175    CONTINUE
          ITRW = ITRW+1

          CALL PHO_SAMP1D(1,X_inp_1,F_inp_1,F_int_1,Max_tab,X_out_1)
          CALL PHO_SAMP1D(1,X_inp_2,F_inp_2,F_int_2,Max_tab,X_out_2)

          g_1 = sqrt(max(0.D0,X_1/(X_out_1+1.D-6)-X_1-1.D0))
          g_2 = sqrt(max(0.D0,X_2/(X_out_2+1.D-6)-X_2-1.D0))
          if(abs(1.D0-A).lt.1.D-3) then
            v = rho**2/4.D0*g_1*g_2
            Wght = exp(-rho**2/8.D0*(g_1-g_2)**2)*pho_ExpBessI0(v)
          else
            Nint = 16
            CALL PHO_GAUSET(0.D0,Pi2,Nint,Xgrid,Wgrid)
            A2 = A**2
            fac = rho**2/(4.D0*(1.D0+A2))
            Wght = 0.D0
            do i1=1,Nint
              phi_1 = Xgrid(i1)
              do i2=1,Nint
                phi_2 = Xgrid(i2)
                Wght = Wght
     &            +exp(-fac*(A2*(g_1*cos(phi_1)+g_2*cos(phi_2))**2
     &                         +(g_1*sin(phi_1)+g_2*sin(phi_2))**2))
     &            *Wgrid(i1)*Wgrid(i2)
              enddo
            enddo
            Wght = Wght/Pi2**2
          endif

          IF(Wght.GT.1.D0) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,A,5E11.4)')
     &        'PHO_GGBLSR:WEIGHT ERROR:',Y1,Y2,Wght
          ENDIF
        IF(DT_RNDM(dum).GT.Wght) GOTO 175

        Y1 = X_out_1
        Y2 = X_out_2

        Q2P1 = 0.D0
        Q2P2 = 0.D0
        GYY(1) = Y1
        GQ2(1) = Q2P1
        GYY(2) = Y2
        GQ2(2) = Q2P2
C  incoming electron 1
        PINI(1,1) = 0.D0
        PINI(2,1) = 0.D0
        PINI(3,1) = EE1
        PINI(4,1) = EE1
        PINI(5,1) = 0.D0
C  outgoing electron 1
        YQ2 = SQRT((1.D0-Y1)*Q2P2)
        Q2E = Q2P1/(4.D0*EE1)
        E1Y = EE1*(1.D0-Y1)
        CALL PHO_SFECFE(SIF,COF)
        PFIN(1,1) = YQ2*COF
        PFIN(2,1) = YQ2*SIF
        PFIN(3,1) = E1Y-Q2E
        PFIN(4,1) = E1Y+Q2E
        PFIN(5,1) = 0.D0
C  photon 1
        P1(1) = -PFIN(1,1)
        P1(2) = -PFIN(2,1)
        P1(3) = PINI(3,1)-PFIN(3,1)
        P1(4) = PINI(4,1)-PFIN(4,1)
C  incoming electron 2
        PINI(1,2) = 0.D0
        PINI(2,2) = 0.D0
        PINI(3,2) = -EE2
        PINI(4,2) = EE2
        PINI(5,2) = 0.D0
C  outgoing electron 2
        YQ2 = SQRT((1.D0-Y2)*Q2P2)
        Q2E = Q2P2/(4.D0*EE2)
        E1Y = EE2*(1.D0-Y2)
        CALL PHO_SFECFE(SIF,COF)
        PFIN(1,2) = YQ2*COF
        PFIN(2,2) = YQ2*SIF
        PFIN(3,2) = -E1Y+Q2E
        PFIN(4,2) = E1Y+Q2E
        PFIN(5,2) = 0.D0
C  photon 2
        P2(1) = -PFIN(1,2)
        P2(2) = -PFIN(2,2)
        P2(3) = PINI(3,2)-PFIN(3,2)
        P2(4) = PINI(4,2)-PFIN(4,2)
C  ECMS cut
        GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
     &         -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
        IF(GGECM.LT.0.1D0) GOTO 175
        GGECM = SQRT(GGECM)
        IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175

        PGAM(1,1) = P1(1)
        PGAM(2,1) = P1(2)
        PGAM(3,1) = P1(3)
        PGAM(4,1) = P1(4)
        PGAM(5,1) = 0.D0
        PGAM(1,2) = P2(1)
        PGAM(2,2) = P2(2)
        PGAM(3,2) = P2(3)
        PGAM(4,2) = P2(4)
        PGAM(5,2) = 0.D0
C  photon helicities
        IGHEL(1) = 1
        IGHEL(2) = 1
C  cut given by user
        CALL PHO_PRESEL(5,IREJ)
        IF(IREJ.NE.0) GOTO 175
C  event generation
        CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
        IF(IREJ.NE.0) GOTO 150

C  statistics
        AY1  = AY1+Y1
        AYS1 = AYS1+Y1*Y1
        AY2  = AY2+Y2
        AYS2 = AYS2+Y2*Y2
C  histograms
        CALL PHO_PHIST(1,HSWGHT(0))
        CALL PHO_LHIST(1,HSWGHT(0))
 200  CONTINUE

      WGY  = DBLE(ITRY)/DBLE(ITRW)
      AY1  = AY1/DBLE(NITER)
      AYS1 = AYS1/DBLE(NITER)
      DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
      AY2  = AY2/DBLE(NITER)
      AYS2 = AYS2/DBLE(NITER)
      DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
      WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
C  output of statistics, histograms
      IF (LPRI.GT.4)
     &WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
     &'=========================================================',
     &' *****   simulated cross section: ',WEIGHT,' mb  *****',
     &'========================================================='
      IF (LPRI.GT.4)
     &WRITE(LO,'(//1X,A,3I10)')
     &  'PHO_GGBLSR:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
     &  WGY,WEIGHT
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBLSR:AVERAGE Y1,DY1 ',AY1,DAY1
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBLSR:AVERAGE Y2,DY2 ',AY2,DAY2

      CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
      IF(NITER.GT.1) THEN
        CALL PHO_PHIST(-2,WEIGHT)
        CALL PHO_LHIST(-2,WEIGHT)
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I4)') 'PHO_GGBLSR:NO OUTPUT OF HISTOGRAMS',NITER
      ENDIF

      END


 
 


CDECK  ID>, PHO_GGEPEM
      SUBROUTINE PHO_GGEPEM(NEVENT,EE1,EE2)
C**********************************************************************
C
C     interface to call PHOJET (variable energy run) for
C     gamma-gamma collisions on e+e- collider
C
C     fully differential equivalent (improved) photon approximation
C     to get photon flux
C
C     input:     EE1     LAB system energy of electron/positron 1
C                EE2     LAB system energy of electron/positron 2
C                NEVENT  >0  number of events to generate
C                        -1   initialization
C                        -2   final call (cross section calculation)
C            from /LEPCUT/:
C                YMIN1   lower limit of Y1
C                        (energy fraction taken by photon from electron)
C                YMAX1   upper limit of Y1
C                Q2MIN1  lower limit of photon virtuality
C                Q2MAX1  upper limit of photon virtuality
C                THMIN1  lower limit of scattered electron
C                THMAX1  upper limit of scattered electron
C                YMIN2   lower limit of Y2
C                        (energy fraction taken by photon from electron)
C                YMAX2   upper limit of Y2
C                Q2MIN2  lower limit of photon virtuality
C                Q2MAX2  upper limit of photon virtuality
C                THMIN2  lower limit of scattered electron
C                THMAX2  upper limit of scattered electron
C
C     output:    after final call with NEVENT=-2
C                EE1     e+ e- cross section (mb)
C                EE2     gamma-gamma cross section (mb)
C
C**********************************************************************

      IMPLICIT NONE
      SAVE

      DOUBLE PRECISION EE1,EE2
      INTEGER NEVENT

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

C  photon flux kinematics and cuts
      DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
     &                 YMIN1,YMAX1,YMIN2,YMAX2,
     &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
     &                 THMIN1,THMAX1,THMIN2,THMAX2
      INTEGER          ITAG1,ITAG2
      COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
     &                YMIN1,YMAX1,YMIN2,YMAX2,
     &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
     &                THMIN1,THMAX1,THMIN2,THMAX2,
     &                ITAG1,ITAG2

C  gamma-lepton or gamma-hadron vertex information
      INTEGER IGHEL,IDPSRC,IDBSRC
      DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
     &                 RADSRC,AMSRC,GAMSRC
      COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
     &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
     &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)

C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
      INTEGER IDEQP,IDEQB,IHFLD,IHFLS
      DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
      COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
     &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)

C  event weights and generated cross section
      INTEGER IPOWGC,ISWCUT,IVWGHT
      DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
      COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
     &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)

C  external functions
      DOUBLE PRECISION DT_RNDM

C  local variables
      DOUBLE PRECISION AN1MAX,AN1MIN,AN2MAX,AN2MIN,AY1,AY2,AYS1,AYS2,
     &  COF1,COF2,CPFTHE,DAY1,DAY2,DELLY,DITRY,DITRW,
     &  ECFRAC,ECMAX2,ECMIN2,EGAM,ELEM,ELEM2,FFL,FFT,FLUXL,FLUXT,
     &  FLXAPP,FLXQPM,GGECM2,P1,P2,PP,PT,PT2,Q21AV2,Q21AVE,Q21MAX,
     &  Q21MIN,Q22AV2,Q22AVE,Q22MAX,Q22MIN,Q2LOG1,Q2LOG2,Q2LOW1,
     &  Q2LOW2,Q2P1,Q2P2,SIF1,SIF2,SIGCUR,SIGMAX,THMAC1,
     &  THMAC2,THMIC1,THMIC2,WEIGHT,WG,WGFX,WGH,WGHAPP,WGHL,WGHQPM,
     &  WGMAX,WGY,X1DEL,X1MAX,X1MIN,X2DEL,X2MAX,X2MIN,Y1,Y2,YEFF1,YEFF2,
     &  YMI,YY1MAX,YY1MIN,YY2MAX,YY2MIN

      INTEGER I,IHEAC1,IHEAC2,IHETRY,IREJ,ITRW_low,ITRW_high,ITRY_low,
     &  ITRY_high,K,Max_tab,NITER,ITG1,ITG2

      DIMENSION P1(4),P2(4),IHETRY(4),IHEAC1(4),IHEAC2(4)
      INTEGER  IPHO_PDG2ID
      EXTERNAL IPHO_PDG2ID

C  initialization of event generation

      if(NEVENT.eq.-1) then

        DO 10 I=1,4
          IHETRY(I) = 0
          IHEAC1(I) = 0
          IHEAC2(I) = 0
 10     CONTINUE

        IF (LPRI.GT.4)
     &  WRITE(LO,'(//1X,A)') 'PHO_GGEPEM: initialization'

C  electron data
        ELEM = 0.512D-03
        ELEM2 = ELEM**2
        AMSRC(1) = ELEM
        AMSRC(2) = ELEM
C  lepton numbers
        IDPSRC(1) = 11
        IDPSRC(2) = -11
        IDBSRC(1) = IPHO_PDG2ID(11)
        IDBSRC(2) = IPHO_PDG2ID(-11)

C  check/update kinematic limitations

        Ymi = min(Ymax1,1.D0-ELEM/EE1)
        if(Ymi.lt.Ymax1) then
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,2E12.5)')
     &      'PHO_GGEPEM: Ymax1 decreased (old/new)',Ymax1,Ymi
          Ymax1 = YMI
        endif
        Ymi = min(Ymax2,1.D0-ELEM/EE2)
        if(Ymi.lt.Ymax2) then
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,2E12.5)')
     &      'PHO_GGEPEM: Ymax2 decreased (old/new)',Ymax2,Ymi
          Ymax2 = YMI
        endif

        YMI = ECMIN**2/(4.D0*EE1*EE2*YMAX2)
        IF(YMIN1.LT.YMI) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,2E12.5)')
     &      'PHO_GGEPEM: Ymin1 increased (old/new)',YMIN1,YMI
          YMIN1 = YMI
        ELSE IF(YMIN1.GT.YMI) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
     &      'PHO_GGEPEM:','ECM-CUT corresponds to YMIN1 of',YMI,
     &      '  INSTEAD OF',YMIN1
        ENDIF
        YMI = ECMIN**2/(4.D0*EE1*EE2*YMAX1)
        IF(YMIN2.LT.YMI) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,2E12.5)')
     &      'PHO_GGEPEM: Ymin2 increased (old/new)',YMIN2,YMI
          YMIN2 = YMI
        ELSE IF(YMIN2.GT.YMI) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
     &      'PHO_GGEPEM:','ECM-CUT corresponds to YMIN2 of',YMI,
     &      '  INSTEAD OF',YMIN2
        ENDIF

C  store COS of angular tagging range
        THMIC1 = COS(MAX(0.D0,THMIN1))
        THMAC1 = COS(MIN(THMAX1,PI))
        THMIC2 = COS(MAX(0.D0,THMIN2))
        THMAC2 = COS(MIN(THMAX2,PI))

        X1MAX = LOG(YMAX1)
        X1MIN = LOG(YMIN1)
        X1DEL = X1MAX-X1MIN
        X2MAX = LOG(YMAX2)
        X2MIN = LOG(YMIN2)
        X2DEL = X2MAX-X2MIN

C  debug: integrated photon flux

        if(IDEB(30).ge.1) then
          Max_tab = 50
          FLUXT = 0.D0
          FLUXL = 0.D0
          DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
          IF (LPRI.GT.4 .AND. IDEB(30).GE.2)
     &    WRITE(LO,'(1X,2A,I5)') 'PHO_GGEPEM: ',
     &      'table of photon flux (trans/long side 1)',Max_tab
          do I=1,Max_tab
            Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
            if((1.D0-Y1).gt.1.D-8) then
              Q2LOW1 = MAX(Q2MIN1,ELEM2*Y1*Y1/(1.D0-Y1))
            else
              Q2low1 = 2.D0*Q2max1
            endif
            if(Q2low1.lt.Q2max1) then
              FFT = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
     &        -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))/(2.D0*PI*137.D0)
              FFL = 2.D0*(1.D0-Y1)*LOG(Q2MAX1/Q2LOW1)/(2.D0*PI*137.D0)
            else
              FFT = 0.D0
              FFL = 0.D0
            endif
            FLUXT = FLUXT + Y1*FFL
            FLUXL = FLUXL + Y1*FFT
            IF (LPRI.GT.4 .AND. IDEB(30).GE.2)
     .      WRITE(LO,'(5X,1P3E14.4)') Y1,FFT,FFL
          enddo
          FLUXT = FLUXT*DELLY
          FLUXL = FLUXL*DELLY
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,2A,1P2E12.4)') 'PHO_GGEPEM: ',
     &      'integrated flux (trans/long side 1):',FLUXT,FLUXL
        endif

C  maximum weight

        Q2LOW1 = MAX(Q2MIN1,ELEM2*YMIN1**2/(1.D0-YMIN1))
        Q2LOW2 = MAX(Q2MIN2,ELEM2*YMIN2**2/(1.D0-YMIN2))
        Y1 = YMIN1
        Y2 = YMIN2
        IF(ISWMDL(10).GE.2) THEN
C  long. and transversely polarized photons
          WGMAX = ((1.D0+(1.D0-Y1)**2+2.D0*(1.D0-Y1))*LOG(Q2MAX1/Q2LOW1)
     &           -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
     &           *((1.D0+(1.D0-Y2)**2+2.D0*(1.D0-Y2))*LOG(Q2MAX2/Q2LOW2)
     &           -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
        ELSE
C  transversely polarized photons only
          WGMAX = ((1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
     &           -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
     &           *((1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
     &           -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
        ENDIF

C  initialize gamma-gamma event generator

C  photon 1
        EGAM = YMAX1*EE1
        P1(1) = 0.D0
        P1(2) = 0.D0
        P1(3) = SQRT(EGAM**2-Q2LOW1)
        P1(4) = EGAM
C  photon 2
        EGAM = YMAX2*EE2
        P2(1) = 0.D0
        P2(2) = 0.D0
        P2(3) = -SQRT(EGAM**2-Q2LOW2)
        P2(4) = EGAM
C  sum of helicities
        IGHEL(1) = -1
        IGHEL(2) = -1

C  set min. energy for interpolation tables
        parmdl(19) = min(parmdl(19),ecmin)

C  initialize event gneration
        CALL PHO_SETPAR(1,22,0,0.D0)
        CALL PHO_SETPAR(2,22,0,0.D0)
        CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
        CALL PHO_PHIST(-1,SIGMAX)
        CALL PHO_LHIST(-1,SIGMAX)

C  generation of events, flux calculation

        ECMIN2 = ECMIN**2
        ECMAX2 = ECMAX**2
        ECFRAC = ECMIN2/(4.D0*EE1*EE2)
        AY1  = 0.D0
        AY2  = 0.D0
        AYS1 = 0.D0
        AYS2 = 0.D0
        Q21MIN = 1.D30
        Q22MIN = 1.D30
        Q21MAX = 0.D0
        Q22MAX = 0.D0
        Q21AVE = 0.D0
        Q22AVE = 0.D0
        Q21AV2 = 0.D0
        Q22AV2 = 0.D0
        AN1MIN = 1.D30
        AN2MIN = 1.D30
        AN1MAX = 0.D0
        AN2MAX = 0.D0
        YY1MIN = 1.D30
        YY2MIN = 1.D30
        YY1MAX = 0.D0
        YY2MAX = 0.D0
        NITER = 0
        ITRY_low = 0
        ITRY_high = 0
        ITRW_low = 0
        ITRW_high = 0

C  generate NEVENT events (might be just 1 per call)

      else if(NEVENT.gt.0) then

        NITER = NITER+NEVENT

        DO 200 I=1,NEVENT

C  sample y1, y2
 150      CONTINUE
          ITRY_low = ITRY_low+1
          if(ITRY_low.eq.1000000) then
            ITRY_low = 0
            ITRY_high = ITRY_high+1
          endif

 175      CONTINUE
            ITRW_low = ITRW_low+1
            if(ITRW_low.eq.1000000) then
              ITRW_low = 0
              ITRW_high = ITRW_high+1
            endif

            Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
            Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
            IF(Y1*Y2.LT.ECFRAC) GOTO 175
            IF(ISWMDL(10).GE.2) THEN
              YEFF1 = 1.D0+(1.D0-Y1)**2+2.D0*(1.D0-Y1)
              YEFF2 = 1.D0+(1.D0-Y2)**2+2.D0*(1.D0-Y2)
            ELSE
              YEFF1 = 1.D0+(1.D0-Y1)**2
              YEFF2 = 1.D0+(1.D0-Y2)**2
            ENDIF

            Q2LOW1 = MAX(Q2MIN1,ELEM2*Y1**2/(1.D0-Y1))
            Q2LOW2 = MAX(Q2MIN2,ELEM2*Y2**2/(1.D0-Y2))
            Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
            Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
            WGH = (YEFF1*Q2LOG1
     &             -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
     &           *(YEFF2*Q2LOG2
     &             -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
            IF(WGMAX.LT.WGH) THEN
              IF (LPRI.GT.4)
     &        WRITE(LO,'(1X,A,4E12.5)')
     &          'PHO_GGEPEM: inconsistent weight:',Y1,Y2,WGMAX,WGH
            ENDIF
          IF(DT_RNDM(AYS1)*WGMAX.GT.WGH) GOTO 175

C  limit on Ecm_gg (app. cut, precise cut applied later)
          GGECM2 = 4.D0*Y1*Y2*EE1*EE2
          if(GGECM2.lt.ECMIN2) goto 175

C  sample Q2
          IF(IPAMDL(174).EQ.1) THEN
 185        CONTINUE
              Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
              WEIGHT = (YEFF1-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF1
            IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
          ELSE
            Q2P1 = Q2LOW1
          ENDIF

          IF(IPAMDL(174).EQ.1) THEN
 186        CONTINUE
              Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
              WEIGHT = (YEFF2-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF2
            IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
          ELSE
            Q2P2 = Q2LOW2
          ENDIF

          GYY(1) = Y1
          GQ2(1) = Q2P1
          GYY(2) = Y2
          GQ2(2) = Q2P2

C  incoming electron 1
          PINI(1,1) = 0.D0
          PINI(2,1) = 0.D0
          PINI(3,1) = EE1*(1.D0-0.5D0*ELEM2/EE1**2)
          PINI(4,1) = EE1
          PINI(5,1) = ELEM
C  photon 1
          PP = (2.D0*EE1**2*Y1+Q2P1)/(2.D0*PINI(3,1))
          PT2 = (EE1**2*(Q2P1*(1.D0-Y1)-ELEM2*Y1**2)
     &         -0.25D0*Q2P1**2-Q2P1*ELEM2)/PINI(3,1)**2
          IF(PT2.LT.0.D0) GOTO 175
          PT = SQRT(PT2)
          CALL PHO_SFECFE(SIF1,COF1)
          P1(1) = COF1*PT
          P1(2) = SIF1*PT
          P1(3) = PP
          P1(4) = EE1*Y1
C  outgoing electron 1
          PFIN(1,1) = -P1(1)
          PFIN(2,1) = -P1(2)
          PFIN(3,1) = PINI(3,1)-P1(3)
          PFIN(4,1) = PINI(4,1)-P1(4)
          PFIN(5,1) = ELEM
C  incoming electron 2
          PINI(1,2) = 0.D0
          PINI(2,2) = 0.D0
          PINI(3,2) = -EE2*(1.D0-0.5D0*ELEM2/EE2**2)
          PINI(4,2) = EE2
          PINI(5,2) = 0.D0
C  photon 2
          PP = (2.D0*EE2**2*Y2+Q2P2)/(2.D0*PINI(3,2))
          PT2 = (EE2**2*(Q2P2*(1.D0-Y2)-ELEM2*Y2**2)
     &         -0.25D0*Q2P2**2-Q2P2*ELEM2)/PINI(3,2)**2
          IF(PT2.LT.0.D0) GOTO 175
          PT = SQRT(PT2)
          CALL PHO_SFECFE(SIF2,COF2)
          P2(1) = COF2*PT
          P2(2) = SIF2*PT
          P2(3) = PP
          P2(4) = EE2*Y2
C  outgoing electron 2
          PFIN(1,2) = -P2(1)
          PFIN(2,2) = -P2(2)
          PFIN(3,2) = PINI(3,2)-P2(3)
          PFIN(4,2) = PINI(4,2)-P2(4)
          PFIN(5,2) = ELEM

C  precise ECMS cut

          GGECM2 = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
     &           -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
          IF((GGECM2.LT.ECMIN2).OR.(GGECM2.GT.ECMAX2)) GOTO 175
          GGECM = SQRT(GGECM2)

C  beam lepton detector acceptance

C  lepton tagger 1
          CPFTHE = PFIN(3,1)/PFIN(4,1)
          ITG1 = 0
          IF(PFIN(4,1).GE.EEMIN1) THEN
            IF((CPFTHE.LE.THMIC1).AND.(CPFTHE.GE.THMAC1)) ITG1 = 1
          ENDIF

C  lepton tagger 2
          CPFTHE = PFIN(3,2)/PFIN(4,2)
          ITG2 = 0
          IF(PFIN(4,2).GE.EEMIN2) THEN
            IF((CPFTHE.LE.THMIC2).AND.(CPFTHE.GE.THMAC2)) ITG2 = 1
          ENDIF

C  beam lepton taggers

C  anti-tag
          IF((ITAG1.EQ.-1).AND.(ITG1.NE.0)) GOTO 175
          IF((ITAG2.EQ.-1).AND.(ITG2.NE.0)) GOTO 175
C  tag
          IF((ITAG1.EQ.1).AND.(ITG1.EQ.0)) GOTO 175
          IF((ITAG2.EQ.1).AND.(ITG2.EQ.0)) GOTO 175
C  single-tag inclusive
          IF((ITAG1.EQ.0).AND.(ITAG2.EQ.0).AND.(ITG1+ITG2.EQ.0))
     &      GOTO 175
C  single-tag/anti-tag
          IF((ITAG1.EQ.2).AND.(ITAG2.EQ.2).AND.(ITG1+ITG2.NE.1))
     &      GOTO 175

          PGAM(1,1) = P1(1)
          PGAM(2,1) = P1(2)
          PGAM(3,1) = P1(3)
          PGAM(4,1) = P1(4)
          PGAM(5,1) = -SQRT(Q2P1)
          PGAM(1,2) = P2(1)
          PGAM(2,2) = P2(2)
          PGAM(3,2) = P2(3)
          PGAM(4,2) = P2(4)
          PGAM(5,2) = -SQRT(Q2P2)

C  photon helicities
          IF(ISWMDL(10).GE.2) THEN
            WGH  = YEFF1-2.D0*ELEM2*Y1**2/Q2P1
            WGHL = 2.D0*(1-Y1)
            IF(DT_RNDM(Y1).GT.WGHL/WGH) THEN
              IGHEL(1) = 1
            ELSE
              IGHEL(1) = 0
            ENDIF
            WGH  = YEFF2-2.D0*ELEM2*Y2**2/Q2P2
            WGHL = 2.D0*(1-Y2)
            IF(DT_RNDM(Y2).GT.WGHL/WGH) THEN
              IGHEL(2) = 1
            ELSE
              IGHEL(2) = 0
            ENDIF
            K = 2*IGHEL(1)+IGHEL(2)+1
            IHETRY(K) = IHETRY(K)+1
          ELSE
            IGHEL(1) = -1
            IGHEL(2) = -1
          ENDIF

C  user cuts
          CALL PHO_PRESEL(5,IREJ)
          IF(IREJ.NE.0) GOTO 175

          WGFX = 1.D0
C  reweight according to LO photon emission diagrams (Budnev et al.)
          IF(IPAMDL(116).GE.1) THEN
            CALL PHO_WGEPEM(FLXAPP,FLXQPM,0)
            WGFX = FLXQPM/FLXAPP
            if(WGFX.gt.1.D0) then
              IF (LPRI.GT.4)
     &        WRITE(LO,'(1x,a,/,5x,1p,5e11.4)')
     &          ' PHO_GGEPEM: flux weight > 1 (y1/2,Q21/2,W)',
     &          Y1,Y2,Q2P1,Q2P2,GGECM
            endif
          ENDIF

C  event generation
*         IVWGHT(1) = 1
*         EVWGHT(1) = MAX(WGFX,1.D0)
          CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
          IF(IREJ.NE.0) GOTO 150
          IF(ISWMDL(10).GE.2) THEN
            K = 2*IGHEL(1)+IGHEL(2)+1
            IHEAC1(K) = IHEAC1(K)+1
          ENDIF

C  reweight according to QPM model (e+e- collider only)
          IF((KHDIR.GT.0).AND.
     &      (IPAMDL(116).GE.2).AND.(ISWMDL(10).GE.2)) THEN
            CALL PHO_WGEPEM(WGHAPP,WGHQPM,1)
            WG = WGHQPM/WGHAPP/MAX(1.D0,WGFX)
            IF(DT_RNDM(WG).GT.WG) GOTO 150
          ELSE IF(IPAMDL(116).GE.1) THEN
            IF(DT_RNDM(WG).GT.WGFX) GOTO 150
          ENDIF

C  polar angle
          PFTHE(1) = ACOS(PFIN(3,1)/PFIN(4,1))
          PFTHE(2) = ACOS(PFIN(3,2)/PFIN(4,2))
C  azimuthal angle
          PFPHI(1) = ATAN2(COF1,SIF1)
          PFPHI(2) = ATAN2(COF2,SIF2)

C  statistics
          AY1  = AY1+Y1
          AYS1 = AYS1+Y1*Y1
          AY2  = AY2+Y2
          AYS2 = AYS2+Y2*Y2
          Q21MIN = MIN(Q21MIN,Q2P1)
          Q22MIN = MIN(Q22MIN,Q2P2)
          Q21MAX = MAX(Q21MAX,Q2P1)
          Q22MAX = MAX(Q22MAX,Q2P2)
          AN1MIN = MIN(AN1MIN,PFTHE(1))
          AN2MIN = MIN(AN2MIN,PFTHE(2))
          AN1MAX = MAX(AN1MAX,PFTHE(1))
          AN2MAX = MAX(AN2MAX,PFTHE(2))
          YY1MIN = MIN(YY1MIN,Y1)
          YY2MIN = MIN(YY2MIN,Y2)
          YY1MAX = MAX(YY1MAX,Y1)
          YY2MAX = MAX(YY2MAX,Y2)
          Q21AVE = Q21AVE+Q2P1
          Q22AVE = Q22AVE+Q2P2
          Q21AV2 = Q21AV2+Q2P1*Q2P1
          Q22AV2 = Q22AV2+Q2P2*Q2P2
          IF(ISWMDL(10).GE.2) THEN
            K = 2*IGHEL(1)+IGHEL(2)+1
            IHEAC2(K) = IHEAC2(K)+1
          ENDIF

C  external histograms
          CALL PHO_PHIST(1,HSWGHT(0))
          CALL PHO_LHIST(1,HSWGHT(0))
 200    CONTINUE

C  final cross section calculation and event generation summary

      else if(NEVENT.eq.-2) then

*       EVWGHT(1) = 1.D0
*       IVWGHT(1) = 0
        DITRY = dble(ITRY_high)*1.D+6+dble(ITRY_low)
        DITRW = dble(ITRW_high)*1.D+6+dble(ITRW_low)
        WGY  = WGMAX*DITRY/DITRW/(137.D0*2.D0*PI)**2
        WGY  = WGY*LOG(YMAX1/YMIN1)*LOG(YMAX2/YMIN2)
        AY1  = AY1/DBLE(NITER)
        AYS1 = AYS1/DBLE(NITER)
        DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
        AY2  = AY2/DBLE(NITER)
        AYS2 = AYS2/DBLE(NITER)
        DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
        Q21AVE = Q21AVE/DBLE(NITER)
        Q21AV2 = Q21AV2/DBLE(NITER)
        Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(NITER))
        Q22AVE = Q22AVE/DBLE(NITER)
        Q22AV2 = Q22AV2/DBLE(NITER)
        Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
        WEIGHT = WGY*SIGMAX*DBLE(NITER)/DITRY
        EE1 = WEIGHT
        EE2 = SIGMAX*DBLE(NITER)/DITRY

C  output of statistics, histograms
        IF (LPRI.GT.4)
     &  WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
     &    '=========================================================',
     &    ' *****   simulated cross section: ',WEIGHT,' mb  *****',
     &    '========================================================='
        IF (LPRI.GT.4)
     &  WRITE(LO,'(//1X,A,I10,1p,2e14.6)')
     &    'PHO_GGEPEM:summary: NITER,ITRY,ITRW',NITER,DITRY,DITRW
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,1P2E12.4)') 'effective weight (FLUX,TOTAL)',
     &    WGY,WEIGHT
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,1P2E12.4)') 'average Y1,DY1               ',
     &    AY1,DAY1
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,1P2E12.4)') 'average Y2,DY2               ',
     &    AY2,DAY2
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Y range photon 1     ',
     &    YY1MIN,YY1MAX
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Y range photon 2     ',
     &    YY2MIN,YY2MAX
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,1P2E12.4)') 'average Q2,DQ2 photon 1      ',
     &    Q21AVE,Q21AV2
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Q2 range photon 1    ',
     &    Q21MIN,Q21MAX
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,1P2E12.4)') 'average Q2,DQ2  photon 2     ',
     &    Q22AVE,Q22AV2
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Q2 range photon 2    ',
     &    Q22MIN,Q22MAX
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,1P2E12.4)') 'sampled THETA range electron1',
     &    AN1MIN,AN1MAX
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,1P4E12.4)') 'sampled THETA range electron2',
     &    AN2MIN,AN2MAX,PI-AN2MAX,PI-AN2MIN

        IF(ISWMDL(10).GE.2) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,3(/1X,A,4I12))')
     &    'Helicity decomposition:    0 0      0 1      1 0       1 1',
     &    'tried:        ',IHETRY,
     &    'accepted (1): ',IHEAC1,
     &    'accepted (2): ',IHEAC2
        ENDIF

        CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
        IF(NITER.GT.1) THEN
          CALL PHO_PHIST(-2,WEIGHT)
          CALL PHO_LHIST(-2,WEIGHT)
        ELSE
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,I4)')
     &      'PHO_GGEPEM: no output of histograms',NITER
        ENDIF

      endif

      END


 
 


CDECK  ID>, PHO_GGFAUX
      DOUBLE PRECISION FUNCTION PHO_GGFAUX(b1)
C*********************************************************************
C
C     auxiliary function for integration over b2,
C     semi-classical photon flux correction due to
C     overlap in impact parameter space (geometrical model)
C
C*********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER (PI = 3.141592653589793238462643383279D+00,ACCUR = 1D-2)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  gamma-lepton or gamma-hadron vertex information
      INTEGER IGHEL,IDPSRC,IDBSRC
      DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
     &                 RADSRC,AMSRC,GAMSRC
      COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
     &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
     &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)

      DIMENSION XGAUSS(126),WGAUSS(126)

      DATA XGAUSS(1)/ .57735026918962576D0/
      DATA XGAUSS(2)/-.57735026918962576D0/
      DATA WGAUSS(1)/ 1.00000000000000000D0/
      DATA WGAUSS(2)/ 1.00000000000000000D0/

      DATA XGAUSS(3)/ .33998104358485627D0/
      DATA XGAUSS(4)/ .86113631159405258D0/
      DATA XGAUSS(5)/-.33998104358485627D0/
      DATA XGAUSS(6)/-.86113631159405258D0/
      DATA WGAUSS(3)/ .65214515486254613D0/
      DATA WGAUSS(4)/ .34785484513745385D0/
      DATA WGAUSS(5)/ .65214515486254613D0/
      DATA WGAUSS(6)/ .34785484513745385D0/

      DATA XGAUSS(7)/ .18343464249564981D0/
      DATA XGAUSS(8)/ .52553240991632899D0/
      DATA XGAUSS(9)/ .79666647741362674D0/
      DATA XGAUSS(10)/ .96028985649753623D0/
      DATA XGAUSS(11)/-.18343464249564981D0/
      DATA XGAUSS(12)/-.52553240991632899D0/
      DATA XGAUSS(13)/-.79666647741362674D0/
      DATA XGAUSS(14)/-.96028985649753623D0/
      DATA WGAUSS(7)/ .36268378337836198D0/
      DATA WGAUSS(8)/ .31370664587788727D0/
      DATA WGAUSS(9)/ .22238103445337448D0/
      DATA WGAUSS(10)/ .10122853629037627D0/
      DATA WGAUSS(11)/ .36268378337836198D0/
      DATA WGAUSS(12)/ .31370664587788727D0/
      DATA WGAUSS(13)/ .22238103445337448D0/
      DATA WGAUSS(14)/ .10122853629037627D0/

      DATA XGAUSS(15)/ .0950125098376374402D0/
      DATA XGAUSS(16)/ .281603550779258913D0/
      DATA XGAUSS(17)/ .458016777657227386D0/
      DATA XGAUSS(18)/ .617876244402643748D0/
      DATA XGAUSS(19)/ .755404408355003034D0/
      DATA XGAUSS(20)/ .865631202387831744D0/
      DATA XGAUSS(21)/ .944575023073232576D0/
      DATA XGAUSS(22)/ .989400934991649933D0/
      DATA XGAUSS(23)/-.0950125098376374402D0/
      DATA XGAUSS(24)/-.281603550779258913D0/
      DATA XGAUSS(25)/-.458016777657227386D0/
      DATA XGAUSS(26)/-.617876244402643748D0/
      DATA XGAUSS(27)/-.755404408355003034D0/
      DATA XGAUSS(28)/-.865631202387831744D0/
      DATA XGAUSS(29)/-.944575023073232576D0/
      DATA XGAUSS(30)/-.989400934991649933D0/
      DATA WGAUSS(15)/ .189450610455068496D0/
      DATA WGAUSS(16)/ .182603415044923589D0/
      DATA WGAUSS(17)/ .169156519395002538D0/
      DATA WGAUSS(18)/ .149595988816576732D0/
      DATA WGAUSS(19)/ .124628971255533872D0/
      DATA WGAUSS(20)/ .0951585116824927848D0/
      DATA WGAUSS(21)/ .0622535239386478929D0/
      DATA WGAUSS(22)/ .0271524594117540949D0/
      DATA WGAUSS(23)/ .189450610455068496D0/
      DATA WGAUSS(24)/ .182603415044923589D0/
      DATA WGAUSS(25)/ .169156519395002538D0/
      DATA WGAUSS(26)/ .149595988816576732D0/
      DATA WGAUSS(27)/ .124628971255533872D0/
      DATA WGAUSS(28)/ .0951585116824927848D0/
      DATA WGAUSS(29)/ .0622535239386478929D0/
      DATA WGAUSS(30)/ .0271524594117540949D0/

      DATA XGAUSS(31)/ .0483076656877383162D0/
      DATA XGAUSS(32)/ .144471961582796493D0/
      DATA XGAUSS(33)/ .239287362252137075D0/
      DATA XGAUSS(34)/ .331868602282127650D0/
      DATA XGAUSS(35)/ .421351276130635345D0/
      DATA XGAUSS(36)/ .506899908932229390D0/
      DATA XGAUSS(37)/ .587715757240762329D0/
      DATA XGAUSS(38)/ .663044266930215201D0/
      DATA XGAUSS(39)/ .732182118740289680D0/
      DATA XGAUSS(40)/ .794483795967942407D0/
      DATA XGAUSS(41)/ .849367613732569970D0/
      DATA XGAUSS(42)/ .896321155766052124D0/
      DATA XGAUSS(43)/ .934906075937739689D0/
      DATA XGAUSS(44)/ .964762255587506430D0/
      DATA XGAUSS(45)/ .985611511545268335D0/
      DATA XGAUSS(46)/ .997263861849481564D0/
      DATA XGAUSS(47)/-.0483076656877383162D0/
      DATA XGAUSS(48)/-.144471961582796493D0/
      DATA XGAUSS(49)/-.239287362252137075D0/
      DATA XGAUSS(50)/-.331868602282127650D0/
      DATA XGAUSS(51)/-.421351276130635345D0/
      DATA XGAUSS(52)/-.506899908932229390D0/
      DATA XGAUSS(53)/-.587715757240762329D0/
      DATA XGAUSS(54)/-.663044266930215201D0/
      DATA XGAUSS(55)/-.732182118740289680D0/
      DATA XGAUSS(56)/-.794483795967942407D0/
      DATA XGAUSS(57)/-.849367613732569970D0/
      DATA XGAUSS(58)/-.896321155766052124D0/
      DATA XGAUSS(59)/-.934906075937739689D0/
      DATA XGAUSS(60)/-.964762255587506430D0/
      DATA XGAUSS(61)/-.985611511545268335D0/
      DATA XGAUSS(62)/-.997263861849481564D0/
      DATA WGAUSS(31)/ .0965400885147278006D0/
      DATA WGAUSS(32)/ .0956387200792748594D0/
      DATA WGAUSS(33)/ .0938443990808045654D0/
      DATA WGAUSS(34)/ .0911738786957638847D0/
      DATA WGAUSS(35)/ .0876520930044038111D0/
      DATA WGAUSS(36)/ .0833119242269467552D0/
      DATA WGAUSS(37)/ .0781938957870703065D0/
      DATA WGAUSS(38)/ .0723457941088485062D0/
      DATA WGAUSS(39)/ .0658222227763618468D0/
      DATA WGAUSS(40)/ .0586840934785355471D0/
      DATA WGAUSS(41)/ .0509980592623761762D0/
      DATA WGAUSS(42)/ .0428358980222266807D0/
      DATA WGAUSS(43)/ .0342738629130214331D0/
      DATA WGAUSS(44)/ .0253920653092620595D0/
      DATA WGAUSS(45)/ .0162743947309056706D0/
      DATA WGAUSS(46)/ .00701861000947009660D0/
      DATA WGAUSS(47)/ .0965400885147278006D0/
      DATA WGAUSS(48)/ .0956387200792748594D0/
      DATA WGAUSS(49)/ .0938443990808045654D0/
      DATA WGAUSS(50)/ .0911738786957638847D0/
      DATA WGAUSS(51)/ .0876520930044038111D0/
      DATA WGAUSS(52)/ .0833119242269467552D0/
      DATA WGAUSS(53)/ .0781938957870703065D0/
      DATA WGAUSS(54)/ .0723457941088485062D0/
      DATA WGAUSS(55)/ .0658222227763618468D0/
      DATA WGAUSS(56)/ .0586840934785355471D0/
      DATA WGAUSS(57)/ .0509980592623761762D0/
      DATA WGAUSS(58)/ .0428358980222266807D0/
      DATA WGAUSS(59)/ .0342738629130214331D0/
      DATA WGAUSS(60)/ .0253920653092620595D0/
      DATA WGAUSS(61)/ .0162743947309056706D0/
      DATA WGAUSS(62)/ .00701861000947009660D0/

      DATA XGAUSS(63)/ .02435029266342443250D0/
      DATA XGAUSS(64)/ .0729931217877990394D0/
      DATA XGAUSS(65)/ .121462819296120554D0/
      DATA XGAUSS(66)/ .169644420423992818D0/
      DATA XGAUSS(67)/ .217423643740007084D0/
      DATA XGAUSS(68)/ .264687162208767416D0/
      DATA XGAUSS(69)/ .311322871990210956D0/
      DATA XGAUSS(70)/ .357220158337668116D0/
      DATA XGAUSS(71)/ .402270157963991604D0/
      DATA XGAUSS(72)/ .446366017253464088D0/
      DATA XGAUSS(73)/ .489403145707052957D0/
      DATA XGAUSS(74)/ .531279464019894546D0/
      DATA XGAUSS(75)/ .571895646202634034D0/
      DATA XGAUSS(76)/ .611155355172393250D0/
      DATA XGAUSS(77)/ .648965471254657340D0/
      DATA XGAUSS(78)/ .685236313054233243D0/
      DATA XGAUSS(79)/ .719881850171610827D0/
      DATA XGAUSS(80)/ .752819907260531897D0/
      DATA XGAUSS(81)/ .783972358943341408D0/
      DATA XGAUSS(82)/ .813265315122797560D0/
      DATA XGAUSS(83)/ .840629296252580363D0/
      DATA XGAUSS(84)/ .865999398154092820D0/
      DATA XGAUSS(85)/ .889315445995114106D0/
      DATA XGAUSS(86)/ .910522137078502806D0/
      DATA XGAUSS(87)/ .929569172131939576D0/
      DATA XGAUSS(88)/ .946411374858402816D0/
      DATA XGAUSS(89)/ .961008799652053719D0/
      DATA XGAUSS(90)/ .973326827789910964D0/
      DATA XGAUSS(91)/ .983336253884625957D0/
      DATA XGAUSS(92)/ .991013371476744321D0/
      DATA XGAUSS(93)/ .996340116771955279D0/
      DATA XGAUSS(94)/ .999305041735772139D0/
      DATA XGAUSS(95)/-.02435029266342443250D0/
      DATA XGAUSS(96)/-.0729931217877990394D0/
      DATA XGAUSS(97)/-.121462819296120554D0/
      DATA XGAUSS(98)/-.169644420423992818D0/
      DATA XGAUSS(99)/-.217423643740007084D0/
      DATA XGAUSS(100)/-.264687162208767416D0/
      DATA XGAUSS(101)/-.311322871990210956D0/
      DATA XGAUSS(102)/-.357220158337668116D0/
      DATA XGAUSS(103)/-.402270157963991604D0/
      DATA XGAUSS(104)/-.446366017253464088D0/
      DATA XGAUSS(105)/-.489403145707052957D0/
      DATA XGAUSS(106)/-.531279464019894546D0/
      DATA XGAUSS(107)/-.571895646202634034D0/
      DATA XGAUSS(108)/-.611155355172393250D0/
      DATA XGAUSS(109)/-.648965471254657340D0/
      DATA XGAUSS(110)/-.685236313054233243D0/
      DATA XGAUSS(111)/-.719881850171610827D0/
      DATA XGAUSS(112)/-.752819907260531897D0/
      DATA XGAUSS(113)/-.783972358943341408D0/
      DATA XGAUSS(114)/-.813265315122797560D0/
      DATA XGAUSS(115)/-.840629296252580363D0/
      DATA XGAUSS(116)/-.865999398154092820D0/
      DATA XGAUSS(117)/-.889315445995114106D0/
      DATA XGAUSS(118)/-.910522137078502806D0/
      DATA XGAUSS(119)/-.929569172131939576D0/
      DATA XGAUSS(120)/-.946411374858402816D0/
      DATA XGAUSS(121)/-.961008799652053719D0/
      DATA XGAUSS(122)/-.973326827789910964D0/
      DATA XGAUSS(123)/-.983336253884625957D0/
      DATA XGAUSS(124)/-.991013371476744321D0/
      DATA XGAUSS(125)/-.996340116771955279D0/
      DATA XGAUSS(126)/-.999305041735772139D0/
      DATA WGAUSS(63)/ .0486909570091397204D0/
      DATA WGAUSS(64)/ .0485754674415034269D0/
      DATA WGAUSS(65)/ .0483447622348029572D0/
      DATA WGAUSS(66)/ .0479993885964583077D0/
      DATA WGAUSS(67)/ .0475401657148303087D0/
      DATA WGAUSS(68)/ .0469681828162100173D0/
      DATA WGAUSS(69)/ .0462847965813144172D0/
      DATA WGAUSS(70)/ .0454916279274181445D0/
      DATA WGAUSS(71)/ .0445905581637565631D0/
      DATA WGAUSS(72)/ .0435837245293234534D0/
      DATA WGAUSS(73)/ .0424735151236535890D0/
      DATA WGAUSS(74)/ .0412625632426235286D0/
      DATA WGAUSS(75)/ .0399537411327203414D0/
      DATA WGAUSS(76)/ .0385501531786156291D0/
      DATA WGAUSS(77)/ .0370551285402400460D0/
      DATA WGAUSS(78)/ .0354722132568823838D0/
      DATA WGAUSS(79)/ .0338051618371416094D0/
      DATA WGAUSS(80)/ .0320579283548515535D0/
      DATA WGAUSS(81)/ .0302346570724024789D0/
      DATA WGAUSS(82)/ .0283396726142594832D0/
      DATA WGAUSS(83)/ .0263774697150546587D0/
      DATA WGAUSS(84)/ .0243527025687108733D0/
      DATA WGAUSS(85)/ .0222701738083832542D0/
      DATA WGAUSS(86)/ .0201348231535302094D0/
      DATA WGAUSS(87)/ .0179517157756973431D0/
      DATA WGAUSS(88)/ .0157260304760247193D0/
      DATA WGAUSS(89)/ .0134630478967186426D0/
      DATA WGAUSS(90)/ .0111681394601311288D0/
      DATA WGAUSS(91)/ .00884675982636394772D0/
      DATA WGAUSS(92)/ .00650445796897836286D0/
      DATA WGAUSS(93)/ .00414703326056246764D0/
      DATA WGAUSS(94)/ .00178328072169643295D0/
      DATA WGAUSS(95)/ .0486909570091397204D0/
      DATA WGAUSS(96)/ .0485754674415034269D0/
      DATA WGAUSS(97)/ .0483447622348029572D0/
      DATA WGAUSS(98)/ .0479993885964583077D0/
      DATA WGAUSS(99)/ .0475401657148303087D0/
      DATA WGAUSS(100)/ .0469681828162100173D0/
      DATA WGAUSS(101)/ .0462847965813144172D0/
      DATA WGAUSS(102)/ .0454916279274181445D0/
      DATA WGAUSS(103)/ .0445905581637565631D0/
      DATA WGAUSS(104)/ .0435837245293234534D0/
      DATA WGAUSS(105)/ .0424735151236535890D0/
      DATA WGAUSS(106)/ .0412625632426235286D0/
      DATA WGAUSS(107)/ .0399537411327203414D0/
      DATA WGAUSS(108)/ .0385501531786156291D0/
      DATA WGAUSS(109)/ .0370551285402400460D0/
      DATA WGAUSS(110)/ .0354722132568823838D0/
      DATA WGAUSS(111)/ .0338051618371416094D0/
      DATA WGAUSS(112)/ .0320579283548515535D0/
      DATA WGAUSS(113)/ .0302346570724024789D0/
      DATA WGAUSS(114)/ .0283396726142594832D0/
      DATA WGAUSS(115)/ .0263774697150546587D0/
      DATA WGAUSS(116)/ .0243527025687108733D0/
      DATA WGAUSS(117)/ .0222701738083832542D0/
      DATA WGAUSS(118)/ .0201348231535302094D0/
      DATA WGAUSS(119)/ .0179517157756973431D0/
      DATA WGAUSS(120)/ .0157260304760247193D0/
      DATA WGAUSS(121)/ .0134630478967186426D0/
      DATA WGAUSS(122)/ .0111681394601311288D0/
      DATA WGAUSS(123)/ .00884675982636394772D0/
      DATA WGAUSS(124)/ .00650445796897836286D0/
      DATA WGAUSS(125)/ .00414703326056246764D0/
      DATA WGAUSS(126)/ .00178328072169643295D0/
C
      W1 = PGAM(4,1)
      W2 = PGAM(4,2)
      bmin = b1 - 2.D0*RADSRC(1)
      IF (RADSRC(1) .GT. bmin) THEN
        bmin = RADSRC(1)
      ENDIF
      bmax = b1 + 2.D0 * RADSRC(1)

      XINT = 0.D0
      DO 100 N=1,6
        XINT2 = XINT
        XINT = 0.D0
        DO 200 I=2**N-1,2**(N+1)-2
          b2 = (bmax-bmin)/2.D0*XGAUSS(I)+(bmax+bmin)/2.D0
          XINT3 = PHO_GGFNUC(W1,b1,GAMSRC(1))
     &      * PHO_GGFNUC(W2,b2,GAMSRC(2))
     &      * ACOS ((b1**2+b2**2-4.D0*RADSRC(1)**2)/(2.D0*b1*b2))
          XINT = XINT +WGAUSS(I) * b2 * XINT3
 200    CONTINUE
        XINT = (bmax-bmin)/2.D0*XINT
        IF (ABS((XINT2 - XINT)/XINT) .LT. ACCUR) GOTO 300
 100  CONTINUE
      IF (LPRI.GT.4)
     &WRITE(LO,*) '  PHO_GGFAUX: (b2) GAUSS MAY BE INACCURATE'
 300  CONTINUE

      PHO_GGFAUX = XINT

      END


 
 


CDECK  ID>, PHO_GGFLCL
      DOUBLE PRECISION FUNCTION PHO_GGFLCL(XI)
C*********************************************************************
C
C     semi-classical photon flux (geometrical model)
C
C*********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PHO_GGFLCL = 2.D0/3.141592653589793238462643383279D+00
     &  *(XI*PHO_BESSK0(XI)*PHO_BESSK1(XI)
     &  -XI**2/2.D0*(PHO_BESSK1(XI)**2-PHO_BESSK0(XI)**2))

      END


 
 


CDECK  ID>, PHO_GGFLCR
      DOUBLE PRECISION FUNCTION PHO_GGFLCR(XI)
C*********************************************************************
C
C     semi-classical photon flux correction due to
C     overlap in impact parameter space (geometrical model)
C
C*********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER (PI = 3.141592653589793238462643383279D+00,ACCUR = 1D-2)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  gamma-lepton or gamma-hadron vertex information
      INTEGER IGHEL,IDPSRC,IDBSRC
      DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
     &                 RADSRC,AMSRC,GAMSRC
      COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
     &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
     &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)

      DIMENSION XGAUSS(126),WGAUSS(126)

      DATA XGAUSS(1)/ .57735026918962576D0/
      DATA XGAUSS(2)/-.57735026918962576D0/
      DATA WGAUSS(1)/ 1.00000000000000000D0/
      DATA WGAUSS(2)/ 1.00000000000000000D0/

      DATA XGAUSS(3)/ .33998104358485627D0/
      DATA XGAUSS(4)/ .86113631159405258D0/
      DATA XGAUSS(5)/-.33998104358485627D0/
      DATA XGAUSS(6)/-.86113631159405258D0/
      DATA WGAUSS(3)/ .65214515486254613D0/
      DATA WGAUSS(4)/ .34785484513745385D0/
      DATA WGAUSS(5)/ .65214515486254613D0/
      DATA WGAUSS(6)/ .34785484513745385D0/

      DATA XGAUSS(7)/ .18343464249564981D0/
      DATA XGAUSS(8)/ .52553240991632899D0/
      DATA XGAUSS(9)/ .79666647741362674D0/
      DATA XGAUSS(10)/ .96028985649753623D0/
      DATA XGAUSS(11)/-.18343464249564981D0/
      DATA XGAUSS(12)/-.52553240991632899D0/
      DATA XGAUSS(13)/-.79666647741362674D0/
      DATA XGAUSS(14)/-.96028985649753623D0/
      DATA WGAUSS(7)/ .36268378337836198D0/
      DATA WGAUSS(8)/ .31370664587788727D0/
      DATA WGAUSS(9)/ .22238103445337448D0/
      DATA WGAUSS(10)/ .10122853629037627D0/
      DATA WGAUSS(11)/ .36268378337836198D0/
      DATA WGAUSS(12)/ .31370664587788727D0/
      DATA WGAUSS(13)/ .22238103445337448D0/
      DATA WGAUSS(14)/ .10122853629037627D0/

      DATA XGAUSS(15)/ .0950125098376374402D0/
      DATA XGAUSS(16)/ .281603550779258913D0/
      DATA XGAUSS(17)/ .458016777657227386D0/
      DATA XGAUSS(18)/ .617876244402643748D0/
      DATA XGAUSS(19)/ .755404408355003034D0/
      DATA XGAUSS(20)/ .865631202387831744D0/
      DATA XGAUSS(21)/ .944575023073232576D0/
      DATA XGAUSS(22)/ .989400934991649933D0/
      DATA XGAUSS(23)/-.0950125098376374402D0/
      DATA XGAUSS(24)/-.281603550779258913D0/
      DATA XGAUSS(25)/-.458016777657227386D0/
      DATA XGAUSS(26)/-.617876244402643748D0/
      DATA XGAUSS(27)/-.755404408355003034D0/
      DATA XGAUSS(28)/-.865631202387831744D0/
      DATA XGAUSS(29)/-.944575023073232576D0/
      DATA XGAUSS(30)/-.989400934991649933D0/
      DATA WGAUSS(15)/ .189450610455068496D0/
      DATA WGAUSS(16)/ .182603415044923589D0/
      DATA WGAUSS(17)/ .169156519395002538D0/
      DATA WGAUSS(18)/ .149595988816576732D0/
      DATA WGAUSS(19)/ .124628971255533872D0/
      DATA WGAUSS(20)/ .0951585116824927848D0/
      DATA WGAUSS(21)/ .0622535239386478929D0/
      DATA WGAUSS(22)/ .0271524594117540949D0/
      DATA WGAUSS(23)/ .189450610455068496D0/
      DATA WGAUSS(24)/ .182603415044923589D0/
      DATA WGAUSS(25)/ .169156519395002538D0/
      DATA WGAUSS(26)/ .149595988816576732D0/
      DATA WGAUSS(27)/ .124628971255533872D0/
      DATA WGAUSS(28)/ .0951585116824927848D0/
      DATA WGAUSS(29)/ .0622535239386478929D0/
      DATA WGAUSS(30)/ .0271524594117540949D0/

      DATA XGAUSS(31)/ .0483076656877383162D0/
      DATA XGAUSS(32)/ .144471961582796493D0/
      DATA XGAUSS(33)/ .239287362252137075D0/
      DATA XGAUSS(34)/ .331868602282127650D0/
      DATA XGAUSS(35)/ .421351276130635345D0/
      DATA XGAUSS(36)/ .506899908932229390D0/
      DATA XGAUSS(37)/ .587715757240762329D0/
      DATA XGAUSS(38)/ .663044266930215201D0/
      DATA XGAUSS(39)/ .732182118740289680D0/
      DATA XGAUSS(40)/ .794483795967942407D0/
      DATA XGAUSS(41)/ .849367613732569970D0/
      DATA XGAUSS(42)/ .896321155766052124D0/
      DATA XGAUSS(43)/ .934906075937739689D0/
      DATA XGAUSS(44)/ .964762255587506430D0/
      DATA XGAUSS(45)/ .985611511545268335D0/
      DATA XGAUSS(46)/ .997263861849481564D0/
      DATA XGAUSS(47)/-.0483076656877383162D0/
      DATA XGAUSS(48)/-.144471961582796493D0/
      DATA XGAUSS(49)/-.239287362252137075D0/
      DATA XGAUSS(50)/-.331868602282127650D0/
      DATA XGAUSS(51)/-.421351276130635345D0/
      DATA XGAUSS(52)/-.506899908932229390D0/
      DATA XGAUSS(53)/-.587715757240762329D0/
      DATA XGAUSS(54)/-.663044266930215201D0/
      DATA XGAUSS(55)/-.732182118740289680D0/
      DATA XGAUSS(56)/-.794483795967942407D0/
      DATA XGAUSS(57)/-.849367613732569970D0/
      DATA XGAUSS(58)/-.896321155766052124D0/
      DATA XGAUSS(59)/-.934906075937739689D0/
      DATA XGAUSS(60)/-.964762255587506430D0/
      DATA XGAUSS(61)/-.985611511545268335D0/
      DATA XGAUSS(62)/-.997263861849481564D0/
      DATA WGAUSS(31)/ .0965400885147278006D0/
      DATA WGAUSS(32)/ .0956387200792748594D0/
      DATA WGAUSS(33)/ .0938443990808045654D0/
      DATA WGAUSS(34)/ .0911738786957638847D0/
      DATA WGAUSS(35)/ .0876520930044038111D0/
      DATA WGAUSS(36)/ .0833119242269467552D0/
      DATA WGAUSS(37)/ .0781938957870703065D0/
      DATA WGAUSS(38)/ .0723457941088485062D0/
      DATA WGAUSS(39)/ .0658222227763618468D0/
      DATA WGAUSS(40)/ .0586840934785355471D0/
      DATA WGAUSS(41)/ .0509980592623761762D0/
      DATA WGAUSS(42)/ .0428358980222266807D0/
      DATA WGAUSS(43)/ .0342738629130214331D0/
      DATA WGAUSS(44)/ .0253920653092620595D0/
      DATA WGAUSS(45)/ .0162743947309056706D0/
      DATA WGAUSS(46)/ .00701861000947009660D0/
      DATA WGAUSS(47)/ .0965400885147278006D0/
      DATA WGAUSS(48)/ .0956387200792748594D0/
      DATA WGAUSS(49)/ .0938443990808045654D0/
      DATA WGAUSS(50)/ .0911738786957638847D0/
      DATA WGAUSS(51)/ .0876520930044038111D0/
      DATA WGAUSS(52)/ .0833119242269467552D0/
      DATA WGAUSS(53)/ .0781938957870703065D0/
      DATA WGAUSS(54)/ .0723457941088485062D0/
      DATA WGAUSS(55)/ .0658222227763618468D0/
      DATA WGAUSS(56)/ .0586840934785355471D0/
      DATA WGAUSS(57)/ .0509980592623761762D0/
      DATA WGAUSS(58)/ .0428358980222266807D0/
      DATA WGAUSS(59)/ .0342738629130214331D0/
      DATA WGAUSS(60)/ .0253920653092620595D0/
      DATA WGAUSS(61)/ .0162743947309056706D0/
      DATA WGAUSS(62)/ .00701861000947009660D0/

      DATA XGAUSS(63)/ .02435029266342443250D0/
      DATA XGAUSS(64)/ .0729931217877990394D0/
      DATA XGAUSS(65)/ .121462819296120554D0/
      DATA XGAUSS(66)/ .169644420423992818D0/
      DATA XGAUSS(67)/ .217423643740007084D0/
      DATA XGAUSS(68)/ .264687162208767416D0/
      DATA XGAUSS(69)/ .311322871990210956D0/
      DATA XGAUSS(70)/ .357220158337668116D0/
      DATA XGAUSS(71)/ .402270157963991604D0/
      DATA XGAUSS(72)/ .446366017253464088D0/
      DATA XGAUSS(73)/ .489403145707052957D0/
      DATA XGAUSS(74)/ .531279464019894546D0/
      DATA XGAUSS(75)/ .571895646202634034D0/
      DATA XGAUSS(76)/ .611155355172393250D0/
      DATA XGAUSS(77)/ .648965471254657340D0/
      DATA XGAUSS(78)/ .685236313054233243D0/
      DATA XGAUSS(79)/ .719881850171610827D0/
      DATA XGAUSS(80)/ .752819907260531897D0/
      DATA XGAUSS(81)/ .783972358943341408D0/
      DATA XGAUSS(82)/ .813265315122797560D0/
      DATA XGAUSS(83)/ .840629296252580363D0/
      DATA XGAUSS(84)/ .865999398154092820D0/
      DATA XGAUSS(85)/ .889315445995114106D0/
      DATA XGAUSS(86)/ .910522137078502806D0/
      DATA XGAUSS(87)/ .929569172131939576D0/
      DATA XGAUSS(88)/ .946411374858402816D0/
      DATA XGAUSS(89)/ .961008799652053719D0/
      DATA XGAUSS(90)/ .973326827789910964D0/
      DATA XGAUSS(91)/ .983336253884625957D0/
      DATA XGAUSS(92)/ .991013371476744321D0/
      DATA XGAUSS(93)/ .996340116771955279D0/
      DATA XGAUSS(94)/ .999305041735772139D0/
      DATA XGAUSS(95)/-.02435029266342443250D0/
      DATA XGAUSS(96)/-.0729931217877990394D0/
      DATA XGAUSS(97)/-.121462819296120554D0/
      DATA XGAUSS(98)/-.169644420423992818D0/
      DATA XGAUSS(99)/-.217423643740007084D0/
      DATA XGAUSS(100)/-.264687162208767416D0/
      DATA XGAUSS(101)/-.311322871990210956D0/
      DATA XGAUSS(102)/-.357220158337668116D0/
      DATA XGAUSS(103)/-.402270157963991604D0/
      DATA XGAUSS(104)/-.446366017253464088D0/
      DATA XGAUSS(105)/-.489403145707052957D0/
      DATA XGAUSS(106)/-.531279464019894546D0/
      DATA XGAUSS(107)/-.571895646202634034D0/
      DATA XGAUSS(108)/-.611155355172393250D0/
      DATA XGAUSS(109)/-.648965471254657340D0/
      DATA XGAUSS(110)/-.685236313054233243D0/
      DATA XGAUSS(111)/-.719881850171610827D0/
      DATA XGAUSS(112)/-.752819907260531897D0/
      DATA XGAUSS(113)/-.783972358943341408D0/
      DATA XGAUSS(114)/-.813265315122797560D0/
      DATA XGAUSS(115)/-.840629296252580363D0/
      DATA XGAUSS(116)/-.865999398154092820D0/
      DATA XGAUSS(117)/-.889315445995114106D0/
      DATA XGAUSS(118)/-.910522137078502806D0/
      DATA XGAUSS(119)/-.929569172131939576D0/
      DATA XGAUSS(120)/-.946411374858402816D0/
      DATA XGAUSS(121)/-.961008799652053719D0/
      DATA XGAUSS(122)/-.973326827789910964D0/
      DATA XGAUSS(123)/-.983336253884625957D0/
      DATA XGAUSS(124)/-.991013371476744321D0/
      DATA XGAUSS(125)/-.996340116771955279D0/
      DATA XGAUSS(126)/-.999305041735772139D0/
      DATA WGAUSS(63)/ .0486909570091397204D0/
      DATA WGAUSS(64)/ .0485754674415034269D0/
      DATA WGAUSS(65)/ .0483447622348029572D0/
      DATA WGAUSS(66)/ .0479993885964583077D0/
      DATA WGAUSS(67)/ .0475401657148303087D0/
      DATA WGAUSS(68)/ .0469681828162100173D0/
      DATA WGAUSS(69)/ .0462847965813144172D0/
      DATA WGAUSS(70)/ .0454916279274181445D0/
      DATA WGAUSS(71)/ .0445905581637565631D0/
      DATA WGAUSS(72)/ .0435837245293234534D0/
      DATA WGAUSS(73)/ .0424735151236535890D0/
      DATA WGAUSS(74)/ .0412625632426235286D0/
      DATA WGAUSS(75)/ .0399537411327203414D0/
      DATA WGAUSS(76)/ .0385501531786156291D0/
      DATA WGAUSS(77)/ .0370551285402400460D0/
      DATA WGAUSS(78)/ .0354722132568823838D0/
      DATA WGAUSS(79)/ .0338051618371416094D0/
      DATA WGAUSS(80)/ .0320579283548515535D0/
      DATA WGAUSS(81)/ .0302346570724024789D0/
      DATA WGAUSS(82)/ .0283396726142594832D0/
      DATA WGAUSS(83)/ .0263774697150546587D0/
      DATA WGAUSS(84)/ .0243527025687108733D0/
      DATA WGAUSS(85)/ .0222701738083832542D0/
      DATA WGAUSS(86)/ .0201348231535302094D0/
      DATA WGAUSS(87)/ .0179517157756973431D0/
      DATA WGAUSS(88)/ .0157260304760247193D0/
      DATA WGAUSS(89)/ .0134630478967186426D0/
      DATA WGAUSS(90)/ .0111681394601311288D0/
      DATA WGAUSS(91)/ .00884675982636394772D0/
      DATA WGAUSS(92)/ .00650445796897836286D0/
      DATA WGAUSS(93)/ .00414703326056246764D0/
      DATA WGAUSS(94)/ .00178328072169643295D0/
      DATA WGAUSS(95)/ .0486909570091397204D0/
      DATA WGAUSS(96)/ .0485754674415034269D0/
      DATA WGAUSS(97)/ .0483447622348029572D0/
      DATA WGAUSS(98)/ .0479993885964583077D0/
      DATA WGAUSS(99)/ .0475401657148303087D0/
      DATA WGAUSS(100)/ .0469681828162100173D0/
      DATA WGAUSS(101)/ .0462847965813144172D0/
      DATA WGAUSS(102)/ .0454916279274181445D0/
      DATA WGAUSS(103)/ .0445905581637565631D0/
      DATA WGAUSS(104)/ .0435837245293234534D0/
      DATA WGAUSS(105)/ .0424735151236535890D0/
      DATA WGAUSS(106)/ .0412625632426235286D0/
      DATA WGAUSS(107)/ .0399537411327203414D0/
      DATA WGAUSS(108)/ .0385501531786156291D0/
      DATA WGAUSS(109)/ .0370551285402400460D0/
      DATA WGAUSS(110)/ .0354722132568823838D0/
      DATA WGAUSS(111)/ .0338051618371416094D0/
      DATA WGAUSS(112)/ .0320579283548515535D0/
      DATA WGAUSS(113)/ .0302346570724024789D0/
      DATA WGAUSS(114)/ .0283396726142594832D0/
      DATA WGAUSS(115)/ .0263774697150546587D0/
      DATA WGAUSS(116)/ .0243527025687108733D0/
      DATA WGAUSS(117)/ .0222701738083832542D0/
      DATA WGAUSS(118)/ .0201348231535302094D0/
      DATA WGAUSS(119)/ .0179517157756973431D0/
      DATA WGAUSS(120)/ .0157260304760247193D0/
      DATA WGAUSS(121)/ .0134630478967186426D0/
      DATA WGAUSS(122)/ .0111681394601311288D0/
      DATA WGAUSS(123)/ .00884675982636394772D0/
      DATA WGAUSS(124)/ .00650445796897836286D0/
      DATA WGAUSS(125)/ .00414703326056246764D0/
      DATA WGAUSS(126)/ .00178328072169643295D0/

C integrate first over b1
C
C Loop incrementing the boundary
C
      tmin = 0.D0
      tmax = 0.25D0
      Sum  = 0.D0

 50   CONTINUE

C
C Loop for the Gauss integration
C
      XINT=0.D0
      DO 100 N=1,6
        XINT2 = XINT
        XINT=0.D0
        DO 200 I=2**N-1,2**(N+1)-2
          t = (tmax-tmin)/2.D0*XGAUSS(I)+(tmax+tmin)/2.D0
          b1 = RADSRC(1) * EXP (t)
          XINT=XINT+WGAUSS(I) * PHO_GGFAUX(b1) * b1**2
 200    CONTINUE
        XINT = (tmax-tmin)/2.D0*XINT
        IF (ABS ((XINT2-XINT)/XINT) .LT. ACCUR) GOTO 300
 100  CONTINUE
        IF (LPRI.GT.4)
     &  WRITE(LO,*) ' PHO_GGFLCR: (b1) GAUSS MAY BE INACCURATE'
 300  CONTINUE

      Sum = Sum + XINT
      IF (ABS (XINT2/Sum) .GT. ACCUR) THEN
        tmin = tmax
        tmax = tmax + 0.5D0
        GOTO 50
      ENDIF

      PHO_GGFLCR = 4.D0*Pi * Sum

      END


 
 


CDECK  ID>, PHO_GGFNUC
      DOUBLE PRECISION FUNCTION PHO_GGFNUC(W,Rho,Gamma)
C**********************************************************************
C
C      differential photonnumber for a nucleus (geometrical model)
C      (without form factor)
C
C*********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER (PI = 3.141592653589793238462643383279D+00)

      WGamma = W/Gamma
      Wphib = WGamma * PHO_BESSK1(WGamma*Rho)

      PHO_GGFNUC = 1.D0/PI**2 * Wphib**2

      END


 
 


CDECK  ID>, PHO_GGHIOF
      SUBROUTINE PHO_GGHIOF(NEVENT,EEN,NA,NZ)
C**********************************************************************
C
C     interface to call PHOJET (variable energy run) for
C     gamma-gamma collisions via heavy ions (form factor approach)
C
C     input:     EEN     LAB system energy per nucleon
C                NA      atomic number of ion/hadron
C                NZ      charge number of ion/hadron
C                NEVENT  number of events to generate
C            from /LEPCUT/:
C                YMIN1,2 lower limit of Y
C                        (energy fraction taken by photon from hadron)
C                YMAX1,2 upper cutoff for Y, necessary to avoid
C                        underflows
C                Q2MIN1,2 minimum Q**2 of photons (should be set to 0)
C                Q2MAX1,2 maximum Q**2 of photons (if necessary,
C                        corrected according size of hadron)
C
C      currently implemented approximation similar to:
C                E.Papageorgiu PhysLettB250(1990)155
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( PI   = 3.141592653589793238462643383279D+00 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  photon flux kinematics and cuts
      DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
     &                 YMIN1,YMAX1,YMIN2,YMAX2,
     &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
     &                 THMIN1,THMAX1,THMIN2,THMAX2
      INTEGER          ITAG1,ITAG2
      COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
     &                YMIN1,YMAX1,YMIN2,YMAX2,
     &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
     &                THMIN1,THMAX1,THMIN2,THMAX2,
     &                ITAG1,ITAG2

C  gamma-lepton or gamma-hadron vertex information
      INTEGER IGHEL,IDPSRC,IDBSRC
      DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
     &                 RADSRC,AMSRC,GAMSRC
      COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
     &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
     &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)

C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
      INTEGER IDEQP,IDEQB,IHFLD,IHFLS
      DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
      COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
     &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)

C  event weights and generated cross section
      INTEGER IPOWGC,ISWCUT,IVWGHT
      DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
      COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
     &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)

      DIMENSION P1(4),P2(4),BIMP(2,2)

C
      IF (LPRI.GT.4)
     &WRITE(LO,'(2(/1X,A))') 'PHO_GGHIOF:GAMMA-GAMMA EVENT GENERATION',
     &                      '--------------------------------------'
C  hadron size and mass
      FM2GEV = 5.07D0
      HIMASS = DBLE(NA)*0.938D0
      HIMA2  = HIMASS**2
      HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
      ALPHA  = DBLE(NZ**2)/137.D0
C  correct Q2MAX1,2 according to hadron size
      Q2MAXH = 2.D0/HIRADI**2
      Q2MAX1 = MIN(Q2MAX1,Q2MAXH)
      Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
      IF(Q2MAX1.LT.1.D-20) Q2MAX1 = Q2MAXH
      IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
C  total hadron / heavy ion energy
      EE = EEN*DBLE(NA)
      GAMMA = EE/HIMASS
C  setup /POFSRC/
      GAMSRC(1) = GAMMA
      GAMSRC(2) = GAMMA
      RADSRC(1) = HIRADI
      RADSRC(2) = HIRADI
      AMSRC(1)  = HIMASS
      AMSRC(1)  = HIMASS
C  kinematic limitations
      YMI = (ECMIN/(2.D0*EE))**2
      IF(YMIN1.LT.YMI) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,2E12.5)')
     &    'PHO_GGHIOF: ymin1 increased to (old/new)',YMIN1,YMI
        YMIN1 = YMI
      ELSE IF(YMIN1.GT.YMI) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
     &    'PHO_GGHIOF:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
     &    '  INSTEAD OF',YMIN1
      ENDIF
      IF(YMIN2.LT.YMI) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,2E12.5)')
     &    'PHO_GGHIOF: ymin2 increased to (old/new)',YMIN2,YMI
        YMIN2 = YMI
      ELSE IF(YMIN2.GT.YMI) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
     &    'PHO_GGHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
     &    '  INSTEAD OF',YMIN2
      ENDIF
C  kinematic limitation
      Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
      Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
C  debug output
      IF (LPRI.GT.4)
     &WRITE(LO,'(/6X,A,2I4)')   'MASS NUMBER, CHARGE NUMBER  ',NA,NZ
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV)           ',HIMASS
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1)     ',HIRADI
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 1 (GEV**2)',Q2LOW1,
     &  Q2MAX1
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
     &  Q2MAX2
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1            ',YMIN1,
     &  YMAX1
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2            ',YMIN2,
     &  YMAX2
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL  ',
     &  2.D0*EEN,2.D0*EE
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,I10)')   'EVENTS TO PROCESS           ',NEVENT
      IF(Q2LOW1.GE.Q2MAX1) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,2E12.4)')
     &    'PHO_GGHIOF:ERROR:INCONSISTENT Q**2 RANGE 1',Q2LOW1,Q2MAX1
        CALL PHO_ABORT
      ENDIF
      IF(Q2LOW2.GE.Q2MAX2) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,2E12.4)')
     &    'PHO_GGHIOF:ERROR:INCONSISTENT Q**2 RANGE 2',Q2LOW2,Q2MAX2
        CALL PHO_ABORT
      ENDIF
C  hadron numbers set to 0
      IDPSRC(1) = 0
      IDPSRC(2) = 0
      IDBSRC(1) = 0
      IDBSRC(2) = 0
C
      Max_tab = 100
      YMAX = YMAX1
      YMIN = YMIN1
      XMAX = LOG(YMAX)
      XMIN = LOG(YMIN)
      XDEL = XMAX-XMIN
      DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
      DO 100 I=1,Max_tab
        Y1 = EXP(XMIN+DELLY*DBLE(I-1))
        Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
        IF(Q2LOW1.GE.Q2MAX1) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,2E12.4)')
     &      'PHO_GGHIOF: ymax1 changed from/to',YMAX1,Y1
          YMAX1 = MIN(Y1,YMAX1)
          GOTO 101
        ENDIF
 100  CONTINUE
 101  CONTINUE
      YMAX = YMAX2
      YMIN = YMIN2
      XMAX = LOG(YMAX)
      XMIN = LOG(YMIN)
      XDEL = XMAX-XMIN
      DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
      DO 102 I=1,Max_tab
        Y1 = EXP(XMIN+DELLY*DBLE(I-1))
        Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
        IF(Q2LOW2.GE.Q2MAX2) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,2E12.4)')
     &      'PHO_GGHIOF: ymax2 changed from/to',YMAX2,Y1
          YMAX2 = MIN(Y1,YMAX2)
          GOTO 103
        ENDIF
 102  CONTINUE
 103  CONTINUE
      YMI = (ECMIN/(2.D0*EE))**2/YMAX2
      IF(YMI.GT.YMIN1) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,2E12.4)')
     &    'PHO_GGHIOF: ymin1 changed from/to',YMIN1,YMI
        YMIN1 = YMI
      ENDIF
      YMI = (ECMIN/(2.D0*EE))**2/YMAX1
      IF(YMI.GT.YMIN2) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,2E12.4)')
     &    'PHO_GGHIOF: ymin2 changed from/to',YMIN2,YMI
        YMIN2 = YMI
      ENDIF
C
      X1MAX = LOG(YMAX1)
      X1MIN = LOG(YMIN1)
      X1DEL = X1MAX-X1MIN
      X2MAX = LOG(YMAX2)
      X2MIN = LOG(YMIN2)
      X2DEL = X2MAX-X2MIN
      DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
      FLUX = 0.D0
      IF (LPRI.GT.4 .AND. IDEB(30).GE.1)
     &WRITE(LO,'(/1X,A,I5)')
     &  'PHO_GGHIOF: table of raw photon flux (side 1)',Max_tab
      DO 105 I=1,Max_tab
        Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
        Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
        FF = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
     &        -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))*ALPHA/(2.D0*PI)
        FLUX = FLUX+Y1*FF
        IF (LPRI.GT.4 .AND. IDEB(30).GE.1)
     &  WRITE(LO,'(5X,2E15.4)') Y1,FF
 105  CONTINUE
      FLUX = FLUX*DELLY
      IF (LPRI.GT.4 .AND. IDEB(30).GE.1)
     &WRITE(LO,'(1X,A,E12.4)')
     &  'PHO_GGHIOF: integrated flux (one side):',FLUX
C
      Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
      Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
      Y1 = YMIN1
      Y2 = YMIN2
      WGMAX = ((1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
     &         -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
     &       *((1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
     &         -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
C
C  photon 1
      EGAM = YMAX1*EE
      P1(1) = 0.D0
      P1(2) = 0.D0
      P1(3) = EGAM
      P1(4) = EGAM
C  photon 2
      EGAM = YMAX2*EE
      P2(1) = 0.D0
      P2(2) = 0.D0
      P2(3) = -EGAM
      P2(4) = EGAM
      CALL PHO_SETPAR(1,22,0,0.D0)
      CALL PHO_SETPAR(2,22,0,0.D0)
      CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
      CALL PHO_PHIST(-1,SIGMAX)
      CALL PHO_LHIST(-1,SIGMAX)
C
C  generation of events, flux calculation

      ECFRAC = ECMIN**2/(4.D0*EE*EE)
      AY1  = 0.D0
      AY2  = 0.D0
      AYS1 = 0.D0
      AYS2 = 0.D0
      Q21MIN = 1.D30
      Q22MIN = 1.D30
      Q21MAX = 0.D0
      Q22MAX = 0.D0
      Q21AVE = 0.D0
      Q22AVE = 0.D0
      Q21AV2 = 0.D0
      Q22AV2 = 0.D0
      YY1MIN = 1.D30
      YY2MIN = 1.D30
      YY1MAX = 0.D0
      YY2MAX = 0.D0
      NITER = NEVENT
      ITRY = 0
      ITRW = 0
      DO 200 I=1,NITER
C  sample y1, y2
 150    CONTINUE
        ITRY = ITRY+1
 175    CONTINUE
          ITRW = ITRW+1
          Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
          Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
          IF(Y1*Y2.LT.ECFRAC) GOTO 175
C
          Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1**2/(1.D0-Y1))
          IF(Q2LOW1.GE.Q2MAX1) GOTO 175
          Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
          IF(Q2LOW2.GE.Q2MAX2) GOTO 175
          Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
          Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
          WGH = ((1.D0+(1.D0-Y1)**2)*Q2LOG1
     &        -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
     &         *((1.D0+(1.D0-Y2)**2)*Q2LOG2
     &        -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
          IF(WGMAX.LT.WGH) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,A,4E12.5)')
     &        'PHO_GGHIOF:WEIGHT ERROR:',Y1,Y2,WGMAX,WGH
          ENDIF
        IF(DT_RNDM(AYS1)*WGMAX.GT.WGH) GOTO 175
C  sample Q2
        IF(IPAMDL(174).EQ.1) THEN
          YEFF = 1.D0+(1.D0-Y1)**2
 185      CONTINUE
            Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
            WEIGHT = (YEFF-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF
          IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
        ELSE
          Q2P1 = Q2LOW1
        ENDIF
        IF(IPAMDL(174).EQ.1) THEN
          YEFF = 1.D0+(1.D0-Y2)**2
 186      CONTINUE
            Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
            WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
          IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
        ELSE
          Q2P2 = Q2LOW2
        ENDIF
C  impact parameter
        GAIMP(1) = 1.D0/SQRT(Q2P1)
        GAIMP(2) = 1.D0/SQRT(Q2P2)
C  form factor (squared)
        FF21 = 1.D0
        IF(GAIMP(1).LT.HIRADI) FF21 = 0.D0
        FF22 = 1.D0
        IF(GAIMP(2).LT.HIRADI) FF22 = 0.D0
        IF(DT_RNDM(Q2P1).GE.FF21*FF22) GOTO 175
C  do the hadrons overlap?
        IF(ISWMDL(26).GT.0) THEN
          DO 190 K=1,2
            CALL PHO_SFECFE(SIF,COF)
            BIMP(1,K) = SIF*GAIMP(K)
            BIMP(2,K) = COF*GAIMP(K)
 190      CONTINUE
          BBABS = SQRT((BIMP(1,1)-BIMP(1,2))**2
     &                 +(BIMP(2,1)-BIMP(2,2))**2)
          IF(BBABS.LT.HIRADI+HIRADI) GOTO 175
        ENDIF
C  photon data
        GYY(1) = Y1
        GQ2(1) = Q2P1
        GYY(2) = Y2
        GQ2(2) = Q2P2
C

C  incoming hadron 1
        PINI(1,1) = 0.D0
        PINI(2,1) = 0.D0
        PINI(3,1) = EE
        PINI(4,1) = EE
        PINI(5,1) = 0.D0
C  outgoing hadron 1
        YQ2 = SQRT((1.D0-Y1)*Q2P1)
        Q2E = Q2P1/(4.D0*EE)
        E1Y = EE*(1.D0-Y1)
        CALL PHO_SFECFE(SIF,COF)
        PFIN(1,1) = YQ2*COF
        PFIN(2,1) = YQ2*SIF
        PFIN(3,1) = E1Y-Q2E
        PFIN(4,1) = E1Y+Q2E
        PFIN(5,1) = 0.D0
        PFPHI(1) = ATAN2(COF,SIF)
        PFTHE(1) = ACOS((E1Y-Q2E)/(Q2E+E1Y))
C  photon 1
        P1(1) = -PFIN(1,1)
        P1(2) = -PFIN(2,1)
        P1(3) = PINI(3,1)-PFIN(3,1)
        P1(4) = PINI(4,1)-PFIN(4,1)
C  incoming hadron 2
        PINI(1,2) = 0.D0
        PINI(2,2) = 0.D0
        PINI(3,2) = -EE
        PINI(4,2) = EE
        PINI(5,2) = 0.D0
C  outgoing hadron 2
        YQ2 = SQRT((1.D0-Y2)*Q2P2)
        Q2E = Q2P2/(4.D0*EE)
        E1Y = EE*(1.D0-Y2)
        CALL PHO_SFECFE(SIF,COF)
        PFIN(1,2) = YQ2*COF
        PFIN(2,2) = YQ2*SIF
        PFIN(3,2) = -E1Y+Q2E
        PFIN(4,2) = E1Y+Q2E
        PFIN(5,2) = 0.D0
        PFPHI(2) = ATAN2(COF,SIF)
        PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
C  photon 2
        P2(1) = -PFIN(1,2)
        P2(2) = -PFIN(2,2)
        P2(3) = PINI(3,2)-PFIN(3,2)
        P2(4) = PINI(4,2)-PFIN(4,2)
C  ECMS cut
        GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
     &         -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
        IF(GGECM.LT.0.1D0) GOTO 175
        GGECM = SQRT(GGECM)
        IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
C
        PGAM(1,1) = P1(1)
        PGAM(2,1) = P1(2)
        PGAM(3,1) = P1(3)
        PGAM(4,1) = P1(4)
        PGAM(5,1) = -SQRT(Q2P1)
        PGAM(1,2) = P2(1)
        PGAM(2,2) = P2(2)
        PGAM(3,2) = P2(3)
        PGAM(4,2) = P2(4)
        PGAM(5,2) = -SQRT(Q2P2)
C  photon helicities
        IGHEL(1) = 1
        IGHEL(2) = 1
C  cut given by user
        CALL PHO_PRESEL(5,IREJ)
        IF(IREJ.NE.0) GOTO 175
C  event generation
        CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
        IF(IREJ.NE.0) GOTO 150

C  statistics
        AY1  = AY1+Y1
        AYS1 = AYS1+Y1*Y1
        AY2  = AY2+Y2
        AYS2 = AYS2+Y2*Y2
        Q21MIN = MIN(Q21MIN,Q2P1)
        Q22MIN = MIN(Q22MIN,Q2P2)
        Q21MAX = MAX(Q21MAX,Q2P1)
        Q22MAX = MAX(Q22MAX,Q2P2)
        YY1MIN = MIN(YY1MIN,Y1)
        YY2MIN = MIN(YY2MIN,Y2)
        YY1MAX = MAX(YY1MAX,Y1)
        YY2MAX = MAX(YY2MAX,Y2)
        Q21AVE = Q21AVE+Q2P1
        Q22AVE = Q22AVE+Q2P2
        Q21AV2 = Q21AV2+Q2P1*Q2P1
        Q22AV2 = Q22AV2+Q2P2*Q2P2
C  histograms
        CALL PHO_PHIST(1,HSWGHT(0))
        CALL PHO_LHIST(1,HSWGHT(0))
 200  CONTINUE
C
      WGY  = WGMAX*DBLE(ITRY)/DBLE(ITRW)*(ALPHA/(2.D0*PI))**2
      WGY  = WGY*LOG(YMAX1/YMIN1)*LOG(YMAX2/YMIN2)
      AY1  = AY1/DBLE(NITER)
      AYS1 = AYS1/DBLE(NITER)
      DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
      AY2  = AY2/DBLE(NITER)
      AYS2 = AYS2/DBLE(NITER)
      DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
      Q21AVE = Q21AVE/DBLE(NITER)
      Q21AV2 = Q21AV2/DBLE(NITER)
      Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(NITER))
      Q22AVE = Q22AVE/DBLE(NITER)
      Q22AV2 = Q22AV2/DBLE(NITER)
      Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
      WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
C  output of statistics, histograms
      IF (LPRI.GT.4)
     &WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
     &'=========================================================',
     &' *****   simulated cross section: ',WEIGHT,' mb  *****',
     &'========================================================='
      IF (LPRI.GT.4)
     &WRITE(LO,'(//1X,A,3I10)')
     &  'PHO_GGHIOF:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
     &  WGY,WEIGHT
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1               ',
     &  AY1,DAY1
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2               ',
     &  AY2,DAY2
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1     ',
     &  YY1MIN,YY1MAX
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2     ',
     &  YY2MIN,YY2MAX
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 1      ',
     &  Q21AVE,Q21AV2
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 1    ',
     &  Q21MIN,Q21MAX
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2  PHOTON 2     ',
     &  Q22AVE,Q22AV2
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2    ',
     &  Q22MIN,Q22MAX
C
      CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
      IF(NITER.GT.1) THEN
        CALL PHO_PHIST(-2,WEIGHT)
        CALL PHO_LHIST(-2,WEIGHT)
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I4)') 'PHO_GGHIOF:NO OUTPUT OF HISTOGRAMS',NITER
      ENDIF

      END


 
 


CDECK  ID>, PHO_GGHIOG
      SUBROUTINE PHO_GGHIOG(NEVENT,EEN,NA,NZ)
C**********************************************************************
C
C     interface to call PHOJET (variable energy run) for
C     gamma-gamma collisions via heavy ions (geometrical approach)
C
C
C     input:     EEN     LAB system energy per nucleon
C                NA      atomic number of ion/hadron
C                NZ      charge number of ion/hadron
C                NEVENT  number of events to generate
C            from /LEPCUT/:
C                YMIN1,2 lower limit of Y
C                        (energy fraction taken by photon from hadron)
C                YMAX1,2 upper cutoff for Y, necessary to avoid
C                        underflows
C
C      currently implemented approximation similar to:
C
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( DEPS = 1.D-20,
     &            PI   = 3.141592653589793238462643383279D+00 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  photon flux kinematics and cuts
      DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
     &                 YMIN1,YMAX1,YMIN2,YMAX2,
     &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
     &                 THMIN1,THMAX1,THMIN2,THMAX2
      INTEGER          ITAG1,ITAG2
      COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
     &                YMIN1,YMAX1,YMIN2,YMAX2,
     &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
     &                THMIN1,THMAX1,THMIN2,THMAX2,
     &                ITAG1,ITAG2

C  gamma-lepton or gamma-hadron vertex information
      INTEGER IGHEL,IDPSRC,IDBSRC
      DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
     &                 RADSRC,AMSRC,GAMSRC
      COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
     &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
     &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)

C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
      INTEGER IDEQP,IDEQB,IHFLD,IHFLS
      DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
      COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
     &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)

C  event weights and generated cross section
      INTEGER IPOWGC,ISWCUT,IVWGHT
      DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
      COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
     &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)

      PARAMETER (Max_tab=100)
      DIMENSION P1(4),P2(4),TABCU(0:Max_tab),TABYL(0:Max_tab)

C
      IF (LPRI.GT.4)
     &WRITE(LO,'(2(/1X,A))') 'PHO_GGHIOG: gamma-gamma event generation',
     &                      '---------------------------------------'
C  hadron size and mass
      FM2GEV = 5.07D0
      HIMASS = DBLE(NA)*0.938D0
      HIMA2  = HIMASS**2
      HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
      ALPHA  = DBLE(NZ**2)/137.D0
C  total hadron / heavy ion energy
      EE     = EEN*DBLE(NA)
      GAMMA  = EE/HIMASS
C  setup /POFSRC/
      GAMSRC(1) = GAMMA
      GAMSRC(2) = GAMMA
      RADSRC(1) = HIRADI
      RADSRC(2) = HIRADI
      AMSRC(1)  = HIMASS
      AMSRC(1)  = HIMASS
C  kinematic limitations
      YMI = (ECMIN/(2.D0*EE))**2
      IF(YMIN1.LT.YMI) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,2E12.5)')
     &    'PHO_GGHIOG: ymin1 increased to (old/new)',YMIN1,YMI
        YMIN1 = YMI
      ELSE IF(YMIN1.GT.YMI) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
     &    'PHO_GGHIOG:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
     &    '  INSTEAD OF',YMIN1
      ENDIF
      IF(YMIN2.LT.YMI) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,2E12.5)')
     &    'PHO_GGHIOG: ymin2 increased to (old/new)',YMIN2,YMI
        YMIN2 = YMI
      ELSE IF(YMIN2.GT.YMI) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
     &    'PHO_GGHIOG:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
     &    '  INSTEAD OF',YMIN2
      ENDIF
C  debug output
      IF (LPRI.GT.4)
     &WRITE(LO,'(/6X,A,2I4)')   'MASS NUMBER, CHARGE NUMBER  ',NA,NZ
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV)           ',HIMASS
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1)     ',HIRADI
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,E12.5)') 'LORENTZ GAMMA               ',GAMMA
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1            ',YMIN1,
     &  YMAX1
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2            ',YMIN2,
     &  YMAX2
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL  ',
     &  2.D0*EEN,2.D0*EE
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,I10)')   'EVENTS TO PROCESS           ',NEVENT
C  hadron numbers set to 0
      IDPSRC(1) = 0
      IDBSRC(1) = 0
      IDPSRC(2) = 0
      IDBSRC(2) = 0
C  table of flux function, log interpolation
      YMIN = YMIN1
      YMAX = YMAX1
      YMAX = MIN(YMAX,0.9999999D0)
      DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
      TABYL(0) = LOG(YMIN)
      FFMAX = 0.D0
      DO 100 I=1,Max_tab
        Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
        WG = EE*Y
        XI = WG*HIRADI/GAMMA
        FF = ALPHA*PHO_GGFLCL(XI)/Y
        FFMAX = MAX(FF,FFMAX)
        IF(FF.LT.1.D-10*FFMAX) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,2E12.4)')
     &      'PHO_GGHIOG: ymax1 changed from/to',YMAX1,Y
          YMAX1 = MIN(Y,YMAX1)
          GOTO 101
        ENDIF
 100  CONTINUE
 101  CONTINUE
      YMIN = YMIN2
      YMAX = YMAX2
      YMAX = MIN(YMAX,0.9999999D0)
      DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
      TABYL(0) = LOG(YMIN)
      FFMAX = 0.D0
      DO 102 I=1,Max_tab
        Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
        WG = EE*Y
        XI = WG*HIRADI/GAMMA
        FF = ALPHA*PHO_GGFLCL(XI)/Y
        FFMAX = MAX(FF,FFMAX)
        IF(FF.LT.1.D-10*FFMAX) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,2E12.4)')
     &      'PHO_GGHIOG: ymax2 changed from/to',YMAX2,Y
          YMAX2 = MIN(Y,YMAX2)
          GOTO 103
        ENDIF
 102  CONTINUE
 103  CONTINUE
      YMI = (ECMIN/(2.D0*EE))**2/YMAX2
      IF(YMI.GT.YMIN1) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,2E12.4)')
     &    'PHO_GGHIOG: ymin1 changed from/to',YMIN1,YMI
        YMIN1 = YMI
      ENDIF
      YMAX1 = MIN(YMAX,YMAX1)
      YMI = (ECMIN/(2.D0*EE))**2/YMAX1
      IF(YMI.GT.YMIN2) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,2E12.4)')
     &    'PHO_GGHIOG: ymin2 changed from/to',YMIN2,YMI
        YMIN2 = YMI
      ENDIF
C
      YMIN = YMIN1
      YMAX = YMAX1
      DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
      TABCU(0) = 0.D0
      TABYL(0) = LOG(YMIN)
      FLUX = 0.D0
      IF (LPRI.GT.4 .AND. IDEB(30).GE.1)
     &WRITE(LO,'(/1X,A,I5)')
     &  'PHO_GGHIOG: table of raw photon flux (side 1)',Max_tab
      DO 105 I=1,Max_tab
        Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
        WG = EE*Y
        XI = WG*HIRADI/GAMMA
        FF = ALPHA*PHO_GGFLCL(XI)/Y
        FFMAX = MAX(FF,FFMAX)
        TABCU(I) = TABCU(I-1)+FF*Y
        TABYL(I) = LOG(Y)
        FLUX = FLUX+Y*FF
        IF (LPRI.GT.4 .AND. IDEB(30).GE.1)
     &  WRITE(LO,'(5X,2E15.4)') Y,FF
 105  CONTINUE
      FLUX = FLUX*DELLY
      IF (LPRI.GT.4 .AND. IDEB(30).GE.1)
     &WRITE(LO,'(1X,A,E12.4)')
     &  'PHO_GGHIOG: integrated flux (one side):',FLUX
C
C  initialization
C  photon 1
      EGAM = YMAX*EE
      P1(1) = 0.D0
      P1(2) = 0.D0
      P1(3) = EGAM
      P1(4) = EGAM
C  photon 2
      EGAM = YMAX*EE
      P2(1) = 0.D0
      P2(2) = 0.D0
      P2(3) = -EGAM
      P2(4) = EGAM
      CALL PHO_SETPAR(1,22,0,0.D0)
      CALL PHO_SETPAR(2,22,0,0.D0)
      CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
      CALL PHO_PHIST(-1,SIGMAX)
      CALL PHO_LHIST(-1,SIGMAX)
C
C  generation of events

      AY1  = 0.D0
      AY2  = 0.D0
      AYS1 = 0.D0
      AYS2 = 0.D0
      YY1MIN = 1.D30
      YY2MIN = 1.D30
      YY1MAX = 0.D0
      YY2MAX = 0.D0
      NITER = NEVENT
      ITRY = 0
      ITRW = 0
      DO 200 I=1,NITER
 150    CONTINUE
        ITRY = ITRY+1
 175    CONTINUE
        ITRW = ITRW+1
        XI = DT_RNDM(AY1)*TABCU(Max_tab)
        DO 110 K=1,Max_tab
          IF(TABCU(K).GE.XI) THEN
            Y1 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
            Y1 = EXP(Y1)
            GOTO 120
          ENDIF
 110    CONTINUE
        Y1 = YMAX1
 120    CONTINUE
        XI = DT_RNDM(AY2)*TABCU(Max_tab)
        DO 130 K=1,Max_tab
          IF(TABCU(K).GE.XI) THEN
            Y2 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
            Y2 = EXP(Y2)
            GOTO 140
          ENDIF
 130    CONTINUE
        Y2 = YMAX2
 140    CONTINUE
C  setup kinematics

        GYY(1) = Y1
        GQ2(1) = 0.D0
        GYY(2) = Y2
        GQ2(2) = 0.D0
C  incoming electron 1
        PINI(1,1) = 0.D0
        PINI(2,1) = 0.D0
        PINI(3,1) = EE
        PINI(4,1) = EE
        PINI(5,1) = 0.D0
C  outgoing electron 1
        E1Y = EE*(1.D0-Y1)
        PFIN(1,1) = 0.D0
        PFIN(2,1) = 0.D0
        PFIN(3,1) = E1Y
        PFIN(4,1) = E1Y
        PFIN(5,1) = 0.D0
C  photon 1
        P1(1) = -PFIN(1,1)
        P1(2) = -PFIN(2,1)
        P1(3) = PINI(3,1)-PFIN(3,1)
        P1(4) = PINI(4,1)-PFIN(4,1)
C  incoming electron 2
        PINI(1,2) = 0.D0
        PINI(2,2) = 0.D0
        PINI(3,2) = -EE
        PINI(4,2) = EE
        PINI(5,2) = 0.D0
C  outgoing electron 2
        E1Y = EE*(1.D0-Y2)
        PFIN(1,2) = 0.D0
        PFIN(2,2) = 0.D0
        PFIN(3,2) = -E1Y
        PFIN(4,2) = E1Y
        PFIN(5,2) = 0.D0
C  photon 2
        P2(1) = -PFIN(1,2)
        P2(2) = -PFIN(2,2)
        P2(3) = PINI(3,2)-PFIN(3,2)
        P2(4) = PINI(4,2)-PFIN(4,2)
C  ECMS cut
        GGECM = (P1(4)+P2(4))**2-(P1(3)+P2(3))**2
        IF(GGECM.LT.0.1D0) GOTO 175
        GGECM = SQRT(GGECM)
        IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
        PGAM(1,1) = P1(1)
        PGAM(2,1) = P1(2)
        PGAM(3,1) = P1(3)
        PGAM(4,1) = P1(4)
        PGAM(5,1) = 0.D0
        PGAM(1,2) = P2(1)
        PGAM(2,2) = P2(2)
        PGAM(3,2) = P2(3)
        PGAM(4,2) = P2(4)
        PGAM(5,2) = 0.D0
C  impact parameter constraints
        XI1   = P1(4)*HIRADI/GAMMA
        XI2   = P2(4)*HIRADI/GAMMA
        FLX   = PHO_GGFLCL(XI1)*PHO_GGFLCL(XI2)
        FCORR = PHO_GGFLCR(HIRADI)
        WGX   = (FLX-FCORR)/FLX
        IF(DT_RNDM(Y2).GT.WGX) GOTO 175
C  photon helicities
        IGHEL(1) = 1
        IGHEL(2) = 1
C  cut given by user
        CALL PHO_PRESEL(5,IREJ)
        IF(IREJ.NE.0) GOTO 175
C  event generation
        CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
        IF(IREJ.NE.0) GOTO 150

C  statistics
        AY1  = AY1+Y1
        AYS1 = AYS1+Y1*Y1
        AY2  = AY2+Y2
        AYS2 = AYS2+Y2*Y2
        YY1MIN = MIN(YY1MIN,Y1)
        YY2MIN = MIN(YY2MIN,Y2)
        YY1MAX = MAX(YY1MAX,Y1)
        YY2MAX = MAX(YY2MAX,Y2)
C  histograms
        CALL PHO_PHIST(1,HSWGHT(0))
        CALL PHO_LHIST(1,HSWGHT(0))
 200  CONTINUE
C
      WGY  = FLUX**2*DBLE(ITRY)/DBLE(ITRW)
      AY1  = AY1/DBLE(NITER)
      AYS1 = AYS1/DBLE(NITER)
      DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
      AY2  = AY2/DBLE(NITER)
      AYS2 = AYS2/DBLE(NITER)
      DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
      WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
C  output of statistics, histograms
      IF (LPRI.GT.4)
     &WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
     &'=========================================================',
     &' *****   simulated cross section: ',WEIGHT,' mb  *****',
     &'========================================================='
      IF (LPRI.GT.4)
     &WRITE(LO,'(//1X,A,3I12)')
     &  'PHO_GGHIOG:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
     &  WGY,WEIGHT
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1               ',
     &  AY1,DAY1
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2               ',
     &  AY2,DAY2
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1     ',
     &  YY1MIN,YY1MAX
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2     ',
     &  YY2MIN,YY2MAX

C
      CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
      IF(NITER.GT.1) THEN
        CALL PHO_PHIST(-2,WEIGHT)
        CALL PHO_LHIST(-2,WEIGHT)
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I4)') 'PHO_GGHIOG:NO OUTPUT OF HISTOGRAMS',NITER
      ENDIF

      END


 
 


CDECK  ID>, PHO_GHHIAS
      SUBROUTINE PHO_GHHIAS(NEVENT,EEP,EEN,NA,NZ)
C**********************************************************************
C
C     interface to call PHOJET (variable energy run) for
C     gamma-hadron collisions in heavy ion - hadron
C     collisions (form factor approach)
C
C     input:     EEP     LAB system energy of proton (GeV)
C                EEN     LAB system energy per nucleon (GeV)
C                NA      atomic number of ion/hadron
C                NZ      charge number of ion/hadron
C                NEVENT  number of events to generate
C            from /LEPCUT/:
C                YMIN2   lower limit of Y
C                        (energy fraction taken by photon from hadron)
C                YMAX2   upper cutoff for Y, necessary to avoid
C                        underflows
C                Q2MIN2  minimum Q**2 of photons (should be set to 0)
C                Q2MAX2  maximum Q**2 of photons (if necessary,
C                        corrected according size of hadron)
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( PI   = 3.141592653589793238462643383279D+00 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  photon flux kinematics and cuts
      DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
     &                 YMIN1,YMAX1,YMIN2,YMAX2,
     &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
     &                 THMIN1,THMAX1,THMIN2,THMAX2
      INTEGER          ITAG1,ITAG2
      COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
     &                YMIN1,YMAX1,YMIN2,YMAX2,
     &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
     &                THMIN1,THMAX1,THMIN2,THMAX2,
     &                ITAG1,ITAG2

C  gamma-lepton or gamma-hadron vertex information
      INTEGER IGHEL,IDPSRC,IDBSRC
      DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
     &                 RADSRC,AMSRC,GAMSRC
      COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
     &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
     &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)

C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
      INTEGER IDEQP,IDEQB,IHFLD,IHFLS
      DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
      COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
     &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

C  event weights and generated cross section
      INTEGER IPOWGC,ISWCUT,IVWGHT
      DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
      COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
     &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)

      DIMENSION P1(4),P2(4)

      IF (LPRI.GT.4)
     &WRITE(LO,'(2(/1X,A))')
     &  'PHO_GHHIAS: hadron-gamma event generation',
     &  '-----------------------------------------'
C  hadron size and mass
      FM2GEV = 5.07D0
      HIMASS = DBLE(NA)*0.938D0
      HIMA2  = HIMASS**2
      HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
      ALPHA  = DBLE(NZ**2)/137.D0
      AMP  = 0.938D0
      AMP2 = AMP**2
C  correct Q2MAX2 according to hadron size
      Q2MAXH = 2.D0/HIRADI**2
      Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
      IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
C  total hadron / heavy ion energy
      EE = EEN*DBLE(NA)
      GAMMA = EE/HIMASS
C  setup /POFSRC/
      GAMSRC(2) = GAMMA
      RADSRC(2) = HIRADI
      AMSRC(2)  = HIMASS
C  check kinematic limitations
      YMI = ECMIN**2/(4.D0*EE*EEP)
      IF(YMIN2.LT.YMI) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,2E12.5)')
     &    'PHO_GHHIAS: ymin2 increased to (old/new)',YMIN2,YMI
        YMIN2 = YMI
      ELSE IF(YMIN2.GT.YMI) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
     &    'PHO_GHHIAS:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
     &    '  INSTEAD OF',YMIN2
      ENDIF
C  kinematic limitation
      Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
C  debug output
      IF (LPRI.GT.4)
     &WRITE(LO,'(/6X,A,2I4)')   'MASS NUMBER, CHARGE NUMBER  ',NA,NZ
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,E12.5)') 'HEAVY ION MASS (GeV)        ',HIMASS
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,E12.5)') 'HEAVY ION  RADIUS (GeV**-1) ',HIRADI
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
     &  Q2MAX2
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2            ',YMIN2,
     &  YMAX2
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL  ',
     &  2.D0*SQRT(EEN*EEP),2.D0*SQRT(EE*EEP)
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,2E12.5)') 'INV.MASS HADRON-PHOTON      ',ECMIN,
     &  ECMAX
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,I10)')   'EVENTS TO PROCESS           ',NEVENT
      IF(Q2LOW2.GE.Q2MAX2) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,2E12.4)')
     &    'PHO_GHHIAS:ERROR:inconsistent Q**2 range 2',Q2LOW2,Q2MAX2
        CALL PHO_ABORT
      ENDIF
C  hadron numbers set to 0
      IDPSRC(1) = 0
      IDPSRC(2) = 0
      IDBSRC(1) = 0
      IDBSRC(2) = 0
C
      Max_tab = 100
      YMAX = YMAX2
      YMIN = YMIN2
      XMAX = LOG(YMAX)
      XMIN = LOG(YMIN)
      XDEL = XMAX-XMIN
      DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
      DO 102 I=1,Max_tab
        Y1 = EXP(XMIN+DELLY*DBLE(I-1))
        Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
        IF(Q2LOW2.GE.Q2MAX2) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,2E12.4)')
     &      'PHO_GHHIAS: ymax2 changed from/to',YMAX2,Y1
          YMAX2 = MIN(Y1,YMAX2)
          GOTO 103
        ENDIF
 102  CONTINUE
 103  CONTINUE
C
      X2MAX = LOG(YMAX2)
      X2MIN = LOG(YMIN2)
      X2DEL = X2MAX-X2MIN
      DELLY = LOG(YMAX2/YMIN2)/DBLE(Max_tab-1)
      FLUX = 0.D0
      IF (LPRI.GT.4 .AND. IDEB(30).GE.1)
     &WRITE(LO,'(/1X,A,I5)')
     &  'PHO_GHHIAS: table of raw photon flux (side 2)',Max_tab
      DO 105 I=1,Max_tab
        Y2 = EXP(X2MIN+DELLY*DBLE(I-1))
        Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2*Y2/(1.D0-Y2))
        FF = ((1.D0+(1.D0-Y2)**2)/Y2*LOG(Q2MAX2/Q2LOW2)
     &        -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2))*ALPHA/(2.D0*PI)
        FLUX = FLUX+Y2*FF
        IF (LPRI.GT.4 .AND. IDEB(30).GE.1)
     &  WRITE(LO,'(5X,2E15.4)') Y2,FF
 105  CONTINUE
      FLUX = FLUX*DELLY
      IF (LPRI.GT.4 .AND. IDEB(30).GE.1)
     &WRITE(LO,'(1X,A,E12.4)')
     &  'PHO_GHHIAS: integrated flux:',FLUX
C
C  hadron
      P1(1) = 0.D0
      P1(2) = 0.D0
      P1(3) = -SQRT(EEP**2-AMP2)
      P1(4) = EEP
C  photon
      EGAM = YMAX2*EE
      P2(1) = 0.D0
      P2(2) = 0.D0
      P2(3) = EGAM
      P2(4) = EGAM
      CALL PHO_SETPAR(1,2212,0,0.D0)
      CALL PHO_SETPAR(2,22,0,0.D0)
      CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
C
      Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
      Y2 = YMIN2
      WGMAX2 = (1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
     &         -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
C
      CALL PHO_PHIST(-1,SIGMAX)
      CALL PHO_LHIST(-1,SIGMAX)
C
C  generation of events, flux calculation

      AY1  = 0.D0
      AY2  = 0.D0
      AYS1 = 0.D0
      AYS2 = 0.D0
      Q22MIN = 1.D30
      Q22MAX = 0.D0
      Q22AVE = 0.D0
      Q22AV2 = 0.D0
      YY2MIN = 1.D30
      YY2MAX = 0.D0
      NITER = NEVENT
      NITERS = 0
      ITRY = 0
      ITRW = 0
      DO 200 I=1,NITER
C  sample photon flux
 150    CONTINUE
        ITRY = ITRY+1
 175    CONTINUE
C
          ITRW = ITRW+1
C  select Y2
          Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
          Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
          IF(Q2LOW2.GE.Q2MAX2) GOTO 175
          Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
          WGH = (1.D0+(1.D0-Y2)**2)*Q2LOG2
     &          -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
          IF (LPRI.GT.4 .AND. WGMAX2.LT.WGH)
     &    WRITE(LO,'(1X,A,3E12.5)')
     &        'PHO_GHHIAS:WEIGHT ERROR (2):',Y2,WGMAX2,WGH
          IF(DT_RNDM(AYS1)*WGMAX2.GT.WGH) GOTO 175
C  sample Q2
          IF(IPAMDL(174).EQ.1) THEN
            YEFF = 1.D0+(1.D0-Y2)**2
 186        CONTINUE
              Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
              WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
            IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
          ELSE
            Q2P2 = Q2LOW2
          ENDIF
C  impact parameter
          GAIMP(2) = 1.D0/SQRT(Q2P2)
C  form factor (squared)
          FF2 = 1.D0
          IF(GAIMP(2).LT.2.D0*HIRADI) FF2 = 0.D0
          IF(DT_RNDM(Q2P2).GE.FF2) GOTO 175
C  photon data
          GYY(2) = Y2
          GQ2(2) = Q2P2

C
C  incoming hadron 1
          PINI(1,1) = 0.D0
          PINI(2,1) = 0.D0
          PINI(3,1) = SQRT(EEP**2-AMP2)
          PINI(4,1) = EEP
          PINI(5,1) = AMP
C  incoming hadron 2
          PINI(1,2) = 0.D0
          PINI(2,2) = 0.D0
          PINI(3,2) = -SQRT(EE**2-AMP2)
          PINI(4,2) = EE
          PINI(5,2) = AMP
C  outgoing hadron 2
          YQ2 = SQRT((1.D0-Y2)*Q2P2)
          Q2E = Q2P2/(4.D0*EE)
          E1Y = EE*(1.D0-Y2)
          CALL PHO_SFECFE(SIF,COF)
          PFIN(1,2) = YQ2*COF
          PFIN(2,2) = YQ2*SIF
          PFIN(3,2) = -E1Y+Q2E
          PFIN(4,2) = E1Y+Q2E
          PFIN(5,2) = 0.D0
          PFPHI(2) = ATAN2(COF,SIF)
          PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
C  scattering hadron
          P1(1) = 0.D0
          P1(2) = 0.D0
          P1(3) = SQRT(EEP**2-AMP2)
          P1(4) = EEP
          Q2P1  = AMP2
C  scattering photon
          P2(1) = -PFIN(1,2)
          P2(2) = -PFIN(2,2)
          P2(3) = PINI(3,2)-PFIN(3,2)
          P2(4) = PINI(4,2)-PFIN(4,2)
          ISIDE = 2
C
C  ECMS cut
        GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
     &         -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
        IF(GGECM.LT.0.1D0) GOTO 175
        GGECM = SQRT(GGECM)
        IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
C
        PGAM(1,1) = P1(1)
        PGAM(2,1) = P1(2)
        PGAM(3,1) = P1(3)
        PGAM(4,1) = P1(4)
        PGAM(5,1) = AMP
        PGAM(1,2) = P2(1)
        PGAM(2,2) = P2(2)
        PGAM(3,2) = P2(3)
        PGAM(4,2) = P2(4)
        PGAM(5,2) = -SQRT(Q2P2)
C  photon helicities
        IGHEL(2) = 1
C  user cuts
        CALL PHO_PRESEL(5,IREJ)
        IF(IREJ.NE.0) GOTO 175
C  event generation
        CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
        IF(IREJ.NE.0) GOTO 150
C  cut on diffractive mass
        DO 250 K=1,NHEP
          IF(ISTHEP(K).EQ.30) THEN
            GHDIFF = PHEP(1,K)
            IF(GHDIFF.GE.PARMDL(175)) THEN
              GOTO 251
            ELSE
              GOTO 150
            ENDIF
          ENDIF
 250    CONTINUE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/,1X,A)')
     &    'PHO_GHHIAS: no diffractive entry found'
          CALL PHO_PREVNT(-1)
        GOTO 150
 251    CONTINUE
C  remove quasi-elastically scattered hadron
        DO 260 K=1,NHEP
          IF((ISTHEP(K).EQ.1).AND.(IDHEP(K).EQ.2212)) THEN
            XF = ABS(PHEP(3,K)/EEN)
            IF(XF.LT.PARMDL(72)) GOTO 150
*           ISTHEP(K) = 2
            GOTO 261
          ENDIF
 260    CONTINUE
 261    CONTINUE
C
C  statistics

        NITERS = NITERS+1

        AY2  = AY2+Y2
        AYS2 = AYS2+Y2*Y2
        Q22AVE = Q22AVE+Q2P2
        Q22AV2 = Q22AV2+Q2P2*Q2P2
        Q22MIN = MIN(Q22MIN,Q2P2)
        Q22MAX = MAX(Q22MAX,Q2P2)
        YY2MIN = MIN(YY2MIN,Y2)
        YY2MAX = MAX(YY2MAX,Y2)
C  histograms
        CALL PHO_PHIST(1,HSWGHT(0))
        CALL PHO_LHIST(1,HSWGHT(0))
 200  CONTINUE
C
      WGMAX = WGMAX2*LOG(YMAX2/YMIN2)
      WGY2 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW,1))*ALPHA/(2.D0*PI)
      AY2  = AY2/DBLE(MAX(NITERS,1))
      AYS2 = AYS2/DBLE(MAX(NITERS,1))
      DAY2 = SQRT((AYS2-AY2**2)/DBLE(MAX(NITERS,1)))
      Q22AVE = Q22AVE/DBLE(MAX(NITERS,1))
      Q22AV2 = Q22AV2/DBLE(MAX(NITERS,1))
      Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(MAX(NITERS,1)))
      WGMAX  = WGMAX2*LOG(YMAX2/YMIN2)
      WGY    = WGMAX*DBLE(ITRY)/DBLE(ITRW)*ALPHA/(2.D0*PI)
      WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
C  output of statistics, histograms
      IF (LPRI.GT.4)
     &WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
     &'=========================================================',
     &' *****   simulated cross section: ',WEIGHT,' mb  *****',
     &'========================================================='
      IF (LPRI.GT.4)
     &WRITE(LO,'(//1X,A,/3X,4I12)')
     &  'PHO_GHHIAS:SUMMARY:  NITER,    NITERS,    ITRY,     ITRW',
     &  NITER,NITERS,ITRY,ITRW
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
     &  WGY,WEIGHT
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2               ',
     &  AY2,DAY2
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2     ',
     &  YY2MIN,YY2MAX
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2  PHOTON 2     ',
     &  Q22AVE,Q22AV2
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2    ',
     &  Q22MIN,Q22MAX
C
      CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
      IF(NITER.GT.1) THEN
        CALL PHO_PHIST(-2,WEIGHT)
        CALL PHO_LHIST(-2,WEIGHT)
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I4)')
     &    'PHO_GHHIAS: no output of histograms',NITER
      ENDIF

      END


 
 


CDECK  ID>, PHO_GHHIOF
      SUBROUTINE PHO_GHHIOF(NEVENT,EEN,NA,NZ)
C**********************************************************************
C
C     interface to call PHOJET (variable energy run) for
C     gamma-hadron collisions in heavy ion collisions
C     (form factor approach)
C
C     input:     EEN     LAB system energy per nucleon
C                NA      atomic number of ion/hadron
C                NZ      charge number of ion/hadron
C                NEVENT  number of events to generate
C            from /LEPCUT/:
C                YMIN1,2 lower limit of Y
C                        (energy fraction taken by photon from hadron)
C                YMAX1,2 upper cutoff for Y, necessary to avoid
C                        underflows
C                Q2MIN1,2 minimum Q**2 of photons (should be set to 0)
C                Q2MAX1,2 maximum Q**2 of photons (if necessary,
C                        corrected according size of hadron)
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( PI   = 3.141592653589793238462643383279D+00 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  photon flux kinematics and cuts
      DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
     &                 YMIN1,YMAX1,YMIN2,YMAX2,
     &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
     &                 THMIN1,THMAX1,THMIN2,THMAX2
      INTEGER          ITAG1,ITAG2
      COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
     &                YMIN1,YMAX1,YMIN2,YMAX2,
     &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
     &                THMIN1,THMAX1,THMIN2,THMAX2,
     &                ITAG1,ITAG2

C  gamma-lepton or gamma-hadron vertex information
      INTEGER IGHEL,IDPSRC,IDBSRC
      DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
     &                 RADSRC,AMSRC,GAMSRC
      COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
     &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
     &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)

C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
      INTEGER IDEQP,IDEQB,IHFLD,IHFLS
      DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
      COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
     &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)


C  event weights and generated cross section
      INTEGER IPOWGC,ISWCUT,IVWGHT
      DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
      COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
     &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)

      DIMENSION P1(4),P2(4)
      DIMENSION NITERS(2),ITRW(2)

      IF (LPRI.GT.4)
     &WRITE(LO,'(2(/1X,A))')
     &  'PHO_GHHIOF: gamma-hadron event generation',
     &  '-----------------------------------------'
C  hadron size and mass
      FM2GEV = 5.07D0
      HIMASS = DBLE(NA)*0.938D0
      HIMA2  = HIMASS**2
      HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
      ALPHA  = DBLE(NZ**2)/137.D0
      AMP  = 0.938D0
      AMP2 = AMP**2
C  correct Q2MAX1,2 according to hadron size
      Q2MAXH = 2.D0/HIRADI**2
      Q2MAX1 = MIN(Q2MAX1,Q2MAXH)
      Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
      IF(Q2MAX1.LT.1.D-20) Q2MAX1 = Q2MAXH
      IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
C  total hadron / heavy ion energy
      EE = EEN*DBLE(NA)
      GAMMA = EE/HIMASS
C  setup /POFSRC/
      GAMSRC(1) = GAMMA
      GAMSRC(2) = GAMMA
      RADSRC(1) = HIRADI
      RADSRC(2) = HIRADI
      AMSRC(1)  = HIMASS
      AMSRC(2)  = HIMASS
C  check cuts on photon-hadron mass
      IF((0.765D0+PARMDL(46)).GT.(PARMDL(45)*ECMIN)) THEN
        YMI = ECMIN
        ECMIN =  PARMDL(46)/PARMDL(45)+0.1D0
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,2E12.5)')
     &    'PHO_GHHIOF: ecmin corrected to (old/new)',YMI,ECMIN
      ENDIF
C  check kinematic limitations
      YMI = ECMIN**2/(4.D0*EE*EEN)
      IF(YMIN1.LT.YMI) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,2E12.5)')
     &    'PHO_GHHIOF: ymin1 increased to (old/new)',YMIN1,YMI
        YMIN1 = YMI
      ELSE IF(YMIN1.GT.YMI) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
     &    'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
     &    '  INSTEAD OF',YMIN1
      ENDIF
      IF(YMIN2.LT.YMI) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,2E12.5)')
     &    'PHO_GHHIOF: ymin2 increased to (old/new)',YMIN2,YMI
        YMIN2 = YMI
      ELSE IF(YMIN2.GT.YMI) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
     &    'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
     &    '  INSTEAD OF',YMIN2
      ENDIF
C  kinematic limitation
      Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
      Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
C  debug output
      IF (LPRI.GT.4)
     &WRITE(LO,'(/6X,A,2I4)')   'MASS NUMBER, CHARGE NUMBER  ',NA,NZ
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV)           ',HIMASS
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1)     ',HIRADI
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 1 (GEV**2)',Q2LOW1,
     &  Q2MAX1
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
     &  Q2MAX2
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1            ',YMIN1,
     &  YMAX1
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2            ',YMIN2,
     &  YMAX2
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL  ',
     &  2.D0*EEN,2.D0*EE
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,2E12.5)') 'INV.MASS PHOTON-HADRON      ',ECMIN,
     &  ECMAX
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,E12.5)') 'MIN. INV.MASS PHOTON-POMERON',
     &  PARMDL(175)
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,I10)')   'EVENTS TO PROCESS           ',NEVENT
      IF(Q2LOW1.GE.Q2MAX1) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,2E12.4)')
     &    'PHO_GHHIOF:ERROR:INCONSISTENT Q**2 RANGE 1',Q2LOW1,Q2MAX1
        CALL PHO_ABORT
      ENDIF
      IF(Q2LOW2.GE.Q2MAX2) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,2E12.4)')
     &    'PHO_GHHIOF:ERROR:INCONSISTENT Q**2 RANGE 2',Q2LOW2,Q2MAX2
        CALL PHO_ABORT
      ENDIF
C  hadron numbers set to 0
      IDPSRC(1) = 0
      IDPSRC(2) = 0
      IDBSRC(1) = 0
      IDBSRC(2) = 0
C
      Max_tab = 100
      YMAX = YMAX1
      YMIN = YMIN1
      XMAX = LOG(YMAX)
      XMIN = LOG(YMIN)
      XDEL = XMAX-XMIN
      DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
      DO 100 I=1,Max_tab
        Y1 = EXP(XMIN+DELLY*DBLE(I-1))
        Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
        IF(Q2LOW1.GE.Q2MAX1) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,2E12.4)')
     &      'PHO_GHHIOF: ymax1 changed from/to',YMAX1,Y1
          YMAX1 = MIN(Y1,YMAX1)
          GOTO 101
        ENDIF
 100  CONTINUE
 101  CONTINUE
      YMAX = YMAX2
      YMIN = YMIN2
      XMAX = LOG(YMAX)
      XMIN = LOG(YMIN)
      XDEL = XMAX-XMIN
      DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
      DO 102 I=1,Max_tab
        Y1 = EXP(XMIN+DELLY*DBLE(I-1))
        Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
        IF(Q2LOW2.GE.Q2MAX2) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,2E12.4)')
     &      'PHO_GHHIOF: ymax2 changed from/to',YMAX2,Y1
          YMAX2 = MIN(Y1,YMAX2)
          GOTO 103
        ENDIF
 102  CONTINUE
 103  CONTINUE
C
      X1MAX = LOG(YMAX1)
      X1MIN = LOG(YMIN1)
      X1DEL = X1MAX-X1MIN
      X2MAX = LOG(YMAX2)
      X2MIN = LOG(YMIN2)
      X2DEL = X2MAX-X2MIN
      DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
      FLUX = 0.D0
      IF (LPRI.GT.4 .AND. IDEB(30).GE.1)
     &WRITE(LO,'(/1X,A,I5)')
     &  'PHO_GHHIOF: table of raw photon flux (side 1)',Max_tab
      DO 105 I=1,Max_tab
        Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
        Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
        FF = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
     &        -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))*ALPHA/(2.D0*PI)
        FLUX = FLUX+Y1*FF
        IF (LPRI.GT.4 .AND. IDEB(30).GE.1)
     &  WRITE(LO,'(5X,2E15.4)') Y1,FF
 105  CONTINUE
      FLUX = FLUX*DELLY
      IF (LPRI.GT.4 .AND. IDEB(30).GE.1)
     &WRITE(LO,'(1X,A,E12.4)')
     &  'PHO_GHHIOF: integrated flux (one side):',FLUX
C
C  photon
      EGAM = MAX(YMAX1,YMAX2)*EE
      P1(1) = 0.D0
      P1(2) = 0.D0
      P1(3) = EGAM
      P1(4) = EGAM
C  hadron
      P2(1) = 0.D0
      P2(2) = 0.D0
      P2(3) = -SQRT(EEN**2-AMP2)
      P2(4) = EEN
      CALL PHO_SETPAR(1,22,0,0.D0)
      CALL PHO_SETPAR(2,2212,0,0.D0)
      CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
C
      Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
      Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
      Y1 = YMIN1
      Y2 = YMIN2
      WGMAX1 = (1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
     &         -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1
      WGMAX2 = (1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
     &         -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
C
      IF(IPAMDL(175).EQ.1) WGMAX2 = 0.D0
      IF(IPAMDL(175).EQ.2) WGMAX1 = 0.D0
C
      FAC12 = WGMAX1*LOG(YMAX1/YMIN1)
     &       /(WGMAX1*LOG(YMAX1/YMIN1)+WGMAX2*LOG(YMAX2/YMIN2))
C
      CALL PHO_PHIST(-1,SIGMAX)
      CALL PHO_LHIST(-1,SIGMAX)
C
C  generation of events, flux calculation

      AY1  = 0.D0
      AY2  = 0.D0
      AYS1 = 0.D0
      AYS2 = 0.D0
      Q21MIN = 1.D30
      Q22MIN = 1.D30
      Q21MAX = 0.D0
      Q22MAX = 0.D0
      Q21AVE = 0.D0
      Q22AVE = 0.D0
      Q21AV2 = 0.D0
      Q22AV2 = 0.D0
      YY1MIN = 1.D30
      YY2MIN = 1.D30
      YY1MAX = 0.D0
      YY2MAX = 0.D0
      NITER = NEVENT
      NITERS(1) = 0
      NITERS(2) = 0
      ITRY = 0
      ITRW(1) = 0
      ITRW(2) = 0
      DO 200 I=1,NITER
C  sample y1, y2
 150    CONTINUE
        ITRY = ITRY+1
 175    CONTINUE
C
C  select side of photon emission
        IF(DT_RNDM(AY1).LT.FAC12) THEN
          ITRW(1) = ITRW(1)+1
C  select Y1
          Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
          Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1**2/(1.D0-Y1))
          IF(Q2LOW1.GE.Q2MAX1) GOTO 175
          Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
          WGH = (1.D0+(1.D0-Y1)**2)*Q2LOG1
     &          -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1
          IF (LPRI.GT.4 .AND. WGMAX1.LT.WGH)
     &    WRITE(LO,'(1X,A,3E12.5)')
     &        'PHO_GHHIOF:WEIGHT ERROR (1):',Y1,WGMAX1,WGH
          IF(DT_RNDM(AYS1)*WGMAX1.GT.WGH) GOTO 175
C  sample Q2
          IF(IPAMDL(174).EQ.1) THEN
            YEFF = 1.D0+(1.D0-Y1)**2
 185        CONTINUE
              Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
              WEIGHT = (YEFF-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF
            IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
          ELSE
            Q2P1 = Q2LOW1
          ENDIF
C  impact parameter
          GAIMP(1) = 1.D0/SQRT(Q2P1)
C  form factor (squared)
          FF2 = 1.D0
          IF(GAIMP(1).LT.2.D0*HIRADI) FF2 = 0.D0
          IF(DT_RNDM(Q2P1).GE.FF2) GOTO 175
C  photon data
          GYY(1) = Y1
          GQ2(1) = Q2P1

C
C  incoming hadron 1
          PINI(1,1) = 0.D0
          PINI(2,1) = 0.D0
          PINI(3,1) = SQRT(EE**2-AMP2)
          PINI(4,1) = EE
          PINI(5,1) = AMP
C  outgoing hadron 1
          YQ2 = SQRT((1.D0-Y1)*Q2P1)
          Q2E = Q2P1/(4.D0*EE)
          E1Y = EE*(1.D0-Y1)
          CALL PHO_SFECFE(SIF,COF)
          PFIN(1,1) = YQ2*COF
          PFIN(2,1) = YQ2*SIF
          PFIN(3,1) = E1Y-Q2E
          PFIN(4,1) = E1Y+Q2E
          PFIN(5,1) = 0.D0
          PFPHI(1) = ATAN2(COF,SIF)
          PFTHE(1) = ACOS((E1Y-Q2E)/(Q2E+E1Y))
C  incoming hadron 2
          PINI(1,2) = 0.D0
          PINI(2,2) = 0.D0
          PINI(3,2) = -SQRT(EE**2-AMP2)
          PINI(4,2) = EE
          PINI(5,2) = AMP
C  scattering photon
          P1(1) = -PFIN(1,1)
          P1(2) = -PFIN(2,1)
          P1(3) = PINI(3,1)-PFIN(3,1)
          P1(4) = PINI(4,1)-PFIN(4,1)
C  scattering hadron
          P2(1) = 0.D0
          P2(2) = 0.D0
          P2(3) = -SQRT(EEN**2-AMP2)
          P2(4) = EEN
          ISIDE = 1
C
        ELSE
C
          ITRW(2) = ITRW(2)+1
C  select Y2
          Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
          Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
          IF(Q2LOW2.GE.Q2MAX2) GOTO 175
          Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
          WGH = (1.D0+(1.D0-Y2)**2)*Q2LOG2
     &          -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
          IF (LPRI.GT.4 .AND. WGMAX2.LT.WGH)
     &    WRITE(LO,'(1X,A,3E12.5)')
     &        'PHO_GHHIOF:WEIGHT ERROR (2):',Y2,WGMAX2,WGH
          IF(DT_RNDM(AYS1)*WGMAX2.GT.WGH) GOTO 175
C  sample Q2
          IF(IPAMDL(174).EQ.1) THEN
            YEFF = 1.D0+(1.D0-Y2)**2
 186        CONTINUE
              Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
              WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
            IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
          ELSE
            Q2P2 = Q2LOW2
          ENDIF
C  impact parameter
          GAIMP(2) = 1.D0/SQRT(Q2P2)
C  form factor (squared)
          FF2 = 1.D0
          IF(GAIMP(2).LT.2.D0*HIRADI) FF2 = 0.D0
          IF(DT_RNDM(Q2P2).GE.FF2) GOTO 175
C  photon data
          GYY(2) = Y2
          GQ2(2) = Q2P2

C
C  incoming hadron 1
          PINI(1,1) = 0.D0
          PINI(2,1) = 0.D0
          PINI(3,1) = SQRT(EE**2-AMP2)
          PINI(4,1) = EE
          PINI(5,1) = AMP
C  incoming hadron 2
          PINI(1,2) = 0.D0
          PINI(2,2) = 0.D0
          PINI(3,2) = -SQRT(EE**2-AMP2)
          PINI(4,2) = EE
          PINI(5,2) = AMP
C  outgoing hadron 2
          YQ2 = SQRT((1.D0-Y2)*Q2P2)
          Q2E = Q2P2/(4.D0*EE)
          E1Y = EE*(1.D0-Y2)
          CALL PHO_SFECFE(SIF,COF)
          PFIN(1,2) = YQ2*COF
          PFIN(2,2) = YQ2*SIF
          PFIN(3,2) = -E1Y+Q2E
          PFIN(4,2) = E1Y+Q2E
          PFIN(5,2) = 0.D0
          PFPHI(2) = ATAN2(COF,SIF)
          PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
C  scattering hadron
          P2(1) = 0.D0
          P2(2) = 0.D0
          P2(3) = SQRT(EEN**2-AMP2)
          P2(4) = EEN
C  scattering photon
          P1(1) = -PFIN(1,2)
          P1(2) = -PFIN(2,2)
          P1(3) = PINI(3,2)-PFIN(3,2)
          P1(4) = PINI(4,2)-PFIN(4,2)
          ISIDE = 2
        ENDIF
C  ECMS cut
        GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
     &         -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
        IF(GGECM.LT.0.1D0) GOTO 175
        GGECM = SQRT(GGECM)
        IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
C
        PGAM(1,1) = P1(1)
        PGAM(2,1) = P1(2)
        PGAM(3,1) = P1(3)
        PGAM(4,1) = P1(4)
        PGAM(5,1) = -SQRT(Q2P1)
        PGAM(1,2) = P2(1)
        PGAM(2,2) = P2(2)
        PGAM(3,2) = P2(3)
        PGAM(4,2) = P2(4)
        PGAM(5,2) = -SQRT(Q2P2)
        CALL PHO_PRESEL(5,IREJ)
C  photon helicities
        IGHEL(1) = 1
        IGHEL(2) = 1
C  user cuts
        IF(IREJ.NE.0) GOTO 175
C  event generation
        CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
        IF(IREJ.NE.0) GOTO 150
C  cut on diffractive mass
        DO 250 K=1,NHEP
          IF(ISTHEP(K).EQ.30) THEN
            GHDIFF = PHEP(1,K)
            IF(GHDIFF.GE.PARMDL(175)) THEN
              GOTO 251
            ELSE
              GOTO 150
            ENDIF
          ENDIF
 250    CONTINUE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/,1X,A)')
     &    'PHO_GHHIOF: no diffractive entry found'
          CALL PHO_PREVNT(-1)
        GOTO 150
 251    CONTINUE
C  remove quasi-elastically scattered hadron
        DO 260 K=1,NHEP
          IF((ISTHEP(K).EQ.1).AND.(IDHEP(K).EQ.2212)) THEN
            XF = ABS(PHEP(3,K)/EEN)
            IF(XF.LT.PARMDL(72)) GOTO 150
*           ISTHEP(K) = 2
            GOTO 261
          ENDIF
 260    CONTINUE
 261    CONTINUE
C
C  statistics

        NITERS(ISIDE) = NITERS(ISIDE)+1
        IF(ISIDE.EQ.1) THEN

          AY1  = AY1+Y1
          AYS1 = AYS1+Y1*Y1
          Q21AVE = Q21AVE+Q2P1
          Q21AV2 = Q21AV2+Q2P1*Q2P1
          Q21MIN = MIN(Q21MIN,Q2P1)
          Q21MAX = MAX(Q21MAX,Q2P1)
          YY1MIN = MIN(YY1MIN,Y1)
          YY1MAX = MAX(YY1MAX,Y1)
        ELSE

          AY2  = AY2+Y2
          AYS2 = AYS2+Y2*Y2
          Q22AVE = Q22AVE+Q2P2
          Q22AV2 = Q22AV2+Q2P2*Q2P2
          Q22MIN = MIN(Q22MIN,Q2P2)
          Q22MAX = MAX(Q22MAX,Q2P2)
          YY2MIN = MIN(YY2MIN,Y2)
          YY2MAX = MAX(YY2MAX,Y2)
        ENDIF
C  histograms
        CALL PHO_PHIST(1,HSWGHT(0))
        CALL PHO_LHIST(1,HSWGHT(0))
 200  CONTINUE
C
      WGMAX = WGMAX1*LOG(YMAX1/YMIN1)*FAC12
      WGY1 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW(1),1))*ALPHA/(2.D0*PI)
      WGMAX = WGMAX2*LOG(YMAX2/YMIN2)*(1.D0-FAC12)
      WGY2 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW(2),1))*ALPHA/(2.D0*PI)
      AY1  = AY1/DBLE(MAX(NITERS(1),1))
      AYS1 = AYS1/DBLE(MAX(NITERS(1),1))
      DAY1 = SQRT((AYS1-AY1**2)/DBLE(MAX(NITERS(1),1)))
      AY2  = AY2/DBLE(MAX(NITERS(2),1))
      AYS2 = AYS2/DBLE(MAX(NITERS(2),1))
      DAY2 = SQRT((AYS2-AY2**2)/DBLE(MAX(NITERS(2),1)))
      Q21AVE = Q21AVE/DBLE(MAX(NITERS(1),1))
      Q21AV2 = Q21AV2/DBLE(MAX(NITERS(1),1))
      Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(MAX(NITERS(1),1)))
      Q22AVE = Q22AVE/DBLE(MAX(NITERS(2),1))
      Q22AV2 = Q22AV2/DBLE(MAX(NITERS(2),1))
      Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(MAX(NITERS(2),1)))
      WGMAX  = WGMAX1*LOG(YMAX1/YMIN1)+WGMAX2*LOG(YMAX2/YMIN2)
      WGY    = WGMAX*DBLE(ITRY)/DBLE(ITRW(1)+ITRW(2))*ALPHA/(2.D0*PI)
      WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
C  output of statistics, histograms
      IF (LPRI.GT.4)
     &WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
     &'=========================================================',
     &' *****   simulated cross section: ',WEIGHT,' mb  *****',
     &'========================================================='
      IF (LPRI.GT.4)
     &WRITE(LO,'(//1X,A,/3X,6I12)')
     &  'PHO_GHHIOF:SUMMARY:  NITER,   NITERS1/2,   ITRY,    ITRW1,2',
     &  NITER,NITERS,ITRY,ITRW
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
     &  WGY,WEIGHT
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1               ',
     &  AY1,DAY1
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2               ',
     &  AY2,DAY2
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1     ',
     &  YY1MIN,YY1MAX
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2     ',
     &  YY2MIN,YY2MAX
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 1      ',
     &  Q21AVE,Q21AV2
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 1    ',
     &  Q21MIN,Q21MAX
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2  PHOTON 2     ',
     &  Q22AVE,Q22AV2
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2    ',
     &  Q22MIN,Q22MAX
C
      CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
      IF(NITER.GT.1) THEN
        CALL PHO_PHIST(-2,WEIGHT)
        CALL PHO_LHIST(-2,WEIGHT)
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I4)') 'PHO_GHHIOF:NO OUTPUT OF HISTOGRAMS',NITER
      ENDIF

      END


 
 


CDECK  ID>, PHO_GLU2QU
      SUBROUTINE PHO_GLU2QU(IG,IQ1,IQ2,IREJ)
C********************************************************************
C
C    split gluon with index I in POEVT1
C          (massless gluon assumed)
C
C    input:      /POEVT1/
C                IG      gluon index
C                IQ1     first quark index
C                IQ2     second quark index
C
C    output:     new quarks in /POEVT1/
C                IREJ    1 splitting impossible
C                        0 splitting successful
C
C********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( DEPS   =  1.D-15,
     &            EPS    =  1.D-5 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

C  internal rejection counters
      INTEGER NMXJ
      PARAMETER (NMXJ=60)
      CHARACTER*10 REJTIT
      INTEGER IFAIL
      COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)

      DIMENSION P1(4),P2(4)
      DATA CUTM  /0.02D0/

      IREJ = 0

C  calculate string masses max possible
      IF(ISWMDL(9).EQ.1) THEN
        CMASS1=2.D0*(PHEP(4,IG)*PHEP(4,IQ1)-PHEP(1,IG)*PHEP(1,IQ1)
     &     -PHEP(2,IG)*PHEP(2,IQ1)-PHEP(3,IG)*PHEP(3,IQ1))
        IF(CMASS1.LT.CUTM) THEN
          IF(IDEB(73).GE.5) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,A,3I4,4E10.3)')
     &        'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS1',IG,IQ1,IQ2,CMASS1
          ENDIF
          IFAIL(33) = IFAIL(33) + 1
          IREJ = 1
          RETURN
        ENDIF
        CMASS2=2.D0*(PHEP(4,IG)*PHEP(4,IQ2)-PHEP(1,IG)*PHEP(1,IQ2)
     &     -PHEP(2,IG)*PHEP(2,IQ2)-PHEP(3,IG)*PHEP(3,IQ2))
        IF(CMASS2.LT.CUTM) THEN
          IF(IDEB(73).GE.5) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,A,3I4,4E10.3)')
     &        'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS2',IG,IQ1,IQ2,CMASS2
          ENDIF
          IFAIL(33) = IFAIL(33) + 1
          IREJ = 1
          RETURN
        ENDIF
C
C  calculate minimal z
        ZMIN1 = (CUTM-SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))/CMASS1+EPS
        ZMIN2 = (CUTM-SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))/CMASS2+EPS
        ZMIN = MIN(ZMIN1,ZMIN2)
        IF(MAX(ZMIN1,ZMIN2).GE.0.45D0) THEN
          IF(IDEB(73).GE.5) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,A,3I3,4E10.3)')
     &        'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,ZMIN1,ZMIN2,P1*PG,P2*PG',
     &        IG,IQ1,IQ2,ZMIN1,ZMIN2,CMASS1,CMASS2
          ENDIF
          IFAIL(33) = IFAIL(33) + 1
          IREJ = 1
          RETURN
        ENDIF
      ELSE
        ZMIN = MIN(0.1D0,0.5D0/PHEP(4,IG))
      ENDIF
C
      ZFRAC = PHO_GLUSPL(ZMIN)
      IF((ZFRAC.LT.ZMIN1).OR.((1.D0-ZFRAC).LT.ZMIN2)) THEN
        ZFRAC = 1.D0-ZFRAC
      ENDIF
      DO 200 I=1,4
        P1(I) = PHEP(I,IG)*ZFRAC
        P2(I) = PHEP(I,IG)*(1.D0-ZFRAC)
 200  CONTINUE
C  quark flavours
      CMASS1 = SQRT(ZFRAC*CMASS1+SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))
      CMASS2 = SQRT((1.D0-ZFRAC)*CMASS2
     &              +SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))
      CALL PHO_SEAFLA(IG,K,I,MIN(CMASS1,CMASS2))

      IF(ABS(IDHEP(IQ1)).GT.6) THEN
        K = SIGN(ABS(K),IDHEP(IQ1))
      ELSE
        K = -SIGN(ABS(K),IDHEP(IQ1))
      ENDIF
C  colors
      IF(K.GT.0) THEN
        IC1 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
        IC2 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
      ELSE
        IC1 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
        IC2 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
      ENDIF
C  register new partons
      CALL PHO_REGPAR(-1,K,0,IG,0,P1(1),P1(2),P1(3),P1(4),
     &            IPHIST(1,IG),0,IC1,0,IPOS,1)
      CALL PHO_REGPAR(-1,-K,0,IG,0,P2(1),P2(2),P2(3),P2(4),
     &            IPHIST(1,IG),0,IC2,0,IPOS,1)
C  debug output
      IF(IDEB(73).GE.20) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,/1X,A,3I3,5E10.3)')
     &      'PHO_GLU2QU:','   IG,IQ1,IQ2,ZMIN1,2,Z,P1*PG,P2*PG',
     &      IG,IQ1,IQ2,ZMIN1,ZMIN2,ZFRAC,CMASS1,CMASS2
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,4I5)') '   flavours, colors  ',
     &    K,-K,IC1,IC2
      ENDIF
      END


 
 


CDECK  ID>, PHO_GLUSPL
      DOUBLE PRECISION FUNCTION PHO_GLUSPL(ZMIN)
C*********************************************************************
C
C     calculate quark - antiquark light cone momentum fractions
C     according to Altarelli-Parisi g->q aq splitting function
C     (symmetric z interval assumed)
C
C     input: ZMIN    minimal Z value allowed,
C                    1-ZMIN maximal Z value allowed
C
C********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( ALEXP= 0.3333333333D0,
     &            DEPS = 1.D-10 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD


      IF(ZMIN.GE.0.5D0) THEN
        IF(IDEB(69).GT.2) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN>=0.5',ZMIN
        ENDIF
        ZZ=0.D0
        GOTO 1000
      ELSE IF(ZMIN.LE.0.D0) THEN
        IF(IDEB(69).GT.2) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN<=0',ZMIN
        ENDIF
        ZMINL = DEPS
      ELSE
        ZMINL = ZMIN
      ENDIF

      ZMAX = 1.D0-ZMINL
      XI   = DT_RNDM(ZMAX)
      ZZ   = ((1.D0-XI)*ZMINL**3+XI*ZMAX**3)**ALEXP
      IF(DT_RNDM(ZZ).LT.0.5D0) ZZ = 1.D0-ZZ

 1000 CONTINUE
      IF(IDEB(69).GE.10) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,2E12.4)') 'PHO_GLUSPL: ZMIN,Z ',ZMIN,ZZ
      ENDIF
      PHO_GLUSPL = ZZ
      END


 
 


CDECK  ID>, PHO_GPHERA
      SUBROUTINE PHO_GPHERA(NEVENT,EE1,EE2)
C**********************************************************************
C
C     interface to call PHOJET (variable energy run) with
C     HERA kinematics, photon as particle 2
C
C     equivalent photon approximation to get photon flux
C
C     input:     NEVENT  number of events to generate
C                EE1     proton energy (LAB system)
C                EE2     electron energy (LAB system)
C             from /POFCUT/:
C                YMIN2    lower limit of Y
C                        (energy fraction taken by photon from electron)
C                YMAX2    upper limit of Y
C                Q2MIN2   lower limit of photon virtuality
C                Q2MAX2   upper limit of photon virtuality
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( DEPS = 1.D-10,
     &            PI   = 3.141592653589793238462643383279D+00 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  photon flux kinematics and cuts
      DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
     &                 YMIN1,YMAX1,YMIN2,YMAX2,
     &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
     &                 THMIN1,THMAX1,THMIN2,THMAX2
      INTEGER          ITAG1,ITAG2
      COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
     &                YMIN1,YMAX1,YMIN2,YMAX2,
     &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
     &                THMIN1,THMAX1,THMIN2,THMAX2,
     &                ITAG1,ITAG2

C  gamma-lepton or gamma-hadron vertex information
      INTEGER IGHEL,IDPSRC,IDBSRC
      DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
     &                 RADSRC,AMSRC,GAMSRC
      COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
     &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
     &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)

C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
      INTEGER IDEQP,IDEQB,IHFLD,IHFLS
      DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
      COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
     &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)

C  event weights and generated cross section
      INTEGER IPOWGC,ISWCUT,IVWGHT
      DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
      COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
     &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)

      DIMENSION P1(4),P2(4)
      
      DOUBLE PRECISION PHO_PMASS
      EXTERNAL         PHO_PMASS

      IF (LPRI.GT.4)
     &WRITE(LO,'(//1X,A,I10)') 'PHO_GPHERA: events to process',NEVENT
C  assign particle momenta according to HERA kinematics
C  proton data
      PROM = PHO_PMASS(2212,1)
      PROM2 = PROM**2
      IDPSRC(1) = 0
      IDBSRC(1) = 0
C  electron data
      ELEM = 0.512D-03
      ELEM2 = ELEM**2
      AMSRC(2) = ELEM
      IDPSRC(2) = 11
      IDBSRC(2) = IPHO_PDG2ID(11)
C
      Q2MIN = Q2MIN2
      Q2MAX = Q2MAX2
C
      XIMAX = LOG(YMAX2)
      XIMIN = LOG(YMIN2)
      XIDEL = XIMAX-XIMIN
C
      IF(Q2MIN.GT.ELEM2*YMIN2**2/(1.D0-YMIN2) .AND. LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,1P2E11.4)')
     &  'PHO_GPHERA: lower Q2 cutoff larger than kin. limit:',
     &  Q2MIN,ELEM2*YMIN2**2/(1.D0-YMIN2)
C
      Max_tab = 50
      DELLY = LOG(YMAX2/YMIN2)/DBLE(Max_tab-1)
      FLUXT = 0.D0
      FLUXL = 0.D0
      IF (LPRI.GT.4 .AND. IDEB(30).GE.1)
     &WRITE(LO,'(1X,A,I5)')
     &  'PHO_GPHERA: table of photon flux (trans/long)',Max_tab
      DO 100 I=1,Max_tab
        Y = EXP(XIMIN+DELLY*DBLE(I-1))
        Q2LOW = MAX(Q2MIN,ELEM2*Y**2/(1.D0-Y))
        FFT = ((1.D0+(1.D0-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
     &         -2.D0*ELEM2*Y*(1.D0/Q2LOW-1.D0/Q2MAX))/(2.D0*PI*137.D0)
        FFL = 2.D0*(1.D0-Y)/Y*LOG(Q2MAX/Q2LOW)/(2.D0*PI*137.D0)
        FLUXT = FLUXT + Y*FFT
        FLUXL = FLUXL + Y*FFL
        IF (LPRI.GT.4 .AND. IDEB(30).GE.1)
     &  WRITE(LO,'(5X,1P3E14.4)') Y,FFT,FFL
 100  CONTINUE
      FLUXT = FLUXT*DELLY
      FLUXL = FLUXL*DELLY
      IF (LPRI.GT.4 .AND. IDEB(30).GE.1)
     &WRITE(LO,'(1X,A,1P2E12.4)')
     &  'PHO_GPHERA: integrated flux (trans./long.):',FLUXT,FLUXL
C
      AY = 0.D0
      AY2 = 0.D0
      YY = YMIN2
      Q2LOW = MAX(Q2MIN,ELEM2*YY**2/(1.D0-YY))
      WGMAX = (1.D0+(1.D0-YY)**2)*LOG(Q2MAX/Q2LOW)
     &        -2.D0*ELEM2*YY*(1.D0/Q2LOW-1.D0/Q2MAX)*YY
      IF(ISWMDL(10).GE.2) WGMAX = WGMAX+2.D0*(1.D0-YY)*LOG(Q2MAX/Q2LOW)
C
C  initialization of PHOJET at upper energy limit
C  proton momentum
      P1(1) = 0.D0
      P1(2) = 0.D0
      P1(3) = SQRT(EE1**2-PROM2+DEPS)
      P1(4) = EE1
C  photon momentum
      EGAM = YMAX2*EE2
      P2(1) = 0.D0
      P2(2) = 0.D0
      P2(3) = -EGAM
      P2(4) = EGAM
C  sum of both photon polarizations
      IGHEL(2) = -1
C
      CALL PHO_SETPAR(1,2212,0,0.D0)
      CALL PHO_SETPAR(2,22,0,0.D0)
      CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
      CALL PHO_PHIST(-1,SIGMAX)
      CALL PHO_LHIST(-1,SIGMAX)
C
C  generation of events, flux calculation

      ECMIN2 = ECMIN**2
      ECMAX2 = ECMAX**2
      AY = 0.D0
      AY2 = 0.D0
      Q22MIN = 1.D30
      Q22AVE = 0.D0
      Q22AV2 = 0.D0
      Q22MAX = 0.D0
      AN2MIN = 1.D30
      AN2MAX = 0.D0
      YY2MIN = 1.D30
      YY2MAX = 0.D0
      NITER = NEVENT
      ITRY = 0
      ITRW = 0
      DO 200 I=1,NITER
 150    CONTINUE
C  sample y
        ITRY = ITRY+1
 175    CONTINUE
          ITRW = ITRW+1
          YY = EXP(XIDEL*DT_RNDM(AY)+XIMIN)
          IF(ISWMDL(10).GE.2) THEN
            YEFF = 1.D0+(1.D0-YY)**2+2.D0*(1.D0-YY)
          ELSE
            YEFF = 1.D0+(1.D0-YY)**2
          ENDIF
          Q2LOW = MAX(Q2MIN,ELEM2*YY**2/(1.D0-YY))
          Q2LOG = LOG(Q2MAX/Q2LOW)
          WGH = YEFF*Q2LOG-2.D0*ELEM2*YY**2*(1.D0/Q2LOW-1.D0/Q2MAX)
          IF(WGMAX.LT.WGH) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,A,3E12.5)')
     &        'PHO_GPHERA: inconsistent weight:',YY,WGMAX,WGH
          ENDIF
        IF(DT_RNDM(AY2)*WGMAX.GT.WGH) GOTO 175
C  sample Q2
        IF(IPAMDL(174).EQ.1) THEN
 185      CONTINUE
            Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
            WEIGHT = (YEFF-2.D0*ELEM2*YY**2/Q2)/YEFF
          IF(WEIGHT.LT.DT_RNDM(Q2)) GOTO 185
        ELSE
          Q2 = Q2LOW
        ENDIF
C

C  incoming electron
        PINI(1,2) = 0.D0
        PINI(2,2) = 0.D0
        PINI(3,2) = -EE2
        PINI(4,2) = EE2
        PINI(5,2) = 0.D0
C  outgoing electron
        YQ2 = SQRT((1.D0-YY)*Q2)
        Q2E = Q2/(4.D0*EE2)
        E1Y = EE2*(1.D0-YY)
        CALL PHO_SFECFE(SIF,COF)
        PFIN(1,2) = YQ2*COF
        PFIN(2,2) = YQ2*SIF
        PFIN(3,2) = -E1Y+Q2E
        PFIN(4,2) = E1Y+Q2E
        PFIN(5,2) = 0.D0
C  set /POFSRC/
        GYY(2) = YY
        GQ2(2) = Q2
C  polar angle
        PFTHE(2) = ACOS(PFIN(3,2)/PFIN(4,2))
C  electron tagger
        IF(PFIN(4,2).GT.EEMIN2) THEN
          IF((PFTHE(2).LT.THMIN2).OR.(PFTHE(2).GT.THMAX2)) GOTO 175
        ENDIF
C  azimuthal angle
        PFPHI(2) = ATAN2(COF,SIF)
C  photon momentum
        P2(1) = -PFIN(1,2)
        P2(2) = -PFIN(2,2)
        P2(3) = PINI(3,2)-PFIN(3,2)
        P2(4) = PINI(4,2)-PFIN(4,2)
C  proton momentum
        P1(1) = 0.D0
        P1(2) = 0.D0
        P1(3) = SQRT(EE1**2-PROM2)
        P1(4) = EE1
C  ECMS cut
        GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
     &         -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
        IF((GGECM.LT.ECMIN2).OR.(GGECM.GT.ECMAX2)) GOTO 175
        GGECM = SQRT(GGECM)
C
        PGAM(1,2) = P2(1)
        PGAM(2,2) = P2(2)
        PGAM(3,2) = P2(3)
        PGAM(4,2) = P2(4)
        PGAM(5,2) = -SQRT(Q2)
C  photon helicity
        IF(ISWMDL(10).GE.2) THEN
          WGH  = YEFF-2.D0*ELEM2*YY**2/Q2
          WGHL = 2.D0*(1-YY)
          IF(DT_RNDM(YY).GE.WGHL/WGH) THEN
            IGHEL(2) = 1
          ELSE
            IGHEL(2) = 0
          ENDIF
        ELSE
          IGHEL(2) = -1
        ENDIF
C  user cuts
        CALL PHO_PRESEL(5,IREJ)
        IF(IREJ.NE.0) GOTO 175
C  event generation
        CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
        IF(IREJ.NE.0) GOTO 150

C  statistics
        AY = AY+YY
        AY2 = AY2+YY*YY
        YY2MIN = MIN(YY2MIN,YY)
        YY2MAX = MAX(YY2MAX,YY)
        Q22MIN = MIN(Q22MIN,Q2)
        Q22MAX = MAX(Q22MAX,Q2)
        Q22AVE = Q22AVE+Q2
        Q22AV2 = Q22AV2+Q2*Q2
        AN2MIN = MIN(AN2MIN,PFTHE(2))
        AN2MAX = MAX(AN2MAX,PFTHE(2))
C  histograms
        CALL PHO_PHIST(1,HSWGHT(0))
        CALL PHO_LHIST(1,HSWGHT(0))
 200  CONTINUE
C
      WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW)/(137.D0*2.D0*PI)
      WGY = WGY*LOG(YMAX2/YMIN2)
      AY  = AY/DBLE(NITER)
      AY2 = AY2/DBLE(NITER)
      DAY = SQRT((AY2-AY**2)/DBLE(NITER))
      Q22AVE = Q22AVE/DBLE(NITER)
      Q22AV2 = Q22AV2/DBLE(NITER)
      Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
      WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
C  output of histograms
      IF (LPRI.GT.4)
     &WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
     &'=========================================================',
     &' *****   simulated cross section: ',WEIGHT,' mb  *****',
     &'========================================================='
      IF (LPRI.GT.4)
     &WRITE(LO,'(//1X,A,3I10)')
     &  'PHO_GPHERA:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
     &  WGY,WEIGHT
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y,DY                 ',AY,DAY
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON       ',
     &  YY2MIN,YY2MAX
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2               ',
     &  Q22AVE,Q22AV2
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON      ',
     &  Q22MIN,Q22MAX
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1P4E12.4)') 'SAMPLED THETA RANGE ELECTRON ',
     &  AN2MIN,AN2MAX,PI-AN2MAX,PI-AN2MIN
C
      CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
      IF(NITER.GT.1) THEN
        CALL PHO_PHIST(-2,WEIGHT)
        CALL PHO_LHIST(-2,WEIGHT)
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I4)') 'PHO_GPHERA:NO OUTPUT OF HISTOGRAMS',NITER
      ENDIF

      END


 
 


CDECK  ID>, PHO_grscalc
      SUBROUTINE PHO_GRSCALC(x,q2,p2,ugam,dgam,sgam,ggam)

      IMPLICIT DOUBLE PRECISION (a-z)
      SAVE

      DIMENSION u1(40),ds1(40),g1(40)
      DIMENSION ud2(20),s2(20),g2(20)
      DIMENSION up0(20),dsp0(20),gp0(20)
c
      DATA u1/-0.139d0,0.783d0,0.132d0,0.087d0,0.003d0,-0.0134d0,
     &   0.009d0,-0.017d0,0.092d0,-0.516d0,-0.085d0,0.439d0,
     &   0.013d0,0.108d0,-0.019d0,-0.272d0,-0.167d0,0.138d0,
     &   0.076d0,0.026d0,-0.013d0,0.27d0,0.107d0,-0.097d0,0.04d0,
     &   0.064d0,0.011d0,0.002d0,0.057d0,-0.057d0,0.162d0,
     &   -0.172d0,0.124d0,-0.016d0,-0.065d0,0.044d0,-1.009d0,
     &   0.622d0,0.227d0,-0.184d0/
      DATA ds1/0.033d0,0.007d0,-0.0516d0,0.12d0,0.001d0,-0.013d0,
     &   0.018d0,-0.028d0,0.102d0,-0.595d0,-0.114d0,0.669d0,
     &   0.022d0,0.001d0,-0.003d0,-0.0583d0,-0.041d0,0.035d0,
     &   0.009d0,0.009d0,0.004d0,0.054d0,0.025d0,-0.02d0,
     &   0.007d0,0.021d0,0.01d0,0.004d0,-0.067d0,0.06d0,-0.148d0,
     &   0.13d0,0.032d0,-0.009d0,-0.06d0,0.036d0,-0.39d0,0.033d0,
     &   0.245d0,-0.171d0/
      DATA g1/0.025d0,0.d0,-0.018d0,0.112d0,-0.025d0,0.177d0,
     &   -0.022d0,0.024d0,0.001d0,-0.0104d0,0.d0,0.d0,-1.082d0,
     &   -1.666d0,0.d0,0.086d0,0.d0,0.053d0,0.005d0,-0.058d0,
     &   0.034d0,0.073d0,1.08d0,1.63d0,-0.0256d0,-0.088d0,0.d0,
     &   0.d0,-0.004d0,0.016d0,0.007d0,-0.012d0,0.01d0,-0.673d0,
     &   0.126d0,-0.167d0,0.032d0,-0.227d0,0.086d0,-0.159d0/
      DATA ud2/0.756d0,0.187d0,0.109d0,-0.163d0,0.002d0,0.004d0,
     &   0.054d0,-0.039d0,22.53d0,-21.02d0,5.608d0,0.332d0,
     &   -0.008d0,-0.021d0,0.381d0,0.572d0,4.774d0,1.436d0,
     &   -0.614d0,3.548d0/
      DATA s2/0.902d0,0.182d0,0.271d0,-0.346d0,0.017d0,-0.01d0,
     &   -0.011d0,0.0065d0,17.1d0,-13.29d0,6.519d0,0.031d0,
     &   -0.0176d0,0.003d0,1.243d0,0.804d0,4.709d0,1.499d0,
     &   -0.48d0,3.401d0/
      DATA g2/0.364d0,1.31d0,0.86d0,-0.254d0,0.611d0,0.008d0,
     &   -0.097d0,-2.412d0,-0.843d0,2.248d0,-0.201d0,1.33d0,
     &   0.572d0,0.44d0,1.233d0,0.009d0,0.954d0,1.862d0,3.791d0,
     &   -0.079d0/
      DATA up0/1.551d0,0.105d0,1.089d0,-0.172d0,3.822d0,-2.162d0,
     &   0.533d0,-0.467d0,-0.412d0,0.2d0,0.377d0,0.299d0,0.487d0,
     &   0.0766d0,0.119d0,0.063d0,7.605d0,0.234d0,-0.567d0,
     &   2.294d0/
      DATA dsp0/2.484d0,1.214d0,1.088d0,-0.1735d0,4.293d0,
     &   -2.802d0,0.5975d0,-0.1193d0,-0.0872d0,0.0418d0,0.128d0,
     &   0.0337d0,0.127d0,0.0135d0,0.14d0,0.0423d0,6.946d0,
     &   0.814d0,1.531d0,0.124d0/
      DATA gp0/1.682d0,1.1d0,0.5888d0,-0.4714d0,0.5362d0,0.0127d0,
     &   -2.438d0,0.03399d0,0.07825d0,0.05842d0,0.08393d0,2.348d0,
     &   -0.07182d0,1.084d0,0.3098d0,-0.07514d0,3.327d0,1.1d0,
     &   2.264d0,0.2675d0/
c
      mu2=0.25d0
      lam2=0.232d0*0.232d0
c
      if(p2.le.0.25d0) then
         s=log(log(q2/lam2)/log(mu2/lam2))
         lp1=0.d0
         lp2=0.d0
      else
         s=log(log(q2/lam2)/log(p2/lam2))
         lp1=log(p2/mu2)*log(p2/mu2)
         lp2=log(p2/mu2+log(p2/mu2))
      endif
c
      alp=up0(1)+lp1*u1(1)+lp2*u1(2)
      bet=up0(2)+lp1*u1(3)+lp2*u1(4)
      a=up0(3)+lp1*u1(5)+lp2*u1(6)+
     &  (up0(4)+lp1*u1(7)+lp2*u1(8))*s
      b=up0(5)+lp1*u1(9)+lp2*u1(10)+
     &  (up0(6)+lp1*u1(11)+lp2*u1(12))*s**0.5+
     &  (up0(7)+lp1*u1(13)+lp2*u1(14))*s**2
      gb=up0(8)+lp1*u1(15)+lp2*u1(16)+
     &  (up0(9)+lp1*u1(17)+lp2*u1(18))*s+
     &  (up0(10)+lp1*u1(19)+lp2*u1(20))*s**2
      ga=up0(11)+lp1*u1(21)+lp2*u1(22)+
     &  (up0(12)+lp1*u1(23)+lp2*u1(24))*s**0.5
      gc=up0(13)+lp1*u1(25)+lp2*u1(33)+
     &  (up0(14)+lp1*u1(26)+lp2*u1(34))*s
      gd=up0(15)+lp1*u1(27)+lp2*u1(35)+
     &  (up0(16)+lp1*u1(28)+lp2*u1(36))*s
      ge=up0(17)+lp1*u1(29)+lp2*u1(37)+
     &  (up0(18)+lp1*u1(30)+lp2*u1(38))*s
      gep=up0(19)+lp1*u1(31)+lp2*u1(39)+
     &  (up0(20)+lp1*u1(32)+lp2*u1(40))*s
      upart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
c
      alp=dsp0(1)+lp1*ds1(1)+lp2*ds1(2)
      bet=dsp0(2)+lp1*ds1(3)+lp2*ds1(4)
      a=dsp0(3)+lp1*ds1(5)+lp2*ds1(6)+
     &  (dsp0(4)+lp1*ds1(7)+lp2*ds1(8))*s
      b=dsp0(5)+lp1*ds1(9)+lp2*ds1(10)+
     &  (dsp0(6)+lp1*ds1(11)+lp2*ds1(12))*s**0.5+
     &  (dsp0(7)+lp1*ds1(13)+lp2*ds1(14))*s**2
      gb=dsp0(8)+lp1*ds1(15)+lp2*ds1(16)+
     &  (dsp0(9)+lp1*ds1(17)+lp2*ds1(18))*s+
     &  (dsp0(10)+lp1*ds1(19)+lp2*ds1(20))*s**2
      ga=dsp0(11)+lp1*ds1(21)+lp2*ds1(22)+
     &  (dsp0(12)+lp1*ds1(23)+lp2*ds1(24))*s
      gc=dsp0(13)+lp1*ds1(25)+lp2*ds1(33)+
     &  (dsp0(14)+lp1*ds1(26)+lp2*ds1(34))*s
      gd=dsp0(15)+lp1*ds1(27)+lp2*ds1(35)+
     &  (dsp0(16)+lp1*ds1(28)+lp2*ds1(36))*s
      ge=dsp0(17)+lp1*ds1(29)+lp2*ds1(37)+
     &  (dsp0(18)+lp1*ds1(30)+lp2*ds1(38))*s
      gep=dsp0(19)+lp1*ds1(31)+lp2*ds1(39)+
     &  (dsp0(20)+lp1*ds1(32)+lp2*ds1(40))*s
      dspart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
c
      alp=gp0(1)+lp1*g1(1)+lp2*g1(2)
      bet=gp0(2)+lp1*g1(3)+lp2*g1(4)
      a=gp0(3)+lp1*g1(5)+lp2*g1(6)+
     &  (gp0(4)+lp1*g1(7)+lp2*g1(8))*s**0.5
      b=gp0(5)+lp1*g1(9)+lp2*g1(10)+
     &  (gp0(6)+lp1*g1(11)+lp2*g1(12))*s**2
      gb=gp0(7)+lp1*g1(13)+lp2*g1(14)+
     &  (gp0(8)+lp1*g1(15)+lp2*g1(16))*s
      ga=gp0(9)+lp1*g1(17)+lp2*g1(18)+
     &  (gp0(10)+lp1*g1(19)+lp2*g1(20))*s**0.5+
     &  (gp0(11)+lp1*g1(21)+lp2*g1(22))*s**2
      gc=gp0(12)+lp1*g1(23)+lp2*g1(24)+
     &  (gp0(13)+lp1*g1(25)+lp2*g1(26))*s**2
      gd=gp0(14)+lp1*g1(27)+lp2*g1(28)+
     &  (gp0(15)+lp1*g1(29)+lp2*g1(30))*s+
     &  (gp0(16)+lp1*g1(31)+lp2*g1(32))*s**2
      ge=gp0(17)+lp1*g1(33)+lp2*g1(34)+
     &  (gp0(18)+lp1*g1(35)+lp2*g1(36))*s
      gep=gp0(19)+lp1*g1(37)+lp2*g1(38)+
     &  (gp0(20)+lp1*g1(39)+lp2*g1(40))*s
      gpart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
c
      s=log(log(q2/lam2)/log(mu2/lam2))
      suppr=1.d0/(1.d0+p2/0.59d0)**2
c
      alp=ud2(1)
      bet=ud2(2)
      a=ud2(3)+ud2(4)*s
      ga=ud2(5)+ud2(6)*s**0.5
      gc=ud2(7)+ud2(8)*s
      b=ud2(9)+ud2(10)*s+ud2(11)*s**2
      gb=ud2(12)+ud2(13)*s+ud2(14)*s**2
      gd=ud2(15)+ud2(16)*s
      ge=ud2(17)+ud2(18)*s
      gep=ud2(19)+ud2(20)*s
      udpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
c
      alp=s2(1)
      bet=s2(2)
      a=s2(3)+s2(4)*s
      ga=s2(5)+s2(6)*s**0.5
      gc=s2(7)+s2(8)*s
      b=s2(9)+s2(10)*s+s2(11)*s**2
      gb=s2(12)+s2(13)*s+s2(14)*s**2
      gd=s2(15)+s2(16)*s
      ge=s2(17)+s2(18)*s
      gep=s2(19)+s2(20)*s
      spart2=suppr*PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
c
      alp=g2(1)
      bet=g2(2)
      a=g2(3)+g2(4)*s**0.5
      b=g2(5)+g2(6)*s**2
      gb=g2(7)+g2(8)*s
      ga=g2(9)+g2(10)*s**0.5+g2(11)*s**2
      gc=g2(12)+g2(13)*s**2
      gd=g2(14)+g2(15)*s+g2(16)*s**2
      ge=g2(17)+g2(18)*s
      gep=g2(19)+g2(20)*s
      gpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
c
      ugam=upart1+udpart2
      dgam=dspart1+udpart2
      sgam=dspart1+spart2
      ggam=gpart1+gpart2
c
      END


 
 


CDECK  ID>, PHO_grsf1
      DOUBLE PRECISION FUNCTION PHO_GRSF1(x,s,alp,bet,a,b,ga,gb,gc,gd,
     &                                ge,gep)
      IMPLICIT DOUBLE PRECISION (a-z)
      SAVE

      PHO_GRSF1=(x**a*(ga+gb*sqrt(x)+gc*x**b)+
     &      s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
     &      (1.d0-x)**gd

      END


 
 


CDECK  ID>, PHO_grsf2
      DOUBLE PRECISION FUNCTION PHO_GRSF2(x,s,alp,bet,a,b,ga,gb,gc,gd,
     &                                ge,gep)
      IMPLICIT DOUBLE PRECISION (a-z)
      SAVE

      PHO_GRSF2=(s*x**a*(ga+gb*sqrt(x)+gc*x**b)+
     &      s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
     &      (1.d0-x)**gd

      END


 
 


CDECK  ID>, PHO_HACODE
      SUBROUTINE PHO_HACODE(ID1,ID2,IDcpc1,IDcpc2)
C*********************************************************************
C
C     determination of hadron index from quarks
C
C     input:   ID1,ID2   parton code according to PDG conventions
C
C     output:  IDcpc1,2  CPC particle codes
C
C*********************************************************************

      IMPLICIT NONE
      SAVE

      INTEGER ID1,ID2,IDcpc1,IDcpc2

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  general particle data
      DOUBLE PRECISION xm_list,tau_list,gam_list,
     &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
     &  xm_bb82_list,xm_bb102_list
      INTEGER          ich3_list,iba3_list,iq_list,
     &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
      COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
     &  xm_psm2_list(6,6),xm_vem2_list(6,6),
     &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
     &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
     &  ich3_list(300),iba3_list(300),iq_list(3,300),
     &  id_psm_list(6,6),id_vem_list(6,6),
     &  id_b8_list(6,6,6),id_b10_list(6,6,6)

C  local variables
      INTEGER ii,jj,kk,i1,i2

      IDcpc1 = 0
      IDcpc2 = 0

      if(ID1*ID2.lt.0) then
C  meson
        if(ID1.gt.0) then
          ii = ID1
          jj = -ID2
        else
          ii = ID2
          jj = -ID1
        endif
        IDcpc1 = ID_psm_list(ii,jj)
        IDcpc2 = ID_vem_list(ii,jj)

      else
C  baryon
        i1 = abs(ID1)
        i2 = abs(ID2)
        if(i1.gt.6) then
          ii = i1/1000
          jj = (i1-ii*1000)/100
          kk = i2
        else
          ii = i1
          jj = i2/1000
          kk = (i2-jj*1000)/100
        endif
        IDcpc1 = sign(ID_b8_list(ii,jj,kk),ID1)
        IDcpc2 = sign(ID_b10_list(ii,jj,kk),ID1)

      endif

      END


 
 


CDECK  ID>, PHO_HADCSL
      SUBROUTINE PHO_HADCSL(ID1,ID2,ECM,PLAB,IMODE,
     &                     SIGTOT,SIGEL,SIGDIF,SLOPE,RHO)
C***********************************************************************
C
C     low-energy cross section parametrizations
C
C     input:   ID1,ID2     PDG IDs of particles (meson first)
C              ECM         c.m. energy (GeV)
C              PLAB        lab. momentum (second particle at rest)
C              IMODE       1    ECM given, PLAB ignored
C                          2    PLAB given, ECM ignored
C
C     output:  SIGTOT      total cross section (mb)
C              SIGEL       elastic cross section (mb)
C              SIGDIF      diffracive cross section (sd-1,sd-2,dd), (mb)
C              SLOPE       forward elastic slope (GeV**-2)
C              RHO         real/imaginary part of elastic amplitude
C
C     comments:
C
C     - low-energy data interpolation uses PDG fits from 1992 issue
C     - high-energy extrapolation by Donnachie-Landshoff like fit made
C       by PDG 1996
C     - analytic extension of amplitude to calculate rho
C
C***********************************************************************

      IMPLICIT NONE
      SAVE

      INTEGER ID1,ID2,IMODE
      DOUBLE PRECISION ECM,PLAB,SIGTOT,SIGEL,SIGDIF(3),SLOPE,RHO

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

      INTEGER K
      DOUBLE PRECISION SIGTO1,SIGTO2,SIGEL1,SIGEL2,
     &  SS,PL,PLL,E1,XP,YP,YM,PHR,PHP,X1,X2

      DOUBLE PRECISION TPDG92(7,2,6),TPDG96(9,6),BURQ83(3,6),XMA(6)

      DATA TPDG92  /
     &  3.D0, 2100.D0, 48.D0, 0.D0, 1.D0, 0.522D0, -4.51D0,
     &  3.D0, 2100.D0, 11.9D0, 26.9D0, -1.21D0, 0.169D0, -1.85D0,
     &  5.D0, 2100.D0, 38.4D0, 77.6D0, -0.64D0, 0.26D0, -1.2D0,
     &  5.D0, 2100.D0, 10.2D0, 52.7D0, -1.16D0, 0.125D0, -1.28D0,
     &  4.D0, 340.D0,  16.4D0, 19.3D0, -0.42D0, 0.19D0, 0.D0,
     &  4.D0, 340.D0,  0.D0, 11.4D0, -0.4D0, 0.079D0, 0.D0,
     &  2.5D0, 370.D0, 33.D0, 14.D0, -1.36D0, 0.456D0, -4.03D0,
     &  2.5D0, 370.D0, 1.76D0, 11.2D0, -0.64D0, 0.043D0, 0.D0,
     &  2.D0, 310.D0,  18.1D0, 0.D0, 1.D0, 0.26D0, -1.D0,
     &  2.D0, 310.D0,  5.D0, 8.1D0, -1.8D0, 0.16D0, -1.3D0,
     &  3.D0, 310.D0,  32.1D0, 0.D0, 1.D0, 0.66D0, -5.6D0,
     &  3.D0, 310.D0,  7.3D0, 0.D0, 1.D0, 0.29D0, -2.4D0  /

      DATA TPDG96  /
     &  50.D0, 22.D0,0.079D0,0.25D0,0.D0,
     &         77.15D0,-21.05D0,0.46D0,0.9D0,
     &  50.D0, 22.D0,0.079D0,0.25D0,0.D0,
     &         77.15D0,21.05D0,0.46D0,0.9D0,
     &  10.D0, 13.70,0.079D0,0.25D0,0.D0,
     &         31.85D0,-4.05D0,0.45D0,0.9D0,
     &  10.D0, 13.70,0.079D0,0.25D0,0.D0,
     &         31.85D0,4.05D0,0.45D0,0.9D0,
     &  10.D0, 12.20,0.079D0,0.25D0,0.D0,
     &         17.35D0,-9.05D0,0.50D0,0.9D0,
     &  10.D0, 12.20,0.079D0,0.25D0,0.D0,
     &         17.35D0,9.05D0,0.50D0,0.9D0  /

      DATA BURQ83 /
     &  11.13D0, -6.21D0, 0.30D0,
     &  11.13D0,  7.23D0, 0.30D0,
     &  9.11D0,  -0.73D0, 0.28D0,
     &  9.11D0,   0.65D0, 0.28D0,
     &  8.55D0,  -5.98D0, 0.28D0,
     &  8.55D0,   1.60D0, 0.28D0  /

      DATA XMA /
     &  2*0.93956563D0, 2*0.13956995D0, 2*0.493677D0 /

C  find index
      IF(ID2.NE.2212) THEN
        GOTO 100
      ELSE IF(ID1.EQ.2212) THEN
        K = 1
      ELSE IF(ID1.EQ.-2212) THEN
        K = 2
      ELSE IF(ID1.EQ.211) THEN
        K = 3
      ELSE IF(ID1.EQ.-211) THEN
        K = 4
      ELSE IF(ID1.EQ.321) THEN
        K = 5
      ELSE IF(ID1.EQ.-321) THEN
        K = 6
      ELSE
        GOTO 100
      ENDIF

C  calculate lab momentum
      IF(IMODE.EQ.1) THEN
        SS = ECM**2
        E1 = 0.5D0/XMA(1)*(SS-XMA(1)**2-XMA(K)**2)
        PL = SQRT(E1*E1-XMA(K)**2)
      ELSE IF(IMODE.EQ.2) THEN
        PL = PLAB
        SS = XMA(1)**2+XMA(K)**2+2.D0*XMA(1)*SQRT(PL**2+XMA(K)**2)
        ECM = SQRT(SS)
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I5)') 'PHO_HADCSL:ERROR: invalid IMODE: ',IMODE
        RETURN
      ENDIF
      PLL = LOG(PL)

C  check against lower limit
      IF(ECM.LE.XMA(1)+XMA(K)) GOTO 200

      XP  = TPDG96(2,K)*SS**TPDG96(3,K)
      YP  = TPDG96(6,K)/SS**TPDG96(8,K)
      YM  = TPDG96(7,K)/SS**TPDG96(8,K)

      PHR = TAN(PI/2.D0*(1.-TPDG96(8,K)))
      PHP = TAN(PI/2.D0*(1.+TPDG96(3,K)))
      RHO = (-YP/PHR + YM*PHR - XP/PHP)/(YP+YM+XP)
      SLOPE = BURQ83(1,K)+BURQ83(2,K)/SQRT(PL)+BURQ83(3,K)*PLL

C  select energy range and interpolation method
      IF(PL.LT.TPDG96(1,K)) THEN
        SIGTOT = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
     &          + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
        SIGEL  = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
     &          + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
      ELSE IF(PL.LT.TPDG92(2,1,K)) THEN
        SIGTO1 = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
     &          + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
        SIGEL1 = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
     &          + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
        SIGTO2 = YP+YM+XP
        SIGEL2 = SIGTO2**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
        X2 = LOG(PL/TPDG96(1,K))/LOG(TPDG92(2,1,K)/TPDG96(1,K))
        X1 = 1.D0 - X2
        SIGTOT = SIGTO2*X2 + SIGTO1*X1
        SIGEL  = SIGEL2*X2 + SIGEL1*X1
      ELSE
        SIGTOT = YP+YM+XP
        SIGEL  = SIGTOT**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
      ENDIF

C  no parametrization of diffraction implemented
      SIGDIF(1) = -1.D0
      SIGDIF(2) = -1.D0
      SIGDIF(3) = -1.D0

      RETURN

 100  CONTINUE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,2A,2I7)') 'PHO_HADCSL:ERROR: ',
     &    'invalid particle combination: ',ID1,ID2
        RETURN

 200  CONTINUE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,2A,1P,2E12.4)') 'PHO_HADCSL:ERROR: ',
     &    'energy too small (Ecm,Plab): ',ECM,PLAB

      END


 
 


CDECK  ID>, PHO_HADSP2
      SUBROUTINE PHO_HADSP2(IFLB,XS1,XMAX,XSOFT1,IREJ)
C***********************************************************************
C
C     split hadron momentum XMAX into two partons using
C     lower cut-off: AS
C
C     input:   IFLB    compressed particle code of particle to split
C              XS1     sum of x values already selected
C              XMAX    maximal x possible
C
C     output:  XS1     new sum of x values (without first one)
C              XSOFT1  field of selected x values
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( DEPS   =  1.D-8 )

      DIMENSION XSOFT1(50)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  internal rejection counters
      INTEGER NMXJ
      PARAMETER (NMXJ=60)
      CHARACTER*10 REJTIT
      INTEGER IFAIL
      COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)

C  data on most recent hard scattering
      INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
      DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
     &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
      COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
     &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
     &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
     &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC

C  model exponents
      DATA PVMES1 /-0.5D0/
      DATA PVMES2 /-0.5D0/
      DATA PVBAR1 / 1.5D0/
      DATA PVBAR2 /-0.5D0/
C
      IREJ = 0
      ITMAX = 100
C
C  mesonic particle
      IF(IPHO_BAR3(IFLB,0).EQ.0) THEN
        XPOT1 = PVMES1+1.D0
        XPOT2 = PVMES2+1.D0
C  baryonic particle
      ELSE
        XPOT1 = PVBAR1+1.D0
        XPOT2 = PVBAR2+1.D0
      ENDIF
      ITER = 0
      XREST= 1.D0-XS1
C  selection loop
 100  CONTINUE
        ITER = ITER+1
        IF(ITER.GE.ITMAX) THEN
          IF(IDEB(39).GE.3) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,A,I8)')
     &        'PHO_HADSP2: REJECTION (ITER)',ITER
            IF (LPRI.GT.4)
     &      WRITE(LO,'(5X,A,3E12.3)') 'XS1,XMAX,AS:',XS1,XMAX,AS
          ENDIF
          IFAIL(14) = IFAIL(14)+1
          IREJ = 1
          RETURN
        ENDIF
        ZZ = XREST*PHO_RNDBET(XPOT2,XPOT1)
      IF((ZZ.GT.XMAX).OR.(ZZ.LT.AS)) GOTO 100
      XSS1 = XS1 + ZZ
      IF((1.D0-XSS1).LT.AS) GOTO 100
C
      XS1 = XSS1
      XSOFT1(1) = 1.D0-XSS1
      XSOFT1(2) = ZZ
C  debug output
      IF(IDEB(39).GE.10) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,2I8)') 'PHO_HADSP2: ITMAX,ITER',ITMAX,ITER
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,3E10.3,5X,2E11.4)') 'XS1,XMAX,AS  X1,X2:',
     &    XS1,XMAX,AS,XSOFT1(1),XSOFT1(2)
      ENDIF
      END


 
 


CDECK  ID>, PHO_HADSP3
      SUBROUTINE PHO_HADSP3(IFLB,XS1,XMAX,XSOFT1,IREJ)
C***********************************************************************
C
C     split hadron momentum XMAX into diquark & quark pair
C     using lower cut-off: AS
C
C     input:   IFLB    compressed particle code of particle to split
C              XS1     sum of x values already selected
C              XMAX    maximal x possible
C
C     output:  XS1     new sum of x values
C              XSOFT1  field of selected x values
C
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE
      PARAMETER ( DEPS   =  1.D-8 )

      DIMENSION XSOFT1(50),XSOFT2(50)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  internal rejection counters
      INTEGER NMXJ
      PARAMETER (NMXJ=60)
      CHARACTER*10 REJTIT
      INTEGER IFAIL
      COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)

C  data of c.m. system of Pomeron / Reggeon exchange
      INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
      DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
     &                 SIDP,CODP,SIFP,COFP
      COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
     &                SIDP,CODP,SIFP,COFP,NPOSP(2),
     &                IDPDG1,IDBAM1,IDPDG2,IDBAM2

      DIMENSION XPOT1(3),XPOT2(3),XMIN(2,3)

C  model exponents
      DATA PVMES1 /-0.5D0/
      DATA PVMES2 /-0.5D0/
      DATA PSMES  /-0.99D0/
      DATA PVBAR1 / 1.5D0/
      DATA PVBAR2 /-0.5D0/
      DATA PSBAR  /-0.99D0/
C
      IREJ = 0
C
C  determine exponents
C  particle 1
C
      XMMIN = 0.3D0/ECMP
      XBMIN = 1.6D0/ECMP
C  mesonic particle
      IF(IPHO_BAR3(IFLB,0).EQ.0) THEN
        XPOT1(1) = PVMES1
        XMIN(1,1)  = XMMIN
        XPOT1(2) = PVMES2
        XMIN(1,2)  = XMMIN
        XPOT1(3) = PSMES
        XMIN(1,3)  = XMMIN
C  baryonic particle
      ELSE
        XPOT1(1) = PVBAR1
        XMIN(1,1)  = XBMIN
        XPOT1(2) = PVBAR2
        XMIN(1,2)  = XMMIN
        XPOT1(3) = PSBAR
        XMIN(1,3)  = XMMIN
      ENDIF
C  particle 2
C  mesonic particle
      XPOT2(1) = PVMES1
      XMIN(2,1)  = XMMIN
      XPOT2(2) = PVMES2
      XMIN(2,2)  = XMMIN
      XPOT2(3) = PSMES
      XMIN(2,3)  = XMMIN
C
      XDUM1 = 0.01D0
      XDUM2 = 0.99D0
      CALL PHO_SELSXS(3,3,XPOT1,XPOT2,XMIN,XS1,XDUM1,XMAX,XDUM2,
     &            XSOFT1,XSOFT2,IREJ)
C  rejection?
      IF(IREJ.NE.0) THEN
        IF (LPRI.GT.4 .AND. IDEB(74).GE.3)
     &  WRITE(LO,'(1X,A,I6,2E12.4)')
     &    'PHO_HADSP3: rejection (IFLB,XS1,XMAX)',IFLB,XS1,XMAX
        IFAIL(15) = IFAIL(15)+1
        IREJ = 1
        RETURN
      ENDIF
C  debug output
      IF(IDEB(74).GE.10) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I6,2E12.4)')
     &    'PHO_HADSP3: IFLB,XS1,XMAX',IFLB,XS1,XMAX
        DO 100 I=1,3
          IF (LPRI.GT.4)
     &    WRITE(LO,'(10X,I4,2E12.4)') I,XSOFT1(I),XSOFT2(I)
 100    CONTINUE
      ENDIF

      END


 
 


CDECK  ID>, PHO_HARCOL
      SUBROUTINE PHO_HARCOL(MSPR,V,IP1,ICA1,ICA2,IP2,ICB1,ICB2,
     &                  IP3,ICC1,ICC2,IP4,ICD1,ICD2)
C*********************************************************************
C
C     calculate color flow for hard resolved process
C
C     input:    IP1..4  flavour of partons (PDG convention)
C               V       parton subprocess Mandelstam variable  V = t/s
C                       (lightcone momenta assumed)
C               ICA,ICB color labels
C               MSPR    process number
C                       -1   initialization of statistics
C                       -2   output of statistics
C
C     output:   ICC,ICD color label of final partons
C
C     (it is possible to use the same variables for in and output)
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  names of hard scattering processes
      INTEGER Max_pro_1
      PARAMETER ( Max_pro_1 = 16 )
      CHARACTER*18 PROC
      COMMON /POHPRO/ PROC(0:Max_pro_1)

      DIMENSION PC(3),ICONF(8,5),IRECN(8,2)

C  initialization
      IF(MSPR.EQ.-1) THEN
        DO 200 I=1,8
          DO 210 K=1,5
            ICONF(I,K) = 0
 210      CONTINUE
          IRECN(I,1) = 0
          IRECN(I,2) = 0
 200    CONTINUE
        RETURN
C  output of statistics
      ELSE IF(MSPR.EQ.-2) THEN
        IF(IDEB(26).LT.1) RETURN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,/1X,A)')
     &    'PHO_HARCOL: sampled color configurations',
     &    '----------------------------------------'
        IF (LPRI.GT.4)
     &  WRITE(LO,'(6X,A,15X,A)')
     &    'diagram                  color configurations (1-4)','sum'
        DO 300 I=1,8
          DO 310 K=1,4
            ICONF(I,5) = ICONF(I,5) + ICONF(I,K)
 310      CONTINUE
          IF (LPRI.GT.4)
     .    WRITE(LO,'(2X,A,4I11,I12)') PROC(I),(ICONF(I,K),K=1,5)
 300    CONTINUE
        IF(ISWMDL(11).GE.2) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/6X,A)')
     &      'diagram             with   /   without color re-connection'
          DO 320 I=1,8
            IF (LPRI.GT.4)
     &      WRITE(LO,'(2X,A,2I11)') PROC(I),IRECN(I,1),IRECN(I,2)
 320      CONTINUE
        ENDIF
        RETURN
      ENDIF
C
C  gluons: first color positive, quarks second color zero
      IF(IP1.EQ.0) THEN
        IF(ICA1.LT.0) THEN
          I = ICA2
          ICA2 = ICA1
          ICA1 = I
        ENDIF
      ELSE
        ICA2 = 0
      ENDIF
      IF(IP2.EQ.0) THEN
        IF(ICB1.LT.0) THEN
          I = ICB2
          ICB2 = ICB1
          ICB1 = I
        ENDIF
      ELSE
        ICB2 = 0
      ENDIF
      IC2 = 0
      IC4 = 0
C  debug output
      IF(IDEB(26).GE.15 .AND. LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I4,/,5X,A,3I5,2X,3I5)')
     &  'PHO_HARCOL: process',MSPR,
     &  'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
C
      IRC = 0
      IF(IPAMDL(21).EQ.1) THEN
C
C  soft color re-connection option
C
        IF(MSPR.EQ.1) THEN
C  hard g g final state, only g g --> g g
          IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
            IF(DT_RNDM(V).LT.PARMDL(140)) THEN
              IC1 = ICA1
              IC2 = ICA2
              IC3 = ICB1
              IC4 = ICB2
              IRECN(MSPR,1) = IRECN(MSPR,1)+1
              IRC = 1
              GOTO 100
            ENDIF
          ENDIF
        ELSE IF(MSPR.EQ.3) THEN
C  hard q g final state
          IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
            IF(DT_RNDM(V).LT.PARMDL(141)) THEN
              IC1 = ICA1
              IC2 = ICA2
              IC3 = ICB1
              IC4 = ICB2
              IRECN(MSPR,1) = IRECN(MSPR,1)+1
              IRC = 1
              GOTO 100
            ENDIF
          ENDIF
        ELSE IF((MSPR.EQ.5).OR.(MSPR.EQ.7).OR.(MSPR.EQ.8)) THEN
C  hard q q final state
          IF(ICA1.NE.-ICB1) THEN
            IF(DT_RNDM(V).LT.PARMDL(142)) THEN
              IC1 = ICA1
              IC2 = ICA2
              IC3 = ICB1
              IC4 = ICB2
              IRECN(MSPR,1) = IRECN(MSPR,1)+1
              IRC = 1
              GOTO 100
            ENDIF
          ENDIF
        ENDIF
        IRECN(MSPR,2) = IRECN(MSPR,2)+1
      ENDIF
C
      IF((ISWMDL(11).EQ.1).AND.(MSPR.LT.10)) THEN
C
C  large Nc limit of all graphs
C
        IF(MSPR.EQ.1) THEN
C  g g --> g g
          IF(DT_RNDM(V).GT.0.5D0) THEN
            IC1 = ICB1
            IC2 = ICA2
            IC3 = ICA1
            IC4 = ICB2
            ICONF(MSPR,1) = ICONF(MSPR,1)+1
          ELSE
            IC1 = ICA1
            IC2 = ICB2
            IC3 = ICB1
            IC4 = ICA2
            ICONF(MSPR,2) = ICONF(MSPR,2)+1
          ENDIF
        ELSE IF(MSPR.EQ.2) THEN
C  q qb --> g g
          CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
          IF(ICA1.LT.0) THEN
            IC1 = I1
            IC2 = ICA1
            IC3 = ICB1
            IC4 = I2
            ICONF(MSPR,2) = ICONF(MSPR,2)+1
          ELSE
            IC1 = ICA1
            IC2 = I2
            IC3 = I1
            IC4 = ICB1
            ICONF(MSPR,1) = ICONF(MSPR,1)+1
          ENDIF
        ELSE IF(MSPR.EQ.3) THEN
C  q g --> q g
          IF(DT_RNDM(V).LT.0.5D0) THEN
            IF(IP1+IP2.GT.0) THEN
              IC1 = ICB1
              IC2 = ICA2
              IC3 = ICA1
              IC4 = ICB2
            ELSE IF(IP1.LT.0) THEN
              IC1 = ICB2
              IC3 = ICB1
              IC4 = ICA1
            ELSE
              IC1 = ICA1
              IC2 = ICB1
              IC3 = ICA2
            ENDIF
            ICONF(MSPR,1) = ICONF(MSPR,1)+1
          ELSE
            IF(IP1.GT.0) THEN
              CALL PHO_HARCOR(-ICA1,ICB2)
              IC1 = ICA1
              IC3 = ICB1
              IC4 = -ICA1
            ELSE IF(IP2.GT.0) THEN
              CALL PHO_HARCOR(-ICB1,ICA2)
              IC1 = ICA1
              IC2 = -ICB1
              IC3 = ICB1
            ELSE IF(IP1.LT.0) THEN
              CALL PHO_HARCOR(-ICA1,ICB1)
              IC1 = ICA1
              IC3 = -ICA1
              IC4 = ICB2
            ELSE IF(IP2.LT.0) THEN
              CALL PHO_HARCOR(-ICB1,ICA1)
              IC1 = -ICB1
              IC2 = ICA2
              IC3 = ICB1
            ENDIF
            ICONF(MSPR,2) = ICONF(MSPR,2)+1
          ENDIF
        ELSE IF(MSPR.EQ.4) THEN
C  g g --> q qb
          IC1 = ICA1
          IC3 = ICB2
          CALL PHO_HARCOR(-ICB1,ICA2)
          IF(ICB2.EQ.-ICB1) IC3 = ICA2
          IF(IP3*IC1.LT.0) THEN
            I = IC1
            IC1 = IC3
            IC3 = I
          ENDIF
          ICONF(MSPR,2) = ICONF(MSPR,2)+1
        ELSE IF(MSPR.EQ.5) THEN
C  q qb --> q qb
          IF(DT_RNDM(V).LT.0.5D0) THEN
            IF(ICA1*IP3.LT.0) THEN
              IC1 = ICB1
              IC3 = ICA1
            ELSE
              IC1 = ICA1
              IC3 = ICB1
            ENDIF
            ICONF(MSPR,1) = ICONF(MSPR,1)+1
          ELSE
            IF(ICA1*IP3.LT.0) THEN
              IC1 = -ICA1
              IC3 = ICA1
            ELSE
              IC1 = ICA1
              IC3 = -ICA1
            ENDIF
            CALL PHO_HARCOR(-ICA1,ICB1)
            ICONF(MSPR,2) = ICONF(MSPR,2)+1
          ENDIF
        ELSE IF(MSPR.EQ.6) THEN
C  q qb --> qp qbp
          IF(ICA1*IP3.LT.0) THEN
            IC1 = ICB1
            IC3 = ICA1
            ICONF(MSPR,1) = ICONF(MSPR,1)+1
          ELSE
            IC1 = ICA1
            IC3 = ICB1
            ICONF(MSPR,2) = ICONF(MSPR,2)+1
          ENDIF
        ELSE IF(MSPR.EQ.7) THEN
C  q q --> q q
          IF(DT_RNDM(V).LT.0.5D0) THEN
            IC1 = ICA1
            IC3 = ICB1
            ICONF(MSPR,1) = ICONF(MSPR,1)+1
          ELSE
            IC1 = ICB1
            IC3 = ICA1
            ICONF(MSPR,2) = ICONF(MSPR,2)+1
          ENDIF
        ELSE IF(MSPR.EQ.8) THEN
C  q qp --> q qp
          IF(IP1*IP2.GT.0) THEN
            IF(IP3.EQ.IP1) THEN
              IC1 = ICB1
              IC3 = ICA1
            ELSE
              IC1 = ICA1
              IC3 = ICB1
            ENDIF
            ICONF(MSPR,1) = ICONF(MSPR,1)+1
          ELSE
            IF(ICA1*IP3.LT.0) THEN
              IC1 = -ICA1
              IC3 = ICA1
            ELSE
              IC1 = ICA1
              IC3 = -ICA1
            ENDIF
            CALL PHO_HARCOR(-ICA1,ICB1)
            ICONF(MSPR,2) = ICONF(MSPR,2)+1
          ENDIF
        ELSE
C  unknown process
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,I3)')
     &      'PHO_HARCOL:ERROR:invalid process number (MSPR)',MSPR
          CALL PHO_ABORT
        ENDIF
C
      ELSE
C
C  color flow according to QCD leading order matrix element
C
        U = -(1.D0+V)
        IF(MSPR.EQ.1) THEN
C  g g --> g g
          PC(1) = 1/V**2  +2.D0/V    +3.D0  +2.D0*V    +V**2
          PC(2) = 1/U**2  +2.D0/U    +3.D0  +2.D0*U    +U**2
          PC(3) = (V/U)**2+2.D0*(V/U)+3.D0  +2.D0*(U/V)+(U/V)**2
          XI = (PC(1)+PC(2)+PC(3))*DT_RNDM(U)
          PCS = 0.D0
          DO 110 I=1,3
            PCS = PCS+PC(I)
            IF(XI.LT.PCS) GOTO 120
 110      CONTINUE
 120      CONTINUE
          IF(I.EQ.1) THEN
            CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
            IF(DT_RNDM(V).GT.0.5D0) THEN
              IC1 = I1
              IC2 = ICA2
              IC3 = ICB1
              IC4 = I2
              CALL PHO_HARCOR(-ICB2,ICA1)
              IF(ICB1.EQ.-ICB2) IC3 = ICA1
            ELSE
              IC1 = ICA1
              IC2 = I2
              IC3 = I1
              IC4 = ICB2
              CALL PHO_HARCOR(-ICB1,ICA2)
              IF(ICB2.EQ.-ICB1) IC4 = ICA2
            ENDIF
          ELSE IF(I.EQ.2) THEN
            CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
            IF(DT_RNDM(U).GT.0.5D0) THEN
              IC1 = ICB1
              IC2 = I2
              IC3 = I1
              IC4 = ICA2
              CALL PHO_HARCOR(-ICB2,ICA1)
              IF(ICB1.EQ.-ICB2) IC1 = ICA1
            ELSE
              IC1 = I1
              IC2 = ICB2
              IC3 = ICA1
              IC4 = I2
              CALL PHO_HARCOR(-ICB1,ICA2)
              IF(ICB2.EQ.-ICB1) IC2 = ICA2
            ENDIF
          ELSE
            IF(DT_RNDM(V).GT.0.5D0) THEN
              IC1 = ICB1
              IC2 = ICA2
              IC3 = ICA1
              IC4 = ICB2
            ELSE
              IC1 = ICA1
              IC2 = ICB2
              IC3 = ICB1
              IC4 = ICA2
            ENDIF
          ENDIF
          ICONF(MSPR,I) = ICONF(MSPR,I)+1
        ELSE IF(MSPR.EQ.2) THEN
C  q qb --> g g
          PC(1) = U/V-2.D0*U**2
          PC(2) = V/U-2.D0*V**2
          CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
          XI = (PC(1)+PC(2))*DT_RNDM(U)
          IF(XI.LT.PC(1)) THEN
            IF(ICA1.GT.0) THEN
              IC1 = ICA1
              IC2 = I2
              IC3 = I1
              IC4 = ICB1
              ICONF(MSPR,1) = ICONF(MSPR,1)+1
            ELSE
              IC1 = I1
              IC2 = ICA1
              IC3 = ICB1
              IC4 = I2
              ICONF(MSPR,2) = ICONF(MSPR,2)+1
            ENDIF
          ELSE
            IF(ICA1.GT.0) THEN
              IC1 = I1
              IC2 = ICB1
              IC3 = ICA1
              IC4 = I2
              ICONF(MSPR,3) = ICONF(MSPR,3)+1
            ELSE
              IC1 = ICB1
              IC2 = I2
              IC3 = I1
              IC4 = ICA1
              ICONF(MSPR,4) = ICONF(MSPR,4)+1
            ENDIF
          ENDIF
        ELSE IF(MSPR.EQ.3) THEN
C  q g --> q g
          PC(1) = 2.D0*(U/V)**2-U
          PC(2) = 2.D0/V**2-1.D0/U
          XI = (PC(1)+PC(2))*DT_RNDM(V)
          IF(XI.LT.PC(1)) THEN
            CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
            IF(IP1.GT.0) THEN
              IC1 = I1
              IC3 = ICB1
              IC4 = I2
              CALL PHO_HARCOR(-ICA1,ICB2)
              ICONF(MSPR,1) = ICONF(MSPR,1)+1
            ELSE IF(IP1.LT.0) THEN
              IC1 = I2
              IC3 = I1
              IC4 = ICB2
              CALL PHO_HARCOR(-ICA1,ICB1)
              ICONF(MSPR,1) = ICONF(MSPR,1)+1
            ELSE IF(IP2.GT.0) THEN
              IC1 = ICA1
              IC2 = I2
              IC3 = I1
              CALL PHO_HARCOR(-ICB1,ICA2)
              ICONF(MSPR,2) = ICONF(MSPR,2)+1
            ELSE
              IC1 = I1
              IC2 = ICA2
              IC3 = I2
              CALL PHO_HARCOR(-ICB1,ICA1)
              ICONF(MSPR,2) = ICONF(MSPR,2)+1
            ENDIF
          ELSE
            IF(IP1.GT.0) THEN
              IC1 = ICB1
              IC3 = ICA1
              IC4 = ICB2
              ICONF(MSPR,3) = ICONF(MSPR,3)+1
            ELSE IF(IP1.LT.0) THEN
              IC1 = ICB2
              IC3 = ICB1
              IC4 = ICA1
              ICONF(MSPR,3) = ICONF(MSPR,3)+1
            ELSE IF(IP2.GT.0) THEN
              IC1 = ICB1
              IC2 = ICA2
              IC3 = ICA1
              ICONF(MSPR,4) = ICONF(MSPR,4)+1
            ELSE
              IC1 = ICA1
              IC2 = ICB1
              IC3 = ICA2
              ICONF(MSPR,4) = ICONF(MSPR,4)+1
            ENDIF
          ENDIF
        ELSE IF(MSPR.EQ.4) THEN
C  g g --> q qb
          PC(1) = U/V-2.D0*U**2
          PC(2) = V/U-2.D0*V**2
          XI = (PC(1)+PC(2))*DT_RNDM(U)
          IF(XI.LT.PC(1)) THEN
            IF(IP3.GT.0) THEN
              IC1 = ICA1
              IC3 = ICB2
              CALL PHO_HARCOR(-ICB1,ICA2)
              IF(ICB2.EQ.-ICB1) IC3 = ICA2
              ICONF(MSPR,1) = ICONF(MSPR,1)+1
            ELSE
              IC1 = ICA2
              IC3 = ICB1
              CALL PHO_HARCOR(-ICB2,ICA1)
              IF(ICB1.EQ.-ICB2) IC3 = ICA1
              ICONF(MSPR,2) = ICONF(MSPR,2)+1
            ENDIF
          ELSE
            IF(IP3.GT.0) THEN
              IC1 = ICB1
              IC3 = ICA2
              CALL PHO_HARCOR(-ICB2,ICA1)
              IF(ICB1.EQ.-ICB2) IC1 = ICA1
              ICONF(MSPR,3) = ICONF(MSPR,3)+1
            ELSE
              IC1 = ICB2
              IC3 = ICA1
              CALL PHO_HARCOR(-ICB1,ICA2)
              IF(ICB2.EQ.-ICB1) IC1 = ICA2
              ICONF(MSPR,4) = ICONF(MSPR,4)+1
            ENDIF
          ENDIF
        ELSE IF(MSPR.EQ.5) THEN
C  q qb --> q qb
          PC(1) = (1.D0+U**2)/V**2
          PC(2) = (V**2+U**2)
          XI = (PC(1)+PC(2))*DT_RNDM(V)
          IF(XI.LT.PC(1)) THEN
            CALL PHO_HARCOR(-ICB1,ICA1)
            CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
            IF(IP3.GT.0) THEN
              IC1 = I1
              IC3 = I2
              ICONF(MSPR,1) = ICONF(MSPR,1)+1
            ELSE
              IC1 = I2
              IC3 = I1
              ICONF(MSPR,2) = ICONF(MSPR,2)+1
            ENDIF
          ELSE
            IF(IP3.GT.0) THEN
              IC1 = MAX(ICA1,ICB1)
              IC3 = MIN(ICA1,ICB1)
              ICONF(MSPR,3) = ICONF(MSPR,3)+1
            ELSE
              IC1 = MIN(ICA1,ICB1)
              IC3 = MAX(ICA1,ICB1)
              ICONF(MSPR,4) = ICONF(MSPR,4)+1
            ENDIF
          ENDIF
        ELSE IF(MSPR.EQ.6) THEN
C  q qb --> qp qpb
          IF(IP3.GT.0) THEN
            IC1 = MAX(ICA1,ICB1)
            IC3 = MIN(ICA1,ICB1)
            ICONF(MSPR,1) = ICONF(MSPR,1)+1
          ELSE
            IC1 = MIN(ICA1,ICB1)
            IC3 = MAX(ICA1,ICB1)
            ICONF(MSPR,2) = ICONF(MSPR,2)+1
          ENDIF
        ELSE IF(MSPR.EQ.7) THEN
C  q q --> q q
          PC(1) = (1.D0+U**2)/V**2
          PC(2) = (1.D0+V**2)/U**2
          XI = (PC(1)+PC(2))*DT_RNDM(U)
          IF(XI.LT.PC(1)) THEN
            IC1 = ICB1
            IC3 = ICA1
            ICONF(MSPR,1) = ICONF(MSPR,1)+1
          ELSE
            IC1 = ICA1
            IC3 = ICB1
            ICONF(MSPR,2) = ICONF(MSPR,2)+1
          ENDIF
        ELSE IF(MSPR.EQ.8) THEN
C  q qp --> q qp
          IF(IP1*IP2.LT.0) THEN
            CALL PHO_HARCOR(-ICB1,ICA1)
            CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
            IF(IP1.GT.0) THEN
              IC1 = I1
              IC3 = I2
              ICONF(MSPR,1) = ICONF(MSPR,1)+1
            ELSE
              IC1 = I2
              IC3 = I1
              ICONF(MSPR,2) = ICONF(MSPR,2)+1
            ENDIF
          ELSE
            IC1 = ICB1
            IC3 = ICA1
            ICONF(MSPR,3) = ICONF(MSPR,3)+1
          ENDIF

        ELSE IF(MSPR.EQ.10) THEN
C  gam q --> q g
          CALL PHO_SELCOL(ICB1,ICB2,IC1,IC2,IC3,IC4,2)
          IF(IP3.EQ.0) THEN
            CALL PHO_SWAPI(IC1,IC3)
            CALL PHO_SWAPI(IC2,IC4)
          ENDIF
        ELSE IF(MSPR.EQ.11) THEN
C  gam g --> q q
          IC1 = ICB1
          IC3 = ICB2
          IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
        ELSE IF(MSPR.EQ.12) THEN
C  q gam --> q g
          CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,2)
          IF(IP3.EQ.0) THEN
            CALL PHO_SWAPI(IC1,IC3)
            CALL PHO_SWAPI(IC2,IC4)
          ENDIF
        ELSE IF(MSPR.EQ.13) THEN
C  g gam --> q q
          IC1 = ICA1
          IC3 = ICA2
          IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
        ELSE IF(MSPR.EQ.14) THEN
          IF(ABS(IP3).GT.12) THEN
            IC1 = 0
            IC3 = 0
          ELSE
            CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,1)
            IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
          ENDIF
        ELSE
C  unknown process
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,I3)')
     &      'PHO_HARCOL:ERROR:invalid process number',MSPR
          CALL PHO_ABORT
        ENDIF
      ENDIF
C
 100  CONTINUE
C  debug output
      IF (LPRI.GT.4 .AND. IDEB(26).GE.10)
     &WRITE(LO,'(5X,A,3I5,2X,3I5)')
     &    'final partons and colors',IP3,IC1,IC2,IP4,IC3,IC4
C  color connection?
*     IF(((IC1.NE.-IC3).AND.(IC1.NE.-IC4)).AND.
*    &  (((IC2.NE.0).AND.(IC2.NE.-IC3).AND.(IC2.NE.-IC4))
*    &  .OR.(IC2.EQ.0))) THEN
C  color exchange?
*       IF(((IP1.EQ.IP3).AND.(ICA1.EQ.IC1).AND.(ICA2.EQ.IC2))
*    &     .OR.((IP1.EQ.IP4).AND.(ICA1.EQ.IC3).AND.(ICA2.EQ.IC4))) THEN
*         IF(IRC.NE.1) THEN
*           WRITE(LO,'(1X,A,I10,I3)')
*    &        'PHO_HARCOL:unexp. re-connection (event/MSPR):',KEVENT,MSPR
*           WRITE(LO,'(5X,A,3I5,2X,3I5)')
*    &        'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
*           WRITE(LO,'(5X,A,3I5,2X,3I5)')
*    &        'final partons and colors  ',IP3,IC1,IC2,IP4,IC3,IC4
*         ENDIF
*         IRC = 0
*       ENDIF
*     ENDIF
*     IF(IRC.EQ.1) THEN
*           WRITE(LO,'(1X,A,I10,I3)')
*    &        'PHO_HARCOL:re-conn. failed (event/MSPR):',KEVENT,MSPR
*           WRITE(LO,'(5X,A,3I5,2X,3I5)')
*    &        'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
*           WRITE(LO,'(5X,A,3I5,2X,3I5)')
*    &        'final partons and colors  ',IP3,IC1,IC2,IP4,IC3,IC4
*     ENDIF
C
      ICC1 = IC1
      ICC2 = IC2
      ICD1 = IC3
      ICD2 = IC4

      END


 
 


CDECK  ID>, PHO_HARCOR
      SUBROUTINE PHO_HARCOR(ICOLD,ICNEW)
C***********************************************************************
C
C     substituite color in /POEVT2/
C
C     input:    ICOLD   old color
C               ICNEW   new color
C
C***********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)


      DO 100 I=NHEP,3,-1
        IF(ISTHEP(I).EQ.-1) THEN
          IF(ICOLOR(1,I).EQ.ICOLD) THEN
            ICOLOR(1,I) = ICNEW
            RETURN
          ELSE IF(IDHEP(I).EQ.21) THEN
            IF(ICOLOR(2,I).EQ.ICOLD) THEN
              ICOLOR(2,I) = ICNEW
              RETURN
            ENDIF
          ENDIF
*       ELSE IF(ISTHEP(I).EQ.20) THEN
*         IF(ICOLOR(1,I).EQ.-ICOLD) THEN
*           print LO,' PHO_HARCOR(3): line, old, new:',I,ICOLD,ICNEW
*           ICOLOR(1,I) = -ICNEW
*           RETURN
*         ELSE IF(IDHEP(I).EQ.21) THEN
*           IF(ICOLOR(2,I).EQ.-ICOLD) THEN
*             print LO,' PHO_HARCOR(4): line, old, new:',I,ICOLD,ICNEW
*             ICOLOR(2,I) = -ICNEW
*             RETURN
*           ENDIF
*         ENDIF
        ENDIF
 100  CONTINUE
      END


 
 


CDECK  ID>, PHO_HARDIR
      SUBROUTINE PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,
     &                      IREJ)
C**********************************************************************
C
C     parton orientated formulation of direct scattering processes
C
C     input:
C
C     output:   II        particle combination (1..4)
C               IVAL1,2   0 no valence quarks engaged
C                         1 valence quarks engaged
C               MSPAR1,2  number of realized soft partons
C               MHPAR1,2  number of realized hard partons
C               IREJ      1 failure
C                         0 success
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  current beam selection
      INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN
      INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL
      DOUBLE PRECISION SQSGLOBMAX
      PARAMETER (MPARMAX=40)
      PARAMETER (MAXMAPPS=40)
      PARAMETER (IKNOWN=9)
      DIMENSION IPAVAIL(IKNOWN)
      DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/
      COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS),
     &           MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP

C  hard scattering parameters used for most recent hard interaction
      INTEGER NFbeta,NF
      DOUBLE PRECISION ALQCD2,BQCD
      COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF

C  data of c.m. system of Pomeron / Reggeon exchange
      INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
      DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
     &                 SIDP,CODP,SIFP,COFP
      COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
     &                SIDP,CODP,SIFP,COFP,NPOSP(2),
     &                IDPDG1,IDBAM1,IDPDG2,IDBAM2

C  obsolete cut-off information
      DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
      COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN

C  hard cross sections and MC selection weights
      INTEGER Max_pro_2
      PARAMETER ( Max_pro_2 = 16 )
      INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
     &  MH_acc_1,MH_acc_2
      DOUBLE PRECISION HFAC, HWGX, HSIG, HDPT, HECM_LAST, 
     &   HQ2A_LAST, HQ2B_LAST
      COMMON /POHRCS/HFAC(-1:MAX_PRO_2, MPARMAX), 
     &   HWGX(-1:MAX_PRO_2, MPARMAX),
     &   HSIG(-1:MAX_PRO_2, MPARMAX), HDPT(-1:MAX_PRO_2, MPARMAX), 
     &   HECM_LAST, HQ2A_LAST, HQ2B_LAST, IHA_LAST, IHB_LAST, 
     &   MH_PRO_ON(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_TRIED(-1:MAX_PRO_2, 0:4, MPARMAX), 
     &   MH_ACC_1(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_ACC_2(-1:MAX_PRO_2, 0:4, MPARMAX) 

C  data on most recent hard scattering
      INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
      DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
     &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
      COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
     &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
     &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
     &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC

C  light-cone x fractions and c.m. momenta of soft cut string ends
      INTEGER MAXSOF
      PARAMETER ( MAXSOF = 2000 )
      INTEGER IJSI2,IJSI1
      DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
      COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
     &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
     &                IJSI1(MAXSOF),IJSI2(MAXSOF)

C  hard scattering data
      INTEGER MSCAHD
      PARAMETER ( MSCAHD = 1000 )
      INTEGER LSCAHD,LSC1HD,LSIDX,
     &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
      DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
      COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
     &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
     &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
     &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
     &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
     &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
     &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)

C  internal rejection counters
      INTEGER NMXJ
      PARAMETER (NMXJ=60)
      CHARACTER*10 REJTIT
      INTEGER IFAIL
      COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)

      DIMENSION P1(4),P2(4),PD1(-6:6)

      PARAMETER ( TINY   =  1.D-10 )

      ITRY  = 0
      NTRY  = 10
      LSC1HD = 0
      LSIDX(1) = 1

C  check phase space
      IF(ECMP.LT.(2.D0*PTWANT+0.1D0)) THEN
        IFAIL(18) = IFAIL(18)+1
        IREJ = 50
        RETURN
      ENDIF

      AS     = (PARMDL(160+II)/ECMP)**2
      AH     = (2.D0*PTWANT/ECMP)**2

      ALNS   = LOG(AS)
      ALNH   = LOG(AH)

      XMAX   = MAX(TINY,1.D0-AS)
      Z1MAX  = LOG(XMAX)
      Z1DIF  = Z1MAX-ALNH
C
C  main loop to select hard and soft parton kinematics
C -----------------------------------------------------
 120  CONTINUE
        IREJ = 0
        ITRY   = ITRY+1
        LSC1HD = LSC1HD+1
        IF(ITRY.GT.1) THEN
          IFAIL(17) = IFAIL(17)+1
          IF(ITRY.GE.NTRY) THEN
            IREJ = 1
            GOTO 450
          ENDIF
        ENDIF
        LINE   = 0
        LSCAHD = 0
        XSS1   = 0.D0
        XSS2   = 0.D0
        MSPAR1 = 0
        MSPAR2 = 0

C  select hard V,X
        CALL PHO_HARSCA(1,II)
        XSS1   = XSS1+X1
        XSS2   = XSS2+X2
C  debug output
        IF(IDEB(25).GE.20) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,2E12.4,2I5)')
     &      'PHO_HARDIR: AS,XMAX,process ID,ITRY',
     &      AS,XMAX,MSPR,ITRY
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,4E12.4)') 'HARD X1,2  SUM X1,2',
     &      X1,X2,XSS1,XSS2
        ENDIF

      IF(MSPR.LE.11) THEN
        IF((XSS2.GT.XMAX).OR.((1.D0-XSS2).LT.AS)) GOTO 120
      ELSE IF(MSPR.LE.13) THEN
        IF((XSS1.GT.XMAX).OR.((1.D0-XSS1).LT.AS)) GOTO 120
      ENDIF

C  fill /POHSLT/
      LSCAHD     = 1
      LSIDX(1)   = 1
      XHD(1,1)   = X1
      XHD(1,2)   = X2
      X0HD(1,1)  = X1
      X0HD(1,2)  = X2
      VHD(1)     = V
      ETAHD(1,1) = ETAC
      ETAHD(1,2) = ETAD
      PTHD(1)    = PT
      Q2SCA(1,1) = QQPD
      Q2SCA(1,2) = QQPD
      NPROHD(1)  = MSPR
      NBRAHD(1,1)= IDPDG1
      NBRAHD(1,2)= IDPDG2
      DO 45 I=1,4
        PPH(I,1)   = PHI1(I)
        PPH(I,2)   = PHI2(I)
        PPH(4+I,1) = PHO1(I)
        PPH(4+I,2) = PHO2(I)
 45   CONTINUE
C  valence quarks
      IVAL1 = IV1
      IVAL2 = IV2
      PDFVA(1,1) = 0.D0
      PDFVA(1,2) = 0.D0
C  parton flavours
      IF(MSPR.LE.11) THEN
        NINHD(1,1) = IDPDG1
        NINHD(1,2) = IB
        PDFVA(1,2) = PDF2(IB)
        KHDIR = 1
      ELSE IF(MSPR.LE.13) THEN
        NINHD(1,1) = IA
        PDFVA(1,1) = PDF1(IA)
        NINHD(1,2) = IDPDG2
        KHDIR = 2
      ELSE
        NINHD(1,1) = IDPDG1
        NINHD(1,2) = IDPDG2
        KHDIR = 3
      ENDIF
      N0INHD(1,1) = NINHD(1,1)
      N0INHD(1,2) = NINHD(1,2)
      N0IVAL(1,1) = IVAL1
      N0IVAL(1,2) = IVAL2
      NOUTHD(1,1) = IC
      NOUTHD(1,2) = ID

C  reweight according to photon virtuality
      IF(MSPR.NE.14) THEN
        IF(IPAMDL(115).GE.1) THEN
          WGX = 1.D0
          IF(((MSPR.EQ.10).OR.(MSPR.EQ.11)).AND.(IDPDG2.EQ.22)) THEN
            QQPD = Q2SCA(1,2)
            IF(IPAMDL(115).EQ.1) THEN
              IF(QQPD.LT.(PVIRTP(2)+PARMDL(144))) THEN
                WGX = 0.D0
              ELSE
                WGX = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
     &               /LOG(QQPD/PARMDL(144))
              ENDIF
              IF(NINHD(1,2).EQ.0) WGX = WGX*WGX
            ELSE IF(IPAMDL(115).EQ.2) THEN
              CALL PHO_PDF(2,X2,QQPD,PVIRTP(2),PD1)
              WGX = PD1(IB)/PDFVA(1,2)
            ENDIF
          ELSE IF(((MSPR.EQ.12).OR.(MSPR.EQ.13))
     &            .AND.(IDPDG1.EQ.22)) THEN
            QQPD = Q2SCA(1,1)
            IF(IPAMDL(115).EQ.1) THEN
              IF(QQPD.LT.(PVIRTP(1)+PARMDL(144))) THEN
                WGX = 0.D0
              ELSE
                WGX = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
     &               /LOG(QQPD/PARMDL(144))
              ENDIF
              IF(NINHD(1,1).EQ.0) WGX = WGX*WGX
            ELSE IF(IPAMDL(115).EQ.2) THEN
              CALL PHO_PDF(1,X1,QQPD,PVIRTP(1),PD1)
              WGX = PD1(IA)/PDFVA(1,1)
            ENDIF
          ENDIF

          IF(IDEB(25).GE.25 .AND. LPRI.GT.4)
     &      WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
     &        're-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
     &        KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX

          IF(WGX.LT.DT_RNDM(WGX)) THEN
            IREJ = 50
            RETURN
          ENDIF

          IF(WGX.GT.1.01D0 .AND. LPRI.GT.4)
     &      WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
     &        're-weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
     &        KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX

        ENDIF
      ENDIF

C  generate ISR
      IF((MSPR.NE.14).AND.(ISWMDL(8).GE.2)) THEN
        IF(IPAMDL(109).EQ.1) THEN
          Q2H = PARMDL(93)*PT**2
        ELSE
          Q2H = -PARMDL(93)*VHD(1)*XHD(1,1)*XHD(1,2)*ECMP*ECMP
        ENDIF
        XHMAX1 =  1.D0 - XSS1 - AS + XHD(1,1)
        XHMAX2 =  1.D0 - XSS2 - AS + XHD(1,2)
        DO 42 J=1,4
          P1(J) = PPH(4+J,1)
          P2(J) = PPH(4+J,2)
 42     CONTINUE
        CALL PHO_HARISR(-1,P1,P2,NOUTHD(1,1),NOUTHD(1,2),N0INHD(1,1),
     &    N0INHD(1,2),N0IVAL(1,1),N0IVAL(1,2),Q2H,X0HD(1,1),X0HD(1,2),
     &    XHMAX1,XHMAX2,IFL1,IFL2,IVAL1,IVAL2,XISR1,XISR2,IREJ)
        XSS1 = XSS1+XISR1-XHD(1,1)
        XSS2 = XSS2+XISR2-XHD(1,2)
        NINHD(1,1) = IFL1
        NINHD(1,2) = IFL2
        XHD(1,1) = XISR1
        XHD(1,2) = XISR2
      ELSE
        IFL1 = NINHD(1,1)
        IFL2 = NINHD(1,2)
      ENDIF
      NIVAL(1,1) = IVAL1
      NIVAL(1,2) = IVAL2

C  add photon/hadron remnant

C  incoming gluon
      IF(IFL2.EQ.0) THEN
        XMAXX    = 1.D0 - XSS2 - AS
        XMAXH    = MIN(XMAXX,PARMDL(44))
        CALL PHO_HADSP2(IDBAM2,XSS2,XMAXH,XS2,IREJ)
        IVAL2 = 1
        MSPAR1 = 0
        MSPAR2 = 2
        MHPAR1 = 1
        MHPAR2 = 1
      ELSE IF(IFL1.EQ.0) THEN
        XMAXX    = 1.D0 - XSS1 - AS
        XMAXH    = MIN(XMAXX,PARMDL(44))
        CALL PHO_HADSP2(IDBAM1,XSS1,XMAXH,XS1,IREJ)
        IVAL1 = 1
        MSPAR1 = 2
        MSPAR2 = 0
        MHPAR1 = 1
        MHPAR2 = 1

C  incoming quark
      ELSE IF(ABS(IFL2).LE.12) THEN
        IF(IVAL2.EQ.1) THEN
          XS2(1) = 1.D0 - XSS2
          MSPAR1 = 0
          MSPAR2 = 1
          MHPAR1 = 1
          MHPAR2 = 1
        ELSE
          XMAXX    = 1.D0 - XSS2 - AS
          XMAXH    = MIN(XMAXX,PARMDL(44))
          CALL PHO_HADSP3(IDBAM2,XSS2,XMAXH,XS2,IREJ)
          MSPAR1 = 0
          MSPAR2 = 3
          MHPAR1 = 1
          MHPAR2 = 1
        ENDIF
      ELSE IF(ABS(IFL1).LE.12) THEN
        IF(IVAL1.EQ.1) THEN
          XS1(1) = 1.D0 - XSS1
          MSPAR1 = 1
          MSPAR2 = 0
          MHPAR1 = 1
          MHPAR2 = 1
        ELSE
          XMAXX    = 1.D0 - XSS1 - AS
          XMAXH    = MIN(XMAXX,PARMDL(44))
          CALL PHO_HADSP3(IDBAM1,XSS1,XMAXH,XS1,IREJ)
          MSPAR1 = 3
          MSPAR2 = 0
          MHPAR1 = 1
          MHPAR2 = 1
        ENDIF

C  double direct process
      ELSE IF(MSPR.EQ.14) THEN
        MSPAR1 = 0
        MSPAR2 = 0
        MHPAR1 = 1
        MHPAR2 = 1

C  unknown process
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,I3/)')
     &    'PHO_HARDIR:ERROR: unsupported hard process (MSPR)',MSPR
        CALL PHO_ABORT
      ENDIF

      IF(IREJ.NE.0) THEN
        IF (LPRI.GT.4 .AND. IDEB(25).GE.3)
     &  WRITE(LO,'(1X,A,3I5)')
     &    'PHO_HARDIR: int. rejection (MSPR,ITRY,NTRY)',MSPR,ITRY,NTRY
        GOTO 120
      ENDIF

C  soft particle momenta
      IF(MSPAR1.GT.0) THEN
        DO 50 I=1,MSPAR1
          PSOFT1(1,I) = 0.D0
          PSOFT1(2,I) = 0.D0
          PSOFT1(3,I) = XS1(I)*ECMP/2.D0
          PSOFT1(4,I) = XS1(I)*ECMP/2.D0
 50     CONTINUE
      ENDIF
      IF(MSPAR2.GT.0) THEN
        DO 55 I=1,MSPAR2
          PSOFT2(1,I) = 0.D0
          PSOFT2(2,I) = 0.D0
          PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
          PSOFT2(4,I) = XS2(I)*ECMP/2.D0
 55     CONTINUE
      ENDIF
C  process counting
      MH_acc_1(MSPR,II,IDXMPAR) = MH_acc_1(MSPR,II,IDXMPAR)+1
      KSOFT = MAX(MSPAR1,MSPAR2)
      KHARD = MAX(MHPAR1,MHPAR2)
C  debug output
      IF(IDEB(25).GE.10) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,2I3,3I5)')
     &    'PHO_HARDIR: accepted IVAL1,IVAL2,MSPR,ITRY,NTRY',
     &     IVAL1,IVAL2,MSPR,ITRY,NTRY
        IF(MSPAR1.GT.0) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,I4)') 'soft x particle 1:',MSPAR1
          DO 105 I=1,MSPAR1
            IF (LPRI.GT.4)
     &      WRITE(LO,'(10X,I3,E12.3)') I,XS1(I)
 105      CONTINUE
        ENDIF
        IF(MSPAR2.GT.0) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,I4)') 'soft x particle 2:',MSPAR2
          DO 106 I=1,MSPAR2
            IF (LPRI.GT.4)
     &      WRITE(LO,'(10X,I3,E12.3)') I,XS2(I)
 106      CONTINUE
        ENDIF
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavor particle 1:',MHPAR1
        IF (LPRI.GT.4)
     &  WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,1),NINHD(1,1)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,I4)') 'fin.hard momenta  particle 1:',MHPAR1
        IF (LPRI.GT.4)
     &  WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,1),K=5,8),NOUTHD(1,1)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavour particle 2:',MHPAR2
        IF (LPRI.GT.4)
     &  WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,2),NINHD(1,2)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,I4)') 'fin.hard momenta  particle 2:',MHPAR2
        IF (LPRI.GT.4)
     &  WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,2),K=5,8),NOUTHD(1,2)
      ENDIF
      RETURN

 450  CONTINUE
      IFAIL(16) = IFAIL(16)+1
      IF(IDEB(25).GE.2) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,3I5)')
     &    'PHO_HARDIR: rejection (ITRY,NTRY,IREJ)',ITRY,NTRY,IREJ
       IF (LPRI.GT.4)
     & WRITE(LO,'(5X,A,E12.4)') 'available energy:',ECMP
       IF(IDEB(25).GE.5) THEN
         CALL PHO_PREVNT(0)
       ELSE
         CALL PHO_PREVNT(-1)
       ENDIF
      ENDIF

      END


 
 


CDECK  ID>, PHO_HARDX1
      SUBROUTINE PHO_HARDX1
C**********************************************************************
C
C     selection of x1 according to 1/x1
C     ( x2 = 1 )
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  data on most recent hard scattering
      INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
      DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
     &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
      COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
     &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
     &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
     &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC


      Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
      X2   = 1.D0
      X1   = EXP(Z1)
      AXX  = AH/X1
      W    = SQRT(MAX(TINY,1.D0-AXX))
      W1   = AXX/(1.D0+W)

      END


 
 


CDECK  ID>, PHO_HARFAC
      SUBROUTINE PHO_HARFAC(PTCUT,ECMI)
C*********************************************************************
C
C     initialization: find scaling factors and maxima of remaining
C                     weights
C
C     input:   PTCUT  transverse momentum cutoff
C              ECMI   cms energy
C
C     output:  Hfac(-1:Max_pro_2)  field for sampling hard processes
C
C*********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( MXABWT = 96 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  current beam selection
      INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN
      INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL
      DOUBLE PRECISION SQSGLOBMAX
      PARAMETER (MPARMAX=40)
      PARAMETER (MAXMAPPS=40)
      PARAMETER (IKNOWN=9)
      DIMENSION IPAVAIL(IKNOWN)
      DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/
      COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS),
     &           MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP

C  data of c.m. system of Pomeron / Reggeon exchange
      INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
      DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
     &                 SIDP,CODP,SIFP,COFP
      COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
     &                SIDP,CODP,SIFP,COFP,NPOSP(2),
     &                IDPDG1,IDBAM1,IDPDG2,IDBAM2

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

C  hard scattering parameters used for most recent hard interaction
      INTEGER NFbeta,NF
      DOUBLE PRECISION ALQCD2,BQCD
      COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF

C  integration precision for hard cross sections (obsolete)
      INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
      COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO

C  data on most recent hard scattering
      INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
      DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
     &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
      COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
     &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
     &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
     &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC

C  hard cross sections and MC selection weights
      INTEGER Max_pro_2
      PARAMETER ( Max_pro_2 = 16 )
      INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
     &  MH_acc_1,MH_acc_2
      DOUBLE PRECISION HFAC, HWGX, HSIG, HDPT, HECM_LAST, 
     &   HQ2A_LAST, HQ2B_LAST
      COMMON /POHRCS/HFAC(-1:MAX_PRO_2, MPARMAX), 
     &   HWGX(-1:MAX_PRO_2, MPARMAX),
     &   HSIG(-1:MAX_PRO_2, MPARMAX), HDPT(-1:MAX_PRO_2, MPARMAX), 
     &   HECM_LAST, HQ2A_LAST, HQ2B_LAST, IHA_LAST, IHB_LAST, 
     &   MH_PRO_ON(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_TRIED(-1:MAX_PRO_2, 0:4, MPARMAX), 
     &   MH_ACC_1(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_ACC_2(-1:MAX_PRO_2, 0:4, MPARMAX) 

      DIMENSION       ABSZ(MXABWT),WEIG(MXABWT)
      DIMENSION S(-1:Max_pro_2),S1(-1:Max_pro_2),S2(-1:Max_pro_2),
     &          F124(-1:Max_pro_2)
      DATA F124 / 1.D0,0.D0,
     &            4.D0,2.D0,2.D0,2.D0,4.D0,1.D0,4.D0,4.D0,0.D0,1.D0,
     &            2.D0,1.D0,2.D0,1.D0,0.D0,1.D0 /

      SS     = ECMI*ECMI
      AH     = (2.D0*PTCUT/ECMI)**2
      ALN    = LOG(AH)
      HLN    = LOG(0.5D0)
      NPOINT = NGAUIN
      CALL PHO_GAUSET(0.D0,1.D0,NPOINT,ABSZ,WEIG)
      DO 10 M=-1,Max_pro_2
        S1(M) = 0.D0
10    CONTINUE

C  resolved processes
      DO 80 I1=1,NPOINT
        Z1   = ABSZ(I1)
        X1   = EXP(ALN*Z1)
        DO 20 M=-1,9
          S2(M) = 0.D0
20      CONTINUE

        DO 60 I2=1,NPOINT
          Z2    = (1.D0-Z1)*ABSZ(I2)
          X2    = EXP(ALN*Z2)
          FAXX  = AH/(X1*X2)
          W     = SQRT(1.D0-FAXX)
          W1    = FAXX/(1.+W)
          WLOG  = LOG(W1)
          FWW   = FAXX*WLOG/W
          DO 30 M=-1,9
            S(M) = 0.D0
30        CONTINUE

          DO 40 I=1,NPOINT
            Z   = ABSZ(I)
            VA  =-0.5D0*W1/(W1+Z*W)
            UA  =-1.D0-VA
            VB  =-0.5D0*FAXX/(W1+2.D0*W*Z)
            UB  =-1.D0-VB
            VC  =-EXP(HLN+Z*WLOG)
            UC  =-1.D0-VC
            VE  =-0.5D0*(1.D0+W)+Z*W
            UE  =-1.D0-VE
            S(1)  = S(1)+(1.+W)*2.25*(VA*VA*(3.-UA*VA-VA/(UA*UA))-UA)*
     &           WEIG(I)
            S(2)  = S(2)+(VC*VC+UC*UC)*((16./27.)/UC-(4./3.)*VC)*FWW*
     &            WEIG(I)
            S(3)  = S(3)+(1.+W)*(1.+UA*UA)*(1.-(4./9.)*VA*VA/UA)*WEIG(I)
            S(5)  = S(5)+((4./9.)*(1.+UB*UB+(UB*UB+VB*VB)*VB*VB)-
     &            (8./27.)*UA*UA*VA)*WEIG(I)
            S(6)  = S(6)+(4./9.)*(UE*UE+VE*VE)*FAXX*WEIG(I)
            S(7)  = S(7)+(1.+W)*((2./9.)*(1.+UA*UA+(1.+VA*VA)*VA*VA/
     &            (UA*UA))-(4./27.)*VA/UA)*WEIG(I)
            S(8)  = S(8)+(4./9.)*(1.+UB*UB)*WEIG(I)
            S(-1) = S(-1)+(1.+VC*VC)*(VC/(UC*UC)-(4./9.))*FWW*WEIG(I)
40        CONTINUE
          S(4)    = S(2)*(9./32.)
          DO 50 M=-1,8
            S2(M) = S2(M)+S(M)*WEIG(I2)*W
50        CONTINUE
60      CONTINUE
        DO 70 M=-1,8
          S1(M) = S1(M)+S2(M)*(1.D0-Z1)*WEIG(I1)
70      CONTINUE
80    CONTINUE
      S1(4) = S1(4)*NF
      S1(6) = S1(6)*MAX(0,NF-1)
C
C  direct processes
      IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
     &   .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
        DO 180 I1=1,NPOINT
          Z2   = ABSZ(I1)
          X2   = EXP(ALN*Z2)
          FAXX  = AH/X2
          W     = SQRT(1.D0-FAXX)
          W1    = FAXX/(1.D0+W)
          WLOG  = LOG(W1)
          WL = LOG(FAXX/(1.D0+W)**2)
          FWW1  = FAXX*WL/ALN
          FWW2  = FAXX*WLOG/ALN
          DO 130 M=10,12
            S(M) = 0.D0
 130      CONTINUE
C
          DO 140 I=1,NPOINT
            Z   = ABSZ(I)
            UA  =-(1.D0+W)/2.D0*EXP(Z*WL)
            VA  =-1.D0-UA
            VB  =-EXP(HLN+Z*WLOG)
            UB  =-1.D0-VB
            S(10)  = S(10)+(8.D0/3.D0)*(1.D0+UA*UA)*WEIG(I)*FWW1
            S(11) = S(11)-(VB*VB+UB*UB)/UB*WEIG(I)*FWW2
 140      CONTINUE
          DO 170 M=10,11
            S1(M) = S1(M)+S(M)*WEIG(I1)
 170      CONTINUE
 180    CONTINUE
        S1(12) = S1(10)
        S1(13) = S1(11)
C  quark charges fractions
        IF(IDPDG1.EQ.22) THEN
          CHRNF = 0.D0
          DO 100 I=1,NF
            CHRNF = CHRNF + Q_ch2(I)
 100      CONTINUE
          S1(11) = S1(11)*CHRNF
        ELSE IF(IDPDG1.EQ.990) THEN
          S1(11) = S1(11)*NF
        ELSE
          S1(11) = 0.D0
        ENDIF
        IF(IDPDG2.EQ.22) THEN
          CHRNF = 0.D0
          DO 200 I=1,NF
            CHRNF = CHRNF + Q_ch2(I)
 200      CONTINUE
          S1(13) = S1(13)*CHRNF
        ELSE IF(IDPDG2.EQ.990) THEN
          S1(13) = S1(13)*NF
        ELSE
          S1(13) = 0.D0
        ENDIF
      ENDIF
C
C  global factors
      FFF    = PI*GEV2MB*ALN*ALN/(AH*SS)
      DO 90 M=-1,Max_pro_2
        Hfac(M,IDXMPAR) = MAX(FFF*F124(M)*S1(M),0.D0)
90    CONTINUE
C
C  double direct process
      IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
     &   .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
        FAC = 0.D0
        DO 300 I=1,NF
          IF(IDPDG1.EQ.22) THEN
            F1 = Q_ch2(I)
          ELSE
            F1 = 1.D0
          ENDIF
          IF(IDPDG2.EQ.22) THEN
            F2 = Q_ch2(I)
          ELSE
            F2 = 1.D0
          ENDIF
          FAC = FAC+F1*F2*3.D0
 300    CONTINUE
        ZZ = SQRT(1.D0-4.D0*PTCUT*PTCUT/SS)
        Hfac(14,IDXMPAR) = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)
     &               *GEV2MB*FAC
      ENDIF
      END


 
 


CDECK  ID>, PHO_HARINI
      SUBROUTINE PHO_HARINI(IP,IDP1,IDP2,PV1,PV2,NOUT,MODE)
C**********************************************************************
C
C     initialize calculation of hard cross section
C
C     must not be called during MC generation
C
C***********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( DEPS   = 1.D-10 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  currently activated parton density parametrizations
      CHARACTER*8 PDFNAM
      INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
      DOUBLE PRECISION PDFLAM,PDFQ2M
      COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
     &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

C  scale parameters for parton model calculations
      INTEGER NQQAL,NQQALI,NQQALF,NQQPD
      DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
      COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
     &                NQQAL,NQQALI,NQQALF,NQQPD

C  data of c.m. system of Pomeron / Reggeon exchange
      INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
      DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
     &                 SIDP,CODP,SIFP,COFP
      COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
     &                SIDP,CODP,SIFP,COFP,NPOSP(2),
     &                IDPDG1,IDBAM1,IDPDG2,IDBAM2

C  obsolete cut-off information
      DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
      COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN

C  hard scattering parameters used for most recent hard interaction
      INTEGER NFbeta,NF
      DOUBLE PRECISION ALQCD2,BQCD
      COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF

      DOUBLE PRECISION PHO_ALPHAS
      EXTERNAL         PHO_ALPHAS

      CHARACTER*20 RFLAG

C  set local Pomeron c.m. system data
      IDPDG1    = IDP1
      IDPDG2    = IDP2
      PVIRTP(1) = PV1
      PVIRTP(2) = PV2
C  initialize PDFs
      CALL PHO_ACTPDF(IDPDG1,1)
      CALL PHO_ACTPDF(IDPDG2,2)
C  initialize alpha_s calculation
      DUMMY = PHO_ALPHAS(0.D0,-4)
C  initialize scales with defaults
      IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
        IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
          AQQAL  = PARMDL(83)
          AQQALI = PARMDL(86)
          AQQALF = PARMDL(89)
          AQQPD  = PARMDL(92)
          NQQAL  = IPAMDL(83)
          NQQALI = IPAMDL(86)
          NQQALF = IPAMDL(89)
          NQQPD  = IPAMDL(92)
        ELSE
          AQQAL  = PARMDL(82)
          AQQALI = PARMDL(85)
          AQQALF = PARMDL(88)
          AQQPD  = PARMDL(91)
          NQQAL  = IPAMDL(82)
          NQQALI = IPAMDL(85)
          NQQALF = IPAMDL(88)
          NQQPD  = IPAMDL(91)
        ENDIF
      ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
        AQQAL  = PARMDL(82)
        AQQALI = PARMDL(85)
        AQQALF = PARMDL(88)
        AQQPD  = PARMDL(91)
        NQQAL  = IPAMDL(82)
        NQQALI = IPAMDL(85)
        NQQALF = IPAMDL(88)
        NQQPD  = IPAMDL(91)
      ELSE
        AQQAL  = PARMDL(81)
        AQQALI = PARMDL(84)
        AQQALF = PARMDL(87)
        AQQPD  = PARMDL(90)
        NQQAL  = IPAMDL(81)
        NQQALI = IPAMDL(84)
        NQQALF = IPAMDL(87)
        NQQPD  = IPAMDL(90)
      ENDIF
      IF(PARMDL(109+IP).LT.DEPS) PARMDL(109+IP) = AQQAL
      IF(PARMDL(113+IP).LT.DEPS) PARMDL(113+IP) = AQQALI
      IF(PARMDL(117+IP).LT.DEPS) PARMDL(117+IP) = AQQALF
      IF(PARMDL(121+IP).LT.DEPS) PARMDL(121+IP) = AQQPD
      IF(IPAMDL(64+IP).LT.0) IPAMDL(64+IP) = NQQAL
      IF(IPAMDL(68+IP).LT.0) IPAMDL(68+IP) = NQQALI
      IF(IPAMDL(72+IP).LT.0) IPAMDL(72+IP) = NQQALF
      IF(IPAMDL(76+IP).LT.0) IPAMDL(76+IP) = NQQPD
      AQQAL  = PARMDL(109+IP)
      AQQALI = PARMDL(113+IP)
      AQQALF = PARMDL(117+IP)
      AQQPD  = PARMDL(121+IP)
      NQQAL  = IPAMDL(64+IP)
      NQQALI = IPAMDL(68+IP)
      NQQALF = IPAMDL(72+IP)
      NQQPD  = IPAMDL(76+IP)
      PTCUT(1) = PARMDL(36)
      PTCUT(2) = PARMDL(37)
      PTCUT(3) = PARMDL(38)
      PTCUT(4) = PARMDL(39)
      PTANO(1) = PARMDL(130)
      PTANO(2) = PARMDL(131)
      PTANO(3) = PARMDL(132)
      PTANO(4) = PARMDL(133)
      RFLAG = '(energy-independent)'
      IF(IPAMDL(7).GT.0) RFLAG = '(energy-dependent)'

C  write out all settings
      IF((IDEB(66).GE.15).OR.(MODE.GT.0)) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,1050) IP,IDPDG1,IDPDG2,PTCUT(IP),RFLAG,
     &    PDFNAM(1),IGRP(1),ISET(1),IEXT(1),
     &    PDFNAM(2),IGRP(2),ISET(2),IEXT(2),
     &    PDFLAM,NF,NQQAL,AQQAL,NQQPD,AQQPD
1050    FORMAT(/,
     &    ' PHO_HARINI: hard scattering parameters for IP:',I3/,
     &    5X,'particle 1 / particle 2:',2I8,/,
     &    5X,'min. PT   :',F7.1,2X,A,/,
     &    5X,'PDF side 1:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
     &    5X,'PDF side 2:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
     &    5X,'LAMBDA1,2 (4 active flavours):',2F8.3,/,
     &    5X,'max. number of active flavours NF  :',I3,/,
     &    5X,'NQQAL/AQQAL/NQQPD/AQQPD:',I5,F8.3,I5,F8.3)
      ENDIF

      END


 
 


CDECK  ID>, PHO_HARINT
      SUBROUTINE PHO_HARINT(IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM)
C**********************************************************************
C
C     interpolate cross sections and weights for hard scattering
C
C     input:  IPP    particle combination (neg. for add. user cuts)
C             ECM    CMS energy (GeV)
C             P2V1/2 particle virtualities (pos., GeV**2)
C             I1     first subprocess to calculate
C             I2     last subprocess to calculate
C                    <-1  only scales and cutoffs calculated
C             K1     first variable to calculate
C             K2     last variable to calculate
C             MSPOM  cross sections to use for pt distribution
C                    0  reggeon
C                    >0 pomeron
C
C             for K1 < 3 the soft pt distribution is also calculated
C
C     output: interpolated values in HWgx, HSig, Hdpt
C
C***********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( DEPS   = 1.D-15,
     &            DEPS2  = 2.D-15 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  current beam selection
      INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN
      INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL
      DOUBLE PRECISION SQSGLOBMAX
      PARAMETER (MPARMAX=40)
      PARAMETER (MAXMAPPS=40)
      PARAMETER (IKNOWN=9)
      DIMENSION IPAVAIL(IKNOWN)
      DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/
      COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS),
     &           MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP

C  Reggeon phenomenology parameters
      DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
     &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
      COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
     &                ALREG,ALREGP,GR(2),B0REG(2),
     &                GPPP,GPPR,B0PPP,B0PPR,
     &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC

C  parameters of 2x2 channel model
      DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
      COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC

C  data needed for soft-pt calculation
      DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
      COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON

C  scale parameters for parton model calculations
      INTEGER NQQAL,NQQALI,NQQALF,NQQPD
      DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
      COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
     &                NQQAL,NQQALI,NQQALF,NQQPD

C  obsolete cut-off information
      DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
      COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN

C  event weights and generated cross section
      INTEGER IPOWGC,ISWCUT,IVWGHT
      DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
      COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
     &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)

C  parameters for DGLAP backward evolution in ISR
      INTEGER NFSISR
      DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
      COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR

C  hard cross sections and MC selection weights
      INTEGER Max_pro_2
      PARAMETER ( Max_pro_2 = 16 )
      INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
     &  MH_acc_1,MH_acc_2
      DOUBLE PRECISION HFAC, HWGX, HSIG, HDPT, HECM_LAST, 
     &   HQ2A_LAST, HQ2B_LAST
      COMMON /POHRCS/HFAC(-1:MAX_PRO_2, MPARMAX), 
     &   HWGX(-1:MAX_PRO_2, MPARMAX),
     &   HSIG(-1:MAX_PRO_2, MPARMAX), HDPT(-1:MAX_PRO_2, MPARMAX), 
     &   HECM_LAST, HQ2A_LAST, HQ2B_LAST, IHA_LAST, IHB_LAST, 
     &   MH_PRO_ON(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_TRIED(-1:MAX_PRO_2, 0:4, MPARMAX), 
     &   MH_ACC_1(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_ACC_2(-1:MAX_PRO_2, 0:4, MPARMAX) 

C  interpolation tables for hard cross section and MC selection weights
      INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
      PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
      INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
      DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
     &  HQ2a_tab,HQ2b_tab,HEcm_tab
      COMMON /POHTAB/
     &  Hfac_tab(-1:Max_pro_tab,Max_tab_E,
     &           Max_tab_Q2,Max_tab_Q2,0:4,MPARMAX),
     &  HWgx_tab(-1:Max_pro_tab,Max_tab_E,
     &           Max_tab_Q2,Max_tab_Q2,0:4,MPARMAX),
     &  HSig_tab(-1:Max_pro_tab,Max_tab_E,
     &           Max_tab_Q2,Max_tab_Q2,0:4,MPARMAX),
     &  Hdpt_tab(-1:Max_pro_tab,Max_tab_E,
     &           Max_tab_Q2,Max_tab_Q2,0:4,MPARMAX),
     &  HQ2a_tab(1:Max_tab_Q2,0:4,MPARMAX),
     &  HQ2b_tab(1:Max_tab_Q2,0:4,MPARMAX),
     &  HEcm_tab(1:Max_tab_E,0:4,MPARMAX),
     &  IH_Q2a_up(0:4,MPARMAX),IH_Q2b_up(0:4,MPARMAX),
     &  IH_Ecm_up(0:4,MPARMAX)

C  data on most recent hard scattering
      INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
      DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
     &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
      COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
     &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
     &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
     &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC

C  energy-interpolation table
      INTEGER IEETA2
      PARAMETER ( IEETA2 = 20 )
      INTEGER ISIMAX
      DOUBLE PRECISION SIGTAB,SIGECM, ECMF
      COMMON /POTABL/ SIGTAB(80, IEETA2, 4, MPARMAX),
     &                SIGECM(IEETA2, 4, MPARMAX), ECMF(4, MPARMAX),
     &                ISIMAX(MPARMAX)

      DOUBLE PRECISION XP,PTS
      DIMENSION XP(2),PTS(0:2,2)

      INTEGER IV
      DIMENSION IV(2)
      DOUBLE PRECISION PHO_PTCUT
      EXTERNAL         PHO_PTCUT

      IF (LPRI.GT.4 .AND. IDEB(58).GE.25)
     &WRITE(LO,'(1X,2A,/,5X,I2,3E12.3,5I4)')
     &    'PHO_HARINT: called with ',
     &    'IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM',
     &    IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM

      IP = ABS(IPP)
      IF(IPP.GT.0) THEN
C  default minimum bias cutoff
        PTCUT(IP) = PHO_PTCUT(ECM,IP)
      ELSE
C  user defined additional cutoff
        PTCUT(IP) = HSWCUT(4+IP)
      ENDIF
      PTWANT = PTCUT(IP)

C  ISR cutoffs
      Q2CUT     = MIN(PTWANT**2,PARMDL(125+IP))
      Q2MISR(1) = MAX(P2V1,Q2CUT)
      Q2MISR(2) = MAX(P2V2,Q2CUT)
C  cutoff for direct photon contribution to photon PDF
      PTANO(IP) = MIN(PTCUT(IP),PARMDL(129+IP))
      PTA1      = PTANO(IP)
C  scales for hard scattering
      AQQAL  = PARMDL(109+IP)
      AQQALI = PARMDL(113+IP)
      AQQALF = PARMDL(117+IP)
      AQQPD  = PARMDL(121+IP)
      NQQAL  = IPAMDL(64+IP)
      NQQALI = IPAMDL(68+IP)
      NQQALF = IPAMDL(72+IP)
      NQQPD  = IPAMDL(76+IP)
      IF (LPRI.GT.4 .AND. IDEB(58).GE.15)
     &WRITE(LO,'(1X,A,4I3,4E15.7)')
     &  'PHO_HARINT: scales:',
     &  NQQAL,NQQALI,NQQALF,NQQPD,AQQAL,AQQALI,AQQALF,AQQPD

      IF(I2.LT.-1) RETURN

      IL = IP
      IF(IPP.LT.0) IL = 0

C  double-log interpolation
      IF(ECM.LT.2.1D0*PTCUT(IP)) THEN
        DO 50 M=I1,I2
          Hfac(M,IDXMPAR) = 0.D0
          HWgx(M,IDXMPAR) = 0.D0
          HSig(M,IDXMPAR) = 0.D0
          Hdpt(M,IDXMPAR) = 0.D0
 50     CONTINUE
      ELSE
        I=1
 310    CONTINUE
          I = I+1
        IF((ECM.GT.HEcm_tab(I,IL,IDXMPAR)).AND.
     &     (I.LT.IH_Ecm_up(IL,IDXMPAR))) GOTO 310

        Ia = 1
        Ib = 1
        fac = LOG(ECM/HEcm_tab(I-1,IL,IDXMPAR))
     &       /LOG(HEcm_tab(I,IL,IDXMPAR)/HEcm_tab(I-1,IL,IDXMPAR))
        do M=I1,I2
C  factor due to phase space integration
          XX = LOG(Hfac_tab(M,I-1,Ia,Ib,IL,IDXMPAR)+DEPS) + fac
     &      *LOG((Hfac_tab(M,I,Ia,Ib,IL,IDXMPAR)+DEPS)
     &           /(Hfac_tab(M,I-1,Ia,Ib,IL,IDXMPAR)+DEPS))
          XX = EXP(XX)
          IF(XX.LT.DEPS2) XX = 0.D0
          Hfac(M,IDXMPAR) = XX
C  max. weight
          XX = LOG(HWgx_tab(M,I-1,Ia,Ib,IL,IDXMPAR)+DEPS) + fac
     &      *LOG((HWgx_tab(M,I,Ia,Ib,IL,IDXMPAR)+DEPS)
     &           /(HWgx_tab(M,I-1,Ia,Ib,IL,IDXMPAR)+DEPS))
          XX = EXP(XX)
          IF(XX.LT.DEPS2) XX = 0.D0
          HWgx(M,IDXMPAR) = XX*1.2D0
C  hard cross section
          XX = LOG(HSig_tab(M,I-1,Ia,Ib,IL,IDXMPAR)+DEPS) + fac
     &      *LOG((HSig_tab(M,I,Ia,Ib,IL,IDXMPAR)+DEPS)
     &           /(HSig_tab(M,I-1,Ia,Ib,IL,IDXMPAR)+DEPS))
          XX = EXP(XX)
          IF(XX.LT.DEPS2) XX = 0.D0
          HSig(M,IDXMPAR) = XX
C  differential hard cross section
          XX = LOG(Hdpt_tab(M,I-1,Ia,Ib,IL,IDXMPAR)+DEPS) + fac
     &      *LOG((Hdpt_tab(M,I,Ia,Ib,IL,IDXMPAR)+DEPS)
     &           /(Hdpt_tab(M,I-1,Ia,Ib,IL,IDXMPAR)+DEPS))
          XX = EXP(XX)
          IF(XX.LT.DEPS2) XX = 0.D0
          Hdpt(M,IDXMPAR) = XX
        enddo
      ENDIF

      IF((K1.LT.3).AND.(K2.GE.3)) THEN
C  cross check
        IF((I1.GT.9).OR.(I2.LT.9)) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,2A,2I4)') 'PHO_HARINT: ',
     &      'hard cross section not calculated ',I1,I2
        ENDIF
        SIGH   = HSig(9,IDXMPAR)
        DSIGHP = Hdpt(9,IDXMPAR)
C  load soft cross sections from interpolation table
        IF(ECM.LE.SIGECM(1,IP,IDXMPAR)) THEN
          L1 = 1
          L2 = 1
        ELSE IF(ECM.LT.SIGECM(ISIMAX(IDXMPAR),IP,IDXMPAR)) THEN
          DO 55 I=2,ISIMAX(IDXMPAR)
            IF(ECM.LE.SIGECM(I,IP,IDXMPAR)) GOTO 205
 55       CONTINUE
 205      CONTINUE
          L1 = I-1
          L2 = I
        ELSE
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,I3,1P,2E11.3)')
     &      'PHO_HARINT: energy too high (IP,Ecm,Emax)',
     &      IP,ECM,SIGECM(ISIMAX(IDXMPAR),IP,IDXMPAR)
          CALL PHO_PREVNT(-1)
          L1 = ISIMAX(IDXMPAR)-1
          L2 = ISIMAX(IDXMPAR)
        ENDIF
        FAC2=0.D0
        IF(L1.NE.L2) FAC2=LOG(ECM/SIGECM(L1,IP,IDXMPAR))/
     &                    LOG(SIGECM(L2,IP,IDXMPAR)/
     &                    SIGECM(L1,IP,IDXMPAR))
        FAC1=1.D0-FAC2
        SIGS = FAC2*(SIGTAB(56,L2,IP,IDXMPAR)+SIGTAB(57,L2,IP,IDXMPAR))+
     &         FAC1*(SIGTAB(56,L1,IP,IDXMPAR)+SIGTAB(57,L1,IP,IDXMPAR))

        FS = FPS(IP)
        FH = FPH(IP)
        CALL PHO_SOFTPT(-1,PTWANT,PTWANT,XP,IV,PTS)
      ENDIF

C300  CONTINUE

C  debug output
      IF(IDEB(58).GE.15) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I10,3I2,2E10.3)')
     &    'PHO_HARINT: weights EV,IP,K1/2,ECM,PTC',
     &    KEVENT,IP,K1,K2,ECM,PTCUT(IP)
        DO 162 M=I1,I2
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,2I3,1p,4E17.8)')
     &      M,MH_pro_on(M,IP,IDXMPAR),Hfac(M,IDXMPAR),HWgx(M,IDXMPAR),
     &      HSig(M,IDXMPAR),Hdpt(M,IDXMPAR)
 162    CONTINUE
      ENDIF

      END


 
 


CDECK  ID>, PHO_HARISR
      SUBROUTINE PHO_HARISR(IHPOM,P1,P2,IPF1,IPF2,IPA1,IPA2,IV1,IV2,Q2H,
     &  XH1,XH2,XHMAX1,XHMAX2,IPB1,IPB2,IVO1,IVO2,XISR1,XISR2,IREJ)
C********************************************************************
C
C     initial state radiation according to DGLAP evolution equations
C     (backward evolution, no spin effects)
C
C     input:    IHPOM     index of hard Pomeron
C                         negative: delete all previous entries
C               P1,P2     4 momenta of hard scattered final partons
C                         (in CMS of hard scattering)
C               IPF1,2    flavours of final partons
C               IPA1,2    flavours of initial partons
C               IV1,2     valence quark labels (0/1)
C               Q2H       momentum transfer (squared, positive)
C               XH1,XH2   x values of initial partons
C               XHMAX1,2  max. x values allowed
C
C     output:   all emitted partons in /POPISR/, final state
C               partons are the first two entries
C               shower evolution traced in /PODGL1/
C               IPB1,2    flavours of new initial partons
C               XISR1,2   x values of new initial partons
C               IVO1,2    valence quark labels (0/1)
C
C     attention: quark numbering according to PDG convention,
C                but 0 for gluons
C
C********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER (RHOMAS =  0.766D0,
     &           DEPS   =  1.D-10,
     &           TINY   =  1.D-10)

      DIMENSION P1(4),P2(4)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  internal rejection counters
      INTEGER NMXJ
      PARAMETER (NMXJ=60)
      CHARACTER*10 REJTIT
      INTEGER IFAIL
      COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  data of c.m. system of Pomeron / Reggeon exchange
      INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
      DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
     &                 SIDP,CODP,SIFP,COFP
      COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
     &                SIDP,CODP,SIFP,COFP,NPOSP(2),
     &                IDPDG1,IDBAM1,IDPDG2,IDBAM2

C  some hadron information, will be deleted in future versions
      INTEGER NFS
      DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
      COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS

C  currently activated parton density parametrizations
      CHARACTER*8 PDFNAM
      INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
      DOUBLE PRECISION PDFLAM,PDFQ2M
      COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
     &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD

C  scale parameters for parton model calculations
      INTEGER NQQAL,NQQALI,NQQALF,NQQPD
      DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
      COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
     &                NQQAL,NQQALI,NQQALF,NQQPD

C  parameters for DGLAP backward evolution in ISR
      INTEGER NFSISR
      DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
      COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR

C  initial state parton radiation (internal part)
      INTEGER MXISR3,MXISR4
      PARAMETER ( MXISR3 = 50, MXISR4 = 1000 )
      INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
      DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
      COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
     &                ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
     &                IFL1(2,MXISR3),IFL2(2,MXISR3),
     &                IBRA(2,MXISR4),IFANO(2),ISH(2),NACC

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

C  particles created by initial state evolution
      INTEGER MXISR1,MXISR2
      PARAMETER ( MXISR1 = 150, MXISR2 = 1000 )
      INTEGER IFLISR,IPOISR,IMXISR
      DOUBLE PRECISION PHISR
      COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
     &                IPOISR(2,2,MXISR2),IMXISR(2)

      DOUBLE PRECISION PYP,EER,THER,QMAXR
      INTEGER PYK

      DOUBLE PRECISION PHO_PMASS
      EXTERNAL         PHO_PMASS
      DIMENSION XHMA(2),NEXT(2),PD1(-6:6),PD2(-6:6),WGGAP(-6:6),
     &          WGPDF(-6:6),XHMI(2),GB(4),PM(4),PN(4),PC(2,4),Q2(2),
     &          IVAL(2),IPAL(2),IL(2),IFSUM(2),IDMO(2)

      IREJ = 0
      NTRY = 1000
      NITER = 0
C  debug output
      IF(IDEB(79).GE.10) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,/1X,I10,3I3,5E11.3,2(/5X,4E12.3))')
     &    'PHO_HARISR: KEV,IHPOM,IPA1,IPA2,Q2H,XH1,XH2,XHM1,XHM2:',
     &    KEVENT,IHPOM,IPA1,IPA2,Q2H,XH1,XH2,XHMAX1,XHMAX2,P1,P2
      ENDIF
      IF(IHPOM.EQ.0) RETURN
C
 10   CONTINUE
      NACC = 0
      IDMO(1) = IDPDG1
      IDMO(2) = IDPDG2
C
C  copy final state partons to local fields
      IHIDX = ABS(IHPOM)

      IF(IHIDX.GT.MXISR2) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
     &    '/POPISR/ for hard scattering labels (IHIDX,MXISR2):',
     &    IHIDX,MXISR2
        IREJ = 1
      ENDIF

      DO 50 K=1,2
        IF(IHPOM.LT.0) IMXISR(K) = 0
        IPOISR(K,1,IHIDX) = IMXISR(K)+1
        IPAL(K) = IPOISR(K,1,IHIDX)
 50   CONTINUE
      DO 55 I=1,4
        PHISR(1,I,IPAL(1)) = P1(I)
        PHISR(2,I,IPAL(2)) = P2(I)
 55   CONTINUE
      IFLISR(1,IPAL(1)) = IPF1
      IFLISR(2,IPAL(2)) = IPF2
C
C  check limitations, initialize /PODGL1/
      IF((Q2H.GT.Q2MISR(1)).AND.(XH1.LT.XHMAX1)) THEN
        NEXT(1) = 1
        Q2SH(1,1) = Q2H
      ELSE
        NEXT(1) = 0
        Q2SH(1,1) = 0.D0
      ENDIF
      IF((Q2H.GT.Q2MISR(2)).AND.(XH2.LT.XHMAX2)) THEN
        NEXT(2) = 1
        Q2SH(2,1) = Q2H
      ELSE
        NEXT(2) = 0
        Q2SH(2,1) = 0.D0
      ENDIF
C
      ISH(1) = 1
      ISH(2) = 1
      XPSH(1,1) = XH1
      XPSH(2,1) = XH2
C
      IFL1(1,1) = IPA1
      IVAL(1)   = IV1
      IF((IPA1.EQ.22).OR.(IPA1.EQ.990)) NEXT(1) = 0
      IFL1(2,1) = IPA2
      IVAL(2)   = IV2
      IF((IPA2.EQ.22).OR.(IPA2.EQ.990)) NEXT(2) = 0
C
      IF (LPRI.GT.4 .AND. IDEB(79).GE.17)
     &WRITE(LO,'(1X,A,/5X,2I2,3E12.3)')
     &  'PHO_HARISR:INITIAL TESTS (NEXT1,2 Q2H Q21,2)',NEXT,Q2H,Q2MISR
      IF(NEXT(1)+NEXT(2).EQ.0) GOTO 800
C
C  initialize parton shower loop
      B0QCD = (33.D0-2.D0*NFSISR)/6.D0
      AL2ISR(1) = PDFLAM(1)
      AL2ISR(2) = PDFLAM(2)
      XHMA(1) = XHMAX1
      XHMA(2) = XHMAX2
      XHMI(1) = PMISR(1)/PCMP
      XHMI(2) = PMISR(2)/PCMP
      ZPSH(1,1) = 1.D0
      ZPSH(2,1) = 1.D0
      SHAT1 = XH1*XH2*ECMP**2
      IF(IPAMDL(109).EQ.1) THEN
        PT2SH(1,1) = Q2H
      ELSE
        PT2SH(1,1) = Q2H*(1.D0-Q2H/SHAT1)
      ENDIF
      PT2SH(2,1) = PT2SH(1,1)
      IF(PT2SH(1,1).LT.Q2MISR(1)) NEXT(1) = 0
      IF(PT2SH(2,1).LT.Q2MISR(2)) NEXT(2) = 0
      THSH(1,1) = 2.D0*SQRT(Q2H/SHAT1)
      THSH(2,1) = THSH(1,1)
      IFANO(1) = 0
      IFANO(2) = 0
      ZZ = 1.D0
      IF(IREJ.NE.0) GOTO 800
C
C  main generation loop
C -------------------------------------------------
 100  CONTINUE
C  choose parton side to become solved
        IF((NEXT(1)+NEXT(2)).EQ.2) THEN
          IF(Q2SH(1,ISH(1)).GT.Q2SH(2,ISH(2))) THEN
            IP = 1
          ELSE IF(Q2SH(2,ISH(2)).GT.Q2SH(1,ISH(1))) THEN
            IP = 2
          ELSE
            IP = MAX(INT(DT_RNDM(SHAT1)*2.D0+0.999999D0),1)
          ENDIF
        ELSE IF(NEXT(1).EQ.1) THEN
          IP = 1
        ELSE IF(NEXT(2).EQ.1) THEN
          IP = 2
        ELSE
          GOTO 800
        ENDIF
        INDX = ISH(IP)
C  INDX now parton position of parton to become solved
C  IP   now side to be treated
        XP = XPSH(IP,INDX)
        Q2P = Q2SH(IP,INDX)
        PT2 = PT2SH(IP,INDX)
        IFLB = IFL1(IP,INDX)
C  check available x
        XMIP = XHMI(IP)
C  cutoff by x limitation: no further development
        IF((XHMA(IP)-XP).LT.XMIP*2.D0) THEN
          NEXT(IP) = 0
          Q2SH(IP,INDX) = 0.D0
          IF(IDEB(79).GE.17) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,A,/5X,3E12.4,2I3)')
     &        'PHO_HARISR: evolution x-stop (XP,XMIP,XHMA,IP,INDX)',
     &        XP,XMIP,XHMA(IP),IP,INDX
          ENDIF
          GOTO 100
        ENDIF
C  initial value of evolution variable t
        TT = LOG(AQQALI*Q2P/AL2ISR(IP))
        DO 110 I=-NFSISR,NFSISR
          WGGAP(I) = 0.D0
          WGPDF(I) = 0.D0
 110    CONTINUE
C  DGLAP weights
        ZMIN = XP/XHMA(IP)
        ZMAX = XP/(XP+XMIP)
        CF = 4./3.
C  q --> q g, g --> g g
        IF(IFLB.EQ.0) THEN
          WGGAP(0) = CF*((ZMAX**2-ZMIN**2)/2.D0-2.D0*(ZMAX-ZMIN)
     &      +2.D0*LOG(ZMAX/ZMIN))
          DO 120 I=1,NFSISR
            WGGAP(I)  = WGGAP(0)
            WGGAP(-I) = WGGAP(0)
 120      CONTINUE
          WGGAP(0) = 6.D0*((ZMIN**3-ZMAX**3)/3.D0+(ZMAX**2-ZMIN**2)/2.D0
     &      -2.D0*(ZMAX-ZMIN)+LOG(ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)))
C  q --> g q, g --> q qb
        ELSE IF(ABS(IFLB).LE.6) THEN
          WGGAP(IFLB) = CF*((ZMIN**2-ZMAX**2)/2.D0-ZMAX+ZMIN
     &      -2.D0*LOG((1.D0-ZMAX)/(1.D0-ZMIN)))
          IF(IVAL(IP).EQ.0) WGGAP(0) = 0.5D0*(2./3.*(ZMAX**3-ZMIN**3)
     &      -ZMAX**2+ZMIN**2+ZMAX-ZMIN)
        ELSE
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,I7)')
     &      'PHO_HARISR:ERROR: unsupported particle ID',IFLB
          CALL PHO_ABORT
        ENDIF
C  anomalous/resolved evolution
        IPDFC = 0
        IF(IPAMDL(110).GE.1) THEN
          IF((IDMO(IP).EQ.22).AND.(IFLB.NE.0)
     &       .AND.(IFLB.NE.21)) THEN
            WGDIR = 0.D0
            IF(NQQALI.EQ.1) THEN
              SCALE2 = PT2*AQQPD
            ELSE
              SCALE2 = Q2P*AQQPD
            ENDIF
            CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
            IPDFC = 1
            CALL PHO_QPMPDF(IFLB,XP,SCALE2,PTA1,PVIRTP(IP),WGDIR)
            XI = DT_RNDM(XP)*PD1(IFLB)
            IF(WGDIR.GT.XI) THEN
C  debug output
              IF (LPRI.GT.4 .AND. IDEB(79).GE.17)
     &        WRITE(LO,'(1X,2A,/5X,4E12.5,I2,I3)')
     &          'PHO_HARISR: ',
     &          'direct splitting (WGDIR,WGPDF,X,SCALE2,IP,IFLB)',
     &          WGDIR,PD1(IFLB),XP,SCALE2,IP,IFLB
              Q2SH(IP,INDX) = 0.D0
              NEXT(IP) = 0
              IFANO(IP) = INDX
              GOTO 100
            ENDIF
          ENDIF
        ENDIF
C
C  rejection loop for z,t sampling
C ------------------------------------
 200    CONTINUE
          NITER = NITER+1
          IF(NITER.GE.NTRY) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,A,2I6)')
     &        'PHO_HARISR: too many rejections',NITER,NTRY
            CALL PHO_PREVNT(-1)
C  clean up event
            IREJ = 1
            GOTO 10
          ENDIF
C  PDF weights
          IF(IPDFC.EQ.0) THEN
            IF(NQQALI.EQ.1) THEN
              SCALE2 = PT2*AQQPD
            ELSE
              SCALE2 = Q2P*AQQPD
            ENDIF
            CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
          ENDIF
          IPDFC = 0
C
          WGTOT = 0.D0
          DO 210 I=-NFSISR,NFSISR
            WGPDF(I) = PD1(I)/(PD1(IFLB)+1.D-12)*5.D0
            WGTOT = WGTOT+WGPDF(I)*WGGAP(I)
 210      CONTINUE
C
 215      CONTINUE
C  sample new t value
          TT = TT*EXP(MAX(-10.D0,LOG(DT_RNDM(SHAT1))*B0QCD/WGTOT))
          Q2NEW = AL2ISR(IP)*EXP(TT)/AQQALI
C  debug output
          IF (LPRI.GT.4 .AND. IDEB(79).GE.20)
     &    WRITE(LO,'(1X,A,E12.5)')
     &      'PHO_HARISR: pre-selected Q2:',Q2NEW
C  compare to limits
          IF(Q2NEW.LT.Q2MISR(IP)) THEN
            Q2SH(IP,INDX) = 0.D0
            NEXT(IP) = 0
            IF (LPRI.GT.4 .AND. IDEB(79).GE.17)
     &      WRITE(LO,'(1X,A,2E10.3,2I3)')
     &        'PHO_HARISR: evolution Q2-stop (Q2,Q2MIN,IP,INDX):',
     &        Q2NEW,Q2MISR(IP),IP,INDX
            GOTO 100
          ENDIF
          Q2SH(IP,INDX) = Q2NEW
          TT = LOG(AQQALI*Q2NEW/AL2ISR(IP))
C  selection of flavours
          XI = WGTOT*DT_RNDM(TT)
          IFLA = -NFSISR-1
 220      CONTINUE
            IFLA = IFLA+1
            XI = XI-WGPDF(IFLA)*WGGAP(IFLA)
          IF((XI.GT.0.D0).AND.(IFLA.LT.NFSISR)) GOTO 220
C  debug output
          IF (LPRI.GT.4 .AND. IDEB(79).GE.20)
     &    WRITE(LO,'(1X,A,2I3)')
C  selection of z
     &      'PHO_HARISR: pre-selected IFLA (IFLA,IFLB):',IFLA,IFLB
          CALL PHO_HARZSP(IFLA,IFLB,NFSISR,ZMIN,ZMAX,ZZ)
C  debug output
          IF (LPRI.GT.4 .AND. IDEB(79).GE.20)
     &    WRITE(LO,'(1X,A,E12.3)')
     &      'PHO_HARISR: pre-selected ZZ',ZZ
C  angular ordering
          THETA = 4.D0*ZZ**2*Q2NEW/((ECMP*XP)**2*(1.D0-ZZ))
          IF(THETA.GT.THSH(IP,INDX)) THEN
            IF (LPRI.GT.4 .AND. IDEB(79).GE.20)
     &      WRITE(LO,'(1X,A,2E12.3)')
     &        'PHO_HARISR: reject by angle (NEW/OLD)',
     &        THETA,THSH(IP,INDX)
            GOTO 215
          ENDIF
C  rejection weight given by new PDFs
          XNEW = XP/ZZ
          PT2NEW = Q2NEW*(1.D0-ZZ)
          IF(NQQALI.EQ.1) THEN
            SCALE2 = PT2NEW*AQQPD
          ELSE
            SCALE2 = Q2NEW*AQQPD
          ENDIF
          IF(SCALE2.LT.Q2MISR(IP)) THEN
            Q2SH(IP,INDX) = 0.D0
            NEXT(IP) = 0
            IF (LPRI.GT.4 .AND. IDEB(79).GE.17)
     &      WRITE(LO,'(1X,A,2E10.3,2I3)')
     &        'PHO_HARISR: evol.Q2-stop (SCALE2,Q2MIN,IP,INDX):',
     &        Q2NEW,Q2MISR(IP),IP,INDX
            GOTO 100
          ENDIF
          CALL PHO_PDF(IP,XNEW,SCALE2,0.D0,PD2)
          IF(PD2(IFLA).LT.1.D-10) GOTO 200
          CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
          PD1(IFLB) = MAX(PD1(IFLB),1.D-10)
          WGF = PD2(IFLA)/PD1(IFLB)/(WGPDF(IFLA)+1.D-12)
          IF(NQQALI.EQ.1) WGF = WGF*LOG(Q2NEW*AQQALI/AL2ISR(IP))
     &      /LOG(PT2NEW*AQQALI/AL2ISR(IP))
          IF((WGF.GT.1.D0).AND.(IDEB(79).GE.2)) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,A,E12.3)')
     &        'PHO_HARISR: final weight:',WGF
            IF (LPRI.GT.4)
     &      WRITE(LO,'(6X,A,I7,2I3,3E11.3)')
     &      'EV,IFLA,IFLB,Q2,PT2,Z:',KEVENT,IFLA,IFLB,Q2NEW,PT2NEW,ZZ
          ENDIF
        IF(WGF.LT.DT_RNDM(XNEW)) GOTO 200

        IF(IDEB(79).GE.15) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,/3X,3I3,3E11.3)')
     &      'PHO_HARISR: accepted IP,IFLA,IFLB,PT2,Q2,Z:',
     &      IP,IFLA,IFLB,PT2NEW,Q2NEW,ZZ
        ENDIF

        IF(INDX.GE.MXISR3) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
     &      '/POINT6/ for parton radiation (INDX,MXISR3):',INDX,MXISR3
          IREJ = 1
          RETURN
        ENDIF

C  branching accepted, registration
        Q2SH(IP,INDX) = Q2NEW
        PT2SH(IP,INDX) = PT2NEW
        ZPSH(IP,INDX) = ZZ
        IFL2(IP,INDX) = IFLA-IFLB
        Q2SH(IP,INDX+1) = Q2NEW
        PT2SH(IP,INDX+1) = PT2SH(IP,INDX)
        XPSH(IP,INDX+1) = XNEW
        THSH(IP,INDX+1) = THETA
        IFL1(IP,INDX+1) = IFLA
        ISH(IP) = ISH(IP)+1

        NACC = NACC+1

        IF(NACC.GT.MXISR4) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
     &      '/POINT6/ for parton radiation (NACC,MXISR4):',NACC,MXISR4
          IREJ = 1
          RETURN
        ENDIF

        SHAT(NACC) = SHAT1
        IBRA(1,NACC) = IP
        IBRA(2,NACC) = INDX
        SHAT1 = SHAT1/ZZ

C  generation of next branching
      IF(NEXT(1)+NEXT(2).NE.0) GOTO 100

 800  CONTINUE

C  new initial flavours, x values
      IPB1 = IFL1(1,ISH(1))
      IPB2 = IFL1(2,ISH(2))
      XISR1 = XPSH(1,ISH(1))
      XISR2 = XPSH(2,ISH(2))
      IVO1  = IVAL(1)
      IVO2  = IVAL(2)
C  valence flavours
      IF(IPB1.NE.0) THEN
        IF(ISH(1).GT.1) THEN
          CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
          IF(IDPDG1.EQ.22) THEN
            CALL PHO_QPMPDF(IPB1,XISR1,Q2MISR(1),0.D0,PVIRTP(1),FXP)
            IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(IPB1)-FXP) IVAL(1) = 1
          ELSE
            CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
            IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(-IPB1)) IVAL(1) = 1
          ENDIF
        ENDIF
      ENDIF
      IF(IPB2.NE.0) THEN
        IF(ISH(2).GT.1) THEN
          CALL PHO_PDF(2,XISR2,Q2MISR(2),0.D0,PD1)
          IF(IDPDG2.EQ.22) THEN
            CALL PHO_QPMPDF(IPB2,XISR2,Q2MISR(2),0.D0,PVIRTP(2),FXP)
            IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(IPB2)-FXP) IVAL(2) = 1
          ELSE
            IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(-IPB2)) IVAL(2) = 1
          ENDIF
        ENDIF
      ENDIF

C  parton kinematics
      IF(NACC.GT.0) THEN
C  final partons in CMS
        PM(3) = (XH1-XH2)*ECMP/2.D0
        PM(4) = (XH1+XH2)*ECMP/2.D0
        SH = XH1*XH2*ECMP**2
        SSH = SQRT(SH)
        GB(3) = PM(3)/SSH
        GB(4) = PM(4)/SSH
        CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P1(1),P1(2),P1(3),
     &    P1(4),PTOT1,PHISR(1,1,IPAL(1)),PHISR(1,2,IPAL(1)),
     &    PHISR(1,3,IPAL(1)),PHISR(1,4,IPAL(1)))
        CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P2(1),P2(2),P2(3),
     &    P2(4),PTOT1,PHISR(2,1,IPAL(2)),PHISR(2,2,IPAL(2)),
     &    PHISR(2,3,IPAL(2)),PHISR(2,4,IPAL(2)))
        IL(1) = 1
        IL(2) = 1
        DO 900 I=1,NACC
          IPA = IBRA(1,I)
          IPB = 3-IPA
          IL(IPA) = IBRA(2,I)
C  new initial partons in CMS
          SH = SHAT(I)
          SSH = SQRT(SH)
          SHZ = SH/ZPSH(IPA,IL(IPA))
          SSHZ = SQRT(SHZ)
          Q2(1) = Q2SH(1,IL(1))
          Q2(2) = Q2SH(2,IL(2))
          PC(1,1) = 0.D0
          PC(1,2) = 0.D0
          PC(1,3) = SQRT((SH+Q2(1)+Q2(2))**2-4.D0*Q2(1)*Q2(2))
     &             /(2.D0*SSH)
          PC(1,4) = (SH-Q2(1)+Q2(2))/(2.D0*SSH)
          PC(2,1) = 0.D0
          PC(2,2) = 0.D0
          PC(2,3) = -PC(1,3)
          PC(2,4) = SSH-PC(1,4)
          XMS4 = PHO_PMASS(IFL2(IPA,IL(IPA)),1)**2
          EE3 = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
          S1 = SH+Q2(IPA)+Q2(IPB)
          S3 = SHZ+Q2(IPB)+Q2SH(IPA,IL(IPA)+1)
          R1 = SQRT(S1**2-4.D0*Q2(IPA)*Q2(IPB))
          R3 = SQRT(S3**2-4.D0*Q2(IPB)*Q2SH(IPA,IL(IPA)+1))
          IF(Q2(IPB).LT.0.1D0) THEN
            XMS4M = (Q2(IPA)/ZPSH(IPA,IL(IPA))-Q2SH(IPA,IL(IPA)+1))
     &             *(SH/(SH+Q2(IPA))-SH/(SHZ+Q2SH(IPA,IL(IPA)+1)))
          ELSE
            XMS4M = (S1*S3-R1*R3)/(2.D0*Q2(IPB))
     &             -Q2(IPA)-Q2SH(IPA,IL(IPA)+1)
          ENDIF
          NGEN = 1
C  max. virtuality for time-like showers
          QMAX = MIN(XMS4M,PARMDL(95)*Q2(IPA))
          IF((IPAMDL(111).GE.1).AND.(QMAX.GT.PARMDL(94))) THEN
C  generate time-like parton shower
            KF = IFL2(IPA,IL(IPA))
            IF(KF.EQ.0) KF = 21
            EER = MIN(EE3-PC(IPA,4),ECMP)
            THER = 0.

            CALL PY1ENT(1,KF,EER,THER,THER)
            QMAXR = SQRT(QMAX)
            CALL PYSHOW(1,0,QMAXR)
C debug output
            IF(IDEB(79).GE.25) THEN
              IF (LPRI.GT.4)
     &        WRITE(LO,'(1X,2A,/,5X,1P,4E12.4)') 'PHO_HARISR: ',
     &          'PYSHOW called for EE,QMAX,XMS4M,Q2(IPA)',
     &          EER,QMAX,XMS4M,Q2(IPA)
              CALL PYLIST(1)
            ENDIF
            NGEN = PYK(0,1)

            IF(NGEN.GT.1) THEN
              PJX = 0.D0
              PJY = 0.D0
              PJZ = 0.D0
              PJE = 0.D0
              KK = IPAL(IPA)
              DO 820 K=3,NGEN

                IF(PYK(K,1).LE.4) THEN
                  KK = KK+1

                  IF(KK.GT.MXISR1) THEN
                    IF (LPRI.GT.4)
     &              WRITE(LO,'(1X,2A,2I5)') 'PHO_HARISR: no space ',
     &                'left in /POPISR/ (KK,MXISR1):',KK,MXISR1
                    IREJ = 1
                    RETURN
                  ENDIF

                  PHISR(IPA,1,KK) = PYP(K,1)
                  PJX = PJX+PHISR(IPA,1,KK)
                  PHISR(IPA,2,KK) = PYP(K,2)
                  PJY = PJY+PHISR(IPA,2,KK)
                  PHISR(IPA,3,KK) = PYP(K,3)
                  PJZ = PJZ+PHISR(IPA,3,KK)
                  PHISR(IPA,4,KK) = PYP(K,4)
                  PJE = PJE+PHISR(IPA,4,KK)
                  IFLISR(IPA,KK)  = PYK(K,2)

                  IF(IFLISR(IPA,KK).EQ.21) IFLISR(IPA,KK) = 0
                  IF(IFLISR(IPA,KK).EQ.5) IFLISR(IPA,KK) = 3
                  IF(IFLISR(IPA,KK).EQ.-5) IFLISR(IPA,KK) = -3
                ENDIF
 820          CONTINUE
              NGEN = KK-IPAL(IPA)
              XMS4 = (PJE+PJZ)*(PJE-PJZ)-PJX**2-PJY**2
              PP4  = SQRT(PJE**2-XMS4)
              EE3  = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
C debug output
              IF (LPRI.GT.4 .AND. IDEB(79).GE.20)
     &        WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)')
     &         'PHO_HARISR: ',
     &         'time-like shower: PJE,PJX,PJY,PJZ,PP4,XMS4',
     &         PJE,PJX,PJY,PJZ,PP4,XMS4
            ENDIF
          ENDIF
          PZ3 = (2.D0*PC(IPA,4)*EE3+Q2(IPA)+Q2SH(IPA,IL(IPA)+1)+XMS4)
     &          /(2.D0*PC(IPA,3))
          PT3 = (EE3+PZ3)*(EE3-PZ3)+Q2SH(IPA,IL(IPA)+1)
          IF(PT3.LT.0.D0) THEN
            IF (LPRI.GT.4 .AND. IDEB(79).GE.5)
     &      WRITE(LO,'(1X,A,E12.3)')
     &        'PHO_HARISR: rejection due to PT3',PT3
            GOTO 10
          ENDIF
          PT3 = SQRT(PT3)
          CALL PHO_SFECFE(SFE,CFE)
          PX3 = CFE*PT3
          PY3 = SFE*PT3
C
          IF(NGEN.GT.1) THEN
C  time-like shower generated
            EE4 = EE3-PC(IPA,4)
            PZ4 = PZ3-PC(IPA,3)
            PP4 = SQRT(PT3**2+PZ4**2)
C  Lorentz boost
            GAM = (EE4*PJE-PP4*PJZ)/XMS4
            BEG = (PJE*PP4-EE4*PJZ)/XMS4
C  rotation angles
            CODD = PZ4/PP4
            SIDD = SQRT(PX3**2+PY3**2)/PP4
            COFD = 1.D0
            SIFD = 0.D0
            IF(PP4*SIDD.GT.1.D-5) THEN
              COFD = PX3/(SIDD*PP4)
              SIFD = PY3/(SIDD*PP4)
              ANORF = SQRT(COFD*COFD+SIFD*SIFD)
              COFD = COFD/ANORF
              SIFD = SIFD/ANORF
            ENDIF
C  copy partons back
            KK = IPAL(IPA)
            DO 830 K=1,NGEN
              KK = KK+1
              PX = PHISR(IPA,1,KK)
              PY = PHISR(IPA,2,KK)
              PZ = PHISR(IPA,3,KK)
              COH= PHISR(IPA,4,KK)
              EE = GAM*COH+BEG*PZ
              PZ = GAM*PZ +BEG*COH
              PHISR(IPA,4,KK) = EE
              CALL PHO_TRANS(PX,PY,PZ,CODD,SIDD,COFD,SIFD,
     &          PHISR(IPA,1,KK),PHISR(IPA,2,KK),PHISR(IPA,3,KK))
 830        CONTINUE
            IPAL(IPA) = KK
          ELSE
C  no time-like shower generated
            IPAL(IPA) = IPAL(IPA)+1
            PHISR(IPA,1,IPAL(IPA)) = PX3
            PHISR(IPA,2,IPAL(IPA)) = PY3
            PHISR(IPA,3,IPAL(IPA)) = PZ3-PC(IPA,3)
            PHISR(IPA,4,IPAL(IPA)) = EE3-PC(IPA,4)
            IFLISR(IPA,IPAL(IPA))  = IFL2(IPA,IL(IPA))
          ENDIF
          PC(IPA,1) = PX3
          PC(IPA,2) = PY3
          PC(IPA,3) = PZ3
          PC(IPA,4) = EE3
C  boost / rotate into new CMS
          DO 842 K=1,4
            GB(K) = (PC(1,K)+PC(2,K))/SSHZ
 842      CONTINUE
          CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),PC(1,1),PC(1,2),
     &      PC(1,3),PC(1,4),PTOT1,PM(1),PM(2),PM(3),PM(4))
          COG= PM(3)/PTOT1
          SIG= SQRT(PM(1)**2+PM(2)**2)/PTOT1
          COH=1.D0
          SIH=0.D0
          IF(PTOT1*SIG.GT.1.D-5) THEN
            COH=PM(1)/(SIG*PTOT1)
            SIH=PM(2)/(SIG*PTOT1)
            ANORF=SQRT(COH*COH+SIH*SIH)
            COH=COH/ANORF
            SIH=SIH/ANORF
          ENDIF
          DO 845 K=1,2
            DO 844 L=IPOISR(K,1,IHIDX),IPAL(K)
              CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),
     &          PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),
     &          PTOT1,PM(1),PM(2),PM(3),PM(4))
              CALL PHO_TRANI(PM(1),PM(2),PM(3),COG,SIG,COH,SIH,PN(1),
     &          PN(2),PN(3))
              CALL PHO_TRANS(PN(1),PN(2),PN(3),1.D0,0.D0,COH,SIH,
     &          PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L))
              PHISR(K,4,L) = PM(4)
 844        CONTINUE
 845      CONTINUE
 900    CONTINUE
C  boost back to global CMS
        PM(3) = (XISR1-XISR2)/2.D0
        PM(4) = (XISR1+XISR2)/2.D0
        SSH = SQRT(XISR1*XISR2)
        GB(3) = PM(3)/SSH
        GB(4) = PM(4)/SSH
        DO 945 K=1,2
          DO 944 L=IPOISR(K,1,IHIDX),IPAL(K)
            CALL PHO_ALTRA(GB(4),0.D0,0.D0,GB(3),PHISR(K,1,L),
     &        PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),PTOT1,PM(1),
     &        PM(2),PM(3),PM(4))
            PHISR(K,1,L) = PM(1)
            PHISR(K,2,L) = PM(2)
            PHISR(K,3,L) = PM(3)
            PHISR(K,4,L) = PM(4)
 944      CONTINUE
 945    CONTINUE
      ENDIF
      IPOISR(1,2,IHIDX) = IPAL(1)
      IPOISR(2,2,IHIDX) = IPAL(2)
      IMXISR(1) = IPAL(1)
      IMXISR(2) = IPAL(2)
C
C  debug output
      IF(IDEB(79).GE.10) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,2I10/,6X,A,2E12.3,2I5)') 'NUMBER OF EMISSIONS',
     &    ISH(1)-1,ISH(2)-1,'NEW X1,X2,IFL1,ILF2',XISR1,XISR2,IPB1,IPB2
        IF(NACC.GT.0) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,2I5,/6X,A)')
     &    'PHO_HARISR: ISR configuration (NITER,NACC)',NITER,NACC,
     &    ' SIDE   NO.   IFLB IFLC     Q2SH    PT2SH     XH         ZZ'
          DO 600 II=1,NACC
            K = IBRA(1,II)
            I = IBRA(2,II)
            IF (LPRI.GT.4)
     &      WRITE(LO,'(5X,4I5,4E11.3)')
     &        K,I,IFL1(K,I),IFL2(K,I),Q2SH(K,I),PT2SH(K,I),XPSH(K,I),
     &        ZPSH(K,I)
 600      CONTINUE
        ENDIF
C  check of final configuration
        PX3 = 0.D0
        PY3 = 0.D0
        PZ3 = 0.D0
        EE3 = 0.D0
        IFSUM(1) = 0
        IFSUM(2) = 0
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A)') 'PHO_HARISR: outgoing partons'
        DO 745 K=1,2
          DO 744 L=IPOISR(K,1,IHIDX),IPOISR(K,2,IHIDX)
            IF (LPRI.GT.4)
     &      WRITE(LO,'(6X,2I4,I6,4E11.3)') K,L,IFLISR(K,L),
     &        PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L)
            IFSUM(K) = IFSUM(K)+ IFLISR(K,L)
            PX3 = PX3 + PHISR(K,1,L)
            PY3 = PY3 + PHISR(K,2,L)
            PZ3 = PZ3 + PHISR(K,3,L)
            EE3 = EE3 + PHISR(K,4,L)
 744      CONTINUE
 745    CONTINUE
        IFSUM(1) = IFSUM(1)-IPB1
        IFSUM(2) = IFSUM(2)-IPB2
        PZ3 = PZ3 -(XISR1-XISR2)*ECMP/2.D0
        EE3 = EE3 -(XISR1+XISR2)*ECMP/2.D0
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,2I4,4E11.3)') 'CHECK:IFL1,2 PCM(1-4)',
     &    IFSUM,PX3,PY3,PZ3,EE3
      ENDIF
      END


 
 


CDECK  ID>, PHO_HARKIN
      SUBROUTINE PHO_HARKIN(IREJ)
C***********************************************************************
C
C     selection of kinematic variables
C     (resolved and direct processes)
C
C***********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( TINY= 1.D-30, TINYP=1.D-14 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  data of c.m. system of Pomeron / Reggeon exchange
      INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
      DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
     &                 SIDP,CODP,SIFP,COFP
      COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
     &                SIDP,CODP,SIFP,COFP,NPOSP(2),
     &                IDPDG1,IDBAM1,IDPDG2,IDBAM2

C  data on most recent hard scattering
      INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
      DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
     &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
      COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
     &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
     &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
     &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC

C  internal cross check information on hard scattering limits
      DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
      COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)

      PARAMETER ( Max_pro_2 = 16 )
      DIMENSION RM(-1:Max_pro_2)
      DATA RM / 3.31D0, 0.0D0,
     &          7.60D0, 0.65D0, 4.00D0, 0.65D0, 0.89D0,
     &          0.45D0, 0.89D0, 0.89D0, 0.0D0,  4.776D0,
     &          0.615D0,4.776D0,0.615D0,1.0D0,  0.0D0,
     &          1.0D0 /

      IREJ = 0
      M    = MSPR

C------------- resolved processes -----------
      IF     ( M.EQ.1 ) THEN
10      CALL PHO_HARX12
        V  =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
        U  =-1.D0-V
        R  = (1.D0+W)*2.25D0*(V*V*(3.D0-U*V-V/(U*U))-U)
        IF (LPRI.GT.4 .AND. R*W.GT.RM(M))
     &  WRITE(LO,'(1X,A,I3)')
     &    'PHO_HARKIN:weight error',M
        IF ( R*W.LT.RM(1)*DT_RNDM(X2) ) GOTO 10
        IF ( DT_RNDM(V).LE.0.5D0 ) V = U
      ELSEIF ( M.EQ.2 .OR. M.EQ.4 ) THEN
20      CALL PHO_HARX12
        WL = LOG(W1)
        V  =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
        U  =-1.D0-V
        R  = (U*U+V*V)*((16.D0/27.D0)/U-(4.D0/3.D0)*V)*(WL/W)*AXX
        IF (LPRI.GT.4 .AND. R*W.GT.RM(M))
     &  WRITE(LO,'(1X,A,I3)')
     &    'PHO_HARKIN:weight error',M
        IF ( R*W.LT.RM(M)*DT_RNDM(X2) ) GOTO 20
        IF ( DT_RNDM(V).LE.0.5D0 ) V = U
      ELSEIF ( M.EQ.3 ) THEN
30      CALL PHO_HARX12
        V  =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
        U  =-1.D0-V
        R  = (1.D0+W)*(1.D0+U*U)*(1.D0-(4.D0/9.D0)*V*V/U)
        IF (LPRI.GT.4 .AND. R*W.GT.RM(M))
     &  WRITE(LO,'(1X,A,I3)')
     &    'PHO_HARKIN:weight error',M
        IF ( R*W.LT.RM(3)*DT_RNDM(X2) ) GOTO 30
      ELSEIF ( M.EQ.5 ) THEN
50      CALL PHO_HARX12
        V  =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
        U  =-1.D0-V
        R  = (4.D0/9.D0)*(1.D0+U*U+V*V*(U*U+V*V))-(8.D0/27.D0)*U*U*V
        IF (LPRI.GT.4 .AND. R*W.GT.RM(M))
     &  WRITE(LO,'(1X,A,I3)')
     &    'PHO_HARKIN:weight error',M
        IF ( R*W.LT.RM(5)*DT_RNDM(X2) ) GOTO 50
      ELSEIF ( M.EQ.6 ) THEN
60      CALL PHO_HARX12
        V  =-0.5D0*(1.D0+W)+DT_RNDM(X1)*W
        U  =-1.D0-V
        R  = (4.D0/9.D0)*(U*U+V*V)*AXX
        IF (LPRI.GT.4 .AND. R*W.GT.RM(M))
     &  WRITE(LO,'(1X,A,I3)')
     &    'PHO_HARKIN:weight error',M
        IF ( R*W.LT.RM(6)*DT_RNDM(V) ) GOTO 60
      ELSEIF ( M.EQ.7 ) THEN
70      CALL PHO_HARX12
        V  =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
        U  =-1.D0-V
        R  = (1.D0+W)*((2.D0/9.D0)*(1.D0+U*U+(1.D0+V*V)*V*V/(U*U))
     &       -(4.D0/27.D0)*V/U)
        IF (LPRI.GT.4 .AND. R*W.GT.RM(M))
     &  WRITE(LO,'(1X,A,I3)')
     &    'PHO_HARKIN:weight error',M
        IF ( R*W.LT.RM(7)*DT_RNDM(X2) ) GOTO 70
        IF ( DT_RNDM(V).LE.0.5D0 ) V = U
      ELSEIF ( M.EQ.8 ) THEN
80      CALL PHO_HARX12
        V  =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
        U  =-1.D0-V
        R  = (4.D0/9.D0)*(1.D0+U*U)
        IF (LPRI.GT.4 .AND. R*W.GT.RM(M))
     &  WRITE(LO,'(1X,A,I3)')
     &    'PHO_HARKIN:weight error',M
        IF ( R*W.LT.RM(8)*DT_RNDM(X2) ) GOTO 80
      ELSEIF ( M.EQ.-1 ) THEN
90      CALL PHO_HARX12
        WL = LOG(W1)
        V  =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
        U  =-1.D0-V
        R  = (1.D0+V*V)*(V/(U*U)-(4.D0/9.D0))*(WL/W)*AXX
        IF (LPRI.GT.4 .AND. R*W.GT.RM(M))
     &  WRITE(LO,'(1X,A,I3)')
     &    'PHO_HARKIN:weight error',M
        IF ( R*W.LT.RM(-1)*DT_RNDM(X2) ) GOTO 90
C------------- direct / single-resolved processes -----------
      ELSEIF ( M.EQ.10 ) THEN
100     CALL PHO_HARDX1
        WL = LOG(AXX/(1.D0+W)**2)
        U  =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
        R  = -(8.D0/3.D0)*(U*U+1.D0)*WL*AXX
        IF (LPRI.GT.4 .AND. R.GT.RM(M))
     &  WRITE(LO,'(1X,A,I3)')
     &    'PHO_HARKIN:weight error',M
        IF ( R.LT.RM(10)*DT_RNDM(U) ) GOTO 100
        V  =-1.D0-U
        X2 = X1
        X1 = 1.D0
      ELSEIF ( M.EQ.11) THEN
110     CALL PHO_HARDX1
        WL = LOG(W1)
        U  =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
        V  =-1.D0-U
        R  = (U*U+V*V)/V*WL*AXX
        IF (LPRI.GT.4 .AND. R.GT.RM(M))
     &  WRITE(LO,'(1X,A,I3)')
     &    'PHO_HARKIN:weight error',M
        IF ( R.LT.RM(11)*DT_RNDM(X2) ) GOTO 110
        IF ( DT_RNDM(V).LE.0.5D0 ) V = U
        X2 = X1
        X1 = 1.D0
      ELSEIF ( M.EQ.12 ) THEN
120     CALL PHO_HARDX1
        WL = LOG(AXX/(1.D0+W)**2)
        V  =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
        R  = -(8.D0/3.D0)*(V*V+1.D0)*WL*AXX
        IF (LPRI.GT.4 .AND. R.GT.RM(M))
     &  WRITE(LO,'(1X,A,I3)')
     &    'PHO_HARKIN:weight error',M
        IF ( R.LT.RM(12)*DT_RNDM(V) ) GOTO 120
      ELSEIF ( M.EQ.13) THEN
130     CALL PHO_HARDX1
        WL = LOG(W1)
        V  =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
        U  =-1.D0-V
        R  = (U*U+V*V)/U*WL*AXX
        IF (LPRI.GT.4 .AND. R.GT.RM(M))
     &  WRITE(LO,'(1X,A,I3)')
     &    'PHO_HARKIN:weight error',M
        IF ( R.LT.RM(13)*DT_RNDM(X2) ) GOTO 130
        IF ( DT_RNDM(V).LE.0.5D0 ) V = U
C------------- (double) direct process -----------
      ELSEIF ((M.EQ.14).OR.(M.EQ.16)) THEN
        X1 = 1.D0
        X2 = 1.D0
        AXX= AH
        W  = SQRT(MAX(TINY,1.D0-AXX))
        W1 = AXX/(1.D0+W)
        WL = LOG(W1)
 140    V  =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
        U  =-1.D0-V
        R  = -(U*U+V*V)/U
        IF (LPRI.GT.4 .AND. R.GT.RM(M))
     &  WRITE(LO,'(1X,A,I3)')
     &    'PHO_HARKIN:weight error',M
        IF ( R.LT.RM(14)*DT_RNDM(X2) ) GOTO 140
        IF ( DT_RNDM(V).LE.0.5D0 ) V = U
C---------------------------------------------
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,I3)')
     &    'PHO_HARKIN:ERROR:unsupported process (MSPR)',MSPR
        CALL PHO_ABORT
      ENDIF

      V    = MAX(MIN(V,-TINYP ),-1.D0+TINYP)
      U    = -1.D0-V
      U    = MAX(MIN(U,-TINYP ),-1.D0+TINYP)
      PT   = SQRT(U*V*X1*X2)*ECMP
      ETAC = 0.5D0*LOG((U*X1)/(V*X2))
      ETAD = 0.5D0*LOG((V*X1)/(U*X2))

***************************************************************
      MM = M
      IF(M.EQ.-1) MM = 3
      ETAMI(1,MM) = MIN(ETAMI(1,MM),ETAC)
      ETAMA(1,MM) = MAX(ETAMA(1,MM),ETAC)
      ETAMI(2,MM) = MIN(ETAMI(2,MM),ETAD)
      ETAMA(2,MM) = MAX(ETAMA(2,MM),ETAD)
      XXMI(1,MM) = MIN(XXMI(1,MM),X1)
      XXMA(1,MM) = MAX(XXMA(1,MM),X1)
      XXMI(2,MM) = MIN(XXMI(2,MM),X2)
      XXMA(2,MM) = MAX(XXMA(2,MM),X2)
***************************************************************

      IF (LPRI.GT.4 .AND. IDEB(81).GE.25)
     &WRITE(LO,'(1X,A,/5X,6E12.3)')
     &  'PHO_HARKIN: V,PT,ETAC,ETAD,X1,X2',V,PT,ETAC,ETAD,X1,X2

      END


 
 


CDECK  ID>, PHO_HARMCI
      SUBROUTINE PHO_HARMCI(IP,EMAXF)
C**********************************************************************
C
C     initialize MC sampling and calculate hard cross section
C
C     input:  IP       particle combination (neg. number for user cut)
C             EMAXF    maximum CMS energy for
C                      interpolation table in reference to PTCUT(1..4)
C
C***********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER (DEPS   = 1.D-10,
     &           PLARGE = 1.D20 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  current beam selection
      INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN
      INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL
      DOUBLE PRECISION SQSGLOBMAX
      PARAMETER (MPARMAX=40)
      PARAMETER (MAXMAPPS=40)
      PARAMETER (IKNOWN=9)
      DIMENSION IPAVAIL(IKNOWN)
      DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/
      COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS),
     &           MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

C  global event kinematics and particle IDs
      INTEGER IFPAP,IFPAB
      DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
      COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)

C  data of c.m. system of Pomeron / Reggeon exchange
      INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
      DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
     &                 SIDP,CODP,SIFP,COFP
      COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
     &                SIDP,CODP,SIFP,COFP,NPOSP(2),
     &                IDPDG1,IDBAM1,IDPDG2,IDBAM2

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  obsolete cut-off information
      DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
      COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN

C  scale parameters for parton model calculations
      INTEGER NQQAL,NQQALI,NQQALF,NQQPD
      DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
      COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
     &                NQQAL,NQQALI,NQQALF,NQQPD

C  names of hard scattering processes
      INTEGER Max_pro_1
      PARAMETER ( Max_pro_1 = 16 )
      CHARACTER*18 PROC
      COMMON /POHPRO/ PROC(0:Max_pro_1)

C  hard cross sections and MC selection weights
      INTEGER Max_pro_2
      PARAMETER ( Max_pro_2 = 16 )
      INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
     &  MH_acc_1,MH_acc_2
      DOUBLE PRECISION HFAC, HWGX, HSIG, HDPT, HECM_LAST, 
     &   HQ2A_LAST, HQ2B_LAST
      COMMON /POHRCS/HFAC(-1:MAX_PRO_2, MPARMAX), 
     &   HWGX(-1:MAX_PRO_2, MPARMAX),
     &   HSIG(-1:MAX_PRO_2, MPARMAX), HDPT(-1:MAX_PRO_2, MPARMAX), 
     &   HECM_LAST, HQ2A_LAST, HQ2B_LAST, IHA_LAST, IHB_LAST, 
     &   MH_PRO_ON(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_TRIED(-1:MAX_PRO_2, 0:4, MPARMAX), 
     &   MH_ACC_1(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_ACC_2(-1:MAX_PRO_2, 0:4, MPARMAX) 

C  interpolation tables for hard cross section and MC selection weights
      INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
      PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
      INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
      DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
     &  HQ2a_tab,HQ2b_tab,HEcm_tab
      COMMON /POHTAB/
     &  Hfac_tab(-1:Max_pro_tab,Max_tab_E,
     &           Max_tab_Q2,Max_tab_Q2,0:4,MPARMAX),
     &  HWgx_tab(-1:Max_pro_tab,Max_tab_E,
     &           Max_tab_Q2,Max_tab_Q2,0:4,MPARMAX),
     &  HSig_tab(-1:Max_pro_tab,Max_tab_E,
     &           Max_tab_Q2,Max_tab_Q2,0:4,MPARMAX),
     &  Hdpt_tab(-1:Max_pro_tab,Max_tab_E,
     &           Max_tab_Q2,Max_tab_Q2,0:4,MPARMAX),
     &  HQ2a_tab(1:Max_tab_Q2,0:4,MPARMAX),
     &  HQ2b_tab(1:Max_tab_Q2,0:4,MPARMAX),
     &  HEcm_tab(1:Max_tab_E,0:4,MPARMAX),
     &  IH_Q2a_up(0:4,MPARMAX),IH_Q2b_up(0:4,MPARMAX),
     &  IH_Ecm_up(0:4,MPARMAX)

C  event weights and generated cross section
      INTEGER IPOWGC,ISWCUT,IVWGHT
      DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
      COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
     &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)

      COMPLEX*16 DSIG
      DIMENSION DSIG(0:Max_pro_2),DSPT(0:Max_pro_2)

C  initialization for all pt cutoffs
      I = ABS(IP)
      IL = I
      IF(IP.LT.0) THEN
        IL = 0
        PTC = HSWCUT(4+I)
      else
        PTC = PHO_PTCUT(parmdl(19),I)
      ENDIF

C  skip unassigned PTCUT
      IF(PTC.LT.0.5D0) GOTO 1000

      IH_Q2a_up(I,IDXMPAR) = 1
      IH_Q2b_up(I,IDXMPAR) = 1
      do ib=1,Max_tab_Q2
        do ia=1,Max_tab_Q2
          do ie=1,Max_tab_E
            do m=-1,Max_pro_2
              Hfac_tab(M,Ie,Ia,Ib,I,IDXMPAR) = 0.D0
              HWgx_tab(M,Ie,Ia,Ib,I,IDXMPAR) = 0.D0
              HSig_tab(M,Ie,Ia,Ib,I,IDXMPAR) = 0.D0
              Hdpt_tab(M,Ie,Ia,Ib,I,IDXMPAR) = 0.D0
            enddo
          enddo
        enddo
      enddo

      ELLOW = LOG(2.05*PTC)
      DELTA = (LOG(EMAXF)-ELLOW)/DBLE(IH_Ecm_up(I,IDXMPAR)-1)
C  energy too low
      IF(DELTA.LE.0.D0) GOTO 1000

C  switch between external particles and Pomeron
      IF(I.EQ.4) THEN
        IDP1 = 990
        PV1  = 0.D0
        IDP2 = 990
        PV2  = 0.D0
      ELSE IF(I.EQ.3) THEN
        IDP1 = IFPAP(2)
        PV1  = PVIRT(2)
        IDP2 = 990
        PV2  = 0.D0
      ELSE IF(I.EQ.2) THEN
        IDP1 = IFPAP(1)
        PV1  = PVIRT(1)
        IDP2 = 990
        PV2  = 0.D0
      ELSE
        IDP1 = IFPAP(1)
        PV1  = PVIRT(1)
        IDP2 = IFPAP(2)
        PV2  = PVIRT(2)
      ENDIF

C  initialize PT scales
      IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
        IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
          FPS(I) = PARMDL(105)
          FPH(I) = PARMDL(106)
        ELSE
          FPS(I) = PARMDL(103)
          FPH(I) = PARMDL(104)
        ENDIF
      ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
        FPS(I) = PARMDL(103)
        FPH(I) = PARMDL(104)
      ELSE
        FPS(I) = PARMDL(101)
        FPH(I) = PARMDL(102)
      ENDIF

C  initialize hard scattering
      IF(IP.GT.0) THEN
        CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8)+1)
      ELSE
        CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8))
      ENDIF

C  energy/virtuality grid
      do Ie=1,IH_Ecm_up(IL,IDXMPAR)
        HEcm_tab(Ie,IL,IDXMPAR) = EXP(ELLOW+DELTA*(IE-1))
      enddo
      do Ia=1,IH_Q2a_up(IL,IDXMPAR)
        HQ2a_tab(Ia,IL,IDXMPAR) = 0.D0
      enddo
      do Ib=1,IH_Q2b_up(IL,IDXMPAR)
        HQ2b_tab(Ib,IL,IDXMPAR) = 0.D0
      enddo

C  initialization for several energies and particle virtualities
      do Ie=1,IH_Ecm_up(IL,IDXMPAR)
        do Ia=1,IH_Q2a_up(IL,IDXMPAR)
          do Ib=1,IH_Q2b_up(IL,IDXMPAR)

            EE = HEcm_tab(IE,IL,IDXMPAR)
            Q2a = HQ2a_tab(Ia,IL,IDXMPAR)
            Q2b = HQ2b_tab(Ib,IL,IDXMPAR)
            CALL PHO_HARINT(IP,EE,0.D0,0.D0,0,-2,0,0,1)
            IF (LPRI.GT.4 .AND. IDEB(8).GE.5)
     &      WRITE(LO,'(1X,A,2E10.3,2I7)')
     &        'PHO_HARMCI: initialization PT,ECM,ID1,ID2:',
     &        PTCUT(I),EE,IDPDG1,IDPDG2
            Hfac_tab(0,Ie,Ia,Ib,IL,IDXMPAR) = PTCUT(I)
            
            CALL PHO_HARFAC(PTCUT(I),EE)
            CALL PHO_HARWGX(PTCUT(I),EE)
C            Write(6,*) 'benchmark Harxto:'
C            CALL CPU_TIME(start)
            CALL PHO_HARXTO(EE,PTCUT(I),PTCUT(I),DSIG,DSPT)
C            CALL CPU_TIME(finish)
C            print '("Time = ",f6.3," seconds.")',finish-start
            
            IF(IDEB(8).GE.10) THEN
              IF (LPRI.GT.4)
     &        WRITE(LO,'(1X,A,/,1X,A)')
     &          'hard cross sections SIGH(mb),DSIG/DPT(mb/GeV**2)',
     &          '------------------------------------------------'
              DO M=0,Max_pro_2
                IF (LPRI.GT.4)
     &          WRITE(LO,'(10X,A,1P2E17.9)')
     &            PROC(M),DREAL(DSIG(M)),DSPT(M)
              ENDDO
            ENDIF

C  store in interpolation tables
            Hfac_tab(-1,IE,Ia,Ib,IL,IDXMPAR) = Hfac(-1,IDXMPAR)
            HWgx_tab(-1,IE,Ia,Ib,IL,IDXMPAR) = HWgx(-1,IDXMPAR)
            do M=0,Max_pro_2
              Hfac_tab(M,IE,Ia,Ib,IL,IDXMPAR) = Hfac(M,IDXMPAR)
              HWgx_tab(M,IE,Ia,Ib,IL,IDXMPAR) = HWgx(M,IDXMPAR)
              HSig_tab(M,IE,Ia,Ib,IL,IDXMPAR) = DREAL(DSIG(M))*
     &                                          MH_pro_on(M,I,IDXMPAR)
              Hdpt_tab(M,IE,Ia,Ib,IL,IDXMPAR) = DSPT(M)*
     &                                          MH_pro_on(M,I,IDXMPAR)
            enddo

C  summed quantities
            HSig_tab(9,IE,Ia,Ib,IL,IDXMPAR) = 0.D0
            Hdpt_tab(9,IE,Ia,Ib,IL,IDXMPAR) = 0.D0
            do M=1,8
              IF(MH_pro_on(M,I,IDXMPAR).GT.0) THEN
                HSig_tab(9,IE,Ia,Ib,IL,IDXMPAR) =
     &            HSig_tab(9,IE,Ia,Ib,IL,IDXMPAR) + 
     &            HSig_tab(M,IE,Ia,Ib,IL,IDXMPAR)
                Hdpt_tab(9,IE,Ia,Ib,IL,IDXMPAR) =
     &            Hdpt_tab(9,IE,Ia,Ib,IL,IDXMPAR) + 
     &            Hdpt_tab(M,IE,Ia,Ib,IL,IDXMPAR)
              ENDIF
            enddo
            HSig_tab(15,IE,Ia,Ib,IL,IDXMPAR) = 0.D0
            Hdpt_tab(15,IE,Ia,Ib,IL,IDXMPAR) = 0.D0
            do M=10,14
              IF(MH_pro_on(M,I,IDXMPAR).GT.0) THEN
                HSig_tab(15,IE,Ia,Ib,IL,IDXMPAR) =
     &            HSig_tab(15,IE,Ia,Ib,IL,IDXMPAR) + 
     &            HSig_tab(M,IE,Ia,Ib,IL,IDXMPAR)
                Hdpt_tab(15,IE,Ia,Ib,IL,IDXMPAR) =
     &            Hdpt_tab(15,IE,Ia,Ib,IL,IDXMPAR) + 
     &            Hdpt_tab(M,IE,Ia,Ib,IL,IDXMPAR)
              ENDIF
            enddo
            HSig_tab(0,IE,Ia,Ib,IL,IDXMPAR) =
     &        HSig_tab(9,IE,Ia,Ib,IL,IDXMPAR) + 
     &        HSig_tab(15,IE,Ia,Ib,IL,IDXMPAR)
            Hdpt_tab(0,IE,Ia,Ib,IL,IDXMPAR) =
     &        Hdpt_tab(9,IE,Ia,Ib,IL,IDXMPAR) + 
     &        Hdpt_tab(15,IE,Ia,Ib,IL,IDXMPAR)

          enddo
        enddo
      enddo

C  debug output of weights
 1000 CONTINUE
      IF(IDEB(8).GE.5) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,5X,2I7,I3,F7.2,/1X,A)')
     &    'PHO_HARMCI: weights, maxima (ID1/2,IP,PTC)',
     &    IDPDG1,IDPDG2,IP,PTCUT(I),
     &    '------------------------------------------'
        DO M=-1,Max_pro_2
          IF((M.EQ.0).OR.(M.EQ.9).OR.(M.EQ.15)) GOTO 512
          IF (LPRI.GT.4)
     &    WRITE(LO,'(2X,A,I3,2I7)')
     &      'PHO_HARMCI: ECM Hfac, HWgx, HSig, Hdpt for MSTR,ID1,ID2',
     &      M,IDPDG1,IDPDG2
          do k=1,IH_Ecm_up(IL,IDXMPAR)
            do ia=1,IH_Q2a_up(IL,IDXMPAR)
              do ib=1,IH_Q2b_up(IL,IDXMPAR)
                IF (LPRI.GT.4)
     &          WRITE(LO,'(3X,1p,7E10.3)') HEcm_tab(k,IL,IDXMPAR),
     &            HQ2a_tab(ia,IL,IDXMPAR),HQ2b_tab(ib,IL,IDXMPAR),
     &            Hfac_tab(M,k,ia,ib,IL,IDXMPAR),
     &            HWgx_tab(M,k,ia,ib,IL,IDXMPAR),
     &            HSig_tab(M,k,ia,ib,IL,IDXMPAR),
     &            Hdpt_tab(M,k,ia,ib,IL,IDXMPAR)
              enddo
            enddo
          enddo
 512      CONTINUE
        ENDDO
      ENDIF

      END


 
 


CDECK  ID>, PHO_HARREM
      SUBROUTINE PHO_HARREM(JM1,JM2,IGEN,IHPOS,IVAL,INDXS,IC1,IC2,
     &                      IUSED,IREJ)
C***********************************************************************
C
C     sample color structure for initial quark/gluon of hard scattering
C     and write hadron remnant to /POEVT1/
C
C     input:    JM1,2   index of mother particle in POEVT1
C               IGEN    mother particle production process
C               IHPOS   hard pomeron number
C               INDXH   index of hard parton
C                       positive for labels 1
C                       negative for labels 2
C               IVAL     1  hard valence parton
C                        0  hard sea parton connected by color flow with
C                           valence quarks
C                       -1  hard sea parton independent off valence
C                           quarks
C               INDXS   index of soft partons needed
C
C     output:   IC1,IC2 color label of initial parton
C               IUSED   number of soft X values used
C               IREJ    rejection flag
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( TINY   =  1.D-10 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  data of c.m. system of Pomeron / Reggeon exchange
      INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
      DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
     &                 SIDP,CODP,SIFP,COFP
      COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
     &                SIDP,CODP,SIFP,COFP,NPOSP(2),
     &                IDPDG1,IDBAM1,IDPDG2,IDBAM2

C  obsolete cut-off information
      DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
      COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN

C  light-cone x fractions and c.m. momenta of soft cut string ends
      INTEGER MAXSOF
      PARAMETER ( MAXSOF = 2000 )
      INTEGER IJSI2,IJSI1
      DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
      COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
     &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
     &                IJSI1(MAXSOF),IJSI2(MAXSOF)

C  hard scattering data
      INTEGER MSCAHD
      PARAMETER ( MSCAHD = 1000 )
      INTEGER LSCAHD,LSC1HD,LSIDX,
     &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
      DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
      COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
     &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
     &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
     &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
     &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
     &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
     &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

C  internal rejection counters
      INTEGER NMXJ
      PARAMETER (NMXJ=60)
      CHARACTER*10 REJTIT
      INTEGER IFAIL
      COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)


      IREJ = 0

      INDXH = SIGN(LSIDX(ABS(IHPOS)),IHPOS)

      IF(INDXH.GT.0) THEN
        IJH = IPHO_CNV1(NINHD(INDXH,1))
      ELSE
        IJH = IPHO_CNV1(NINHD(-INDXH,2))
      ENDIF
C  direct process (photon or pomeron)
      IUSED = 0
      IC1   = 0
      IC2   = 0
      IF((IJH.EQ.22).OR.(IJH.EQ.990)) RETURN

      IHP = 100*ABS(IHPOS)
      IVSW = 1
***************************************
*     IF((IDHEP(JM1).EQ.22).OR.(IDHEP(JM1).EQ.990)) IVSW = 0
***************************************

      IF (LPRI.GT.4 .AND. IDEB(28).GE.20)
     &WRITE(LO,'(1X,A,2I3,1X,5I4)')
     &  'PHO_HARREM: JM1,JM2,IHPOS,INDXH,IFLH,IVAL,INDXS:',
     &  JM1,JM2,IHPOS,INDXH,IJH,IVAL,INDXS

C  quark
C****************************************************************

        IF(IJH.NE.21) THEN

C  valence quark engaged in hard scattering
          IF(IVAL.EQ.1) THEN
            CALL PHO_PARREM(JM1,IJH,IREM,IREJ)
            IF(IREJ.NE.0) THEN
              IF (LPRI.GT.4)
     &        WRITE(LO,'(/1X,2A,2I6)') 'PHO_HARREM: ',
     &          'invalid valence flavour requested JM,IFLA',JM1,IJH
              return
            ENDIF
            CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
            IF(((ABS(IREM).GT.6).AND.(IREM.GT.0))
     &         .OR.((ABS(IREM).LE.6).AND.(IREM.LT.0))) THEN
              I = ICA1
              ICA1 = ICB1
              ICB1 = I
            ENDIF
C  remnant of hadron
            IF(INDXH.GT.0) THEN
              P1 = PSOFT1(1,INDXS)
              P2 = PSOFT1(2,INDXS)
              P3 = PSOFT1(3,INDXS)
              P4 = PSOFT1(4,INDXS)
              IJSI1(INDXS) = IREM
            ELSE
              P1 = PSOFT2(1,INDXS)
              P2 = PSOFT2(2,INDXS)
              P3 = PSOFT2(3,INDXS)
              P4 = PSOFT2(4,INDXS)
              IJSI2(INDXS) = IREM
            ENDIF
C  registration
            CALL PHO_REGPAR(-1,IREM,0,JM1,JM2,P1,P2,P3,P4,
     &                      IHP,IGEN,ICA1,IVSW,IPOS,1)
            IF (LPRI.GT.4 .AND. IDEB(28).GE.20)
     &      WRITE(LO,'(1X,A,3I5)')
     &        'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
     &        IREM,IPOS,SIGN(INDXS,INDXH)

            IUSED = 1

C  sea quark engaged in hard scattering, valence quarks treated
          ELSE IF(IVAL.EQ.0) THEN
            IF(INDXH.GT.0) THEN
              E1 = PSOFT1(4,INDXS)
              E2 = PSOFT1(4,INDXS+1)
            ELSE
              E1 = PSOFT2(4,INDXS)
              E2 = PSOFT2(4,INDXS+1)
            ENDIF
            CALL PHO_VALFLA(JM1,IVFL1,IVFL2,E1,E2)
            CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
            IF(DT_RNDM(P1).LT.0.5D0) THEN
              CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
            ELSE
              CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
            ENDIF
            IF(((ABS(IVFL1).GT.6).AND.(IVFL1.GT.0))
     &         .OR.((ABS(IVFL1).LE.6).AND.(IVFL1.LT.0))) THEN
              I = ICA1
              ICA1 = ICB1
              ICB1 = I
            ENDIF
            IF(INDXH.GT.0) THEN
              P1 = PSOFT1(1,INDXS)
              P2 = PSOFT1(2,INDXS)
              P3 = PSOFT1(3,INDXS)
              P4 = PSOFT1(4,INDXS)
              IJSI1(INDXS) = IVFL1
            ELSE
              P1 = PSOFT2(1,INDXS)
              P2 = PSOFT2(2,INDXS)
              P3 = PSOFT2(3,INDXS)
              P4 = PSOFT2(4,INDXS)
              IJSI2(INDXS) = IVFL1
            ENDIF
C  registration
            CALL PHO_REGPAR(-1,IVFL1,0,JM1,JM2,P1,P2,P3,P4,
     &                      IHP,IGEN,ICA1,IVSW,IPOS,1)
            IF (LPRI.GT.4 .AND. IDEB(28).GE.20)
     &      WRITE(LO,'(1X,A,3I5)')
     &        'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
     &        IVFL1,IPOS,SIGN(INDXS,INDXH)

C
            IF(INDXH.GT.0) THEN
              P1 = PSOFT1(1,INDXS+1)
              P2 = PSOFT1(2,INDXS+1)
              P3 = PSOFT1(3,INDXS+1)
              P4 = PSOFT1(4,INDXS+1)
              IJSI1(INDXS+1) = IVFL2
            ELSE
              P1 = PSOFT2(1,INDXS+1)
              P2 = PSOFT2(2,INDXS+1)
              P3 = PSOFT2(3,INDXS+1)
              P4 = PSOFT2(4,INDXS+1)
              IJSI2(INDXS+1) = IVFL2
            ENDIF
C  registration
            CALL PHO_REGPAR(-1,IVFL2,0,JM1,JM2,P1,P2,P3,P4,
     &                  IHP,IGEN,ICB1,IVSW,IPOS,1)
            IF (LPRI.GT.4 .AND. IDEB(28).GE.20)
     &      WRITE(LO,'(1X,A,3I5)')
     &        'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
     &        IVFL2,IPOS,SIGN(INDXS+1,INDXH)

C
            IF(IJH.LT.0) THEN
              ICB1 = ICC2
              ICA1 = ICC1
            ELSE
              ICB1 = ICC1
              ICA1 = ICC2
            ENDIF
            IF(INDXH.GT.0) THEN
              P1 = PSOFT1(1,INDXS+2)
              P2 = PSOFT1(2,INDXS+2)
              P3 = PSOFT1(3,INDXS+2)
              P4 = PSOFT1(4,INDXS+2)
              IJSI1(INDXS+2) = -IJH
            ELSE
              P1 = PSOFT2(1,INDXS+2)
              P2 = PSOFT2(2,INDXS+2)
              P3 = PSOFT2(3,INDXS+2)
              P4 = PSOFT2(4,INDXS+2)
              IJSI2(INDXS+2) = -IJH
            ENDIF
C  registration
            CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
     &                      IHP,IGEN,ICA1,0,IPOS,1)
            IF (LPRI.GT.4 .AND. IDEB(28).GE.20)
     &      WRITE(LO,'(1X,A,3I5)')
     &        'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
     &        -IJH,IPOS,SIGN(INDXS+2,INDXH)
            IUSED = 3
C
C  sea quark engaged in hard scattering, valences treated separately
          ELSE IF(IVAL.EQ.-1) THEN
            CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
            IF(IJH.GT.0) THEN
              ICC1 = ICB1
              ICB1 = ICA1
              ICA1 = ICC1
            ENDIF
            IF(INDXH.GT.0) THEN
              P1 = PSOFT1(1,INDXS)
              P2 = PSOFT1(2,INDXS)
              P3 = PSOFT1(3,INDXS)
              P4 = PSOFT1(4,INDXS)
              IJSI1(INDXS) = -IJH
            ELSE
              P1 = PSOFT2(1,INDXS)
              P2 = PSOFT2(2,INDXS)
              P3 = PSOFT2(3,INDXS)
              P4 = PSOFT2(4,INDXS)
              IJSI2(INDXS) = -IJH
            ENDIF
C  registration
            CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
     &                      IHP,IGEN,ICA1,0,IPOS,1)
            IF (LPRI.GT.4 .AND. IDEB(28).GE.20)
     &      WRITE(LO,'(1X,A,3I5)')
     &        'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
     &        -IJH,IPOS,SIGN(INDXS,INDXH)

            IUSED = 1
          ELSE
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,A,2I5)')
     &        'PHO_HARREM:ERROR:unsupported combination of IVAL,IJH',
     &        IVAL,IJH
            CALL PHO_ABORT
          ENDIF
C
          IC1 = ICB1
          IC2 = 0
C
C  gluon
C****************************************************************
C
C  gluon from valence quarks
        ELSE
          IF(IVAL.EQ.1) THEN
C  purely gluonic pomeron remnant
            IF((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0)) THEN
              IF(INDXH.GT.0) THEN
                P1 = PSOFT1(1,INDXS) + PSOFT1(1,INDXS+1)
                P2 = PSOFT1(2,INDXS) + PSOFT1(2,INDXS+1)
                P3 = PSOFT1(3,INDXS) + PSOFT1(3,INDXS+1)
                P4 = PSOFT1(4,INDXS) + PSOFT1(4,INDXS+1)
                IJSI1(INDXS) = 0
              ELSE
                P1 = PSOFT2(1,INDXS) + PSOFT2(1,INDXS+1)
                P2 = PSOFT2(2,INDXS) + PSOFT2(2,INDXS+1)
                P3 = PSOFT2(3,INDXS) + PSOFT2(3,INDXS+1)
                P4 = PSOFT2(4,INDXS) + PSOFT2(4,INDXS+1)
                IJSI2(INDXS) = 0
              ENDIF
              IFL1 = 21
              CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
              IF(DT_RNDM(P2).LT.0.5D0) THEN
                CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
              ELSE
                CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
              ENDIF
C  registration
              CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
     &                        IHP,IGEN,ICA1,ICB1,IPOS,1)
              IF (LPRI.GT.4 .AND. IDEB(28).GE.20)
     &        WRITE(LO,'(1X,A,3I5)')
     &          'PHO_HARREM: val.gluon:(IFL,IPOS,INDXS)',

     &          IFL1,IPOS,SIGN(INDXS,INDXH)
              IUSED = 2
C  valence quark remnant
            ELSE
              IF(INDXH.GT.0) THEN
                E1 = PSOFT1(4,INDXS)
                E2 = PSOFT1(4,INDXS+1)
              ELSE
                E1 = PSOFT2(4,INDXS)
                E2 = PSOFT2(4,INDXS+1)
              ENDIF
              CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
              CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
              IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
     &           .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
                I = ICA1
                ICA1 = ICB1
                ICB1 = I
              ENDIF
              IF(DT_RNDM(P2).LT.0.5D0) THEN
                CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
              ELSE
                CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
              ENDIF
C  remnant of hadron
              IF(INDXH.GT.0) THEN
                P1 = PSOFT1(1,INDXS)
                P2 = PSOFT1(2,INDXS)
                P3 = PSOFT1(3,INDXS)
                P4 = PSOFT1(4,INDXS)
                IJSI1(INDXS) = IFL1
              ELSE
                P1 = PSOFT2(1,INDXS)
                P2 = PSOFT2(2,INDXS)
                P3 = PSOFT2(3,INDXS)
                P4 = PSOFT2(4,INDXS)
                IJSI2(INDXS) = IFL1
              ENDIF
C  registration
              CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
     &                        IHP,IGEN,ICA1,IVSW,IPOS,1)
              IF (LPRI.GT.4 .AND. IDEB(28).GE.20)
     &        WRITE(LO,'(1X,A,3I5)')
     &          'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',

C
     &          IFL1,IPOS,SIGN(INDXS,INDXH)
              IF(INDXH.GT.0) THEN
                P1 = PSOFT1(1,INDXS+1)
                P2 = PSOFT1(2,INDXS+1)
                P3 = PSOFT1(3,INDXS+1)
                P4 = PSOFT1(4,INDXS+1)
                IJSI1(INDXS+1) = IFL2
              ELSE
                P1 = PSOFT2(1,INDXS+1)
                P2 = PSOFT2(2,INDXS+1)
                P3 = PSOFT2(3,INDXS+1)
                P4 = PSOFT2(4,INDXS+1)
                IJSI2(INDXS+1) = IFL2
              ENDIF
C  registration
              CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
     &                        IHP,IGEN,ICB1,IVSW,IPOS,1)
              IF (LPRI.GT.4 .AND. IDEB(28).GE.20)
     &        WRITE(LO,'(1X,A,3I5)')
     &          'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',

     &          IFL2,IPOS,SIGN(INDXS+1,INDXH)
              IUSED = 2
            ENDIF
C
C  gluon from sea quarks connected with valence quarks
          ELSE IF(IVAL.EQ.0) THEN
            IF(INDXH.GT.0) THEN
              E1 = PSOFT1(4,INDXS)
              E2 = PSOFT1(4,INDXS+1)
            ELSE
              E1 = PSOFT2(4,INDXS)
              E2 = PSOFT2(4,INDXS+1)
            ENDIF
            CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
            CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
            IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
     &         .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
              I = ICA1
              ICA1 = ICB1
              ICB1 = I
            ENDIF
            IF(DT_RNDM(P3).LT.0.5D0) THEN
              CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
            ELSE
              CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
            ENDIF
C  remnant of hadron
            IF(INDXH.GT.0) THEN
              P1 = PSOFT1(1,INDXS)
              P2 = PSOFT1(2,INDXS)
              P3 = PSOFT1(3,INDXS)
              P4 = PSOFT1(4,INDXS)
              IJSI1(INDXS) = IFL1
            ELSE
              P1 = PSOFT2(1,INDXS)
              P2 = PSOFT2(2,INDXS)
              P3 = PSOFT2(3,INDXS)
              P4 = PSOFT2(4,INDXS)
              IJSI2(INDXS) = IFL1
            ENDIF
C  registration
            CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
     &                      IHP,IGEN,ICA1,IVSW,IPOS,1)
            IF (LPRI.GT.4 .AND. IDEB(28).GE.20)
     &      WRITE(LO,'(1X,A,3I5)')
     &        'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',

C
     &        IFL1,IPOS,SIGN(INDXS,INDXH)
            IF(INDXH.GT.0) THEN
              P1 = PSOFT1(1,INDXS+1)
              P2 = PSOFT1(2,INDXS+1)
              P3 = PSOFT1(3,INDXS+1)
              P4 = PSOFT1(4,INDXS+1)
              IJSI1(INDXS+1) = IFL2
            ELSE
              P1 = PSOFT2(1,INDXS+1)
              P2 = PSOFT2(2,INDXS+1)
              P3 = PSOFT2(3,INDXS+1)
              P4 = PSOFT2(4,INDXS+1)
              IJSI2(INDXS+1) = IFL2
            ENDIF
C  registration
            CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
     &                      IHP,IGEN,ICB1,IVSW,IPOS,1)
            IF (LPRI.GT.4 .AND. IDEB(28).GE.20)
     &      WRITE(LO,'(1X,A,3I5)')
     &        'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',

     &        IFL2,IPOS,SIGN(INDXS+1,INDXH)
            IF(IPAMDL(18).EQ.0)  THEN
C  sea quark pair
              CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
              IF(ICC1.GT.0) THEN
                IFL1 = ABS(IFL1)
                IFL2 = -IFL1
              ELSE
                IFL1 = -ABS(IFL1)
                IFL2 = -IFL1
              ENDIF
              IF(DT_RNDM(P4).LT.0.5D0) THEN
                ICB1 = ICC2
                CALL PHO_SELCOL(ICC1,0,ICA1,ICA2,ICC1,ICC2,2)
              ELSE
                ICA1 = ICC1
                CALL PHO_SELCOL(ICC2,0,ICB1,ICB2,ICC1,ICC2,2)
              ENDIF
              IF(INDXH.GT.0) THEN
                P1 = PSOFT1(1,INDXS+2)
                P2 = PSOFT1(2,INDXS+2)
                P3 = PSOFT1(3,INDXS+2)
                P4 = PSOFT1(4,INDXS+2)
                IJSI1(INDXS+2) = IFL1
              ELSE
                P1 = PSOFT2(1,INDXS+2)
                P2 = PSOFT2(2,INDXS+2)
                P3 = PSOFT2(3,INDXS+2)
                P4 = PSOFT2(4,INDXS+2)
                IJSI2(INDXS+2) = IFL1
              ENDIF
C  registration
              CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
     &                        IHP,IGEN,ICA1,0,IPOS,1)
              IF (LPRI.GT.4 .AND. IDEB(28).GE.20)
     &        WRITE(LO,'(1X,A,3I5)')
     &          'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',

C
     &          IFL1,IPOS,SIGN(INDXS+2,INDXH)
              IF(INDXH.GT.0) THEN
                P1 = PSOFT1(1,INDXS+3)
                P2 = PSOFT1(2,INDXS+3)
                P3 = PSOFT1(3,INDXS+3)
                P4 = PSOFT1(4,INDXS+3)
                IJSI1(INDXS+3) = IFL2
              ELSE
                P1 = PSOFT2(1,INDXS+3)
                P2 = PSOFT2(2,INDXS+3)
                P3 = PSOFT2(3,INDXS+3)
                P4 = PSOFT2(4,INDXS+3)
                IJSI2(INDXS+3) = IFL2
              ENDIF
C  registration
              CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
     &                        IHP,IGEN,ICB1,0,IPOS,1)
              IF (LPRI.GT.4 .AND. IDEB(28).GE.20)
     &        WRITE(LO,'(1X,A,3I5)')
     &          'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',

     &          IFL2,IPOS,SIGN(INDXS+3,INDXH)
              IUSED = 4
            ELSE
              IUSED = 2
            ENDIF
C
C  gluon from independent sea quarks
          ELSE IF(IVAL.EQ.-1) THEN
            IF(IPAMDL(18).EQ.0) THEN
              CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
              CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
              IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
     &           .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
                I = ICA1
                ICA1 = ICB1
                ICB1 = I
              ENDIF
              IF(DT_RNDM(P1).LT.0.5D0) THEN
                CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
              ELSE
                CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
              ENDIF
C  remainder of hadron
              IF(INDXH.GT.0) THEN
                P1 = PSOFT1(1,INDXS)
                P2 = PSOFT1(2,INDXS)
                P3 = PSOFT1(3,INDXS)
                P4 = PSOFT1(4,INDXS)
                IJSI1(INDXS) = IFL1
              ELSE
                P1 = PSOFT2(1,INDXS)
                P2 = PSOFT2(2,INDXS)
                P3 = PSOFT2(3,INDXS)
                P4 = PSOFT2(4,INDXS)
                IJSI2(INDXS) = IFL1
              ENDIF
C  registration
              CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
     &                        IHP,IGEN,ICA1,ICA2,IPOS,1)
              IF (LPRI.GT.4 .AND. IDEB(28).GE.20)
     &        WRITE(LO,'(1X,A,3I5)')
     &          'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',

C  remnant of sea
     &          IFL1,IPOS,SIGN(INDXS,INDXH)
              IF(INDXH.GT.0) THEN
                P1 = PSOFT1(1,INDXS-1)
                P2 = PSOFT1(2,INDXS-1)
                P3 = PSOFT1(3,INDXS-1)
                P4 = PSOFT1(4,INDXS-1)
                IJSI1(INDXS-1) = IFL2
              ELSE
                P1 = PSOFT2(1,INDXS-1)
                P2 = PSOFT2(2,INDXS-1)
                P3 = PSOFT2(3,INDXS-1)
                P4 = PSOFT2(4,INDXS-1)
                IJSI2(INDXS-1) = IFL2
              ENDIF
C  registration
              CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
     &                        IHP,IGEN,ICB1,ICB2,IPOS,1)
              IF (LPRI.GT.4 .AND. IDEB(28).GE.20)
     &        WRITE(LO,'(1X,A,3I5)')
     &          'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',

     &          IFL2,IPOS,SIGN(INDXS-1,INDXH)
              IUSED = 2
            ELSE
              CALL PHO_SELCOL(0,0,ICC1,ICA2,ICC2,ICB2,1)
              IF (LPRI.GT.4 .AND. IDEB(28).GE.20)
     &        WRITE(LO,'(1X,A,I5)')
     &          'PHO_HARREM: no spectator added:(INDXS)',
     &          SIGN(INDXS,INDXH)
              IUSED = 0
            ENDIF
C
          ELSE
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,A,2I5)')
     &        'PHO_HARREM:ERROR: unsupported combination of IVAL,IJH',
     &        IVAL,IJH
            CALL PHO_ABORT
          ENDIF
          IC1 = ICC1
          IC2 = ICC2
        ENDIF
      END


 
 


CDECK  ID>, PHO_HARSCA
      SUBROUTINE PHO_HARSCA(IMODE,IP)
C***********************************************************************
C
C     PHO_HARSCA determines the type of hard subprocess, the partons
C     taking part in this subprocess and the kinematic variables
C
C     input:  IMODE   1   direct processes
C                     2   resolved processes
C                     -1  initialization
C                     -2  output of statistics
C             IP      1-4 particle combination (hadron/photon)
C
C***********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER( EPS  = 1.D-10,
     &           DEPS = 1.D-30 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  current beam selection
      INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN
      INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL
      DOUBLE PRECISION SQSGLOBMAX
      PARAMETER (MPARMAX=40)
      PARAMETER (MAXMAPPS=40)
      PARAMETER (IKNOWN=9)
      DIMENSION IPAVAIL(IKNOWN)
      DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/
      COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS),
     &           MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  internal rejection counters
      INTEGER NMXJ
      PARAMETER (NMXJ=60)
      CHARACTER*10 REJTIT
      INTEGER IFAIL
      COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)

C  hard scattering parameters used for most recent hard interaction
      INTEGER NFbeta,NF
      DOUBLE PRECISION ALQCD2,BQCD
      COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF

C  data of c.m. system of Pomeron / Reggeon exchange
      INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
      DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
     &                 SIDP,CODP,SIFP,COFP
      COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
     &                SIDP,CODP,SIFP,COFP,NPOSP(2),
     &                IDPDG1,IDBAM1,IDPDG2,IDBAM2

C  names of hard scattering processes
      INTEGER Max_pro_1
      PARAMETER ( Max_pro_1 = 16 )
      CHARACTER*18 PROC
      COMMON /POHPRO/ PROC(0:Max_pro_1)

C  data on most recent hard scattering
      INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
      DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
     &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
      COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
     &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
     &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
     &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC

C  hard scattering data
      INTEGER MSCAHD
      PARAMETER ( MSCAHD = 1000 )
      INTEGER LSCAHD,LSC1HD,LSIDX,
     &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
      DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
      COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
     &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
     &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
     &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
     &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
     &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
     &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)

C  hard cross sections and MC selection weights
      INTEGER Max_pro_2
      PARAMETER ( Max_pro_2 = 16 )
      INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
     &  MH_acc_1,MH_acc_2
      DOUBLE PRECISION HFAC, HWGX, HSIG, HDPT, HECM_LAST, 
     &   HQ2A_LAST, HQ2B_LAST
      COMMON /POHRCS/HFAC(-1:MAX_PRO_2, MPARMAX), 
     &   HWGX(-1:MAX_PRO_2, MPARMAX),
     &   HSIG(-1:MAX_PRO_2, MPARMAX), HDPT(-1:MAX_PRO_2, MPARMAX), 
     &   HECM_LAST, HQ2A_LAST, HQ2B_LAST, IHA_LAST, IHB_LAST, 
     &   MH_PRO_ON(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_TRIED(-1:MAX_PRO_2, 0:4, MPARMAX), 
     &   MH_ACC_1(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_ACC_2(-1:MAX_PRO_2, 0:4, MPARMAX) 

C  cross sections
      INTEGER IPFIL,IFAFIL,IFBFIL
      DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
     &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
     &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
     &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
     &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
      COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
     &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
     &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
     &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
     &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
     &                IPFIL,IFAFIL,IFBFIL

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

      DOUBLE PRECISION PHO_PMASS
      EXTERNAL         PHO_PMASS

 111  CONTINUE

C  resolved processes
      IF(IMODE.EQ.2) THEN

        MH_pro_on(0,IP,IDXMPAR) = 0
        HWgx(9,IDXMPAR)  = 0.D0
        DO 15 M=-1,8
          IF(MH_pro_on(M,IP,IDXMPAR).EQ.1) HWgx(9,IDXMPAR) = 
     &      HWgx(9,IDXMPAR)+HWgx(M,IDXMPAR)
 15     CONTINUE
        IF(HWgx(9,IDXMPAR).LT.DEPS) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,2A,I4,1P,E12.4)') 'PHO_HARSCA:ERROR: ',
     &      'no resolved process possible for IP',IP,HWgx(9,IDXMPAR)
          CALL PHO_ABORT
        ENDIF
C
C ----------------------------------------------I
C  begin of iteration loop (resolved processes) I
C                                               I
        IREJSC = 0
 10     CONTINUE
        IREJSC = IREJSC+1
        IF(IREJSC.GT.1000) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,I10)')
     &      'PHO_HARSCA:ERROR: too many rejections (resolved)',IREJSC
            CALL PHO_ABORT
        ENDIF

C  find subprocess
        B      = DT_RNDM(X1)*HWgx(9,IDXMPAR)
        MSPR   =-2
        SUM    = 0.D0
 20     MSPR   = MSPR+1
        IF ( MH_pro_on(MSPR,IP,IDXMPAR).EQ.1 ) SUM = SUM+
     &    HWgx(MSPR,IDXMPAR)
        IF ( SUM.LT.B  .AND. MSPR.LT.8 ) GOTO 20

        IF (LPRI.GT.4 .AND. IDEB(78).GE.20)
     &  WRITE(LO,'(1x,a,i3,i6)')
     &    'PHO_HARSCA: resolved process (MSPR,IREJSC)',MSPR,IREJSC

C  find kin. variables X1,X2 and V
        CALL PHO_HARKIN(IREJ)
        IF(IREJ.NE.0) THEN
          IFAIL(29) = IFAIL(29)+1
          GOTO 10
        ENDIF
C  calculate remaining distribution
        CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
C  actualize counter for cross-section calculation
        if(F.LE.1.D-15) then
          F = 0.D0
          goto 10
        endif
*       XSECT(5,MSPR) = XSECT(5,MSPR)+F
*       XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
        MH_tried(MSPR,IP,IDXMPAR) = MH_tried(MSPR,IP,IDXMPAR)+1
C  check F against FMAX
        WEIGHT = F/(HWgx(MSPR,IDXMPAR)+DEPS)
        IF ( WEIGHT.LT.DT_RNDM(X2) ) GOTO 10
C-------------------------------------------------------------------
        IF(WEIGHT.GT.1.D0) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,1234) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR,IDXMPAR),
     &                    WEIGHT
 1234     FORMAT(/,' PHO_HARSCA: (resolved) W>1 (MSPR,IP,ID1,2)',
     &      2I3,2I7,/' F,HWgx(MSPR),W',3E12.4)
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
     &      ECMP,PTWANT,AS,AH,PT
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
     &      ETAC,ETAD,X1,X2,V
          CALL PHO_PREVNT(-1)
        ENDIF
C-------------------------------------------------------------------
C                                             I
C  end of iteration loop (resolved processes) I
C --------------------------------------------I
C
C*********************************************************************
C
C  direct processes

      ELSE IF(IMODE.EQ.1) THEN

C  single-resolved processes kinematically forbidden
        if(Z1DIF.lt.0.D0) then
          HWgx(10,IDXMPAR) = 0.D0
          HWgx(11,IDXMPAR) = 0.D0
          HWgx(12,IDXMPAR) = 0.D0
          HWgx(13,IDXMPAR) = 0.D0
        endif

        HWgx(15,IDXMPAR)  = 0.D0
        if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
          DO M= 10,14
            IF(MH_pro_on(M,IP,IDXMPAR).EQ.1) then
              if((M.eq.10).or.(M.eq.11)) then
                fac = FSUH(1)*FSUP(2)
              else if((M.eq.12).or.(M.eq.13)) then
                fac = FSUP(1)*FSUH(2)
              else
                fac = FSUH(1)*FSUH(2)
              endif
              HWgx(15,IDXMPAR) = HWgx(15,IDXMPAR)+HWgx(M,IDXMPAR)*fac
            endif
          ENDDO
        else
          DO M= 10,14
            IF(MH_pro_on(M,IP,IDXMPAR).EQ.1) HWgx(15,IDXMPAR)=
     &         HWgx(15,IDXMPAR)+HWgx(M,IDXMPAR)
          ENDDO
        endif
        IF(HWgx(15,IDXMPAR).LT.DEPS) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,2A,I4)') 'PHO_HARSCA:ERROR: ',
     &      'no direct/single-resolved process possible (IP)',IP
          CALL PHO_ABORT
        ENDIF
C
C ----------------------------------------------I
C  begin of iteration loop (direct processes)   I
C                                               I
        IREJSC = 0
 100    CONTINUE
        IREJSC = IREJSC+1
        IF(IREJSC.GT.1000) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,I10)')
     &      'PHO_HARSCA:ERROR: too many rejections (direct)',IREJSC
            CALL PHO_ABORT
        ENDIF

C  find subprocess
        B      = DT_RNDM(X1)*HWgx(15,IDXMPAR)
        MSPR   = 9
        SUM    = 0.D0
        if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
 150      continue
            MSPR   = MSPR+1
            IF(MH_pro_on(MSPR,IP,IDXMPAR).EQ.1) then
              if((MSPR.eq.10).or.(MSPR.eq.11)) then
                fac = FSUH(1)*FSUP(2)
              else if((MSPR.eq.12).or.(MSPR.eq.13)) then
                fac = FSUP(1)*FSUH(2)
              else
                fac = FSUH(1)*FSUH(2)
              endif
              SUM = SUM+HWgx(MSPR,IDXMPAR)*fac
            endif
          IF ( SUM.LT.B  .AND. MSPR.LT.14 ) GOTO 150
        else
 200      continue
            MSPR   = MSPR+1
            IF(MH_pro_on(MSPR,IP,IDXMPAR).EQ.1) SUM = SUM+
     &        HWgx(MSPR,IDXMPAR)
          IF ( SUM.LT.B  .AND. MSPR.LT.14 ) GOTO 200
        endif

        IF (LPRI.GT.4 .AND. IDEB(78).GE.20)
     &  WRITE(LO,'(1x,a,i3,i6)')
     &    'PHO_HARSCA: direct process (MSPR,IREJSC)',MSPR,IREJSC

C  find kin. variables X1,X2 and V
        CALL PHO_HARKIN(IREJ)
        IF(IREJ.NE.0) THEN
          IFAIL(28) = IFAIL(28)+1
          GOTO 100
        ENDIF

C  calculate remaining distribution
        CALL PHO_HARWGH(PDS,PDF1,PDF2,F)

C  counter for cross-section calculation
        if(F.LE.1.D-15) then
          F=0.D0
          goto 100
        endif
*       XSECT(5,MSPR) = XSECT(5,MSPR)+F
*       XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
        MH_tried(MSPR,IP,IDXMPAR) = MH_tried(MSPR,IP,IDXMPAR)+1
C  check F against FMAX
        WEIGHT = F/(HWgx(MSPR,IDXMPAR)+DEPS)
        IF(WEIGHT.LT.DT_RNDM(X2)) GOTO 100
C-------------------------------------------------------------------
        IF(WEIGHT.GT.1.D0) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,1235) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR,IDXMPAR),
     &      WEIGHT
 1235     FORMAT(/,' PHO_HARSCA: (direct) W>1 (MSPR,IP,ID1,2)',
     &      2I3,2I7,/,' F,HWgx(MSPR),W',3E12.4)
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
     &      ECMP,PTWANT,AS,AH,PT
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
     &      ETAC,ETAD,X1,X2,V
          CALL PHO_PREVNT(-1)
        ENDIF
C-------------------------------------------------------------------
C                                             I
C  end of iteration loop (direct processes)   I
C --------------------------------------------I

      ELSE IF(IMODE.EQ.-1) THEN

C  initialize cross section calculations

        DO 40 M=-1,Max_pro_2
*         DO 30 I=5,6
*           XSECT(I,M) = 0.D0
*30       CONTINUE
C  reset counters
          DO 35 J=1,4
            MH_tried(M,J,IDXMPAR) = 0
            MH_acc_1(M,J,IDXMPAR) = 0
            MH_acc_2(M,J,IDXMPAR) = 0
 35       CONTINUE
 40     CONTINUE
        IF(IDEB(78).GE.0) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,/1X,A)')
     &      'PHO_HARSCA: activated hard processes',
     &      '------------------------------------'
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A)') 'PROCESS,    IP= 1 ... 4 (on/off)'
          DO 42 M=1,Max_pro_2
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,I3,5X,A,4I3)') M,PROC(M),
     &        (MH_pro_on(M,J,IDXMPAR),J=1,4)
 42       CONTINUE
        ENDIF
        RETURN

      ELSE IF(IMODE.EQ.-2) THEN

C  calculation of process statistics

        do K=1,4

          MH_tried(0,K,IDXMPAR)  = 0
          MH_acc_1(0,K,IDXMPAR)  = 0
          MH_acc_2(0,K,IDXMPAR)  = 0
          MH_tried(9,K,IDXMPAR)  = 0
          MH_acc_1(9,K,IDXMPAR)  = 0
          MH_acc_2(9,K,IDXMPAR)  = 0
          MH_tried(15,K,IDXMPAR) = 0
          MH_acc_1(15,K,IDXMPAR) = 0
          MH_acc_2(15,K,IDXMPAR) = 0

          MH_tried(3,K,IDXMPAR) = MH_tried(3,K,IDXMPAR)+
     &                            MH_tried(-1,K,IDXMPAR)
          MH_acc_1(3,K,IDXMPAR) = MH_acc_1(3,K,IDXMPAR)+
     &                            MH_acc_1(-1,K,IDXMPAR)
          MH_acc_2(3,K,IDXMPAR) = MH_acc_2(3,K,IDXMPAR)+
     &                            MH_acc_2(-1,K,IDXMPAR)

          do M=1,8
            MH_tried(9,K,IDXMPAR) = MH_tried(9,K,IDXMPAR)+
     &                              MH_tried(M,K,IDXMPAR)
            MH_acc_1(9,K,IDXMPAR) = MH_acc_1(9,K,IDXMPAR)+
     &                              MH_acc_1(M,K,IDXMPAR)
            MH_acc_2(9,K,IDXMPAR) = MH_acc_2(9,K,IDXMPAR)+
     &                              MH_acc_2(M,K,IDXMPAR)
          enddo
          do M=10,14
            MH_tried(15,K,IDXMPAR) = MH_tried(15,K,IDXMPAR)+
     &                               MH_tried(M,K,IDXMPAR)
            MH_acc_1(15,K,IDXMPAR) = MH_acc_1(15,K,IDXMPAR)+
     &                               MH_acc_1(M,K,IDXMPAR)
            MH_acc_2(15,K,IDXMPAR) = MH_acc_2(15,K,IDXMPAR)+
     &                               MH_acc_2(M,K,IDXMPAR)
          enddo
          MH_tried(0,K,IDXMPAR) = MH_tried(9,K,IDXMPAR)+
     &                            MH_tried(15,K,IDXMPAR)
          MH_acc_1(0,K,IDXMPAR) = MH_acc_1(9,K,IDXMPAR)+
     &                            MH_acc_1(15,K,IDXMPAR)
          MH_acc_2(0,K,IDXMPAR) = MH_acc_2(9,K,IDXMPAR)+
     &                            MH_acc_2(15,K,IDXMPAR)
        enddo

        IF(IDEB(78).GE.1) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,/1X,A)')
     &      'PHO_HARSCA: internal rejection statistics',
     &      '-----------------------------------------'
          do K=1,4
            IF(MH_tried(0,K,IDXMPAR).GT.0) THEN
              IF (LPRI.GT.4)
     &        WRITE(LO,'(5X,A,I3)')
     &          'process (sampled/accepted) for IP:',K
              do M=0,Max_pro_2
                IF (LPRI.GT.4)
     &          WRITE(LO,'(1X,I3,1X,A,2X,3I12,F10.4)') M,PROC(M),
     &            MH_tried(M,K,IDXMPAR),MH_acc_1(M,K,IDXMPAR),
     &            MH_acc_2(K,K,IDXMPAR),dble(MH_acc_1(M,K,IDXMPAR))/
     &            dble(max(1,MH_tried(M,K,IDXMPAR)))
              enddo
            ENDIF
          enddo
        ENDIF
        RETURN

      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,2A,I10)') 'PHO_HARSCA:ERROR: ',
     &    'unsupported mode',IMODE
        CALL PHO_ABORT
      ENDIF

C  the event is accepted now
C  actualize counter for accepted events
      MH_acc_1(MSPR,IP,IDXMPAR) = MH_acc_1(MSPR,IP,IDXMPAR)+1
      IF(MSPR.EQ.-1) MSPR = 3
C
C  find flavor of initial partons
C
      SUM    = 0.D0
      SCHECK = DT_RNDM(SUM)*PDS-EPS
      IF     ( MSPR.EQ.1  .OR.  MSPR.EQ.4 ) THEN
        IA = 0
        IB = 0
      ELSEIF ( MSPR.EQ.2  .OR.  MSPR.EQ.5  .OR.  MSPR.EQ.6 ) THEN
        DO 610 IA=-NF,NF
          IF ( IA.EQ.0 ) GOTO 610
          SUM  = SUM+PDF1(IA)*PDF2(-IA)
          IF ( SUM.GE.SCHECK ) GOTO 620
 610      CONTINUE
 620    IB =-IA
      ELSEIF ( MSPR.EQ.3 ) THEN
        IB     = 0
        DO 630 IA=-NF,NF
          IF ( IA.EQ.0 ) GOTO 630
          SUM  = SUM+PDF1(0)*PDF2(IA)
          IF ( SUM.GE.SCHECK ) GOTO 640
          SUM  = SUM+PDF1(IA)*PDF2(0)
          IF ( SUM.GE.SCHECK ) GOTO 650
 630    CONTINUE
 640    IB     = IA
        IA     = 0
 650    CONTINUE
      ELSEIF ( MSPR.EQ.7 ) THEN
        DO 660 IA=-NF,NF
          IF ( IA.EQ.0 ) GOTO 660
          SUM  = SUM+PDF1(IA)*PDF2(IA)
          IF ( SUM.GE.SCHECK ) GOTO 670
 660      CONTINUE
 670    IB     = IA
      ELSEIF ( MSPR.EQ.8 ) THEN
        DO 690 IA=-NF,NF
          IF ( IA.EQ.0 ) GOTO 690
          DO 680 IB=-NF,NF
            IF ( ABS(IB).EQ.ABS(IA)  .OR.  IB.EQ.0 ) GOTO 680
            SUM = SUM+PDF1(IA)*PDF2(IB)
            IF ( SUM.GE.SCHECK ) GOTO 700
 680        CONTINUE
 690      CONTINUE
 700    CONTINUE
      ELSEIF ( MSPR.EQ.10 ) THEN
        IA     = 0
        DO 710 IB=-NF,NF
          IF ( IB.NE.0 ) THEN
            IF(IDPDG1.EQ.22) THEN
*             IF(MOD(ABS(IB),2).EQ.0) THEN
*               SUM = SUM+PDF2(IB)*4.D0/9.D0
*             ELSE
*               SUM = SUM+PDF2(IB)*1.D0/9.D0
*             ENDIF
              SUM = SUM+PDF2(IB)*Q_ch2(IB)
            ELSE
              SUM = SUM+PDF2(IB)
            ENDIF
            IF ( SUM.GE.SCHECK ) GOTO 720
          ENDIF
 710    CONTINUE
 720    CONTINUE
      ELSEIF ( MSPR.EQ.12 ) THEN
        IB     = 0
        DO 810 IA=-NF,NF
          IF ( IA.NE.0 ) THEN
            IF(IDPDG2.EQ.22) THEN
*             IF(MOD(ABS(IA),2).EQ.0) THEN
*               SUM = SUM+PDF1(IA)*4.D0/9.D0
*             ELSE
*               SUM = SUM+PDF1(IA)*1.D0/9.D0
*             ENDIF
              SUM = SUM+PDF1(IA)*Q_ch2(IA)
            ELSE
              SUM = SUM+PDF1(IA)
            ENDIF
            IF ( SUM.GE.SCHECK ) GOTO 820
          ENDIF
 810    CONTINUE
 820    CONTINUE
      ELSEIF ((MSPR.EQ.11).OR.(MSPR.EQ.13).OR.(MSPR.EQ.14)) THEN
        IA     = 0
        IB     = 0
      ENDIF
C  final check
      IF((ABS(IA).GT.NF).OR.(ABS(IB).GT.NF)) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,*)'PHO_HARSCA: rejection, final check IA,IB',IA,IB
        IF (LPRI.GT.4)
     &  WRITE(LO,*)'EVENT,MSPR,IA,IB,NF: ',KEVENT,MSPR,IA,IB,NF
        GOTO 111
      ENDIF
C
C  find flavour of final partons
C
      IC = IA
      ID = IB
      IF     ( MSPR.EQ.2 ) THEN
        IC = 0
        ID = 0
      ELSEIF ( MSPR.EQ.4 ) THEN
        IC = INT(FLOAT(NF+NF)*DT_RNDM(SUM))+1
        IF ( IC.GT.NF ) IC = NF-IC
        ID =-IC
      ELSEIF ( MSPR.EQ.6 ) THEN
        IC = INT(FLOAT(NF+NF-2)*DT_RNDM(SUM))+1
        IF ( IC.GT.NF-1 ) IC = NF-1-IC
        IF ( ABS(IC).EQ.ABS(IA) ) IC = SIGN(NF,IC)
        ID =-IC
      ELSEIF ( MSPR.EQ.11) THEN
        SUM = 0.D0
        DO 730 IC=-NF,NF
          IF ( IC.NE.0 ) THEN
            IF(IDPDG1.EQ.22) THEN
*             IF(MOD(ABS(IC),2).EQ.0) THEN
*               SUM = SUM + 4.D0
*             ELSE
*               SUM = SUM + 1.D0
*             ENDIF
              SUM = SUM + Q_ch2(IC)
            ELSE
              SUM = SUM + 1.D0
            ENDIF
          ENDIF
 730    CONTINUE
        SCHECK = DT_RNDM(SUM)*SUM-EPS
        SUM = 0.D0
        DO 740 IC=-NF,NF
          IF ( IC.NE.0 ) THEN
            IF(IDPDG1.EQ.22) THEN
*             IF(MOD(ABS(IC),2).EQ.0) THEN
*               SUM = SUM + 4.D0
*             ELSE
*               SUM = SUM + 1.D0
*             ENDIF
              SUM = SUM + Q_ch2(IC)
            ELSE
              SUM = SUM + 1.D0
            ENDIF
            IF ( SUM.GE.SCHECK ) GOTO 750
          ENDIF
 740    CONTINUE
 750    CONTINUE
        ID = -IC
      ELSEIF ( MSPR.EQ.12) THEN
        IC = 0
        ID = IA
      ELSEIF ( MSPR.EQ.13) THEN
        SUM = 0.D0
        DO 830 IC=-NF,NF
          IF ( IC.NE.0 ) THEN
            IF(IDPDG2.EQ.22) THEN
*             IF(MOD(ABS(IC),2).EQ.0) THEN
*               SUM = SUM + 4.D0
*             ELSE
*               SUM = SUM + 1.D0
*             ENDIF
              SUM = SUM +  Q_ch2(IC)
            ELSE
              SUM = SUM + 1.D0
            ENDIF
          ENDIF
 830    CONTINUE
        SCHECK = DT_RNDM(SUM)*SUM-EPS
        SUM = 0.D0
        DO 840 IC=-NF,NF
          IF ( IC.NE.0 ) THEN
            IF(IDPDG2.EQ.22) THEN
*             IF(MOD(ABS(IC),2).EQ.0) THEN
*               SUM = SUM + 4.D0
*             ELSE
*               SUM = SUM + 1.D0
*             ENDIF
              SUM = SUM +  Q_ch2(IC)
            ELSE
              SUM = SUM + 1.D0
            ENDIF
            IF ( SUM.GE.SCHECK ) GOTO 850
          ENDIF
 840    CONTINUE
 850    CONTINUE
        ID = -IC
      ELSEIF ( MSPR.EQ.14) THEN
        SUM = 0.D0
        DO 930 IC=1,NF
          FAC1 = 1.D0
          FAC2 = 1.D0
          IF(MOD(ABS(IC),2).EQ.0) THEN
            IF(IDPDG1.EQ.22) FAC1 = 4.D0
            IF(IDPDG2.EQ.22) FAC2 = 4.D0
          ENDIF
          SUM = SUM + FAC1*FAC2
 930    CONTINUE
        IF(IPAMDL(64).NE.0) THEN
          IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) SUM = SUM + 81.D0
        ENDIF
        SCHECK = DT_RNDM(SUM)*SUM-EPS
        SUM = 0.D0
        DO 940 IC=1,NF
          FAC1 = 1.D0
          FAC2 = 1.D0
          IF(MOD(ABS(IC),2).EQ.0) THEN
            IF(IDPDG1.EQ.22) FAC1 = 4.D0
            IF(IDPDG2.EQ.22) FAC2 = 4.D0
          ENDIF
          SUM = SUM + FAC1*FAC2
          IF ( SUM.GE.SCHECK ) GOTO 950
 940    CONTINUE
        IC = 15
 950    CONTINUE
        ID = -IC
        IF(DT_RNDM(FAC1).GT.0.5D0) CALL PHO_SWAPI(IC,ID)
      ENDIF
      if(IC.eq.0) then
        XM3 = 0.D0
      else
        XM3 = PHO_PMASS(IC,3)
      endif
      if(ID.eq.0) then
        XM4 = 0.D0
      else
        XM4 = PHO_PMASS(ID,3)
      endif
      IF(ABS(IC).EQ.15) GOTO 955

C  valence quarks involved?
      IV1 = 0
      IF(IA.NE.0) THEN
        IF(IDPDG1.EQ.22) THEN
          CALL PHO_QPMPDF(IA,X1,QQPD,0.D0,PVIRTP(1),FXP)
          IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(IA)-FXP) IV1 = 1
        ELSE
          IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(-IA)) IV1 = 1
        ENDIF
      ENDIF
      IV2 = 0
      IF(IB.NE.0) THEN
        IF(IDPDG2.EQ.22) THEN
          CALL PHO_QPMPDF(IB,X2,QQPD,0.D0,PVIRTP(2),FXP)
          IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(IB)-FXP) IV2 = 1
        ELSE
          IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(-IB)) IV2 = 1
        ENDIF
      ENDIF
C
C  fill event record
C
 955  CONTINUE
      CALL PHO_SFECFE(SINPHI,COSPHI)
      ECM2 = ECMP/2.D0
C  incoming partons
      PHI1(1) = 0.D0
      PHI1(2) = 0.D0
      PHI1(3) = ECM2*X1
      PHI1(4) = PHI1(3)
      PHI1(5) = 0.D0
      PHI2(1) = 0.D0
      PHI2(2) = 0.D0
      PHI2(3) = -ECM2*X2
      PHI2(4) = -PHI2(3)
      PHI2(5) = 0.D0
C  outgoing partons
      PHO1(1) = PT*COSPHI
      PHO1(2) = PT*SINPHI
      PHO1(3) = -ECM2*(U*X1-V*X2)
      PHO1(4) = -ECM2*(U*X1+V*X2)
      PHO1(5) = XM3
      PHO2(1) = -PHO1(1)
      PHO2(2) = -PHO1(2)
      PHO2(3) = -ECM2*(V*X1-U*X2)
      PHO2(4) = -ECM2*(V*X1+U*X2)
      PHO2(5) = XM4

C  convert to mass shell
      CALL PHO_MSHELL(PHO1,PHO2,XM3,XM4,PHO1,PHO2,IREJ)
      IF(IREJ.NE.0) THEN
        IF (LPRI.GT.4 .AND. IDEB(78).GE.5)
     &  WRITE(LO,'(1X,A,1P,3E11.3)')
     &    'PHO_HARSCA: rejection by PHO_MSHELL (PT,M1,M2)',
     &    PT,XM3,XM4
        GOTO 111
      ENDIF
      PTfin = SQRT(PHO1(1)**2+PHO1(2)**2)

C  debug output
      IF(IDEB(78).GE.20) THEN
        SHAT = X1*X2*ECMP*ECMP
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,5I4)') 'PHO_HARSCA: MSPR,IA,IB,IC,ID',
     &    MSPR,IA,IB,IC,ID
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,1P,4E11.3)') 'X1/2,MU2,Q2 ',X1,X2,QQPD,QQAL
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,1P,4E11.3)') 'U,V,PT,SHAT ',U,V,PT,SHAT
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI1 ',PHI1
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI2 ',PHI2
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO1 ',PHO1
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO2 ',PHO2
      ENDIF

      END


 
 


CDECK  ID>, PHO_HARWGH
      SUBROUTINE PHO_HARWGH(PDS,PDA,PDB,FDISTR)
C***********************************************************************
C
C     calculate product of PDFs and coupling constants
C     according to selected MSPR (process type)
C
C     input:    /POCKIN/
C
C     output:   PDS     resulting from PDFs alone
C               FDISTR  complete weight function
C               PDA,PDB fields containing the PDFs
C
C***********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  current beam selection
      INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN
      INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL
      DOUBLE PRECISION SQSGLOBMAX
      PARAMETER (MPARMAX=40)
      PARAMETER (MAXMAPPS=40)
      PARAMETER (IKNOWN=9)
      DIMENSION IPAVAIL(IKNOWN)
      DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/
      COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS),
     &           MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  data of c.m. system of Pomeron / Reggeon exchange
      INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
      DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
     &                 SIDP,CODP,SIFP,COFP
      COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
     &                SIDP,CODP,SIFP,COFP,NPOSP(2),
     &                IDPDG1,IDBAM1,IDPDG2,IDBAM2

C  currently activated parton density parametrizations
      CHARACTER*8 PDFNAM
      INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
      DOUBLE PRECISION PDFLAM,PDFQ2M
      COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
     &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD

C  hard scattering parameters used for most recent hard interaction
      INTEGER NFbeta,NF
      DOUBLE PRECISION ALQCD2,BQCD
      COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF

C  some hadron information, will be deleted in future versions
      INTEGER NFS
      DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
      COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS

C  scale parameters for parton model calculations
      INTEGER NQQAL,NQQALI,NQQALF,NQQPD
      DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
      COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
     &                NQQAL,NQQALI,NQQALF,NQQPD

C  data on most recent hard scattering
      INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
      DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
     &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
      COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
     &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
     &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
     &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC

C  hard cross sections and MC selection weights
      INTEGER Max_pro_2
      PARAMETER ( Max_pro_2 = 16 )
      INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
     &  MH_acc_1,MH_acc_2
      DOUBLE PRECISION HFAC, HWGX, HSIG, HDPT, HECM_LAST, 
     &   HQ2A_LAST, HQ2B_LAST
      COMMON /POHRCS/HFAC(-1:MAX_PRO_2, MPARMAX), 
     &   HWGX(-1:MAX_PRO_2, MPARMAX),
     &   HSIG(-1:MAX_PRO_2, MPARMAX), HDPT(-1:MAX_PRO_2, MPARMAX), 
     &   HECM_LAST, HQ2A_LAST, HQ2B_LAST, IHA_LAST, IHB_LAST, 
     &   MH_PRO_ON(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_TRIED(-1:MAX_PRO_2, 0:4, MPARMAX), 
     &   MH_ACC_1(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_ACC_2(-1:MAX_PRO_2, 0:4, MPARMAX) 

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

      DOUBLE PRECISION PHO_ALPHAS,PHO_ALPHAE
      EXTERNAL         PHO_ALPHAS,PHO_ALPHAE
      DIMENSION PDA(-6:6),PDB(-6:6)

      FDISTR = 0.D0
C  set hard scale  QQ  for alpha and partondistr.
      IF     ( NQQAL.EQ.1 ) THEN
        QQAL = AQQAL*PT*PT
      ELSEIF ( NQQAL.EQ.2 ) THEN
        QQAL = AQQAL*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
      ELSEIF ( NQQAL.EQ.3 ) THEN
        QQAL = AQQAL*X1*X2*ECMP*ECMP
      ELSEIF ( NQQAL.EQ.4 ) THEN
        QQAL = AQQAL*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
      ENDIF
      IF     ( NQQPD.EQ.1 ) THEN
        QQPD = AQQPD*PT*PT
      ELSEIF ( NQQPD.EQ.2 ) THEN
        QQPD = AQQPD*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
      ELSEIF ( NQQPD.EQ.3 ) THEN
        QQPD = AQQPD*X1*X2*ECMP*ECMP
      ELSEIF ( NQQPD.EQ.4 ) THEN
        QQPD = AQQPD*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
      ENDIF
C  coupling constants, PDFs
      IF(MSPR.LT.9) THEN
        ALPHA1 = PHO_ALPHAS(QQAL,3)
        ALPHA2 = ALPHA1
        CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
        CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
        IF ( MSPR.EQ.1  .OR.  MSPR.EQ.4 ) THEN
          PDS   = PDA(0)*PDB(0)
        ELSE
          S2    = 0.D0
          S3    = 0.D0
          S4    = 0.D0
          S5    = 0.D0
          DO 10 I=1,NF
            S2  = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
            S3  = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
            S4  = S4+PDA(I)+PDA(-I)
            S5  = S5+PDB(I)+PDB(-I)
 10       CONTINUE
          IF ((MSPR.EQ.2).OR.(MSPR.EQ.5).OR.(MSPR.EQ.6)) THEN
            PDS = S2
          ELSE IF((MSPR.EQ.3).OR.(MSPR.EQ.-1)) THEN
            PDS = PDA(0)*S5+PDB(0)*S4
          ELSE IF(MSPR.EQ.7) THEN
            PDS = S3
          ELSE IF(MSPR.EQ.8) THEN
            PDS = S4*S5-(S2+S3)
          ENDIF
        ENDIF
      ELSE IF(MSPR.LT.12) THEN
        ALPHA2 = PHO_ALPHAS(QQAL,2)
        IF(IDPDG1.EQ.22) THEN
          ALPHA1 = PHO_ALPHAE(QQAL)
        ELSE IF(IDPDG1.EQ.990) THEN
          ALPHA1 = PARMDL(74)
        ENDIF
        CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
        S4    = 0.D0
        S6    = 0.D0
        DO 15 I=1,NF
          S4  = S4+PDB(I)+PDB(-I)
C  charge counting
*         IF(MOD(I,2).EQ.0) THEN
*           S6  = S6+(PDB(I)+PDB(-I))*4.D0/9.D0
*         ELSE
*           S6  = S6+(PDB(I)+PDB(-I))*1.D0/9.D0
*         ENDIF
          S6  = S6+(PDB(I)+PDB(-I))*Q_ch2(I)
 15     CONTINUE
        IF(MSPR.EQ.10) THEN
          IF(IDPDG1.EQ.990) THEN
            PDS = S4
          ELSE
            PDS = S6
          ENDIF
        ELSE
          PDS = PDB(0)
        ENDIF
      ELSE IF(MSPR.LT.14) THEN
        ALPHA1 = PHO_ALPHAS(QQAL,1)
        IF(IDPDG2.EQ.22) THEN
          ALPHA2 = PHO_ALPHAE(QQAL)
        ELSE IF(IDPDG2.EQ.990) THEN
          ALPHA2 = PARMDL(74)
        ENDIF
        CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
        S4    = 0.D0
        S6    = 0.D0
        DO 20 I=1,NF
          S4  = S4+PDA(I)+PDA(-I)
C  charge counting
*         IF(MOD(I,2).EQ.0) THEN
*           S6  = S6+(PDA(I)+PDA(-I))*4.D0/9.D0
*         ELSE
*           S6  = S6+(PDA(I)+PDA(-I))*1.D0/9.D0
*         ENDIF
          S6  = S6+(PDA(I)+PDA(-I))*Q_ch2(I)
 20     CONTINUE
        IF(MSPR.EQ.12) THEN
          IF(IDPDG2.EQ.990) THEN
            PDS = S4
          ELSE
            PDS = S6
          ENDIF
        ELSE
          PDS = PDA(0)
        ENDIF
      ELSE IF(MSPR.EQ.14) THEN
        SSR = X1*X2*ECMP*ECMP
        IF(IDPDG1.EQ.22) THEN
          ALPHA1 = PHO_ALPHAE(SSR)
        ELSE IF(IDPDG1.EQ.990) THEN
          ALPHA1 = PARMDL(74)
        ENDIF
        IF(IDPDG2.EQ.22) THEN
          ALPHA2 = PHO_ALPHAE(SSR)
        ELSE IF(IDPDG2.EQ.990) THEN
          ALPHA2 = PARMDL(74)
        ENDIF
        PDS = 1.D0
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,I4)')
     &    'PHO_HARWGH:ERROR: invalid hard process number (MSPR)',MSPR
        CALL PHO_ABORT
      ENDIF

C  complete weight
      FDISTR  = HFac(MSPR,IDXMPAR)*ALPHA1*ALPHA2*PDS

C  debug output
      IF (LPRI.GT.4 .AND. IDEB(15).GE.20)
     &WRITE(LO,'(1X,A,/5X,I3,2I6,4E10.3)')
     &    'PHO_HARWGH: MSPR,ID1,ID2,AL1,AL2,PDS,FDIS',
     &    MSPR,IDPDG1,IDPDG2,ALPHA1,ALPHA2,PDS,FDISTR

      END


 
 


CDECK  ID>, PHO_HARWGI
      SUBROUTINE PHO_HARWGI(ECMX,PTCUT,NKON,Z,FDIS)
C**********************************************************************
C
C     auxiliary subroutine to find maximum of remaining weight
C
C     input:  ECMX   current CMS energy
C             PTCUT  current pt cutoff
C             NKON   process label  1..5  resolved
C                                   6..7  direct particle 1
C                                   8..9  direct particle 2
C                                   10    double direct
C             Z(3)   transformed variable
C
C     output: remaining weight
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      DIMENSION Z(3)

      PARAMETER ( NKM   = 10 )
      PARAMETER ( TINY  = 1.D-30,
     &            TINY6 = 1.D-06 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  data of c.m. system of Pomeron / Reggeon exchange
      INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
      DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
     &                 SIDP,CODP,SIFP,COFP
      COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
     &                SIDP,CODP,SIFP,COFP,NPOSP(2),
     &                IDPDG1,IDBAM1,IDPDG2,IDBAM2

C  currently activated parton density parametrizations
      CHARACTER*8 PDFNAM
      INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
      DOUBLE PRECISION PDFLAM,PDFQ2M
      COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
     &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD

C  hard scattering parameters used for most recent hard interaction
      INTEGER NFbeta,NF
      DOUBLE PRECISION ALQCD2,BQCD
      COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF

C  some hadron information, will be deleted in future versions
      INTEGER NFS
      DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
      COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS

C  scale parameters for parton model calculations
      INTEGER NQQAL,NQQALI,NQQALF,NQQPD
      DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
      COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
     &                NQQAL,NQQALI,NQQALF,NQQPD

C  data on most recent hard scattering
      INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
      DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
     &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
      COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
     &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
     &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
     &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC

      DOUBLE PRECISION PHO_ALPHAS,PHO_ALPHAE
      EXTERNAL         PHO_ALPHAS,PHO_ALPHAE
      DIMENSION F(NKM),PDA(-6:6),PDB(-6:6)

      FDIS = 0.D0

      IF (LPRI.GT.4 .AND. IDEB(64).GE.25)
     &WRITE(LO,'(1X,A,/5X,5E12.3,I5)')
     &  'PHO_HARWGI: ECM,PT,Z,NK',ECMX,PTCUT,Z,NKON
C  check input values
      IF ( Z(1).LT.0.D0  .OR.  Z(1).GT.1.D0 ) RETURN
      IF ( Z(2).LT.0.D0  .OR.  Z(2).GT.1.D0 ) RETURN
      IF ( Z(3).LT.0.D0  .OR.  Z(3).GT.1.D0 ) RETURN
C  transformations
      Y1    = EXP(ALNH*Z(1))
      IF(NKON.LE.5) THEN
C  resolved kinematic
        Y2  =-(1.D0-Y1)+2.D0*(1.D0-Y1)*Z(2)
        X1  = 0.5D0*(Y2+SQRT(Y2*Y2+4.D0*Y1))
        X2  = X1-Y2
        X1 = MIN(X1,0.999999999999D0)
        X2 = MIN(X2,0.999999999999D0)
      ELSE IF(NKON.LE.7) THEN
C  direct kinematic 1
        X1 = 1.D0
        X2 = MIN(Y1,0.999999999999D0)
      ELSE IF(NKON.LE.9) THEN
C  direct kinematic 2
        X1 = MIN(Y1,0.999999999999D0)
        X2 = 1.D0
      ELSE
C  double direct kinematic
        X1 = 1.D0
        X2 = 1.D0
      ENDIF
      W   = SQRT(MAX(TINY,1.D0-AH/Y1))
      V   =-0.5D0+W*(Z(3)-0.5D0)
      U   =-(1.D0+V)
      PT  = MAX(SQRT(U*V*Y1*ECMX*ECMX),PTCUT)

C  set hard scale  QQ  for alpha and partondistr.
      IF     ( NQQAL.EQ.1 ) THEN
        QQAL = AQQAL*PT*PT
      ELSEIF ( NQQAL.EQ.2 ) THEN
        QQAL = AQQAL*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
      ELSEIF ( NQQAL.EQ.3 ) THEN
        QQAL = AQQAL*Y1*ECMX*ECMX
      ELSEIF ( NQQAL.EQ.4 ) THEN
        QQAL = AQQAL*Y1*ECMX*ECMX*(U*V)**(1./3.)
      ENDIF
      IF     ( NQQPD.EQ.1 ) THEN
        QQPD = AQQPD*PT*PT
      ELSEIF ( NQQPD.EQ.2 ) THEN
        QQPD = AQQPD*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
      ELSEIF ( NQQPD.EQ.3 ) THEN
        QQPD = AQQPD*Y1*ECMX*ECMX
      ELSEIF ( NQQPD.EQ.4 ) THEN
        QQPD = AQQPD*Y1*ECMX*ECMX*(U*V)**(1./3.)
      ENDIF
C
      IF(NKON.LE.5) THEN
        DO 10 N=1,5
          F(N) = 0.D0
 10     CONTINUE
C  resolved processes
        ALPHA1 = PHO_ALPHAS(QQAL,3)
        ALPHA2 = ALPHA1
        CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
        CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
C  calculate full distribution FDIS
        DO 20 I=1,NF
          F(2) = F(2)+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
          F(3) = F(3)+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
          F(4) = F(4)+PDA(I)+PDA(-I)
          F(5) = F(5)+PDB(I)+PDB(-I)
20      CONTINUE
        F(1)   = PDA(0)*PDB(0)
        T      = PDA(0)*F(5)+PDB(0)*F(4)
        F(5)   = F(4)*F(5)-(F(2)+F(3))
        F(4)   = T
      ELSE IF(NKON.LE.7) THEN
C  direct processes particle 1
        IF(IDPDG1.EQ.22) THEN
          ALPHA1 = PHO_ALPHAE(QQAL)
          CH1 = 4.D0/9.D0
          CH2 = 3.D0/9.D0
        ELSE IF(IDPDG1.EQ.990) THEN
          ALPHA1 = PARMDL(74)
          CH1 = 1.D0
          CH2 = 0.D0
        ELSE
          FDIS = -1.D0
          RETURN
        ENDIF
        ALPHA2 = PHO_ALPHAS(QQAL,2)
        CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
        F(6) = 0.D0
        DO 30 I=1,NF
          F(6) = F(6)+(PDB(I)+PDB(-I))*(CH1-CH2*MOD(I,2))
 30     CONTINUE
        F(7)   = PDB(0)
      ELSE IF(NKON.LE.9) THEN
C  direct processes particle 2
        ALPHA1 = PHO_ALPHAS(QQAL,1)
        IF(IDPDG2.EQ.22) THEN
          ALPHA2 = PHO_ALPHAE(QQAL)
          CH1 = 4.D0/9.D0
          CH2 = 3.D0/9.D0
        ELSE IF(IDPDG2.EQ.990) THEN
          ALPHA2 = PARMDL(74)
          CH1 = 1.D0
          CH2 = 0.D0
        ELSE
          FDIS = -1.D0
          RETURN
        ENDIF
        CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
        F(8) = 0.D0
        DO 40 I=1,NF
          F(8) = F(8)+(PDA(I)+PDA(-I))*(CH1-CH2*MOD(I,2))
 40     CONTINUE
        F(9)   = PDA(0)
      ELSE
C  double direct process
        SSR = ECMX*ECMX
        IF(IDPDG1.EQ.22) THEN
          ALPHA1 = PHO_ALPHAE(SSR)
        ELSE IF(IDPDG1.EQ.990) THEN
          ALPHA1 = PARMDL(74)
        ELSE
          FDIS = -1.D0
          RETURN
        ENDIF
        IF(IDPDG2.EQ.22) THEN
          ALPHA2 = PHO_ALPHAE(SSR)
        ELSE IF(IDPDG2.EQ.990) THEN
          ALPHA2 = PARMDL(74)
        ELSE
          FDIS = -1.D0
          RETURN
        ENDIF
        F(10) = 1.D0
      ENDIF

      FDIS   = MAX(0.D0,F(NKON)*ALPHA1*ALPHA2)

C  debug output
      IF (LPRI.GT.4 .AND. IDEB(64).GE.20)
     &WRITE(LO,'(1X,A,/2X,I3,2I6,7E11.3)')
     &  'PHO_HARWGI: NKON,ID1,ID2,AL1,AL2,X1,X2,PT,F(NKON),FDIS',
     &  NKON,IDPDG1,IDPDG2,ALPHA1,ALPHA2,X1,X2,PT,F(NKON),FDIS

      END


 
 


CDECK  ID>, PHO_HARWGX
      SUBROUTINE PHO_HARWGX(PTCUT,ECM)
C**********************************************************************
C
C     find maximum of remaining weight for MC sampling
C
C     input:   PTCUT  transverse momentum cutoff
C              ECM    cms energy
C
C     output:  HWgx(-1:Max_pro_2)  field for sampling hard processes
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( NKM = 10 )
      PARAMETER ( TINY = 1.D-20 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  current beam selection
      INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN
      INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL
      DOUBLE PRECISION SQSGLOBMAX
      PARAMETER (MPARMAX=40)
      PARAMETER (MAXMAPPS=40)
      PARAMETER (IKNOWN=9)
      DIMENSION IPAVAIL(IKNOWN)
      DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/
      COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS),
     &           MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  data on most recent hard scattering
      INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
      DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
     &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
      COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
     &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
     &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
     &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC

C  hard cross sections and MC selection weights
      INTEGER Max_pro_2
      PARAMETER ( Max_pro_2 = 16 )
      INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
     &  MH_acc_1,MH_acc_2
      DOUBLE PRECISION HFAC, HWGX, HSIG, HDPT, HECM_LAST, 
     &   HQ2A_LAST, HQ2B_LAST
      COMMON /POHRCS/HFAC(-1:MAX_PRO_2, MPARMAX), 
     &   HWGX(-1:MAX_PRO_2, MPARMAX),
     &   HSIG(-1:MAX_PRO_2, MPARMAX), HDPT(-1:MAX_PRO_2, MPARMAX), 
     &   HECM_LAST, HQ2A_LAST, HQ2B_LAST, IHA_LAST, IHB_LAST, 
     &   MH_PRO_ON(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_TRIED(-1:MAX_PRO_2, 0:4, MPARMAX), 
     &   MH_ACC_1(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_ACC_2(-1:MAX_PRO_2, 0:4, MPARMAX) 

      DIMENSION Z(3),D(3),FF(0:NKM),PDA(-6:6),PDB(-6:6),XM1(NKM),
     &  XM2(NKM),PTM(NKM),ZMX(3,NKM),DMX(3,NKM),IMX(NKM),IPO(NKM)
      DIMENSION IFTAB(-1:Max_pro_2)

C  initial settings
      DATA IFTAB  / 4,0,1,2,4,1,2,2,3,5,0,6,7,8,9,10,0,10 /


      AH    = (2.D0*PTCUT/ECM)**2
      ALNH  = LOG(AH)
      FF(0) = 0.D0
      DO 22 I=1,NKM
        FF(I) = 0.D0
        XM1(I) = 0.D0
        XM2(I) = 0.D0
        PTM(I) = 0.D0
        ZMX(1,I) = 0.D0
        ZMX(2,I) = 0.D0
        ZMX(3,I) = 0.D0
        DMX(1,I) = 0.D0
        DMX(2,I) = 0.D0
        DMX(3,I) = 0.D0
        IMX(I) = 0
        IPO(I) = 0
 22   CONTINUE

      NKML = 10
      DO 40 NKON=1,NKML

        DO 50 IST=1,3
C  start configuration
        IF(IST.EQ.1) THEN
          Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
          Z(2) = 0.5
          Z(3) = 0.1
          D(1) =-0.5
          D(2) = 0.5
          D(3) = 0.5
        ELSE IF(IST.EQ.2) THEN
          Z(1) = 0.999D0
          Z(2) = 0.5
          Z(3) = 0.0
          D(1) =-0.5
          D(2) = 0.5
          D(3) = 0.5
        ELSE IF(IST.EQ.3) THEN
          Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
          Z(2) = 0.1
          Z(3) = 0.1
          D(1) =-0.5
          D(2) = 0.5
          D(3) = 0.5
        ELSE IF(IST.EQ.4) THEN
          Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
          Z(2) = 0.9
          Z(3) = 0.1
          D(1) =-0.5
          D(2) = 0.5
          D(3) = 0.5
        ENDIF
        IT   = 0
        CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F2)
C  process possible?
        IF(F2.LE.0.D0) GOTO 35

 10     CONTINUE
          IT   = IT+1
          FOLD = F2
          DO 30 I=1,3
            D(I) = D(I)/5.D0
            Z(I)   = Z(I)+D(I)
            CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
            IF ( F2.GT.F3 ) Z(I) = Z(I)-D(I)
            IF ( F2.GT.F3 ) D(I) =-D(I)
 20         CONTINUE
              F1   = MIN(F2,F3)
              F2   = MAX(F2,F3)
              Z(I) = Z(I)+D(I)
              CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
            IF ( F3.GT.F2 ) GOTO 20
            ZZ     = Z(I)-D(I)
            Z(I)   = ZZ+0.5*D(I)*(F3-F1)/MAX(TINY,F2+F2-F1-F3)
            IF ( ABS(ZZ-Z(I)).GT.D(I)*0.1D0 )
     &        CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F1)
            IF ( F1.LE.F2 ) Z(I) = ZZ
            F2     = MAX(F1,F2)
 30       CONTINUE
        IF((ABS(FOLD-F2)/MAX(TINY,F2).GT.0.002D0).OR.(IT.LT.3)) GOTO 10

        IF(F2.GT.FF(NKON)) THEN
          FF(NKON)  = MAX(F2,0.D0)
          XM1(NKON) = X1
          XM2(NKON) = X2
          PTM(NKON) = PT
          ZMX(1,NKON) = Z(1)
          ZMX(2,NKON) = Z(2)
          ZMX(3,NKON) = Z(3)
          DMX(1,NKON) = D(1)
          DMX(2,NKON) = D(2)
          DMX(3,NKON) = D(3)
          IMX(NKON) = IT
          IPO(NKON) = IST
        ENDIF
C
 50     CONTINUE
 35     CONTINUE
 40   CONTINUE

C  debug output
      IF(IDEB(38).GE.5) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A)')
     &    'PHO_HARWGX: maximum of weight (I,IT,IS,FF,Z(1-3),D(1-3))'
        DO 60 I=1,NKM
          IF (LPRI.GT.4 .AND. IMX(I).NE.0)
     &    WRITE(LO,'(1X,I2,I3,I2,7E10.3)') I,IMX(I),
     &      IPO(I),FF(I),ZMX(1,I),ZMX(2,I),ZMX(3,I),DMX(1,I),
     &      DMX(2,I),DMX(3,I)
 60     CONTINUE
      ENDIF

      DO 70 I=-1,Max_pro_2
        HWgx(I,IDXMPAR)  = MAX(FF(IFTAB(I))*Hfac(I,IDXMPAR),0.D0)
 70   CONTINUE

C  debug output
      IF(IDEB(38).GE.5) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A)') 'PHO_HARWGX: total weights'
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A)') 'I    X1   X2   PT   HWgx(I)  FDIS'
        DO 80 I=-1,Max_pro_2
          IF((IFTAB(I).NE.0).AND.(HWgx(I,IDXMPAR).GT.0.D0)) THEN
            MSPR = I
            X1 = MIN(XM1(IFTAB(I)),0.9999999999D0)
            X2 = MIN(XM2(IFTAB(I)),0.9999999999D0)
            PT = PTM(IFTAB(I))
            CALL PHO_HARWGH(PDS,PDA,PDB,FDIS)
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,I3,5E12.3)') I,X1,X2,PT,HWgx(I,IDXMPAR),FDIS
          ENDIF
 80     CONTINUE
      ENDIF

      END


 
 


CDECK  ID>, PHO_HARX12
      SUBROUTINE PHO_HARX12
C**********************************************************************
C
C     selection of x1 and x2 according to 1/x1*1/x2
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  data on most recent hard scattering
      INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
      DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
     &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
      COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
     &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
     &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
     &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC


10    CONTINUE
        Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
        Z2 = Z2MAX-DT_RNDM(X2)*Z2DIF
        IF ( (Z1+Z2).LT.ALNH ) GOTO 10
      X1   = EXP(Z1)
      X2   = EXP(Z2)
      AXX  = AH/(X1*X2)
      W    = SQRT(MAX(TINY,1.D0-AXX))
      W1   = AXX/(1.D0+W)

      END


 
 


CDECK  ID>, PHO_HARXD2
      SUBROUTINE PHO_HARXD2(ECMH,PT,ETAC,DSIGMC)
C**********************************************************************
C
C     differential cross section DSIG/(DETAC*DPT) for direct processes
C
C     input:  ECMH     CMS energy of scattering system
C             PT       parton PT
C             ETAC     pseudorapidity of parton C
C
C     output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( Max_pro_2 = 16 )
      COMPLEX*16 DSIGMC
      DIMENSION DSIGMC(0:Max_pro_2)
      PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-25)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  data of c.m. system of Pomeron / Reggeon exchange
      INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
      DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
     &                 SIDP,CODP,SIFP,COFP
      COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
     &                SIDP,CODP,SIFP,COFP,NPOSP(2),
     &                IDPDG1,IDBAM1,IDPDG2,IDBAM2

C  Reggeon phenomenology parameters
      DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
     &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
      COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
     &                ALREG,ALREGP,GR(2),B0REG(2),
     &                GPPP,GPPR,B0PPP,B0PPR,
     &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC

C  currently activated parton density parametrizations
      CHARACTER*8 PDFNAM
      INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
      DOUBLE PRECISION PDFLAM,PDFQ2M
      COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
     &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD

C  hard scattering parameters used for most recent hard interaction
      INTEGER NFbeta,NF
      DOUBLE PRECISION ALQCD2,BQCD
      COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF

C  some hadron information, will be deleted in future versions
      INTEGER NFS
      DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
      COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS

C  scale parameters for parton model calculations
      INTEGER NQQAL,NQQALI,NQQALF,NQQPD
      DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
      COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
     &                NQQAL,NQQALI,NQQALF,NQQPD

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

      DOUBLE PRECISION PHO_ALPHAS,PHO_ALPHAE
      EXTERNAL         PHO_ALPHAS,PHO_ALPHAE
      DIMENSION PDA(-6:6),PDB(-6:6),DSIGM(0:Max_pro_2)

*     ONE32=1.D0/9.D0
*     TWO32=4.D0/9.D0
      DO 10 I=10,13
        DSIGMC(I) = DCMPLX(0.D0,0.D0)
        DSIGM(I) = 0.D0
 10   CONTINUE
      DSIGMC(15) = DCMPLX(0.D0,0.D0)
      DSIGM(15) = 0.D0

C  direct particle 1
      IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
        EC     = EXP(ETAC)
        ED     = ECMH/PT-EC
C  kinematic conversions
        XA     = 1.D0
        XB     = 1.D0/(EC*ED)
        IF ( XB.GE.1.D0 ) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,2E12.4)')
     &      'PHO_HARXD2:ERROR: XB>1 (XA,XB)',XA,XB
          RETURN
        ENDIF
        SP     = XA*XB*ECMH*ECMH
        UP     =-ECMH*PT*EC*XB
        UP     = UP/SP
        TP     =-(1.D0+UP)
        UU     = UP*UP
        TT     = TP*TP
C  set hard scale  QQ  for alpha and partondistr.
        IF     ( NQQAL.EQ.1 ) THEN
          QQAL = AQQAL*PT*PT
        ELSEIF ( NQQAL.EQ.2 ) THEN
          QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
        ELSEIF ( NQQAL.EQ.3 ) THEN
          QQAL = AQQAL*SP
        ELSEIF ( NQQAL.EQ.4 ) THEN
          QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
        ENDIF
        IF     ( NQQPD.EQ.1 ) THEN
          QQPD = AQQPD*PT*PT
        ELSEIF ( NQQPD.EQ.2 ) THEN
          QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
        ELSEIF ( NQQPD.EQ.3 ) THEN
          QQPD = AQQPD*SP
        ELSEIF ( NQQPD.EQ.4 ) THEN
          QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
        ENDIF

        ALPHA2 = PHO_ALPHAS(QQAL,2)
        IF(IDPDG1.EQ.22) THEN
          ALPHA1 = PHO_ALPHAE(QQAL)
        ELSE IF(IDPDG1.EQ.990) THEN
          ALPHA1 = PARMDL(74)
        ENDIF
        FACTOR = -PI2*GEV2MB*UP/PT*ALPHA1*ALPHA2/SP*AKFAC
C  parton distribution (times x)
        CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
        S1    = PDB(0)
C  charge counting
        S2    = 0.D0
        S3    = 0.D0
        IF(IDPDG1.EQ.22) THEN
          DO 20 I=1,NF
*           IF(MOD(I,2).EQ.0) THEN
*             S2 = S2 + (PDB(I)+PDB(-I))*TWO32
*             S3 = S3 + TWO32
*           ELSE
*             S2 = S2 + (PDB(I)+PDB(-I))*ONE32
*             S3 = S3 + ONE32
*           ENDIF
            S2 = S2 + (PDB(I)+PDB(-I))*Q_ch2(I)
            S3 = S3 + Q_ch2(I)
 20       CONTINUE
        ELSE IF(IDPDG1.EQ.990) THEN
          DO 25 I=1,NF
            S2 = S2 + PDB(I)+PDB(-I)
 25       CONTINUE
          S3 = NF
        ENDIF
C  partial cross sections (including color and symmetry factors)
C  direct photon matrix elements
        DSIGM(10) = -8.D0/3.D0*(UU+1.D0)/UP
        DSIGM(11) = (UU+TT)/(UP*TP)
C
        DSIGM(10) = FACTOR*DSIGM(10)*S2
        DSIGM(11) = FACTOR*DSIGM(11)*S1*S3
C  complex part
        X=ABS(TP-UP)
        FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
C
        DO 50 I=10,11
          IF(DSIGM(I).LT.0.D0) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,A,I3,1P,2E12.4)')
     &        'PHO_HARXD2: neg. cross section',I,DSIGM(I),ECMH
            DSIGM(I) = 0.D0
          ENDIF
          DSIGMC(I) = DCMPLX(DSIGM(I),DSIGM(I)*FAC2)
          DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
 50     CONTINUE
      ENDIF
C
C  direct particle 2
      IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
        EC     = EXP(ETAC)
        ED     = 1.D0/(ECMH/PT-1.D0/EC)
C  kinematic conversions
        XA     = PT*(EC+ED)/ECMH
        XB     = 1.D0
        IF ( XA.GE.1.D0 ) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,2E12.4)')
     &      'PHO_HARXD2:ERROR:XA>1 (XA,XB)',XA,XB
          RETURN
        ENDIF
        SP     = XA*XB*ECMH*ECMH
        UP     =-ECMH*PT*EC*XB
        UP     = UP/SP
        TP     =-(1.D0+UP)
        UU     = UP*UP
        TT     = TP*TP
C  set hard scale  QQ  for alpha and partondistr.
        IF     ( NQQAL.EQ.1 ) THEN
          QQAL = AQQAL*PT*PT
        ELSEIF ( NQQAL.EQ.2 ) THEN
          QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
        ELSEIF ( NQQAL.EQ.3 ) THEN
          QQAL = AQQAL*SP
        ELSEIF ( NQQAL.EQ.4 ) THEN
          QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
        ENDIF
        IF     ( NQQPD.EQ.1 ) THEN
          QQPD = AQQPD*PT*PT
        ELSEIF ( NQQPD.EQ.2 ) THEN
          QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
        ELSEIF ( NQQPD.EQ.3 ) THEN
          QQPD = AQQPD*SP
        ELSEIF ( NQQPD.EQ.4 ) THEN
          QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
        ENDIF

        ALPHA1 = PHO_ALPHAS(QQAL,1)
        IF(IDPDG2.EQ.22) THEN
          ALPHA2 = PHO_ALPHAE(QQAL)
        ELSE IF(IDPDG2.EQ.990) THEN
          ALPHA2 = PARMDL(74)
        ENDIF
        FACTOR = -PI2*GEV2MB*TP/PT*ALPHA1*ALPHA2/SP*AKFAC
C  parton distribution (times x)
        CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
        S1    = PDA(0)
C  charge counting
        S2    = 0.D0
        S3    = 0.D0
        IF(IDPDG2.EQ.22) THEN
          DO 70 I=1,NF
*           IF(MOD(I,2).EQ.0) THEN
*             S2 = S2 + (PDA(I)+PDA(-I))*TWO32
*             S3 = S3 + TWO32
*           ELSE
*             S2 = S2 + (PDA(I)+PDA(-I))*ONE32
*             S3 = S3 + ONE32
*           ENDIF
            S2 = S2 + (PDA(I)+PDA(-I))*Q_ch2(I)
            S3 = S3 + Q_ch2(I)
 70       CONTINUE
        ELSE IF(IDPDG2.EQ.990) THEN
          DO 75 I=1,NF
            S2 = S2 + PDA(I)+PDA(-I)
 75       CONTINUE
          S3 = NF
        ENDIF
C  partial cross sections (including color and symmetry factors)
C  direct photon matrix elements
        DSIGM(12) = -8.D0/3.D0*(TT+1.D0)/TP
        DSIGM(13) = (UU+TT)/(UP*TP)
C
        DSIGM(12) = FACTOR*DSIGM(12)*S2
        DSIGM(13) = FACTOR*DSIGM(13)*S3*S1
C  complex part
        X=ABS(TP-UP)
        FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
C
        DO 80 I=12,13
          IF(DSIGM(I).LT.0.D0) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,A,I3,1P,2E12.4)')
     &        'PHO_HARXD2: neg. cross section:',I,DSIGM(I),ECMH
            DSIGM(I) = 0.D0
          ENDIF
          DSIGMC(I) = DCMPLX(DSIGM(I),DSIGM(I)*FAC2)
          DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
 80     CONTINUE
      ENDIF
      END


 
 


CDECK  ID>, PHO_HARXPT
      SUBROUTINE PHO_HARXPT(ECMH,PT,IPRO,DSIGMC)
C**********************************************************************
C
C     differential cross section DSIG/DPT
C
C     input:  ECMH     CMS energy of scattering system
C             PT       parton PT
C             IPRO     1  resolved processes
C                      2  direct processes
C                      3  resolved and direct processes
C
C     output: DSIGMC(0:12) QCD-PM cross sections dsigma/dpt
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( Max_pro_2 = 16 )
      COMPLEX*16 DSIGMC
      DIMENSION  DSIGMC(0:Max_pro_2)
      PARAMETER ( TINY= 1.D-10, ONEP1=1.1, EPS=1.D-25)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  data of c.m. system of Pomeron / Reggeon exchange
      INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
      DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
     &                 SIDP,CODP,SIFP,COFP
      COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
     &                SIDP,CODP,SIFP,COFP,NPOSP(2),
     &                IDPDG1,IDBAM1,IDPDG2,IDBAM2

C  Reggeon phenomenology parameters
      DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
     &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
      COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
     &                ALREG,ALREGP,GR(2),B0REG(2),
     &                GPPP,GPPR,B0PPP,B0PPR,
     &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC

C  integration precision for hard cross sections (obsolete)
      INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
      COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO

C  hard scattering parameters used for most recent hard interaction
      INTEGER NFbeta,NF
      DOUBLE PRECISION ALQCD2,BQCD
      COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF

C  some hadron information, will be deleted in future versions
      INTEGER NFS
      DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
      COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS

      DOUBLE PRECISION PHO_ALPHAE
      EXTERNAL         PHO_ALPHAE

      COMPLEX*16 DSIG1
      DIMENSION  DSIG1(0:Max_pro_2)
      DIMENSION ABSZ(32),WEIG(32)

      DO 10 M=0,Max_pro_2
        DSIGMC(M) = DCMPLX(0.D0,0.D0)
        DSIG1(M)  = DCMPLX(0.D0,0.D0)
 10   CONTINUE

C  resolved and direct processes
      AMT = 2.D0*PT/ECMH
      IF ( AMT.GE.1.D0 ) RETURN
      ECU = LOG((SQRT(1.D0-AMT*AMT)+1.D0)/AMT)
      ECL = -ECU
      NPOINT = NGAUET
      CALL PHO_GAUSET(ECL,ECU,NPOINT,ABSZ,WEIG)
      DO 30 I=1,NPOINT
        DSIG1(9)  = DCMPLX(0.D0,0.D0)
        DSIG1(15) = DCMPLX(0.D0,0.D0)
        IF(IPRO.EQ.1) THEN
          CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
        ELSE IF(IPRO.EQ.2) THEN
          CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
        ELSE
          CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
          CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
        ENDIF
        DO 20 M=1,Max_pro_2
          DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
 20     CONTINUE
 30   CONTINUE

C  direct processes
      IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
     &   .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
        FAC = 0.D0
        SS = ECMH*ECMH
        ALPHAE = PHO_ALPHAE(SS)
        DO 300 I=1,NF
          IF(IDPDG1.EQ.22) THEN
*           F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
            F1 = Q_ch2(I)*ALPHAE
          ELSE
            F1 = PARMDL(74)
          ENDIF
          IF(IDPDG2.EQ.22) THEN
*           F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
            F2 = Q_ch2(I)*ALPHAE
          ELSE
            F2 = PARMDL(74)
          ENDIF
          FAC = FAC+F1*F2*3.D0
 300    CONTINUE
C  direct cross sections
        ZZ = SQRT(1.D0-4.D0*PT*PT/SS+TINY)
        T1 = -SS/2.D0*(1.D0+ZZ)
        T2 = -SS/2.D0*(1.D0-ZZ)
        XM = -2.D0*PT/ZZ*((SS+T1)/T1+T1/(SS+T1)+(SS+T2)/T2+T2/(SS+T2))
C  hadronic part
        DSIGMC(14) = GEV2MB*2.D0*PI*FAC/(SS*SS)*XM*AKFAC

C  leptonic part (e, mu, tau)
        DSIGMC(16) = 0.D0
        IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
          DSIGMC(16) = DSIGMC(14)/FAC*3.D0*ALPHAE**2
C  simulation of tau together with quarks
          IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
        ENDIF
      ENDIF

      DSIGMC(15) = DSIGMC(15)+DSIGMC(14)
      DSIGMC(0)  = DSIGMC(9)+DSIGMC(15)

      END


 
 


CDECK  ID>, PHO_HARXR2
      SUBROUTINE PHO_HARXR2(ECMH,PT,ETAC,DSIGMC)
C**********************************************************************
C
C     differential cross section DSIG/(DETAC*DPT)
C
C     input:  ECMH     CMS energy
C             PT       parton PT
C             ETAC     pseudorapidity of parton C
C
C     output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( TINY= 1.D-20 )

      PARAMETER ( Max_pro_2 = 16 )
      COMPLEX*16 DSIGMC
      DIMENSION DSIGMC(0:Max_pro_2)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  integration precision for hard cross sections (obsolete)
      INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
      COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO

      COMPLEX*16 DSIG1
      DIMENSION DSIG1(0:Max_pro_2)
      DIMENSION ABSZ(32),WEIG(32)

      DO 10 M=1,9
        DSIGMC(M) = DCMPLX(0.D0,0.D0)
        DSIG1(M)  = 0.D0
10    CONTINUE
C
      EC  = EXP(ETAC)
      ARG = ECMH/PT
      IF  ( ARG.LE.EC .OR. ARG.LE.1.D0/EC ) RETURN
      EDU = LOG(ARG-EC)
      EDL =-LOG(ARG-1.D0/EC)
      NPOINT = NGAUET
      CALL PHO_GAUSET(EDL,EDU,NPOINT,ABSZ,WEIG)
      DO 30 I=1,NPOINT
        CALL PHO_HARXR3(ECMH,PT,ETAC,ABSZ(I),DSIG1)
        DO 20 M=1,9
          PCTRL= DREAL(DSIG1(M))/TINY
          IF( PCTRL.GE.1.D0 ) THEN
            DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
          ENDIF
20      CONTINUE
30    CONTINUE
      END


 
 


CDECK  ID>, PHO_HARXR3
      SUBROUTINE PHO_HARXR3(ECMH,PT,ETAC,ETAD,DSIGMC)
C**********************************************************************
C
C     differential cross section DSIG/(DETAC*DETAD*DPT)
C
C     input:  ECMH     CMS energy
C             PT       parton PT
C             ETAC     pseudorapidity of parton C
C             ETAD     pseudorapidity of parton D
C
C     output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac/detad
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-20)

      PARAMETER ( Max_pro_2 = 16 )
      COMPLEX*16 DSIGMC
      DIMENSION DSIGMC(0:Max_pro_2)
      DIMENSION DSIGM(0:Max_pro_2)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

C  Reggeon phenomenology parameters
      DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
     &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
      COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
     &                ALREG,ALREGP,GR(2),B0REG(2),
     &                GPPP,GPPR,B0PPP,B0PPR,
     &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC

C  currently activated parton density parametrizations
      CHARACTER*8 PDFNAM
      INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
      DOUBLE PRECISION PDFLAM,PDFQ2M
      COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
     &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD

C  hard scattering parameters used for most recent hard interaction
      INTEGER NFbeta,NF
      DOUBLE PRECISION ALQCD2,BQCD
      COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF

C  scale parameters for parton model calculations
      INTEGER NQQAL,NQQALI,NQQALF,NQQPD
      DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
      COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
     &                NQQAL,NQQALI,NQQALF,NQQPD

      DOUBLE PRECISION PHO_ALPHAS
      DIMENSION PDA(-6:6),PDB(-6:6)

      DO 10 I=1,9
        DSIGMC(I) = DCMPLX(0.D0,0.D0)
        DSIGM(I)  = 0.D0
10    CONTINUE

      EC     = EXP(ETAC)
      ED     = EXP(ETAD)
C  kinematic conversions
      XA     = PT*(EC+ED)/ECMH
      XB     = XA/(EC*ED)
      IF((XA.GE.1.D0).OR.(XB.GE.1.D0)) THEN
        IF (LPRI.GT.4)
     .  WRITE(LO,'(/1X,A,2E12.4)') 'PHO_HARXR3:ERROR:X1 OR X2 > 1',XA,XB
        RETURN
      ENDIF
      SP     = XA*XB*ECMH*ECMH
      UP     =-ECMH*PT*EC*XB
      UP     = UP/SP
      TP     =-(1.D0+UP)
      UU     = UP*UP
      TT     = TP*TP
C  set hard scale  QQ  for alpha and partondistr.
      IF     ( NQQAL.EQ.1 ) THEN
        QQAL = AQQAL*PT*PT
      ELSEIF ( NQQAL.EQ.2 ) THEN
        QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
      ELSEIF ( NQQAL.EQ.3 ) THEN
        QQAL = AQQAL*SP
      ELSEIF ( NQQAL.EQ.4 ) THEN
        QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
      ENDIF
      IF     ( NQQPD.EQ.1 ) THEN
        QQPD = AQQPD*PT*PT
      ELSEIF ( NQQPD.EQ.2 ) THEN
        QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
      ELSEIF ( NQQPD.EQ.3 ) THEN
        QQPD = AQQPD*SP
      ELSEIF ( NQQPD.EQ.4 ) THEN
        QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
      ENDIF
      
      ALPHA  = PHO_ALPHAS(QQAL,3)
      FACTOR = PI2*GEV2MB*PT*(ALPHA/SP)**2*AKFAC
C  parton distributions (times x)
      CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
      CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
      S1    = PDA(0)*PDB(0)
      S2    = 0.D0
      S3    = 0.D0
      S4    = 0.D0
      S5    = 0.D0
      DO 20 I=1,NF
        S2  = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
        S3  = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
        S4  = S4+PDA(I)+PDA(-I)
        S5  = S5+PDB(I)+PDB(-I)
20    CONTINUE
C  partial cross sections (including color and symmetry factors)
C  resolved photon matrix elements (light quarks)
      DSIGM(1) = 2.25D0*(3.-((UP*TP)+UP/TT+TP/UU))
      DSIGM(6) = (4.D0/9.D0)*(UU+TT)
      DSIGM(8) = (4.D0/9.D0)*(1.D0+UU)/TT
      DSIGM(2) = (16.D0/27.D0)*(UU+TT)/(UP*TP)-3.D0*DSIGM(6)
      DSIGM(3) = ((1.D0+UU)/TT)-(4.D0/9.D0)*(1.D0+UU)/UP
      DSIGM(4) = (9.D0/32.D0)*DSIGM(2)
      DSIGM(5) = DSIGM(6)+DSIGM(8)-(8.D0/27.D0)*UU/TP
      DSIGM(7) = 0.5D0*(DSIGM(8)+(4.D0/9.D0)*(1.D0+TT)/UU-
     &           (8.D0/27.D0)/(UP*TP))
C
      DSIGM(1) = FACTOR*DSIGM(1)*S1
      DSIGM(2) = FACTOR*DSIGM(2)*S2
      DSIGM(3) = FACTOR*DSIGM(3)*(PDA(0)*S5+PDB(0)*S4)
      DSIGM(4) = FACTOR*DSIGM(4)*S1*NF
      DSIGM(5) = FACTOR*DSIGM(5)*S2
      DSIGM(6) = FACTOR*DSIGM(6)*S2*MAX(0,(NF-1))
      DSIGM(7) = FACTOR*DSIGM(7)*S3
      DSIGM(8) = FACTOR*DSIGM(8)*(S4*S5-(S2+S3))
C  complex part
      X=ABS(TP-UP)
      FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
C
      DO 50 I=1,8
        IF(DSIGM(I).LT.EPS) DSIGM(I) = 0.D0
        DSIGMC(I) = DCMPLX(DSIGM(I),DSIGM(I)*FAC2)
        DSIGMC(9) = DSIGMC(9)+DSIGMC(I)
 50   CONTINUE
      END


 
 


CDECK  ID>, PHO_HARXTO
      SUBROUTINE PHO_HARXTO(ECMH,PTCUTR,PTCUTD,DSIGMC,DSDPTC)
C**********************************************************************
C
C     total hard cross section (perturbative QCD, Parton Model)
C
C     input:  ECMH     CMS energy of scattering system
C             PTCUTR   PT cutoff for resolved processes
C             PTCUTD   PT cutoff for direct processes (photon, Pomeron)
C
C     output: DSIGMC(0:MARPR2) cross sections for given cutoff
C             DSDPTC(0:MARPR2) differential cross sections at cutoff
C
C     note:  COMPLEX*16          DSIGMC
C            DOUBLE PRECISION    DSDPTC
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( Max_pro_2 = 16 )
      COMPLEX*16 DSIGMC
      DIMENSION DSIGMC(0:Max_pro_2),DSDPTC(0:Max_pro_2)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  data of c.m. system of Pomeron / Reggeon exchange
      INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
      DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
     &                 SIDP,CODP,SIFP,COFP
      COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
     &                SIDP,CODP,SIFP,COFP,NPOSP(2),
     &                IDPDG1,IDBAM1,IDPDG2,IDBAM2

C  Reggeon phenomenology parameters
      DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
     &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
      COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
     &                ALREG,ALREGP,GR(2),B0REG(2),
     &                GPPP,GPPR,B0PPP,B0PPR,
     &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

C  integration precision for hard cross sections (obsolete)
      INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
      COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO

C  some hadron information, will be deleted in future versions
      INTEGER NFS
      DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
      COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS

C  hard scattering parameters used for most recent hard interaction
      INTEGER NFbeta,NF
      DOUBLE PRECISION ALQCD2,BQCD
      COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF

      DOUBLE PRECISION PHO_ALPHAE
      EXTERNAL         PHO_ALPHAE

      COMPLEX*16 DSIG1
      DIMENSION DSIG1(0:Max_pro_2)
      DIMENSION ABSZ(32),WEIG(32)

      DATA FAC / 3.0D0 /

      DO 10 M=0,Max_pro_2
        DSIGMC(M)= DCMPLX(0.D0,0.D0)
 10   CONTINUE
C  integration up to kin. limit, but not further than PARMDL(96) GeV
      EEC = MIN(ECMH/2.001D0, PARMDL(96))
C
      IF ( PTCUTR.GE.EEC ) GOTO 100
C
C  integration for resolved processes
      PTMIN  = PTCUTR
      PTMAX  = MIN(FAC*PTMIN,EEC)
      NPOINT = NGAUP1
      CALL PHO_HARXPT(ECMH,PTMIN,1,DSIG1)
      DO 60 M=1,9
        DSDPTC(M) = DREAL(DSIG1(M))
 60   CONTINUE
      DSIGH   = DREAL(DSIG1(9))
      PTMXX  = 0.95D0*PTMAX
      CALL PHO_HARXPT(ECMH,PTMXX,1,DSIG1)
      DSIGL  = DREAL(DSIG1(9))
      EX     = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
      EX1    = 1.0D0-EX
      DO 50 K=1,2
        IF ( PTMIN.GE.PTMAX ) GOTO 40
        RL   = PTMIN**EX1
        RU   = PTMAX**EX1
        CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
        DO 30 I=1,NPOINT
          R  = ABSZ(I)
          PT = R**(1.0D0/EX1)
          CALL PHO_HARXPT(ECMH,PT,1,DSIG1)
          F  = WEIG(I)*PT/(R*EX1)
          DO 20 M=1,9
            DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
 20       CONTINUE
 30     CONTINUE
 40     PTMIN  = PTMAX
        PTMAX  = EEC
        NPOINT = NGAUP2
 50   CONTINUE
 100  CONTINUE
      DSIGMC(0) = DSIGMC(9)
      DSDPTC(0) = DSDPTC(9)
C
C  integration for direct processes
      IF((PTCUTD.GE.EEC).OR.(PTCUTD.LT.0.5D0)) RETURN
C
      IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
     &   .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
        PTMIN  = PTCUTD
        PTMAX  = MIN(FAC*PTMIN,EEC)
        NPOINT = NGAUP1
        CALL PHO_HARXPT(ECMH,PTMIN,2,DSIG1)
        IF(DREAL(DSIG1(15)).LT.1.D-15) GOTO 170
        DO 160 M=10,16
          DSDPTC(M) = DREAL(DSIG1(M))
 160    CONTINUE
        DSIGH   = DREAL(DSIG1(15)-DSIG1(14))
        PTMXX  = 0.95D0*PTMAX
        CALL PHO_HARXPT(ECMH,PTMXX,2,DSIG1)
        DSIGL  = DREAL(DSIG1(15)-DSIG1(14))
        EX     = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
        EX1    = 1.0D0-EX
        DO 150 K=1,2
          IF ( PTMIN.GE.PTMAX ) GOTO 140
          RL   = PTMIN**EX1
          RU   = PTMAX**EX1
          CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
          DO 130 I=1,NPOINT
            R  = ABSZ(I)
            PT = R**(1.0D0/EX1)
            CALL PHO_HARXPT(ECMH,PT,2,DSIG1)
            F  = WEIG(I)*PT/(R*EX1)
            DO 120 M=10,15
              DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
 120        CONTINUE
 130      CONTINUE
 140      PTMIN  = PTMAX
          PTMAX  = EEC
          NPOINT = NGAUP2
 150    CONTINUE
      ENDIF
C
 170  CONTINUE
C
C  double direct process
      IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
     &   .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
        FACC = 0.D0
        SS = ECMH*ECMH
        ALPHAE = PHO_ALPHAE(SS)
        DO 300 I=1,NF
          IF(IDPDG1.EQ.22) THEN
*           F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
            F1 = Q_ch2(I)*ALPHAE
          ELSE
            F1 = PARMDL(74)
          ENDIF
          IF(IDPDG2.EQ.22) THEN
*           F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
            F2 = Q_ch2(I)*ALPHAE
          ELSE
            F2 = PARMDL(74)
          ENDIF
          FACC = FACC + F1*F2*3.D0
 300    CONTINUE

        ZZ = SQRT(1.D0-4.D0*PTCUTD*PTCUTD/SS)
        R  = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)*GEV2MB
C  hadronic cross section
        DSIGMC(14) = R*FACC*AKFAC
C  leptonic cross section
        IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
          DSIGMC(16) = R*3.D0*ALPHAE**2*AKFAC
C  simulation of tau together with quarks
          IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
          DSIGMC(16) = DSIGMC(16)*2.D0/3.D0
        ELSE
          DSIGMC(16) = DCMPLX(0.D0,0.D0)
        ENDIF
C  sum of direct part
        DSIGMC(15) = DCMPLX(0.D0,0.D0)
        DO 400 I=10,14
          DSIGMC(15) = DSIGMC(15) + DSIGMC(I)
 400    CONTINUE
      ENDIF
C total sum (hadronic)
      DSIGMC(0) = DSIGMC(9) + DSIGMC(15)
      DSDPTC(0) = DSDPTC(9) + DSDPTC(15)

      END


 
 


CDECK  ID>, PHO_HARZSP
      SUBROUTINE PHO_HARZSP(IFLA,IFLB,NFSH,ZMIN,ZMAX,ZZ)
C*********************************************************************
C
C     sampling of z values from DGLAP kernels
C
C     input:  IFLA,IFLB      parton flavours
C             NFSH           flavours involved in hard processes
C             ZMIN           minimal ZZ allowed
C             ZMAX           maximal ZZ allowed
C
C     output: ZZ             z value
C
C*********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( DEPS   =  1.D-10 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  internal rejection counters
      INTEGER NMXJ
      PARAMETER (NMXJ=60)
      CHARACTER*10 REJTIT
      INTEGER IFAIL
      COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)


      IF(ZMAX.LE.ZMIN) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,2E12.3)')
     &    'PHO_HARZSP: ZMAX<ZMIN (ZMAX,ZMIN)',ZMAX,ZMIN
        CALL PHO_PREVNT(-1)
        ZZ = 0.D0
        RETURN
      ENDIF
C
      IF(IFLB.EQ.0) THEN
        IF(IFLA.EQ.0) THEN
C  g --> g g
          C1 = ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)
          C2 = (1.D0-ZMIN)/ZMIN
 100      CONTINUE
            ZZ = 1.D0/(1.D0+C2/C1**DT_RNDM(ZMIN))
          IF(((1.D0-ZZ*(1.D0-ZZ))**2).LT.DT_RNDM(ZMAX)) GOTO 100
        ELSE IF(ABS(IFLA).LE.NFSH) THEN
C  q --> q g
          C1 = ZMAX/ZMIN
 200      CONTINUE
            ZZ = ZMIN*C1**DT_RNDM(ZMIN)
          IF((0.5D0*(1.D0+(1.D0-ZZ)**2)).LT.DT_RNDM(ZMAX)) GOTO 200
        ELSE
          GOTO 900
        ENDIF
      ELSE IF(ABS(IFLB).LE.NFSH) THEN
        IF(IFLA.EQ.0) THEN
C  g --> q qb
          C1 = ZMAX-ZMIN
 300      CONTINUE
            ZZ = ZMIN+C1*DT_RNDM(ZMIN)
          IF((2.D0*ZZ*(ZZ-1.D0)+1.D0).LT.DT_RNDM(ZMAX)) GOTO 300
        ELSE IF(ABS(IFLA).LE.NFSH) THEN
C  q --> g q
          C1 = (1.D0-ZMAX)/(1.D0-ZMIN)
          C2 = 1.D0-ZMIN
 400      CONTINUE
            ZZ = 1.D0-C2*C1**DT_RNDM(ZMIN)
          IF(0.5D0*(1.D0+ZZ**2).LT.DT_RNDM(ZMAX)) GOTO 400
        ELSE
          GOTO 900
        ENDIF
      ELSE
        GOTO 900
      ENDIF
C  debug output
      IF (LPRI.GT.4 .AND. IDEB(84).GE.20)
     &WRITE(LO,'(1X,A,2I3,3E11.3)')
     &  'PHO_HARZSP: IFLA,IFLB,ZZ,ZMIN,ZMAX',
     &  IFLA,IFLB,ZZ,ZMIN,ZMAX
      RETURN

 900  CONTINUE
      IF (LPRI.GT.4)
     &WRITE(LO,'(/1X,A,2I7)') 'PHO_HARZSP:ERROR: invalid flavours A,B',
     &  IFLA,IFLB
      CALL PHO_ABORT

      END


 
 


CDECK  ID>, PHO_ID2STR
      SUBROUTINE PHO_ID2STR(ID1,ID2,NOBAM,IBAM1,IBAM2,IBAM3,IBAM4)
C*********************************************************************
C
C     conversion of quark numbering scheme
C
C     input:   standard particle codes:
C                       ID1
C                       ID2
C
C     output:  NOBAM    CPC string code
C              quark codes (PDG convention):
C                       IBAM1
C                       IBAM2
C                       IBAM3
C                       IBAM4
C
C              NOBAM = -1 invalid flavour combinations
C
C*********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI


      IDA1 = ABS(ID1)
      IDA2 = ABS(ID2)

C  quark-antiquark string
      IF((IDA1.LE.6).AND.(IDA2.LE.6)) THEN
        IF((ID1*ID2).GE.0) GOTO 100
        IBAM1 = ID1
        IBAM2 = ID2
        IBAM3 = 0
        IBAM4 = 0
        NOBAM = 3
C  quark-diquark string
      ELSE IF((IDA2.GT.6).AND.(IDA1.LE.6)) THEN
        IF((ID1*ID2).LE.0) GOTO 100
        IBAM1 = ID1
        IBAM2 = ID2/1000
        IBAM3 = (ID2-IBAM2*1000)/100
        IBAM4 = 0
        NOBAM = 4
C  diquark-quark string
      ELSE IF((IDA1.GT.6).AND.(IDA2.LE.6)) THEN
        IF((ID1*ID2).LE.0) GOTO 100
        IBAM1 = ID1/1000
        IBAM2 = (ID1-IBAM1*1000)/100
        IBAM3 = ID2
        IBAM4 = 0
        NOBAM = 6
C  gluon-gluon string
      ELSE IF((IDA1.EQ.21).AND.(IDA2.EQ.21)) THEN
        IBAM1 = 21
        IBAM2 = 21
        IBAM3 = 0
        IBAM4 = 0
        NOBAM = 7
C  diquark-antidiquark string
      ELSE IF((IDA1.GT.6).AND.(IDA2.GT.6)) THEN
        IF((ID1*ID2).GE.0) GOTO 100
        IBAM1 = ID1/1000
        IBAM2 = (ID1-IBAM1*1000)/100
        IBAM3 = ID2/1000
        IBAM4 = (ID2-IBAM3*1000)/100
        NOBAM = 5
      ENDIF
      RETURN

C  invalid combination
 100  CONTINUE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(//1X,A,2I10)')
     &    'PHO_ID2STR: invalid flavors for string (ID1,ID2)',ID1,ID2
        CALL PHO_ABORT

      END


 
 


CDECK  ID>, PHO_IMPAMP
      SUBROUTINE PHO_IMPAMP(EE,BMIN,BMAX,NSTEP)
C*********************************************************************
C
C     calculation of physical  impact parameter amplitude
C
C     input:   EE      cm energy (GeV)
C              BMIN    lower bound in B
C              BMAX    upper bound in B
C              NSTEP   number of values (linear)
C
C     output:  values written to output unit
C
C*********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER(ONEM=-1.D0,
     &         THOUS=1.D3,
     &          DEPS=1.D-20)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  global event kinematics and particle IDs
      INTEGER IFPAP,IFPAB
      DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
      COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)

C  complex Born graph amplitudes used for unitarization
      COMPLEX*16      AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
     &                AMHMDD,AMPDP
      COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
     &                AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)


      ECM=EE
      BSTEP = (BMAX-BMIN)/DBLE(NSTEP-1)
C
      IF (LPRI.GT.4)
     &WRITE(LO,'(3(/,1X,A))')
     &  'impact parameter amplitudes:',
     &  '  B  AMP-EL  AMP-LMSD(1,2)  AMP-HMSD(1,2)  AMP-LMDD  AMP-HMDD',
     &  '-------------------------------------------------------------'
C
      BB = BMIN
      DO 100 I=1,NSTEP
C  calculate impact parameter amplitudes
        IF(I.EQ.1) THEN
          CALL PHO_EIKON(1,-1,BMIN)
        ELSE
          CALL PHO_EIKON(1,1,BB)
        ENDIF
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,8E12.4)') BB,DREAL(AMPEL),
     &    DREAL(AMLMSD(1)),DREAL(AMLMSD(2)),
     &    DREAL(AMHMSD(1)),DREAL(AMHMSD(2)),DREAL(AMLMDD),DREAL(AMHMDD)
        BB = BB+BSTEP
 100  CONTINUE

      END


 
 

C***********************************************************************
C
C
C                       PHOJET version 1.20.0
C                       -------------------
C
C
C    ($Revision: 1.20.0 $, $Date: 2017/03/05 15:20:10 $)
C
C
C    Authors: Ralph Engel
C             (ralph.engel@kit.edu)       
C
C             Anatoli Fedynitch
C             (anatoli.fedynitch@desy.de)
C
C             Johannes Ranft
C             (johannes.ranft@cern.ch)
C
C             Stefan Roesler
C             (stefan.roesler@cern.ch)
C
C
C    Bug reports, questions, complaints are welcome
C    (please send a mail to: anatoli.fedynitch@desy.de
C
C
C    Note that the code is available with several interfaces to
C    Lund fragmentation programs (JETSET7.x, 1.x and a double
C    precision JETSET version). This file is the code with
C                interface to PYTHIA 6.4.27 (or higher)
C
C    for usage in DPMJET-III version 2017.1
C       (Lund common block dimensions increased)
C
C    Field dimensions increased by A. Fedynitch (DESY)
C       (anatoli.fedynitch@desy.de)
C
C***********************************************************************
C
C
C             List of subroutines and functions
C             ---------------------------------
C
C
C  main event simulation routines
C
C      PHO_EVENT
C      PHO_PARTON
C      PHO_POSPOM
C
C      PHO_STDPAR
C      PHO_POMSCA
C
C
C  user steering interface
C
C      PHO_SETMDL
C      PHO_PRESEL
C
C
C  experimental setup / photon flux calculation
C
C      PHO_FIXLAB
C      PHO_FIXCOL
C      PHO_GPHERA
C      PHO_GGEPEM
C      PHO_WGEPEM
C      PHO_GGBLSR
C      PHO_GGBEAM
C      PHO_GGHIOF
C      PHO_GGHIOG
C      PHO_GGFLCL
C      PHO_GGFLCR
C      PHO_GGFAUX
C      PHO_GGFNUC
C      PHO_GHHIOF
C      PHO_GHHIAS
C
C
C  initialization
C
C      PHO_INIT
C      PHO_DATINI
C      PHO_PARDAT
C      PHO_MCINI
C
C      PHO_EVEINI
C
C      PHO_HARINI
C      PHO_FRAINI
C
C      PHO_FITPAR
C
C
C  cross section calculation
C
C      PHO_CSINT
C
C      PHO_XSECT
C      PHO_BORNCS
C      PHO_HARXTO
C
C      PHO_DSIGDT
C
C      PHO_TRIREG
C      PHO_LOOREG
C      PHO_TRXPOM
C
C      PHO_EIKON
C      PHO_CHAN2A
C
C      PHO_SCALES
C
C
C  multiple interaction structure
C
C      PHO_IMPAMP
C      PHO_PRBDIS
C      PHO_SAMPRO
C      PHO_SAMPRB
C
C
C  hadron / photon remnant treatment, soft x selection
C
C      PHO_HARREM
C      PHO_PARREM
C
C      PHO_HADSP2
C      PHO_HADSP3
C      PHO_SOFTXX
C      PHO_SELSXR
C      PHO_SELSX2
C      PHO_SELSXS
C      PHO_SELSXI
C
C      PHO_VALFLA
C      PHO_REGFLA
C      PHO_SEAFLA
C      PHO_FLAUX
C      PHO_BETAF
C      IPHO_DIQU
C
C
C  primordial kt and soft parton pt
C
C      PHO_PRIMKT
C      PHO_PARTPT
C      PHO_SOFTPT
C      PHO_SELPT
C
C      PHO_CONN0
C      PHO_CONN1
C
C
C  simulation of hard scattering, initial state radiation
C
C      PHO_HARCOL
C      PHO_SELCOL
C      PHO_HARCOR
C
C      PHO_HARDIR
C      PHO_HARX12
C      PHO_HARDX1
C      PHO_HARKIN
C      PHO_HARWGH
C      PHO_HARSCA
C      PHO_HARFAC
C      PHO_HARWGX
C      PHO_HARWGI
C      PHO_HARINT
C      PHO_HARMCI
C
C      PHO_HARXR3
C      PHO_HARXR2
C      PHO_HARXD2
C      PHO_HARXPT
C      PHO_HARISR
C      PHO_HARZSP
C
C      PHO_PTCUT
C      PHO_ALPHAE
C      PHO_ALPHAS
C
C
C  diffraction dissociation
C
C      PHO_DIFDIS
C      PHO_DIFPRO
C      PHO_DIFPAR
C      PHO_QELAST
C      PHO_CDIFF
C      PHO_DFWRAP
C
C      PHO_SAMASS
C      PHO_DSIGDM
C      PHO_DFMASS
C
C      PHO_SDECAY
C      PHO_SDECY2
C      PHO_SDECY3
C
C      PHO_DIFSLP
C      PHO_DIFKIN
C      PHO_VECRES
C      PHO_DIFRES
C
C      PHO_REGPAR
C
C      PHO_PECMS
C      PHO_SETPAR
C
C
C  fragmentation, treatment of low-mass strings
C
C      PHO_STRING
C      PHO_STRFRA
C
C      PHO_ID2STR
C      PHO_MCHECK
C      PHO_POMCOR
C      PHO_MASCOR
C      PHO_PARCOR
C
C      PHO_GLU2QU
C      PHO_GLUSPL
C
C      PHO_DQMASS
C      PHO_BAMASS
C      PHO_MEMASS
C
C
C  particle code tables, particle numbering conversion
C
C      PHO_PNAME
C      PHO_PMASS
C      IPHO_CHR3
C      IPHO_BAR3
C
C      IPHO_ANTI
C
C      IPHO_PDG2ID
C      IPHO_ID2PDG
C      IPHO_LU2PDG
C      IPHO_PDG2LU
C
C      IPHO_CNV1
C      PHO_HACODE
C
C
C
C  Lorentz transformations, rotations and mass adjustment
C
C      PHO_ALTRA
C      PHO_LTRANS
C      PHO_TRANS
C      PHO_TRANI
C
C      PHO_MKSLTR
C      PHO_GETLTR
C
C      PHO_LTRHEP
C
C      PHO_MSHELL
C      PHO_MASSAD
C
C
C  program debugging and internal cross-checks
C
C      PHO_PREVNT
C      PHO_PRSTRG
C      PHO_CHECK
C
C      PHO_TRACE
C
C      PHO_REJSTA
C
C      PHO_ABORT
C
C
C  cross section fitting
C
C      PHO_FITMAI
C      PHO_FITINP
C      PHO_FITDAT
C      PHO_FITOUT
C      PHO_FITAMP
C      PHO_FITTST
C      PHO_FITMSQ
C      PHO_FITVD1
C      PHO_FITCN1
C      PHO_FITINI
C
C
C  cross section parametrizations
C
C      PHO_HADCSL
C      PHO_ALLM97
C      PHO_CSDIFF
C

C
C  random numbers
C

C      DPMJET random number generator DT_RNDM used

C
C      PHO_SFECFE
C      PHO_RNDBET
C      PHO_RNDGAM
C
C
C  auxiliary routines / numerical methods
C
C      PHO_GAUSET
C      PHO_GAUDAT
C
C      pho_samp1d
C
C      PHO_DZEROX
C      PHO_EXPINT
C      PHO_BESSJ0
C      PHO_BESSI0
C      pho_ExpBessI0
C      PHO_BESSI1
C      PHO_BESSK0
C      PHO_BESSK1
C
C      PHO_XLAM
C
C      PHO_SWAPD
C      PHO_SWAPI
C
C
C  parton density parametrization management / interface
C
C      PHO_PDF
C
C      PHO_SETPDF
C      PHO_GETPDF
C      PHO_ACTPDF
C
C      PHO_QPMPDF
C
C      PHO_PDFTST
C
C
C  parton density parametrizations from other authors
C
C      PHO_DOR98LO
C      PHO_DOR98SC
C      PHO_DOR94LO
C      PHO_DOR94HO
C      PHO_DOR94DI
C      PHO_DOR92LO
C      PHO_DOR92HO
C      PHO_DORPLO
C      PHO_DORPHO
C      PHO_DORGLO
C      PHO_DORGHO
C      PHO_DORGH0
C      PHO_DOR94FV
C      PHO_DOR94FW
C      PHO_DOR94FS
C      PHO_DOR92FV
C      PHO_DOR92FW
C      PHO_DOR92FS
C      PHO_DORFVP
C      PHO_DORFGP
C      PHO_DORFQP
C      PHO_DORGF
C      PHO_DORGFS
C      PHO_grsf1
C      PHO_grsf2
C
C      PHO_CKMTPA
C      PHO_CKMTPD
C      PHO_CKMTPO
C      PHO_CKMTFV
C
C      PHO_DBFINT
C
C      PHO_SASGAM
C      PHO_SASVMD
C      PHO_SASANO
C      PHO_SASBEH
C      PHO_SASDIR
C
C      PHO_PHGAL
C      PHVAL
C
C
C***********************************************************************

CDECK  ID>, PHO_INIT
      SUBROUTINE PHO_INIT(LINP,LOUT,IREJ)
**
C***********************************************************************
C
C     main subroutine to configure and manage PHOJET calculations
C
C     input:  LINP       input unit to read from
C                        -1 to skip reading of input file
C             LOUT       output unit to write to
C
C     output: IREJ       0  success
C                        1  failure
C
C***********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  current beam selection
      INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN
      INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL
      DOUBLE PRECISION SQSGLOBMAX
      PARAMETER (MPARMAX=40)
      PARAMETER (MAXMAPPS=40)
      PARAMETER (IKNOWN=9)
      DIMENSION IPAVAIL(IKNOWN)
      DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/
      COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS),
     &           MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP

C  general process information
      INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
      COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)

C  global event kinematics and particle IDs
      INTEGER IFPAP,IFPAB
      DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
      COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)

C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
      INTEGER IDEQP,IDEQB,IHFLD,IHFLS
      DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
      COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
     &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)

C  integration precision for hard cross sections (obsolete)
      INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
      COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO

C  some hadron information, will be deleted in future versions
      INTEGER NFS
      DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
      COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS

C  obsolete cut-off information
      DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
      COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN

C  photon flux kinematics and cuts
      DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
     &                 YMIN1,YMAX1,YMIN2,YMAX2,
     &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
     &                 THMIN1,THMAX1,THMIN2,THMAX2
      INTEGER          ITAG1,ITAG2
      COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
     &                YMIN1,YMAX1,YMIN2,YMAX2,
     &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
     &                THMIN1,THMAX1,THMIN2,THMAX2,
     &                ITAG1,ITAG2

C  cut probability distribution
      INTEGER IEETA1,IIMAX,KKMAX
      PARAMETER( IEETA1=20, IIMAX=20, KKMAX=500 )
      INTEGER IEEMAX,IMAX,KMAX
      DOUBLE PRECISION EPTAB, PROB
      COMMON /POPROB/ PROB(IEETA1, 0:IIMAX, 0:KKMAX, 4, MPARMAX),
     &          EPTAB(IEETA1, 4, MPARMAX), IEEMAX, IMAX, KMAX

C  event weights and generated cross section
      INTEGER IPOWGC,ISWCUT,IVWGHT
      DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
      COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
     &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)

C  names of hard scattering processes
      INTEGER Max_pro_1
      PARAMETER ( Max_pro_1 = 16 )
      CHARACTER*18 PROC
      COMMON /POHPRO/ PROC(0:Max_pro_1)

C  hard cross sections and MC selection weights
      INTEGER Max_pro_2
      PARAMETER ( Max_pro_2 = 16 )
      INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
     &  MH_acc_1,MH_acc_2
      DOUBLE PRECISION HFAC, HWGX, HSIG, HDPT, HECM_LAST, 
     &   HQ2A_LAST, HQ2B_LAST
      COMMON /POHRCS/HFAC(-1:MAX_PRO_2, MPARMAX), 
     &   HWGX(-1:MAX_PRO_2, MPARMAX),
     &   HSIG(-1:MAX_PRO_2, MPARMAX), HDPT(-1:MAX_PRO_2, MPARMAX), 
     &   HECM_LAST, HQ2A_LAST, HQ2B_LAST, IHA_LAST, IHB_LAST, 
     &   MH_PRO_ON(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_TRIED(-1:MAX_PRO_2, 0:4, MPARMAX), 
     &   MH_ACC_1(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_ACC_2(-1:MAX_PRO_2, 0:4, MPARMAX) 

      DOUBLE PRECISION PHO_PMASS
      EXTERNAL         PHO_PMASS
      INTEGER MSTU,MSTJ
      DOUBLE PRECISION PARU,PARJ
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      SAVE /PYDAT1/

      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      SAVE /PYDAT2/

      COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
      SAVE /PYDAT3/


cf2py intent(inout) irej
      
      INTEGER PYCOMP

      DIMENSION ITMP(0:11)
      CHARACTER*10 CNAME
C     CHARACTER*70 NUMBER,FILENA
      CHARACTER*70 NUMBER

 14   FORMAT(A10,A69)
C15   FORMAT(A12)

C  define input/output units
      IF(LINP.GE.0) THEN
        LI = LINP
**anfe initialize random number generator in standalone (-2) mode
      ELSE IF (LINP .EQ. -2) THEN
        CALL DT_RNDMST(22,54,76,92)
        CALL DT_RNDMTE(0)
      ELSE
        LI = 5
      ENDIF
**sr temporarily changed
      LO = LOUT
**
      
      LPRI= IREJ
      IREJ = 0

cdh   IF (LPRI.GT.4) THEN
cdh   WRITE(LO,*)
      WRITE(LO,*) ' ==================================================='
      WRITE(LO,*) '                                                    '
      WRITE(LO,*) '   ----  PHOJET version 1.20.0 (DPMJET-III)  ----   '
      WRITE(LO,*) '                                                    '
      WRITE(LO,*) ' ==================================================='
      WRITE(LO,*) '     Authors: Ralph Engel          (KIT)'
      WRITE(LO,*) '              Anatoli Fedynitch    (DESY)'
      WRITE(LO,*) '              Johannes Ranft       (Siegen Univ.)'
      WRITE(LO,*) '              Stefan Roesler       (CERN)'
      WRITE(LO,*) ' ---------------------------------------------------'
      WRITE(LO,*) '      Manual, updates, and further information:'
      WRITE(LO,*) '      https://dpmjetiii.hepforge.org/'
      WRITE(LO,*) ' ---------------------------------------------------'
      WRITE(LO,*) '    please send suggestions / bug reports etc. to:'
      WRITE(LO,*) '              anatoli.fedynitch@desy.de'
      WRITE(LO,*) ' ==================================================='
      WRITE(LO,*) '    Date: 2017/03/05'
      WRITE(LO,*) '    Revision: 1.20.0'
      WRITE(LO,*) '   (code version with interface to PYTHIA 6.4.27)'
      WRITE(LO,*) ' ==================================================='
cdh   WRITE(LO,*)
cdh   ENDIF

C  standard initializations
      CALL PHO_DATINI
      CALL PHO_PARDAT
      IPROCE = 0
      DUM = PHO_PMASS(0,-1)

C  multiparticle mapping tables (default selection)
      CALL PHO_INITPMAP(-1, 0, 0, 0)

C  initialize standard PDFs
C  proton
      CALL PHO_SETPDF(2212, idum, 2, 1, 0, 0, -1)
      CALL PHO_SETPDF(-2212, idum, 2, 1, 0, 0, -1)
C  neutron
      CALL PHO_SETPDF(2112, idum, 2, 1, 0, 0, -1)
      CALL PHO_SETPDF(-2112, idum, 2, 1, 0, 0, -1)
C  lambda
      CALL PHO_SETPDF(3122, idum, 2, 1, 0, 0, -1)
      CALL PHO_SETPDF(-3122, idum, 2, 1, 0, 0, -1)
C  lambda
      CALL PHO_SETPDF(3122, idum, 2, 1, 0, 0, -1)
      CALL PHO_SETPDF(-3122, idum, 2, 1, 0, 0, -1)
C  sigmamp
      CALL PHO_SETPDF(3112, idum, 2, 1, 0, 0, -1)
      CALL PHO_SETPDF(-3112, idum, 2, 1, 0, 0, -1)            
C  photon
      CALL PHO_SETPDF(22,IDUM,5,3,0,0,-1)
C  pomeron
      CALL PHO_SETPDF(990,IDUM,4,0,0,0,-1)
C  pions
      CALL PHO_SETPDF(211,IDUM,5,2,0,0,-1)
      CALL PHO_SETPDF(-211,IDUM,5,2,0,0,-1)
      CALL PHO_SETPDF(111,IDUM,5,2,0,0,-1)
C  kaons
      CALL PHO_SETPDF(321,IDUM,5,2,0,0,-1)
      CALL PHO_SETPDF(-321,IDUM,5,2,0,0,-1)
      CALL PHO_SETPDF(311,IDUM,5,2,0,0,-1)
      CALL PHO_SETPDF(-311,IDUM,5,2,0,0,-1)
      CALL PHO_SETPDF(130,IDUM,5,2,0,0,-1)
      CALL PHO_SETPDF(310,IDUM,5,2,0,0,-1)

C  nothing to be done
      IF(LINP.LT.0) RETURN

C  main loop to read input cards
 1200 CONTINUE
        READ(LINP,14,END=1300) CNAME,NUMBER
        IF(CNAME.EQ.'ENDINPUT  ') THEN
          GOTO 1300
        ELSE IF(CNAME.EQ.'STOP      ') THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'STOP'
          STOP
        ELSE IF(CNAME.EQ.'COMMENT   ') THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A10,A69)') 'COMMENT   ',NUMBER
        ELSE IF(CNAME(1:1).EQ.'*') THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A10,A69)') CNAME,NUMBER
        ELSE IF(CNAME.EQ.'PTCUT     ') THEN
          READ(NUMBER,*) PARMDL(36),PARMDL(37),PARMDL(38),PARMDL(39)
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'PTCUT     ',PARMDL(36),PARMDL(37),
     &      PARMDL(38),PARMDL(39)
        ELSE IF(CNAME.EQ.'PROCESS   ') THEN
          READ(NUMBER,*) (IPRON(KK,1),KK=1,8)
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'PROCESS   ',(IPRON(KK,1),KK=1,8)
        ELSE IF(CNAME.EQ.'DIFF-PROC ') THEN
          READ(NUMBER,*) (ITMP(KK),KK=0,11)
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'DIFF-PROC ',(ITMP(KK),KK=0,8)
          DO 112 KK=1,8
            IPRON(KK,ITMP(0)) = ITMP(KK)
 112      CONTINUE
        ELSE IF(CNAME.EQ.'SUBPROCESS') THEN
          READ(NUMBER,*) IMPRO,IP,ION
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'SUBPROCESS',IMPRO,IP,ION
          MH_pro_on(IMPRO,IP,IDXMPAR) = ION
        ELSE IF(CNAME.EQ.'PARTICLE1 ') THEN
          READ(NUMBER,*) IDPDG,PVIR
          IHFLS(1) = 1
          XPSUB = 1.D0
          CALL PHO_SETPAR(1,IDPDG,0,PVIR)
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'PARTICLE1  ',IDPDG,PVIR
        ELSE IF(CNAME.EQ.'PARTICLE2 ') THEN
          READ(NUMBER,*) IDPDG,PVIR
          IHFLS(2) = 1
          XTSUB = 1.D0
          CALL PHO_SETPAR(2,IDPDG,0,PVIR)
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'PARTICLE2  ',IDPDG,PVIR
        ELSE IF(CNAME.EQ.'REMNANT1  ') THEN
          READ(NUMBER,*) IDPDG,IFL1,IFL2,IVAL,XSUB
          IHFLS(1) = IVAL
          IHFLD(1,1) = IFL1
          IHFLD(1,2) = IFL2
          XPSUB = XSUB
          PVIR = 0.D0
          CALL PHO_SETPAR(1,IDPDG,-1,PVIR)
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'REMNANT1   ',IDPDG,IFL1,IFL2,IVAL,XSUB
        ELSE IF(CNAME.EQ.'REMNANT2  ') THEN
          READ(NUMBER,*) IDPDG,IFL1,IFL2,IVAL,XSUB
          IHFLS(2) = IVAL
          IHFLD(2,1) = IFL1
          IHFLD(2,2) = IFL2
          XTSUB = XSUB
          PVIR = 0.D0
          CALL PHO_SETPAR(2,IDPDG,-1,PVIR)
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'REMNANT2   ',IDPDG,IFL1,IFL2,IVAL,XSUB
        ELSE IF(CNAME.EQ.'PDF       ') THEN
          READ(NUMBER,*) IDPDG,IPAR,ISET,IEXT
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'PDF        ',IDPDG,IPAR,ISET,IEXT
          CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,IEXT,0,-1)
        ELSE IF(CNAME.EQ.'SETMODEL  ') THEN
          READ(NUMBER,*) I,IVAL
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'SETMODEL   ',I,IVAL
          CALL PHO_SETMDL(I,IVAL,1)
        ELSE IF(CNAME.EQ.'SETPARAM  ') THEN
          READ(NUMBER,*) I,PARNEW
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'SETPARAM   ',I,PARNEW
          PARMDL(I) = PARNEW
        ELSE IF(CNAME.EQ.'DEBUG     ') THEN
          READ(NUMBER,*) IDEBF,IDEBN,IDLEV
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'DEBUG      ',IDEBF,IDEBN,IDLEV
          CALL PHO_TRACE(IDEBF,IDEBN,IDLEV)
        ELSE IF(CNAME.EQ.'TRACE     ') THEN
          READ(NUMBER,*) IDEBF,IDLEV
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'TRACE      ',IDEBF,IDLEV
          IDEB(IDEBF) = IDLEV
        ELSE IF(CNAME.EQ.'SETICUT   ') THEN
          READ(NUMBER,*) I,ICUT
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'SETICUT    ',I,ICUT
          ISWCUT(I) = ICUT
        ELSE IF(CNAME.EQ.'SETFCUT   ') THEN
          READ(NUMBER,*) I,PARNEW
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'SETFCUT    ',I,PARNEW
          HSWCUT(I) = PARNEW
        ELSE IF(CNAME.EQ.'LUND-MSTU ') THEN
          READ(NUMBER,*) I,IVAL
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'LUND-MSTU  ',I,IVAL
          MSTU(I) = IVAL
        ELSE IF(CNAME.EQ.'LUND-MSTJ ') THEN
          READ(NUMBER,*) I,IVAL
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'LUND-MSTJ  ',I,IVAL
          MSTJ(I) = IVAL
        ELSE IF(CNAME.EQ.'LUND-PARJ ') THEN
          READ(NUMBER,*) I,EE
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'LUND-PARJ  ',I,EE
          PARJ(I) = REAL(EE)
        ELSE IF(CNAME.EQ.'LUND-PARU ') THEN
          READ(NUMBER,*) I,EE
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'LUND-PARU  ',I,EE
          PARU(I) = REAL(EE)
        ELSE IF(CNAME.EQ.'LUND-DECAY') THEN
          READ(NUMBER,*) ID,ION
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'LUND-DECAY ',ID,ION

          KC=PYCOMP(ID)

          MDCY(KC,1) = ION
        ELSE IF(CNAME.EQ.'PSOFTMIN  ') THEN
          READ(NUMBER,*) PSOMIN
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'PSOFTMIN   ',PSOMIN
        ELSE IF(CNAME.EQ.'INTPREC   ') THEN
          READ(NUMBER,*) NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'INTPREC    ',NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO

C  PDF test utility
        ELSE IF(CNAME.EQ.'PDFTEST   ') THEN
          READ(NUMBER,*) IDPDG,SCALE2,PVIRT2
          PVIRT2 = ABS(PVIRT2)
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'PDFTEST   ',IDPDG,' ',SCALE2,' ',PVIRT2
          CALL PHO_PDFTST(IDPDG,SCALE2,PVIRT2)

C  mass cut on gamma-gamma or gamma-hadron system
        ELSE IF(CNAME.EQ.'ECMS-CUT  ') THEN
          READ(NUMBER,*) ECMIN,ECMAX
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'ECMS-CUT  ',ECMIN,ECMAX

C  beam lepton (anti-)tagging system
        ELSE IF(CNAME.EQ.'TAG-METHOD') THEN
          READ(NUMBER,*) ITAG1,ITAG2
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'TAG-METHOD',ITAG1,ITAG2
        ELSE IF(CNAME.EQ.'E-TAG1    ') THEN
          READ(NUMBER,*)
     &      EEMIN1,YMIN1,YMAX1,Q2MIN1,Q2MAX1,THMIN1,THMAX1
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'E-TAG1    ',EEMIN1,YMIN1,YMAX1,
     &      Q2MIN1,Q2MAX1,THMIN1,THMAX1
        ELSE IF(CNAME.EQ.'E-TAG2    ') THEN
          READ(NUMBER,*)
     &      EEMIN2,YMIN2,YMAX2,Q2MIN2,Q2MAX2,THMIN2,THMAX2
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'E-TAG2    ',EEMIN2,YMIN2,YMAX2,
     &      Q2MIN2,Q2MAX2,THMIN2,THMAX2

C  sampling of gamma-p events in ep (HERA)
        ELSE IF(    (CNAME.EQ.'WW-HERA   ')
     &          .OR.(CNAME.EQ.'GP-HERA   ')) THEN
          READ(NUMBER,*) EE1,EE2,NEV
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'GP-HERA   ',EE1,EE2,NEV
          IF(YMAX2.LT.0.D0) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGER NOT SET'
          ELSE
            CALL PHO_GPHERA(NEV,EE1,EE2)
            KEVENT = 0
          ENDIF

C  sampling of gamma-gamma events in e+e- (LEP)
        ELSE IF(    (CNAME.EQ.'GG-EPEM   ')
     &          .OR.(CNAME.EQ.'WW-EPEM   ')) THEN
          READ(NUMBER,*) EE1,EE2,NEV
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'GG-EPEM   ',EE1,EE2,NEV
          IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGERS NOT SET'
          ELSE
            CALL PHO_GGEPEM(-1,EE1,EE2)
            CALL PHO_GGEPEM(NEV,EE1,EE2)
            CALL PHO_GGEPEM(-2,sig_tot,sig_gg)
            KEVENT = 0
          ENDIF

C  sampling of gamma-gamma in heavy-ion collisions
        ELSE IF(CNAME.EQ.'GG-HION-F ') THEN
          READ(NUMBER,*) EE,NA,NZ,NEV
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'GG-HION-F ',EE,NA,NZ,NEV
          IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
          ELSE
            CALL PHO_GGHIOF(NEV,EE,NA,NZ)
            KEVENT = 0
          ENDIF
        ELSE IF(CNAME.EQ.'GG-HION-G ') THEN
          READ(NUMBER,*) EE,NA,NZ,NEV
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'GG-HION-G ',EE,NA,NZ,NEV
          IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
          ELSE
            CALL PHO_GGHIOG(NEV,EE,NA,NZ)
            KEVENT = 0
          ENDIF

C  sampling of gamma-hadron events in heavy ion collisions
        ELSE IF(CNAME.EQ.'GH-HION-F ') THEN
          READ(NUMBER,*) EE,NA,NZ,NEV
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'GH-HION-F ',EE,NA,NZ,NEV
          IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
          ELSE
            CALL PHO_GHHIOF(NEV,EE,NA,NZ)
            KEVENT = 0
          ENDIF

C  sampling of hadron-gamma events in hadron - heavy ion collisions
        ELSE IF(CNAME.EQ.'HG-HIAS-F ') THEN
          READ(NUMBER,*) EP,EE,NA,NZ,NEV
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'HG-HIAS-F ',EP,EE,NA,NZ,NEV
          IF(YMAX2.LT.0.D0) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
          ELSE
            CALL PHO_GHHIAS(NEV,EP,EE,NA,NZ)
            KEVENT = 0
          ENDIF

C  sampling of photoproduction events e+e-, backscattered laser
        ELSE IF(CNAME.EQ.'BLASER    ') THEN
          READ(NUMBER,*) EE1,EE2,Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A,NEV
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'BLASER    ',EE1,EE2,
     &      Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A,NEV
          CALL PHO_GGBLSR(NEV,EE1,EE2,Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A)
          KEVENT = 0

C  sampling of photoproduction events beamstrahlung
        ELSE IF(CNAME.EQ.'BEAMST    ') THEN
          READ(NUMBER,*) EE1,YPSI,SIGX,SIGY,SIGZ,AEB,NEV
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'BEAMST    ',EE1,YPSI,SIGX,SIGY,SIGZ,AEB,NEV
          IF(YMAX1.LT.0.D0) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGER 1 NOT SET'
          ELSE
            CALL PHO_GGBEAM(NEV,EE1,YPSI,SIGX,SIGY,SIGZ,AEB)
            KEVENT = 0
          ENDIF

C  fixed-energy events in LAB system of particle 2
        ELSE IF(CNAME.EQ.'EVENT-LAB ') THEN
          READ(NUMBER,*) PLAB,NEV
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'EVENT-LAB ',PLAB,NEV
          CALL PHO_FIXLAB(PLAB,NEV)
          KEVENT = 0

C  fixed-energy events in CM system
        ELSE IF(CNAME.EQ.'EVENT-CMS ') THEN
          READ(NUMBER,*) ECM,NEV
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'EVENT-CMS ',ECM,NEV
          PMASS1 = PHO_PMASS(IFPAB(1),0)-SQRT(PVIRT(1))
          PMASS2 = PHO_PMASS(IFPAB(2),0)-SQRT(PVIRT(2))
          CALL PHO_PECMS(1,PMASS1,PMASS2,ECM,PCM,EE)
          E1 = EE
          E2 = ECM-EE
          THETA = 0.D0
          PHI   = 0.D0
          CALL PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
          KEVENT = 0

C  fixed-energy events for collider setup with crossing angle
        ELSE IF(CNAME.EQ.'EVENT-COLL') THEN
          READ(NUMBER,*) E1,E2,THETA,PHI,NEV
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'EVENT-COLL',E1,E2,THETA,PHI,NEV
          CALL PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
          KEVENT = 0

C  unknown data card
        ELSE
          IF (LPRI.GT.4)
     &    WRITE(LO,*) 'PHO_INIT: unknown data card: ',CNAME,NUMBER
        ENDIF

      GOTO 1200
 1300 CONTINUE
      IF (LPRI.GT.4)
     &WRITE(LO,*) ' RETURN'

      END


 
 


CDECK  ID>, PHO_INITPMAP
      SUBROUTINE PHO_INITPMAP(imode, mapfrom, mapto, IFAST)
c*********************************************************************
c
c     maps more exotic hadrons to known particles
c
c     input:   imode    -2: print current mappings
c                       -1: initialize default selection
c                        1: add particle combination to list 
c                   
c              mapfrom  PDG particle code of (exotic) hadron
c              mapto    PDG particle code of known hadron
c              IFAST    Use simplified mapping scheme p,pi+,pi0
c
c     output:  in /pompmp/
c              mpmapp   table where mappings are stored
c              nmapp    number of mappings available
c
c*********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      SAVE

      INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN
      INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL
      DOUBLE PRECISION SQSGLOBMAX
      PARAMETER (MPARMAX=40)
      PARAMETER (MAXMAPPS=40)
      PARAMETER (IKNOWN=9)
      DIMENSION IPAVAIL(IKNOWN)
      DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/
      COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS),
     &           MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP

      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

      DOUBLE PRECISION xm_list,tau_list,gam_list,
     &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
     &  xm_bb82_list,xm_bb102_list
      INTEGER          ich3_list,iba3_list,iq_list,
     &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
      COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
     &  xm_psm2_list(6,6),xm_vem2_list(6,6),
     &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
     &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
     &  ich3_list(300),iba3_list(300),iq_list(3,300),
     &  id_psm_list(6,6),id_vem_list(6,6),
     &  id_b8_list(6,6,6),id_b10_list(6,6,6)

      INTEGER  IPHO_PDG2ID
      EXTERNAL IPHO_PDG2ID
      DOUBLE PRECISION PHO_PMASS
      EXTERNAL         PHO_PMASS

c This flag makes init. faster by reducing the number of particles to 
c map
       
      DATA nmapp /0/
      DATA maptonew /-1/
      
      If (imode.EQ.-2) Then

        IF (LPRI.GT.4)
     &  Write (lo, '(/1X,30A/)') 'PHO_INITPMAP: particle mappings'
        Do i=1,nmapp
          Write (lo, '(1X,I8,A,I8)') mpmapp(1, i), '  -->', mpmapp(2, i)
        End Do
      Else If (imode.EQ.-1) Then
C    Example how to force fixed particle assignments
C    omega -> pi0
C    mpmapp(1,1) = 223
C    mpmapp(2,1) = 111
C    nmapp = nmapp + 1
C    CALL PHO_SETPDF(maptonew, NULL, mapfrom, NULL, NULL, NULL, 2)

        nmapp = 0
      Else If (imode.EQ.1) Then
        
        If (ipho_findidx(1, mapfrom, max(1,nmapp)).NE.-1) Then
          IF (LPRI.GT.4)
     &      Write(lo, '(/1X,2A,I5)') 
     &      "PHO_INITPMAP: Error, trying to overwrite mapping for", 
     &      mapfrom
          CALL PHO_ABORT
        End If

        If (mapto.EQ.-1) Then
C   Determine mapping partner
          idcpc = IPHO_PDG2ID(mapfrom)
          ichar = IPHO_CHR3(idcpc, 0)
          ibar = IPHO_BAR3(idcpc, 0)
          pmass = PHO_PMASs(idcpc, 0)
          pmass_k = PHO_PMASS(321, 1)
          If (ibar.NE.0) Then
            If ((ichar.NE.0).Or.(IFAST.NE.0)) Then
              maptonew = sign(2212, mapfrom)
            Else
              maptonew = sign(2112, mapfrom)
            End If
          Else 
            If (ichar.EQ.0) Then
              ifl1 = iq_list(1,idcpc)
              ifl2 = iq_list(2,idcpc)
C   map to pi0 if unflavored
              If ((ifl1.EQ.-ifl2).Or.(IFAST.NE.0)) Then
                 maptonew = 111
              Else
C   map to K0
                 maptonew = sign(311,mapfrom)
              End If
            Else
              If ((IFAST.NE.0).And.(pmass<=pmass_k)) Then  
                maptonew = sign(211, mapfrom)
              Else
                maptonew = sign(321, mapfrom)
              End If
            End If
          End If
        End If

        If (IFAST.NE.0) maptonew = abs(maptonew)

        mpmapp(1,nmapp + 1) = mapfrom
        mpmapp(2,nmapp + 1) = maptonew
        nmapp = nmapp + 1

C    Map PDF entry of intialized particle to the requested particle
        CALL PHO_SETPDF(maptonew, NULL, mapfrom, NULL, NULL, NULL, 2)
        
        IF (LPRI.GT.4) Then
           If (ideb(91) >= 0) Write (lo, '(1X,A,1X,I8,A,I8)')
     &        'PHO_INITPMAP: added mapping: ', mpmapp(1, nmapp),
     &        '     -->', mpmapp(2, nmapp)
        End If
      Else
         Write (lo, '(1X,A,I5)') 'PHO_INITPMAP: Error, invalid IMODE: ', 
     &      imode
         CALL PHO_ABORT
      End If

      END 


 
 


CDECK  ID>, PHO_LOOREG
      SUBROUTINE PHO_LOOREG(S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP,
     &                     VIR2A,VIR2B,SIGLO,BLO)
C**********************************************************************
C
C     calculation of loop-Pomeron total cross section
C     according to Gribov's Regge theory
C
C     input:        S        squared cms energy
C                   GA       coupling constant to diffractive line
C                   AA       slope related to GA (GeV**-2)
C                   GB       coupling constant to elastic line
C                   BB       slope related to GB (GeV**-2)
C                   DELTA    effective pomeron delta (intercept-1)
C                   ALPHAP   slope of pomeron trajectory (GeV**-2)
C                   GPPP     triple-Pomeron coupling
C                   BPPP     slope related to B0PPP (GeV**-2)
C                   VIR2A    virtuality of particle a (GeV**2)
C                   VIR2B    virtuality of particle b (GeV**2)
C                   note: units of all coupling constants are mb**1/2
C
C     output:       SIGLO    total loop-Pomeron cross section
C                   BLO      effective loop-Pomeron slope
C                            (differs from double diffractive slope!)
C
C     uses E_i (Exponential-Integral function)
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER (EPS =0.0001D0)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)


C  integration cut-off Sigma_U ( see Nucl.Phys.B97(1975)493 )
      SIGU = 2.5
C  integration cut-off Sigma_L (min. squared mass of diff. blob)
      SIGL = 5.+VIR2A+VIR2B
C  debug output
      IF (LPRI.GT.4 .AND. IDEB(51).GE.10)
     &WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
     &       'PHO_LOOREG: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP ',
     &       S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
C
      IF(S.LT.5.D0) THEN
        SIGLO = 0.D0
        BLO = 2.D0*BPPP
        RETURN
      ENDIF

C
C  change units of ALPHAP to mb
      ALSCA  = ALPHAP*GEV2MB
C
C  cross section
      PART1=GA*GB*GPPP**2/(16.*PI*2.*ALSCA)*S**DELTA*
     &        EXP(-DELTA*BPPP/ALPHAP)
      PARTA=BPPP/ALPHAP+LOG(S/SIGL**2)
      PARTB=BPPP/ALPHAP+LOG(SIGU)
      SIGLO=PART1*(PARTA*(PHO_EXPINT(PARTA*DELTA)
     &                    -PHO_EXPINT(PARTB*DELTA))
     &             +EXP(PARTA*DELTA)/DELTA-EXP(PARTB*DELTA)/DELTA
     &            )
C
C  slope
      PART1 = LOG(ABS(PARTA/PARTB))
     &       *(PARTA-LOG(1.D0+S/(SIGL**2*SIGU)))
      PART1 = 0.25*ALPHAP*LOG(1.D0+S/(SIGU*SIGL))**2/PART1
      BLO = (AA+BB)/2.+2.*BPPP+ALPHAP*LOG(S/4.D0)
      BLO = BLO-PART1
C
      IF(SIGLO.LT.EPS) SIGLO = 0.D0
      IF(BLO.LT.2.D0*BPPP) BLO = 2.D0*BPPP
C
      IF (LPRI.GT.4 .AND. IDEB(51).GE.7)
     &WRITE(LO,'(1X,A,1P,3E12.3)')
     &  'PHO_LOOREG: ENERGY,SIGLO,BLO',SQRT(S),SIGLO,BLO
      END


 
 


CDECK  ID>, PHO_LTRANS
      SUBROUTINE PHO_LTRANS(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
     &                 PL,CXL,CYL,CZL,EL)
C**********************************************************************
C
C     Lorentz transformation into lab - system
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( TINY=1.D-08,TINY2=1.D-30 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI


      SID=SQRT(1.D0-COD*COD)
      PLX=P*SID*COF
      PLY=P*SID*SIF
      PCMZ=P*COD
      PLZ=GAM*PCMZ+BGAM*ECM
      PL=SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
      EL=GAM*ECM+BGAM*PCMZ

C  rotation into the original direction
      COZ=PLZ/PL
      SIZ=SQRT(MAX((1.D0-COZ)*(1.D0+COZ),0.D0))

*      CALL PHO_DTRANS(CX,CY,CZ,COZ,SIZ,COF,SIF,CXL,CYL,CZL)

      AX=ABS(CX)
      AY=ABS(CY)
      IF(AX.LT.AY) THEN
        AMAX=AY
        AMIN=AX
      ELSE
        AMAX=AX
        AMIN=AY
      ENDIF
      IF (ABS(CX)-TINY) 1,1,2

    1 IF (ABS(CY)-TINY) 3,3,2
    3 CONTINUE
*     WRITE(LO,*)' PHO_DTRANS CX CY CZ =',CX,CY,CZ
      CXL=SIZ*COF
      CYL=SIZ*SIF
      CZL=COZ*CZ
*     WRITE(LO,*)' PHO_DTRANS CXL=SIZ*COF CYL=SIZ*SIF CZL=COZ'
*     WRITE(LO,*) CXL,CYL,CZL
      RETURN

    2 CONTINUE
      IF(AMAX.GT.TINY2) THEN
        AR=AMIN/AMAX
        AR=AR*AR
        A=AMAX*SQRT(1.D0+AR)
      ELSE
*       WRITE(LO,*)' PHO_DTRANS AMAX LE TINY2 '
        GOTO 3
      ENDIF
      XI=SIZ*COF
      YI=SIZ*SIF
      ZI=COZ
      CXL=-CY*XI/A-CZ*CX*YI/A+CX*ZI
      CYL=CX*XI/A-CZ*CY*YI/A+CY*ZI
      CZL=A*YI+CZ*ZI

      END


 
 


CDECK  ID>, PHO_LTRHEP
      SUBROUTINE PHO_LTRHEP(I1,I2,COD,SID,COF,SIF,GAM,BGX,BGY,BGZ)
C*******************************************************************
C
C     Lorentz transformation of entries I1 to I2 in /POEVT1/
C
C********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( DIFF = 0.001D0,
     &            EPS  = 1.D-5 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)


      DO 100 I=I1,MIN(I2,NHEP)
        IF((ABS(ISTHEP(I)).LE.10).OR.(ISTHEP(I).EQ.21)) THEN
          CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
     &      XX,YY,ZZ)
          EE=PHEP(4,I)
          CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
     &      PHEP(1,I),PHEP(2,I),PHEP(3,I),PHEP(4,I))
        ELSE IF(ISTHEP(I).EQ.20) THEN
          EE=SQRT(PHEP(1,I)**2+PHEP(2,I)**2+PHEP(3,I)**2)
          CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
     &      XX,YY,ZZ)
          CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
     &      PHEP(1,I),PHEP(2,I),PHEP(3,I),PMASS)
        ENDIF
 100  CONTINUE

C  debug precision
      IF(IDEB(70).LT.1) RETURN
      DO 200 I=I1,MIN(NHEP,I2)
        IF(ABS(ISTHEP(I)).GT.10) GOTO 190
        PMASS = PHEP(4,I)**2-PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
        PMASS = SIGN(SQRT(ABS(PMASS)),PMASS)
        IF((ABS(PMASS-PHEP(5,I))/MAX(PHEP(5,I),1.D0)).GT.DIFF) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,I5,2E13.4)')
     &      'PHO_LTRHEP: inconsistent masses:',I,PMASS,PHEP(5,I)
        ENDIF
 190    CONTINUE
 200  CONTINUE

      END


 
 


CDECK  ID>, PHO_MASCOR
      SUBROUTINE PHO_MASCOR(IREJ)
C********************************************************************
C
C    check and adjust parton momenta for fragmentation
C
C    input:      /POEVT1/
C                /POSTRG/
C                IREJ    -1          initialization
C                        -2          output of statistics
C
C    output:     /POEVT1/
C                /POSTRG/
C                IREJ    0  successful
C                        1  failure
C
C    in case of very small string mass:
C       - direct manipulation of /POEVT1/ and /POEVT2/
C       - string will be deleted from /POSTRG/ (label -99)
C
C********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( EPS    =  1.D-10,
     &            EMIN   =  0.3D0,
     &            DEPS   =  1.D-15)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  internal rejection counters
      INTEGER NMXJ
      PARAMETER (NMXJ=60)
      CHARACTER*10 REJTIT
      INTEGER IFAIL
      COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

C  color string configurations including collapsed strings and hadrons
      INTEGER MSTR
      PARAMETER (MSTR=2000)
      INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
      COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
     &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
     &                NNCH(MSTR),IBHAD(MSTR),ISTR

      DIMENSION PC1(4),PC2(4),P1(4),PTR(4),GAM(3),GAMB(3)

      IF(IREJ.EQ.-1) THEN
        ICTOT = 0
        ICCOR = 0
        RETURN
      ELSE IF(IREJ.EQ.-2) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,2I8/)')
     &    'PHO_MASCOR: total/converted strings',ICTOT,ICCOR
        RETURN
      ENDIF

      IREJ = 0
      NITER = 100
      ITER = 0
      ICTOT = ICTOT+ISTR
      IF(ISWMDL(7).EQ.-1) RETURN
C  debug /POSTRG/
      IF(IDEB(42).GE.25) CALL PHO_PRSTRG

      ITOUCH = 0
 50   CONTINUE
      ITER = ITER+1
      IF(ITER.GE.NITER) THEN
        IREJ = 1
        IF(IDEB(42).GE.2) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,2I5)') 'PHO_MASCOR: rejection',ITER,NITER
          IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
        ENDIF
        RETURN
      ENDIF

C  check mass limits
      IF(DT_RNDM(CMASS0).LT.0.5D0) THEN
        IM1 = 1
        IM2 = ISTR
        IST = 1
      ELSE
        IM1 = ISTR
        IM2 = 1
        IST = -1
      ENDIF
      DO 100 I=IM1,IM2,IST
        J1 = NPOS(1,I)
        CMASS0 = PHEP(5,J1)
C  get masses
        IF(NCODE(I).EQ.3) THEN
          CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
        ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
          CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
     &                AM1,AM2,AM3,AM4,IP1,IP2)
        ELSE IF(NCODE(I).EQ.5) THEN
          CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
     &              AM1,AM2)
          AM3 = 0.D0
          AM4 = 0.D0
          IP1 = 0
          IP2 = 0
        ELSE IF(NCODE(I).EQ.7) THEN
          AM1 = 0.15D0
          AM2 = 0.3D0
          AM3 = 0.765D0
          AM4 = 1.5D0
*??????????????????????????????????
          IP1 = 23
          IP2 = 33
*??????????????????????????????????
        ELSE IF(NCODE(I).LT.0) THEN
          GOTO 90
        ELSE
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/,1X,A,2I5)') 'PHO_MASCOR:ERROR: string no,NCODE ',
     &                            J1,NCODE(I)
          CALL PHO_ABORT
        ENDIF
        IF (LPRI.GT.4 .AND. IDEB(42).GE.20)
     &  WRITE(LO,'(1X,A,/3X,I3,5E11.3,2I5)')
     &    'PHO_MASCOR: string no CHMASS,AM1,AM2,AM3,AM4,IP1,IP2:',
     &    I,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
C  select masses to correct
        IBHAD(I) = 0
        NNCH(I) = 0
C  correction needed?
C  no resonances for diquark-antidiquark and gluon-gluon strings
        IF(NCODE(I).EQ.5) THEN
          IF(CMASS0.LT.1.3D0*AM1) THEN
            IF(ISWMDL(7).LE.2) THEN
              IBHAD(I) = 90
              NNCH(I)  = -1
              CHMASS   = AM1*1.3D0
            ELSE
              IREJ = 1
              RETURN
            ENDIF
          ENDIF
        ELSE
          INEED = 0
C  resonances possible
          IF(ISWMDL(7).EQ.0) THEN
            IF(CMASS0.LT.AM1*0.99D0) THEN
              IBHAD(I) = IP1
              NNCH(I)  = -1
              CHMASS   = AM1
              INEED = 1
            ELSE IF(CMASS0.LT.MIN(AM2,AM4)*1.2D0) THEN
              DELM1 = 1.D0/((CMASS0-AM1)**2+EPS)
              DELM2 = 1.D0/((CMASS0-AM3)**2+EPS)
              IF(DT_RNDM(DELM1).LT.DELM1/(DELM1+DELM2)) THEN
                IBHAD(I) = IP1
                NNCH(I)  = -1
                CHMASS   = AM1
              ELSE
                IBHAD(I) = IP2
                NNCH(I)  = 1
                CHMASS   = AM3
              ENDIF
            ENDIF
          ELSE IF((ISWMDL(7).EQ.1).OR.(ISWMDL(7).EQ.2)) THEN
            IF(CMASS0.LT.AM1*0.99) THEN
              IBHAD(I) = IP1
              NNCH(I) = -1
              CHMASS = AM1
              INEED = 1
            ENDIF
          ELSE IF(ISWMDL(7).EQ.3) THEN
            IF(CMASS0.LT.AM1) THEN
              IREJ = 1
              RETURN
            ENDIF
          ELSE
            IF (LPRI.GT.4)
     &      WRITE(LO,'(/1X,A,I5)')
     &        'PHO_MASCOR:ERROR:UNSUPPORTED ISWMDL(7)',ISWMDL(7)
            CALL PHO_ABORT
          ENDIF
        ENDIF
C
C  correction necessary?
        IF(IBHAD(I).NE.0) THEN
C  find largest invar. mass
          IPOS = 0
          CMASS1 = -1.D0
          DO 200 J2=NHEP,3,-1

            IF(ABS(ISTHEP(J2)).EQ.1) THEN
              IF((IPHIST(1,J2).LE.0).OR.(IPHIST(1,J2).GT.ISTR)) THEN
                IF (LPRI.GT.4)
     &          WRITE(LO,'(1X,2A,I7,I12)') 'PHO_MASCOR: ',
     &            'inconsistent IPHIST(1,J2) entry (J2,KEV):',J2,KEVENT
                CALL PHO_PREVNT(0)
              ELSE IF(NCODE(IPHIST(1,J2)).GT.0) THEN
                CMASS2= (PHEP(4,J1)+PHEP(4,J2))**2
     &                 -(PHEP(1,J1)+PHEP(1,J2))**2
     &                 -(PHEP(2,J1)+PHEP(2,J2))**2
     &                 -(PHEP(3,J1)+PHEP(3,J2))**2
                IF(CMASS2.GT.CMASS1) THEN
                  IPOS=J2
                  CMASS1=CMASS2
                ENDIF
              ENDIF
            ENDIF

 200      CONTINUE
          J2 = IPOS
          IF((J1.EQ.J2).OR.(CMASS1.LE.EMIN)) THEN
            IF(INEED.EQ.1) THEN
              IREJ = 1
              RETURN
            ELSE
              IBHAD(I) = 0
              NNCH(I) = 0
              GOTO 90
            ENDIF
          ENDIF
          ISTA = ISTHEP(J1)
          ISTB = ISTHEP(J2)
          CMASS1 = SQRT(CMASS1)
          CMASS2 = PHEP(5,J2)
          IF(CMASS1.LT.(CMASS2+CHMASS)) CMASS2 = CMASS1-1.1D0*CHMASS
          IREJ = 1
          IF(CMASS2.GT.0.D0) CALL PHO_MSHELL(PHEP(1,J1),PHEP(1,J2),
     &      CHMASS,CMASS2,PC1,PC2,IREJ)
          IF(IREJ.NE.0) THEN
            IFAIL(24) = IFAIL(24)+1
            IF(IDEB(42).GE.2) THEN
              IF (LPRI.GT.4)
     &        WRITE(LO,'(1X,A,2I4)')
     &          'PHO_MASCOR: rejection by PHO_MSHELL (J1,J2):',J1,J2
              IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
            ENDIF
            IREJ = 1
            RETURN
          ENDIF
C  momentum transfer
          DO 210 II=1,4
            PTR(II) = PHEP(II,J2)-PC2(II)
 210      CONTINUE
          IF (LPRI.GT.4 .AND. IDEB(42).GE.10)
     &    WRITE(LO,'(1X,A,/5X,2I3,4E12.3)')
     &      'PHO_MASCOR: J1,J2,transfer',J1,J2,PTR
C  copy parents of strings
C  register partons belonging to first string
          IF(IDHEP(J1).EQ.90) THEN
            K1 = JMOHEP(1,J1)
            K2 = MAX(JMOHEP(1,J1),-JMOHEP(2,J1))
            ESUM = 0.D0
            DO 500 II=K1,K2
              ESUM = ESUM+PHEP(4,II)
 500        CONTINUE
            IF(JMOHEP(2,J1).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J1))
            IF ( ABS (ESUM) .LT. 1.D-38 ) THEN
               IREJ = 1
               RETURN
            END IF
            DO 600 II=K1,K2
              FAC = PHEP(4,II)/ESUM
              DO 650 K=1,4
                P1(K) = PHEP(K,II)+FAC*PTR(K)
 650          CONTINUE
              CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
     &          P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
     &          ICOLOR(2,II),IPOS,1)
 600        CONTINUE
            K1A = IPOS+K1-K2
            IF(JMOHEP(2,J1).GT.0) THEN
              II = JMOHEP(2,J1)
              FAC = PHEP(4,II)/ESUM
              DO 675 K=1,4
                P1(K) = PHEP(K,II)+FAC*PTR(K)
 675          CONTINUE
              CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
     &          P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
     &          ICOLOR(2,II),IPOS,1)
            ENDIF
            K2A = -IPOS
          ELSE
            K1A = J1
            K2A = J2
          ENDIF
C  register partons belonging to second string
          IF(IDHEP(J2).EQ.90) THEN
            CALL PHO_GETLTR(PHEP(1,J2),PC2,GAM,GAMB,DELE,IREJL)
            K1 = JMOHEP(1,J2)
            K2 = MAX(JMOHEP(1,J2),-JMOHEP(2,J2))
            ESUM = 0.D0
            DO 300 II=K1,K2
              ESUM = ESUM+PHEP(4,II)
 300        CONTINUE
            IF(JMOHEP(2,J2).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J2))
            DO 400 II=K1,K2
              IF(ESUM.GT.0.D0)FAC = PHEP(4,II)/ESUM
              IF(IREJL.EQ.0) THEN
                CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
                P1(4) = P1(4)+FAC*DELE
              ELSE
                DO 450 K=1,4
                  P1(K) = PHEP(K,II)-FAC*PTR(K)
 450            CONTINUE
              ENDIF
              CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
     &          P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
     &          ICOLOR(2,II),IPOS,1)
 400        CONTINUE
            K1B = IPOS+K1-K2
            IF(JMOHEP(2,J2).GT.0) THEN
              II = JMOHEP(2,J2)
              FAC = PHEP(4,II)/ESUM
              IF(IREJL.EQ.0) THEN
                CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
                P1(4) = P1(4)+FAC*DELE
              ELSE
                DO 475 K=1,4
                  P1(K) = PHEP(K,II)-FAC*PTR(K)
 475            CONTINUE
              ENDIF
              CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
     &          P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
     &          ICOLOR(2,II),IPOS,1)
            ENDIF
            K2B = -IPOS
          ELSE
            K1B = J1
            K2B = J2
          ENDIF
C  register first string/collapsed to hadron
          IF((ISWMDL(7).EQ.0).OR.(ISWMDL(7).EQ.1)) THEN
            IF(NCODE(I).NE.5) THEN
              CALL PHO_REGPAR(1,0,IBHAD(I),K1A,K2A,PC1(1),PC1(2),PC1(3),
     &          PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
C  label string as collapsed to hadron/resonance
              NCODE(I)  = -99
              IDHEP(J1) = 92
            ELSE
              CALL PHO_REGPAR(-1,90,0,K1A,K2A,PC1(1),PC1(2),PC1(3),
     &          PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
              IDHEP(J1) = 91
            ENDIF
            NPOS(1,I) = IPOS
            NPOS(2,I) = K1A
            NPOS(3,I) = K2A
          ELSE
            CALL PHO_REGPAR(ISTA,IDHEP(J1),IMPART(J1),K1A,K2A,PC1(1),
     &        PC1(2),PC1(3),PC1(4),IPHIST(1,J1),IPHIST(2,J1),
     &        ICOLOR(1,J1),ICOLOR(2,J1),IPOS,1)
            IF(IDHEP(J1).EQ.90) THEN
              NPOS(1,IPHIST(1,J1)) = IPOS
              NPOS(2,IPHIST(1,J1)) = K1A
              NPOS(3,IPHIST(1,J1)) = K2A
C  label string as collapsed to resonance-string
              IDHEP(J1) = 91
            ELSE IF((IPHIST(1,J1).GE.1).AND.(IPHIST(1,J1).LE.ISTR)) THEN
              IF(NPOS(1,IPHIST(1,J1)).EQ.J1) NPOS(1,IPHIST(1,J1))=IPOS
            ENDIF
          ENDIF
C  register second string/hadron/parton
          CALL PHO_REGPAR(ISTB,IDHEP(J2),IMPART(J2),K1B,K2B,PC2(1),
     &      PC2(2),PC2(3),PC2(4),IPHIST(1,J2),IPHIST(2,J2),ICOLOR(1,J2),
     &      ICOLOR(2,J2),IPOS,1)
          IF(IDHEP(J2).EQ.90) THEN
            NPOS(1,IPHIST(1,J2))=IPOS
            NPOS(2,IPHIST(1,J2))=K1B
            NPOS(3,IPHIST(1,J2))=K2B
C  label string touched by momentum transfer
            IDHEP(J2) = 91
          ELSE IF((IPHIST(1,J2).GE.1).AND.(IPHIST(1,J2).LE.ISTR)) THEN
            IF(NPOS(1,IPHIST(1,J2)).EQ.J2) NPOS(1,IPHIST(1,J2))=IPOS
          ENDIF
          ICCOR = ICCOR+1
          ITOUCH = ITOUCH+1
C  consistency checks
          IF(IDEB(42).GE.5) THEN
            CALL PHO_CHECK(-1,IDEV)
            IF(IDEB(42).GE.25) CALL PHO_PREVNT(0)
          ENDIF
C  jump to next iteration
          GOTO 50
        ENDIF
 90     CONTINUE
 100  CONTINUE
C  debug output
      IF(IDEB(42).GE.15) THEN
        IF((ITOUCH.GT.0).OR.(IDEB(42).GE.25)) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,I5)') 'PHO_MASCOR: iterations:',ITER
          CALL PHO_PREVNT(1)
        ENDIF
      ENDIF
      END


 
 


CDECK  ID>, PHO_MASSAD
      SUBROUTINE PHO_MASSAD(IFLMO,IFL1,IFL2,
     &                     PMASS,XMCON,XMOUT,IDPDG,IDcpc)
C***********************************************************************
C
C    fine-correction of low mass strings to mass of corresponding
C    resonance or two particle threshold
C
C    input:     IFLMO         PDG ID of mother particle
C               IFL1,2        requested parton flavours
C                             (not used at the moment)
C               PMASS         reference mass (mass of mother particle)
C               XMCON         conjecture of mass
C
C    output:    XMOUT         output mass (adjusted input mass)
C                             moved ot nearest mass possible
C               IDPDG         PDG resonance ID
C               IDcpc         CPC resonance ID
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( DEPS   =  1.D-8 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  general particle data
      DOUBLE PRECISION xm_list,tau_list,gam_list,
     &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
     &  xm_bb82_list,xm_bb102_list
      INTEGER          ich3_list,iba3_list,iq_list,
     &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
      COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
     &  xm_psm2_list(6,6),xm_vem2_list(6,6),
     &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
     &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
     &  ich3_list(300),iba3_list(300),iq_list(3,300),
     &  id_psm_list(6,6),id_vem_list(6,6),
     &  id_b8_list(6,6,6),id_b10_list(6,6,6)

C  particle decay data
      DOUBLE PRECISION wg_sec_list
      INTEGER          idec_list,isec_list
      COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
     &  isec_list(3,500)

      DIMENSION XWG(10),RMA(10),RGA(10),RWG(10),IRPDG(10),IRBAM(10)

      XMINP = XMCON
      IDPDG = 0
      IDcpc = 0
      XMOUT = XMINP

C  resonance treatment activated?
      IF(ISWMDL(23).EQ.0) RETURN

      CALL PHO_DIFRES(IFLMO,IFL1,IFL2,IRPDG,IRBAM,RMA,RGA,RWG,LISTL)
      IF(LISTL.LT.1) THEN
        IF (LPRI.GT.4 .AND. IDEB(7).GE.2)
     &  WRITE(LO,'(1X,A,3I7)')
     &    'PHO_MASSAD: no resonances for (IFMO,IF1,IF2)',
     &    IFLMO,IFL1,IFL2
        GOTO 50
      ENDIF
C  mass small?
      PMASSL = (PMASS+0.15D0)**2
      XMINP2 = XMINP**2
C  determine resonance probability
      DM2 = 1.1D0
      RPROB = (PMASSL+DM2)*(XMINP2-PMASSL)/(DM2*XMINP2)
      IF(RPROB.LT.DT_RNDM(PMASSL)) THEN
C  sample new resonance
        XWGSUM = 0.D0
        DO 100 I=1,LISTL
          XWG(I) = RWG(I)/RMA(I)**2
          XWGSUM = XWGSUM+XWG(I)
 100    CONTINUE

        ITER = 0
 150    CONTINUE
        ITER = ITER+1
        IF(ITER.GE.5) THEN
          IDcpc = 0
          IDPDG = 0
          XMOUT = XMINP
          GOTO 50
        ENDIF

        I = 0
        XI = XWGSUM*DT_RNDM(XMOUT)
 200    CONTINUE
          I = I+1
          XWGSUM = XWGSUM-XWG(I)
        IF((XI.LT.XWGSUM).AND.(I.LT.LISTL)) GOTO 200
        IDPDG = IRPDG(I)
        IDcpc = IRBAM(I)
        GARES = RGA(I)
        XMRES = RMA(I)
        XMRES2 = XMRES**2
C  sample new mass (from Breit-Wigner cross section)
        ALO = ATAN((PMASSL-XMRES2)/(XMRES*GARES))
        AHI = ATAN((5.D0-XMRES2)/(XMRES*GARES))
        XI = (AHI-ALO)*DT_RNDM(XMRES)+ALO
        XMOUT = XMRES*GARES*TAN(XI)+XMRES2
        XMOUT = SQRT(XMOUT)

C  check mass for decay
        AMDCY = 2.D0*XMRES
        ID = abs(IDcpc)
        DO 250 IK=idec_list(2,ID),idec_list(3,ID)
          AMSUM = 0.D0
          DO 275 I=1,3
            IF(isec_list(I,IK).NE.0)
     &        AMSUM = AMSUM + xm_list(abs(isec_list(I,IK)))
 275      CONTINUE
          AMDCY = MIN(AMDCY,AMSUM)
 250    CONTINUE
        IF(AMDCY.GE.XMOUT) GOTO 150

C  debug output
        IF(IDEB(7).GE.10 .AND. LPRI.GT.4)
     &    WRITE(LO,'(1X,2A,/1X,3I6,2E10.3,2I7,2E10.3)')
     &    'PHO_MASSAD: ',
     &    'IFMO,IF1,IF2,XMCON,XMOUT,IDPDG,IDcpc,RMA,RGA',
     &    IFLMO,IFL1,IFL2,XMCON,XMOUT,IDPDG,IDcpc,RMA(I),RGA(I)
        RETURN
      ENDIF

 50   CONTINUE
C  debug output
      IF(IDEB(7).GE.15 .AND. LPRI.GT.4)
     &  WRITE(LO,'(1X,A,/1X,3I6,2E10.3)')
     &    'PHO_MASSAD: string sampled: IFMO,IF1,IF2,XMCON,XMOUT',

     &    IFLMO,IFL1,IFL2,XMCON,XMOUT
      END


 
 


CDECK  ID>, PHO_MCHECK
      SUBROUTINE PHO_MCHECK(J1,IREJ)
C********************************************************************
C
C    check parton momenta for fragmentation
C
C    input:      J1      first  string number
C                        /POEVT1/
C                        /POSTRG/
C
C    output:             /POEVT1/
C                        /POSTRG/
C                IREJ    0  successful
C                        1  failure
C
C    in case of very small string mass:
C                NNCH    mass label of string
C                        0  string
C                       -1  octett baryon / pseudo scalar meson
C                        1  decuplett baryon / vector meson
C                IBHAD   hadron number according to CPC,
C                        string will be treated as resonance
C                        (sometimes far off mass shell)
C
C    constant WIDTH ( 0.01GeV ) determines range of acceptance
C
C********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( WIDTH  =  0.01D0,
     &            DEPS   =  1.D-15 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)


C  color string configurations including collapsed strings and hadrons
      INTEGER MSTR
      PARAMETER (MSTR=2000)
      INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
      COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
     &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
     &                NNCH(MSTR),IBHAD(MSTR),ISTR

C  internal rejection counters
      INTEGER NMXJ
      PARAMETER (NMXJ=60)
      CHARACTER*10 REJTIT
      INTEGER IFAIL
      COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)


      IREJ = 0
C  quark antiquark jet
      STRM = PHEP(5,NPOS(1,J1))
      IF(NCODE(J1).EQ.3) THEN
        CALL PHO_MEMASS(IPAR1(J1),IPAR2(J1),
     &    AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
        IF(IDEB(18).GE.5 .AND. LPRI.GT.4)
     &    WRITE(LO,'(1X,A,/3X,I3,5E12.3)')
     &      'PHO_MCHECK:1.STRING NO, CHMASS,AMPS,AMPS2,AMVE,AMVE2 ',
     &      J1,STRM,AMPS,AMPS2,AMVE,AMVE2
        IF(STRM.LT.AMPS) THEN
          IREJ = 1
          IFAIL(20) = IFAIL(20) + 1
          RETURN
        ELSE IF(STRM.LT.AMPS2) THEN
          IF(STRM.LT.(AMVE-WIDTH)) THEN
            NNCH(J1) = -1
            IBHAD(J1) = IPS
          ELSE
            NNCH(J1) = 1
            IBHAD(J1) = IVE
          ENDIF
        ELSE
          NNCH(J1) = 0
          IBHAD(J1) = 0
        ENDIF
C  quark diquark or v.s. jet
      ELSE IF((NCODE(J1).EQ.4).OR.(NCODE(J1).EQ.6)) THEN
        CALL PHO_BAMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),
     &              AM8,AM82,AM10,AM102,I8,I10)
        IF(IDEB(18).GE.5 .AND. LPRI.GT.4)
     &    WRITE(LO,'(1X,A,/5X,I3,5E12.3)')
     &            'PHO_MCHECK:1.STRING NO, CHMASS,AM8,AM82,AM10,AM102 ',
     &            J1,STRM,AM8,AM82,AM10,AM102
        IF(STRM.LT.AM8) THEN
          IREJ = 1
          IFAIL(19) = IFAIL(19) + 1
          RETURN
        ELSE IF(STRM.LT.AM82) THEN
          IF(STRM.LT.(AM10-WIDTH)) THEN
            NNCH(J1) = -1
            IBHAD(J1) = I8
          ELSE
            NNCH(J1) = 1
            IBHAD(J1) = I10
          ENDIF
        ELSE
          NNCH(J1) = 0
          IBHAD(J1) = 0
        ENDIF
C  diquark a-diquark string
      ELSE IF(NCODE(J1).EQ.5) THEN
        CALL PHO_DQMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),IPAR4(J1),
     &              AM82,AM102)
        IF(IDEB(18).GE.5 .AND. LPRI.GT.4)
     &    WRITE(LO,'(1X,A,/5X,I3,3E12.3)')
     &            'PHO_MCHECK:1.STRING NO, CHMASS,AM82,AM102 ',
     &            J1,STRM,AM82,AM102
        IF(STRM.LT.AM82) THEN
          IREJ = 1
          IFAIL(19) = IFAIL(19) + 1
          RETURN
        ELSE
          NNCH(J1) = 0
          IBHAD(J1) = 0
        ENDIF
      ELSE IF(NCODE(J1).LT.0) THEN
        RETURN
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/,1X,2A,2I8)')  'PHO_MCHECK: ',
     &    'inconsistent flavours for string (NO,NCODE)',J1,NCODE(J1)
        CALL PHO_ABORT
      ENDIF
      END


 
 


CDECK  ID>, PHO_MCINI
      SUBROUTINE PHO_MCINI
C********************************************************************
C
C     initialization of MC event generation
C
C********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( PIMASS =  0.13D0,
     &            TINY   =  1.D-10 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  current beam selection
      INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN
      INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL
      DOUBLE PRECISION SQSGLOBMAX
      PARAMETER (MPARMAX=40)
      PARAMETER (MAXMAPPS=40)
      PARAMETER (IKNOWN=9)
      DIMENSION IPAVAIL(IKNOWN)
      DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/
      COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS),
     &           MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  general process information
      INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
      COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)

C  cross sections
      INTEGER IPFIL,IFAFIL,IFBFIL
      DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
     &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
     &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
     &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
     &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
      COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
     &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
     &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
     &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
     &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
     &                IPFIL,IFAFIL,IFBFIL

C  hard cross sections and MC selection weights
      INTEGER Max_pro_2
      PARAMETER ( Max_pro_2 = 16 )
      INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
     &  MH_acc_1,MH_acc_2
      DOUBLE PRECISION HFAC, HWGX, HSIG, HDPT, HECM_LAST, 
     &   HQ2A_LAST, HQ2B_LAST
      COMMON /POHRCS/HFAC(-1:MAX_PRO_2, MPARMAX), 
     &   HWGX(-1:MAX_PRO_2, MPARMAX),
     &   HSIG(-1:MAX_PRO_2, MPARMAX), HDPT(-1:MAX_PRO_2, MPARMAX), 
     &   HECM_LAST, HQ2A_LAST, HQ2B_LAST, IHA_LAST, IHB_LAST, 
     &   MH_PRO_ON(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_TRIED(-1:MAX_PRO_2, 0:4, MPARMAX), 
     &   MH_ACC_1(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_ACC_2(-1:MAX_PRO_2, 0:4, MPARMAX) 

C  interpolation tables for hard cross section and MC selection weights
      INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
      PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
      INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
      DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
     &  HQ2a_tab,HQ2b_tab,HEcm_tab
      COMMON /POHTAB/
     &  Hfac_tab(-1:Max_pro_tab,Max_tab_E,
     &           Max_tab_Q2,Max_tab_Q2,0:4,MPARMAX),
     &  HWgx_tab(-1:Max_pro_tab,Max_tab_E,
     &           Max_tab_Q2,Max_tab_Q2,0:4,MPARMAX),
     &  HSig_tab(-1:Max_pro_tab,Max_tab_E,
     &           Max_tab_Q2,Max_tab_Q2,0:4,MPARMAX),
     &  Hdpt_tab(-1:Max_pro_tab,Max_tab_E,
     &           Max_tab_Q2,Max_tab_Q2,0:4,MPARMAX),
     &  HQ2a_tab(1:Max_tab_Q2,0:4,MPARMAX),
     &  HQ2b_tab(1:Max_tab_Q2,0:4,MPARMAX),
     &  HEcm_tab(1:Max_tab_E,0:4,MPARMAX),
     &  IH_Q2a_up(0:4,MPARMAX),IH_Q2b_up(0:4,MPARMAX),
     &  IH_Ecm_up(0:4,MPARMAX)

C  global event kinematics and particle IDs
      INTEGER IFPAP,IFPAB
      DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
      COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)

C  obsolete cut-off information
      DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
      COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN

C  event weights and generated cross section
      INTEGER IPOWGC,ISWCUT,IVWGHT
      DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
      COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
     &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)

C  cut probability distribution
      INTEGER IEETA1,IIMAX,KKMAX
      PARAMETER( IEETA1=20, IIMAX=20, KKMAX=500 )
      INTEGER IEEMAX,IMAX,KMAX
      DOUBLE PRECISION EPTAB, PROB
      COMMON /POPROB/ PROB(IEETA1, 0:IIMAX, 0:KKMAX, 4, MPARMAX),
     &          EPTAB(IEETA1, 4, MPARMAX), IEEMAX, IMAX, KMAX

C  energy-interpolation table
      INTEGER IEETA2
      PARAMETER ( IEETA2 = 20 )
      INTEGER ISIMAX
      DOUBLE PRECISION SIGTAB,SIGECM, ECMF
      COMMON /POTABL/ SIGTAB(80, IEETA2, 4, MPARMAX),
     &                SIGECM(IEETA2, 4, MPARMAX), ECMF(4, MPARMAX),
     &                ISIMAX(MPARMAX)

      CHARACTER*15 PHO_PNAME
      DATA  XMPOM / 0.766D0 /

C  initialize fragmentation
      CALL PHO_FRAINI(ISWMDL(6))

C  reset interpolation tables
      DO K = 1, 4
        DO J = 1, IEETA1
          DO I = 1, 80
            SIGTAB(I, J, K, IDXMPAR) = 0.D0
          END DO
          SIGECM(J, K, IDXMPAR) = 0.D0
        END DO
      END DO

C  max. number of allowed colors (large N expansion)
      IC1 = 0
      IC2 = 10000
      CALL PHO_SELCOL(IC1,IC2,0,0,0,0,-1)

C  lower energy limit of initialization
      ETABLO = PARMDL(19)
      IF(SQSGLOBMAX.LE.5.D0) ETABLO = MIN(2.5D0,ETABLO)

      IF (LPRI.GT.4)
     &WRITE(LO,'(/,1X,A,2F12.1)')
     &  'PHO_MCINI: selected energy range (SQRT(S))',ETABLO,SQSGLOBMAX
      IF (LPRI.GT.4)
     &WRITE(LO,'(5X,A,A,F7.3,E15.4)')
     &  'particle 1 (name,mass,virtuality): ',PHO_PNAME(IFPAP(1),1),
     &  PMASS(1),PVIRT(1)
      IF (LPRI.GT.4)
     &WRITE(LO,'(5X,A,A,F7.3,E15.4)')
     &  'particle 2 (name,mass,virtuality): ',PHO_PNAME(IFPAP(2),1),
     &  PMASS(2),PVIRT(2)

C  cuts on probabilities of multiple interactions
      IMAX = MIN(IPAMDL(32),IIMAX)
      KMAX = MIN(IPAMDL(33),KKMAX)
      AH = 2.D0*PTCUT(1)/SQSGLOBMAX
      IMAX = MAX(5,MIN(IMAX,INT(SQSGLOBMAX/2.0D0)))
      KMAX = MIN(KMAX,1+INT(0.9*1.D0/AH))

C  hard interpolation table
      ECMF(1,IDXMPAR) = SQSGLOBMAX
      ECMF(2,IDXMPAR) = 0.9D0*ECMF(1,IDXMPAR)
      ECMF(3,IDXMPAR) = ECMF(2,IDXMPAR)
      ECMF(4,IDXMPAR) = ECMF(2,IDXMPAR)
      do k=1,4
        IH_Ecm_up(k,IDXMPAR) = MIN(IPAMDL(30),Max_tab_E)
        IF(ECMF(k,IDXMPAR).LT.100.D0) IH_Ecm_up(k,IDXMPAR) = 
     &    MIN(IH_Ecm_up(k,IDXMPAR),15)
        IF(ECMF(k,IDXMPAR).LT.50.D0)  IH_Ecm_up(k,IDXMPAR) = 
     &    MIN(IH_Ecm_up(k,IDXMPAR),10)
        IF(ECMF(k,IDXMPAR).LT.10.D0)  IH_Ecm_up(k,IDXMPAR) = 
     &    MIN(IH_Ecm_up(k,IDXMPAR),5)
      enddo

C  initialization of hard scattering for all channels and cutoffs
      IF(HSWCUT(5).GT.PARMDL(36))  CALL PHO_HARMCI(-1,ECMF(1,IDXMPAR))
      I0 = 4
      IF(ISWMDL(2).EQ.0) I0 = 1
      DO 110 I=I0,1,-1
        CALL PHO_HARMCI(I,ECMF(I,IDXMPAR))
 110  CONTINUE

C  dimension of interpolation table of cut probabilities
      IEEMAX = MIN(IPAMDL(31),IEETA1)
      IF(SQSGLOBMAX.LT.100.D0) IEEMAX = MIN(IEEMAX,15)
      IF(SQSGLOBMAX.LT.50.D0)  IEEMAX = MIN(IEEMAX,10)
      IF(SQSGLOBMAX.LT.10.D0)  IEEMAX = MIN(IEEMAX,5)
      ISIMAX(IDXMPAR) = IEEMAX

C  calculate probability distribution
      I0 = 4
      IFT1 = IFPAP(1)
      IFT2 = IFPAP(2)
      XMT1 = PMASS(1)
      XMT2 = PMASS(2)
      XVT1 = PVIRT(1)
      XVT2 = PVIRT(2)
      IF(ISWMDL(2).EQ.0) I0 = 1
      DO 150 IP=I0,1,-1
      ECMPRO = ECMF(IP,IDXMPAR)*1.001D0
      IF(IP.EQ.4) THEN
        IFPAP(1) = 990
        IFPAP(2) = 990
        PMASS(1) = XMPOM
        PMASS(2) = XMPOM
        PVIRT(1) = 0.D0
        PVIRT(2) = 0.D0
      ELSE IF(IP.EQ.3) THEN
        IFPAP(1) = IFT2
        IFPAP(2) = 990
        PMASS(1) = XMT2
        PMASS(2) = XMPOM
        PVIRT(1) = XVT2
        PVIRT(2) = 0.D0
      ELSE IF(IP.EQ.2) THEN
        IFPAP(1) = IFT1
        IFPAP(2) = 990
        PMASS(1) = XMT1
        PMASS(2) = XMPOM
        PVIRT(1) = XVT1
        PVIRT(2) = 0.D0
      ELSE
        IFPAP(1) = IFT1
        IFPAP(2) = IFT2
        PMASS(1) = XMT1
        PMASS(2) = XMT2
        PVIRT(1) = XVT1
        PVIRT(2) = XVT2
      ENDIF
      IF(IEEMAX.GT.1) THEN
        IF(IP.EQ.1) THEN
          ELMIN = LOG(ETABLO)
        ELSE
          ELMIN = LOG(2.5D0)
        ENDIF
        EDELTA = (LOG(ECMPRO)-ELMIN)/DBLE(MAX(1,IEEMAX-1))
        DO 100 I=1,IEEMAX
          ECMPRO = EXP(ELMIN+DBLE(I-1)*EDELTA)
          CALL PHO_PRBDIS(IP,ECMPRO,I)
 100    CONTINUE
      ELSE
        CALL PHO_PRBDIS(IP,ECMPRO,1)
      ENDIF

C  debug output of cross section tables
      IF(((IDEB(62).GE.0).AND.(IP.EQ.1)).OR.(IDEB(62).GE.3)) THEN
      IF((PVIRT(1)+PVIRT(2).GT.0.01D0).AND.(IDEB(62).EQ.0)) GOTO 201
      IF (LPRI.GT.4)
     &WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
     &'Table of total cross sections (mb) for particle combination',IP,
     &' Ecm    SIGtot  SIGela  SIGine  SIGqel  SIGsd1  SIGsd2  SIGdd',
     &'-------------------------------------------------------------'
      DO 200 I=1,IEEMAX
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,1P,8E9.2)') 
     &    SIGECM(I,IP,IDXMPAR),SIGTAB(1,I,IP,IDXMPAR),
     &    SIGTAB(2,I,IP,IDXMPAR),SIGTAB(28,I,IP,IDXMPAR),
     &    SIGTAB(3,I,IP,IDXMPAR),
     &    SIGTAB(30,I,IP,IDXMPAR)+SIGTAB(32,I,IP,IDXMPAR),
     &    SIGTAB(31,I,IP,IDXMPAR)+SIGTAB(33,I,IP,IDXMPAR),
     &    SIGTAB(34,I,IP,IDXMPAR)+SIGTAB(35,I,IP,IDXMPAR)
 200  CONTINUE
 201  CONTINUE
      IF(IDEB(62).GE.2) THEN
      IF (LPRI.GT.4)
     &WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
     &'Table of partial x-sections (mb) for particle combination',IP,
     &' Ecm    SIGSD1L SIGSD1H SIGSD2L SIGSD2H SIGDDL  SIGDDH  SIGCDF',
     &'--------------------------------------------------------------'
      DO 205 I=1,IEEMAX
        IF (LPRI.GT.4)
     .  WRITE(LO,'(1X,1P,8E9.2)') 
     &    SIGECM(I,IP,IDXMPAR),SIGTAB(30,I,IP,IDXMPAR),
     &    SIGTAB(32,I,IP,IDXMPAR),SIGTAB(31,I,IP,IDXMPAR),
     &    SIGTAB(33,I,IP,IDXMPAR),
     &    SIGTAB(34,I,IP,IDXMPAR),SIGTAB(35,I,IP,IDXMPAR),
     &    SIGTAB(36,I,IP,IDXMPAR)
 205  CONTINUE
      ENDIF
      IF(IDEB(62).GE.2) THEN
      IF (LPRI.GT.4)
     &WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
     &'Table of born graph x-sections (mb) for particle combination',IP,
     &' Ecm    SIGSVDM SIGHRES SIGHDIR SIGTR1  SIGTR2  SIGLOO SIGDPO',
     &'-------------------------------------------------------------'
      DO 210 I=1,IEEMAX
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,1P,8E9.2)') SIGECM(I,IP,IDXMPAR),
     &    SIGTAB(56,I,IP,IDXMPAR)+SIGTAB(57,I,IP,IDXMPAR),
     &    SIGTAB(58,I,IP,IDXMPAR),
     &    SIGTAB(59,I,IP,IDXMPAR),SIGTAB(60,I,IP,IDXMPAR)
     &    +SIGTAB(61,I,IP,IDXMPAR),
     &    SIGTAB(62,I,IP,IDXMPAR)+SIGTAB(63,I,IP,IDXMPAR),
     &    SIGTAB(64,I,IP,IDXMPAR),
     &    SIGTAB(65,I,IP,IDXMPAR)+SIGTAB(66,I,IP,IDXMPAR)
     &    +SIGTAB(67,I,IP,IDXMPAR)+SIGTAB(68,I,IP,IDXMPAR)
 210  CONTINUE
      IF (LPRI.GT.4)
     &WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
     &'Table of unitarized x-sections (mb) for particle combination',IP,
     &' Ecm    SIGSVDM SIGHVDM  SIGTR1  SIGTR2  SIGLOO SIGDPO  SLOPE',
     &'-------------------------------------------------------------'
      DO 215 I=1,IEEMAX
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,1P,8E9.2)') 
     &    SIGECM(I,IP,IDXMPAR),SIGTAB(79,I,IP,IDXMPAR),
     &    SIGTAB(80,I,IP,IDXMPAR),SIGTAB(32,I,IP,IDXMPAR),
     &    SIGTAB(33,I,IP,IDXMPAR),SIGTAB(35,I,IP,IDXMPAR),
     &    SIGTAB(36,I,IP,IDXMPAR),SIGTAB(39,I,IP,IDXMPAR)
 215  CONTINUE
      ENDIF
      IF(IDEB(62).GE.1) THEN
      IF (LPRI.GT.4)
     &WRITE(LO,'(/1X,A,/1X,A,2I4,/1X,A,/1X,A)')
     &'Table of expected average number of cuts in non-diff events:',
     &'       for max. number of cuts soft/hard:',IMAX,KMAX,
     &' Ecm   PTCUT   SIGNDF   POM-S   POM-H   REG-S',
     &'---------------------------------------------'
      DO 220 I=1,IEEMAX
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,1P,6E10.3)') 
     &    SIGECM(I,IP,IDXMPAR),SIGTAB(77,I,IP,IDXMPAR),
     &    SIGTAB(78,I,IP,IDXMPAR),SIGTAB(74,I,IP,IDXMPAR),
     &    SIGTAB(75,I,IP,IDXMPAR),SIGTAB(76,I,IP,IDXMPAR)
 220  CONTINUE
      IF(IP.EQ.1) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,/1X,A,/1X,A)')
     &  'Table of rapidity gap survival probability (high-mass diff.):',
     &  ' Ecm    Spro-sd1     Spro-sd2    Spro-dd    Spro-cd',
     &  '---------------------------------------------------'
        DO 230 I=1,IEEMAX
          IF(SIGECM(I,IP,IDXMPAR).GT.10.D0) THEN
            SPRSD1 = SIGTAB(32,I,IP,IDXMPAR)/(SIGTAB(60,I,IP,IDXMPAR)
     &        -2.D0*(SIGTAB(65,I,IP,IDXMPAR)+SIGTAB(66,I,IP,IDXMPAR)))
            SPRSD2 = SIGTAB(33,I,IP,IDXMPAR)/(SIGTAB(62,I,IP,IDXMPAR)
     &        -2.D0*(SIGTAB(65,I,IP,IDXMPAR)+SIGTAB(67,I,IP,IDXMPAR)))
            SPRDD  = SIGTAB(35,I,IP,IDXMPAR)/(SIGTAB(64,I,IP,IDXMPAR)
     &        +SIGTAB(61,I,IP,IDXMPAR)
     &        +SIGTAB(63,I,IP,IDXMPAR)-2.D0*(SIGTAB(66,I,IP,IDXMPAR)
     &        +SIGTAB(67,I,IP,IDXMPAR)+2.D0*SIGTAB(68,I,IP,IDXMPAR)))
cdh 23.1.2017          
c           SPRCDF = SIGTAB(36,I,IP,IDXMPAR)/(SIGTAB(65,I,IP,IDXMPAR)
c    &        +SIGTAB(66,I,IP,IDXMPAR)
c    &        +SIGTAB(67,I,IP,IDXMPAR)+SIGTAB(68,I,IP,IDXMPAR))
            IF ( SIGTAB(65,I,IP,IDXMPAR).GT.0.D0 ) THEN
              SPRCDF = SIGTAB(36,I,IP,IDXMPAR)/(SIGTAB(65,I,IP,IDXMPAR)
     &               + SIGTAB(66,I,IP,IDXMPAR)
     &               + SIGTAB(67,I,IP,IDXMPAR)+SIGTAB(68,I,IP,IDXMPAR))
            ELSE
              SPRCDF = 0.D0
            ENDIF
cdh
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,1P,5E10.3)') SIGECM(I,IP,IDXMPAR),
     &        SPRSD1,SPRSD2,SPRDD,SPRCDF
          ENDIF
 230    CONTINUE
      ENDIF
      ENDIF
      ENDIF
 150  CONTINUE

C  simulate only hard scatterings
      IF(ISWMDL(2).EQ.0) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(2(/1X,A))')
     &    'WARNING: generation of hard scatterings only!',
     &    '============================================='
        DO 151 I=2,7
          IPRON(I,1) = 0
 151    CONTINUE
        DO 152 K=2,4
          DO 153 I=1,15
            IPRON(I,K) = 0
 153      CONTINUE
 152    CONTINUE
        SIGGEN(4) = 0.D0
        DO 160 I=1,IEEMAX
          SIGMAX = 0.D0
          IF(IPRON(1,1).EQ.1) SIGMAX = SIGTAB(58,I,1,IDXMPAR)
          IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGTAB(59,I,1,IDXMPAR)
          IF(SIGMAX.GT.SIGGEN(4)) THEN
            ISIGM = I
            SIGGEN(4) = SIGMAX
          ENDIF
 160    CONTINUE
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(2(/1X,A))')
     &    'activated processes, cross section',
     &    '----------------------------------'
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,I3,2X,3I3)')
     &    '  nondiffr. resolved processes',(IPRON(1,K),K=1,4)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,I3,2X,3I3)')
     &    '            elastic scattering',(IPRON(2,K),K=1,4)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,I3,2X,3I3)')
     &    'qelast. vectormeson production',(IPRON(3,K),K=1,4)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,I3,2X,3I3)')
     &    '      double pomeron processes',(IPRON(4,K),K=1,4)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,I3,2X,3I3)')
     &    ' single diffract. particle (1)',(IPRON(5,K),K=1,4)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,I3,2X,3I3)')
     &    ' single diffract. particle (2)',(IPRON(6,K),K=1,4)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,I3,2X,3I3)')
     &    '    double diffract. processes',(IPRON(7,K),K=1,4)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,I3,2X,3I3)')
     &    '       direct photon processes',(IPRON(8,K),K=1,4)

C  calculate effective cross section
        SIGGEN(4) = 0.D0
        DO 165 I=1,IEEMAX
          CALL PHO_CSINT(1,IFPAP(1),IFPAP(2),-1,-1,SIGECM(I,1,IDXMPAR),
     &                PVIRT(1),PVIRT(2))
          SIGMAX = 0.D0
          if(iswmdl(2).ge.1) then
            IF(IPRON(1,1).EQ.1) SIGMAX = SIGTOT-SIGELA-SIGVM(0,0)
     &        -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
     &        -SIGLDD-SIGHDD-SIGDIR
            IF(IPRON(2,1).EQ.1) SIGMAX = SIGMAX+SIGELA
            IF(IPRON(3,1).EQ.1) SIGMAX = SIGMAX+SIGVM(0,0)
            IF(IPRON(4,1).EQ.1) SIGMAX = SIGMAX+SIGCDF(0)
            IF(IPRON(5,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(1)+SIGHSD(1)
            IF(IPRON(6,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(2)+SIGHSD(2)
            IF(IPRON(7,1).EQ.1) SIGMAX = SIGMAX+SIGLDD+SIGHDD
            IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
          else
            IF(IPRON(1,1).EQ.1) SIGMAX = SIGHAR
            IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
          endif
          IF(SIGMAX.GT.SIGGEN(4)) THEN
            ISIGM = I
            SIGGEN(4) = SIGMAX
          ENDIF
 165    CONTINUE
      ENDIF

C  debug output
      IF(SIGGEN(4).LT.1.D-20) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(//1X,A)')
     &  'PHO_MCINI:ERROR: selected processes have vanishing x-section'
        STOP
      ENDIF
      IF (LPRI.GT.4)
     &WRITE(LO,'(3X,A,1P3E11.4)') 'maximum search (Elow/Eup/Epeak)',
     &  SIGECM(1,1,IDXMPAR),SIGECM(IEEMAX,1,IDXMPAR),
     &  SIGECM(ISIGM,1,IDXMPAR)
      IF (LPRI.GT.4)
     &WRITE(LO,'(11X,A,1PE12.4,/)') 'max. cross section (mb)',SIGGEN(4)

      END


 
 


CDECK  ID>, PHO_MEMASS
      SUBROUTINE PHO_MEMASS(I,J,AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
C**********************************************************************
C
C     determine meson masses corresponding to the input flavours
C
C     input: I,J,K     quark flavours (PDG convention)
C
C     output: AMPS     pseudo scalar meson mass
C             AMPS2    next possible two particle configuration
C                      (two pseudo scalar  mesons)
C             AMVE     vector meson mass
C             AMVE2    next possible two particle configuration
C                      (two vector mesons)
C             IPS,IVE  meson numbers in CPC
C
C**********************************************************************

      IMPLICIT NONE
      SAVE

      INTEGER I,J,IPS,IVE
      DOUBLE PRECISION AMPS,AMPS2,AMVE,AMVE2

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  particle ID translation table
      integer         ID_pdg_list,ID_list,ID_pdg_max
      character*12    name_list
      COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
     &                ID_pdg_max

C  general particle data
      DOUBLE PRECISION xm_list,tau_list,gam_list,
     &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
     &  xm_bb82_list,xm_bb102_list
      INTEGER          ich3_list,iba3_list,iq_list,
     &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
      COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
     &  xm_psm2_list(6,6),xm_vem2_list(6,6),
     &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
     &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
     &  ich3_list(300),iba3_list(300),iq_list(3,300),
     &  id_psm_list(6,6),id_vem_list(6,6),
     &  id_b8_list(6,6,6),id_b10_list(6,6,6)


C  local variables
      INTEGER ii,jj

      IF(I.GT.0) THEN
        ii = I
        jj = -J
      ELSE
        ii = J
        jj = -I
      ENDIF

C  particle ID's
      IPS = id_psm_list(ii,jj)
      IVE = id_vem_list(ii,jj)
C  masses
      if(IPS.ne.0) then
        AMPS = xm_list(abs(IPS))
      else
        AMPS = 0.D0
      endif
      if(IVE.ne.0) then
        AMVE = xm_list(abs(IVE))
      else
        AMVE = 0.D0
      endif

C  next possible two-particle configurations (add phase space)
      AMPS2 = xm_psm2_list(ii,jj)*1.5D0
      AMVE2 = xm_vem2_list(ii,jj)*1.1D0

      END


 
 


CDECK  ID>, PHO_MKSLTR
      SUBROUTINE PHO_MKSLTR(P1,P2,GAM,GAMB)
C********************************************************************
C
C     calculate successive Lorentz boots for arbitrary Lorentz trans.
C
C     input:   P1                initial 4 vector
C              GAM(3),GAMB(3)    Lorentz boost parameters
C
C     output:  P2                final  4 vector
C
C********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      DIMENSION P1(4),P2(4),GAM(3),GAMB(3)

      P2(4) = P1(4)
      DO 150 I=1,3
        P2(I)=GAM(I)*P1(I)+GAMB(I)*P2(4)
        P2(4)=GAM(I)*P2(4)+GAMB(I)*P1(I)
 150  CONTINUE

      END


 
 


CDECK  ID>, PHO_MSHELL
      SUBROUTINE PHO_MSHELL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
C********************************************************************
C
C    rescaling of momenta of two partons to put both
C                                       on mass shell
C
C    input:       PA1,PA2   input momentum vectors
C                 XM1,2     desired masses of particles afterwards
C                 P1,P2     changed momentum vectors
C
C********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( DEPS   =  1.D-20 )

      DIMENSION PA1(*),PA2(*),P1(*),P2(*)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  internal rejection counters
      INTEGER NMXJ
      PARAMETER (NMXJ=60)
      CHARACTER*10 REJTIT
      INTEGER IFAIL
      COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)


      IREJ = 0
      IDEV = 0
C  debug output
      IF(IDEB(40).GE.10) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,2E12.3)') 'new masses:',XM1,XM2
      ENDIF

C  Lorentz transformation into system CMS
      PX = PA1(1)+PA2(1)
      PY = PA1(2)+PA2(2)
      PZ = PA1(3)+PA2(3)
      EE = PA1(4)+PA2(4)
      XMS = EE**2-PX**2-PY**2-PZ**2
      IF(XMS.LT.(XM1+XM2)**2) THEN
        IREJ = 1
        IFAIL(37) = IFAIL(37)+1

        if((xm1.gt.1.D4).or.(xm2.gt.1.D4)) irej = irej/idev

        IF(IDEB(40).GE.3) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,I12)')
     &      'PHO_MSHELL:reject: too small string mass (KEVENT)',KEVENT
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,3E12.4)') 'two-part.mass, part.masses:',
     &      SIGN(SQRT(ABS(XMS)),XMS),XM1,XM2
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,4E11.4)') 'PX,PY,PZ,EE:',PX,PY,PZ,EE
          IDEV = 5
          IF(IDEB(40).GE.3) GOTO 55
        ENDIF
        RETURN
      ENDIF
      XMS = SQRT(XMS)
      BGX = PX/XMS
      BGY = PY/XMS
      BGZ = PZ/XMS
      GAM = EE/XMS
      CALL PHO_ALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
     &           PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
C  rotation angles
      PTOT1 = MAX(DEPS,PTOT1)
      COD = P1(3)/PTOT1
      SID = SQRT(P1(1)**2+P1(2)**2)/PTOT1
      COF = 1.D0
      SIF = 0.D0
      IF(PTOT1*SID.GT.1.D-5) THEN
        COF = P1(1)/(SID*PTOT1)
        SIF = P1(2)/(SID*PTOT1)
        ANORF = SQRT(COF*COF+SIF*SIF)
        COF = COF/ANORF
        SIF = SIF/ANORF
      ENDIF

C  new CM momentum and energies (for masses XM1,XM2)
      XM12 = XM1**2
      XM22 = XM2**2
      SS   = XMS**2
      PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*XMS)
      EE1  = SQRT(XM12+PCMP**2)
      EE2  = XMS-EE1
C  back rotation
      CALL PHO_TRANS(0.D0,0.D0,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
      CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
     &           PTOT1,P1(1),P1(2),P1(3),P1(4))
      CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
     &           PTOT2,P2(1),P2(2),P2(3),P2(4))

C  check consistency
      DEL = XMS*0.0001
      IF(ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
        IDEV = 1
      ELSE IF(ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
        IDEV = 2
      ELSE IF(ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
        IDEV = 3
      ELSE IF(ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
        IDEV = 4
      ENDIF
 55   CONTINUE
C  debug output
      IF(IDEV.NE.0) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I3)')
     &    'PHO_MSHELL: inconsistent transformation (IDEV)',IDEV
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,3E12.3)') 'ava.mass,masses:',XMS,XM1,XM2
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
      ELSE IF(IDEB(40).GE.10) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
      ENDIF

      END

 
 


CDECK  ID>, PHO_PARCOR
      SUBROUTINE PHO_PARCOR(MODE,IREJ)
C********************************************************************
C
C    conversion of string partons (using JETSET masses)
C
C    input:      MODE    >0 position index of corresponding string
C                        -1 initialization
C                        -2 output of statistics
C
C    output:     /POSTRG/
C                IREJ    1 combination of strings impossible
C                        0 successful combination
C
C********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( DELM   =  0.005D0,
     &            DEPS   =  1.D-15,
     &            EPS    =  1.D-5)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  internal rejection counters
      INTEGER NMXJ
      PARAMETER (NMXJ=60)
      CHARACTER*10 REJTIT
      INTEGER IFAIL
      COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

C  color string configurations including collapsed strings and hadrons
      INTEGER MSTR
      PARAMETER (MSTR=2000)
      INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
      COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
     &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
     &                NNCH(MSTR),IBHAD(MSTR),ISTR

      DIMENSION PP1(4),PP2(4),PB1(4),PB2(4),GAM(3),GAMB(3),
     &          PL(4,100),XMP(100),XML(100)

      DOUBLE PRECISION PYMASS

      IREJ = 0
      IMODE = MODE
C
      IF(IMODE.GT.0) THEN
        ICH = 0
        I1 = JMOHEP(1,IMODE)
        I2 = ABS(JMOHEP(2,IMODE))
C  copy to local field
        L = 0
        DO 100 I=I1,I2
          L = L+1
          DO 200 K=1,4
            PL(K,L) = PHEP(K,I)
 200      CONTINUE
          XMP(L) = PHEP(5,I)

          XML(L) = PYMASS(IDHEP(I))

 100    CONTINUE
        IPAR = L
        XMC = PHEP(5,IMODE)
        IF(IDEB(82).GE.20) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,I7,2I4)')
     &      'PHO_PARCOR: ini.momenta,masses(C/L),EV,ICH,L',
     &      KEVENT,IMODE,L
          DO 150 I=1,L
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
     &       XMP(I),XML(I)
 150      CONTINUE
        ENDIF
C
C  two parton configurations
C  -----------------------------------------
        IF(IPAR.EQ.2) THEN
          XM1 = XML(1)
          XM2 = XML(2)
          IF((XM1+XM2).GE.XMC) THEN
            IF (LPRI.GT.4 .AND. IDEB(82).GE.6)
     &      WRITE(LO,'(1X,A,/,5X,I3,3E12.4)')
     &        'PHO_PARCOR: REJECTION I,XM1,XM2,XMC',
     &        IMODE,XM1,XM2,XMC
            GOTO 990
          ENDIF
C  conversion possible
          CALL PHO_MSHELL(PL(1,1),PL(1,2),XM1,XM2,PP1,PP2,IREJ)
          IF(IREJ.NE.0) THEN
            IFAIL(36) = IFAIL(36)+1
            IF (LPRI.GT.4 .AND. IDEB(82).GE.6)
     &      WRITE(LO,'(1X,A,I8,I4,E12.4)')
     &      'PHO_PARCOR: rejection by PHO_MSHELL EV,STRING,MASS',
     &        KEVENT,IMODE,XMC
            GOTO 990
          ENDIF
          ICH = 1
          DO 115 K=1,4
            PL(K,1) = PP1(K)
            PL(K,2) = PP2(K)
            XMP(1) = XM1
            XMP(2) = XM2
 115      CONTINUE
C
C  multi parton configurations
C  ---------------------------------
        ELSE
C
C  random selection of string side to start with
          IF(DT_RNDM(XMC).LT.0.5D0) THEN
            K1 = 1
            K2 = IPAR
            KS = 1
          ELSE
            K1 = IPAR
            K2 = 1
            KS = -1
          ENDIF
          ITER = 0
C
 300      CONTINUE
          IF(ITER.LT.4) THEN
            KK = K1
            K1 = K2
            K2 = KK
            KS = -KS
          ELSE
            GOTO 990
          ENDIF
          ITER = ITER+1
C  select method
          IF(ITER.GT.2) GOTO 230

C  conversion according to color flow method
          IFAI = 0
          DO 210 II=K1,K2-KS,KS
            DO 215 IK=II+KS,K2,KS
              XM1 = XML(II)
              XM2 = XML(IK)
*             IF(IDEB(82).GE.10) WRITE(LO,'(1X,A,2I3,4E12.4)')
*    &          'PHO_PARCOR:I,K,XM(1-4)',II,IK,XM1,XMP(II),XM2,XMP(IK)
              IF((ABS(XM1-XMP(II)).GT.DELM)
     &           .OR.(ABS(XM2-XMP(IK)).GT.DELM)) THEN
                CALL PHO_MSHELL(PL(1,II),PL(1,IK),XM1,XM2,PP1,PP2,IREJ)
                IF(IREJ.NE.0) THEN
                  IFAIL(36) = IFAIL(36)+1
                  IF (LPRI.GT.4 .AND. IDEB(82).GE.6)
     &            WRITE(LO,'(1X,2A,I8,3I4)')
     &              'PHO_PARCOR: ',
     &              'int.rej. by PHO_MSHELL EV,IC,I1,I2',
     &              KEVENT,IMODE,II,IK
                  IREJ = 0
                ELSE
                  ICH = ICH+1
                  DO 220 KK=1,4
                    PL(KK,II) = PP1(KK)
                    PL(KK,IK) = PP2(KK)
 220              CONTINUE
                  XMP(II) = XM1
                  XMP(IK) = XM2
                  GOTO 219
                ENDIF
              ELSE
                GOTO 219
              ENDIF
 215        CONTINUE
            IFAI = II
 219        CONTINUE
 210      CONTINUE
          IF(IFAI.NE.0) GOTO 300
          GOTO 950
C
 230      CONTINUE
C
C  conversion according to remainder method
          DO 350 I=K1,K2,KS
            XM1 = XML(I)
            IF(ABS(XM1-XMP(I)).GT.DELM) THEN
              ICH = ICH+1
              IFAI = I
C  conversion necessary
              DO 400 K=1,4
                PB1(K) = PL(K,I)
                PB2(K) = PHEP(K,IMODE)-PB1(K)
 400          CONTINUE
              XM2 = PB2(4)**2-PB2(1)**2-PB2(2)**2-PB2(3)**2
              IF(XM2.LT.0.D0) THEN
                IF (LPRI.GT.4 .AND. IDEB(82).GE.10)
     &          WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
     &            'PHO_PARCOR: ',
     &            'int.rej. I,IPA,ICH,XML,XMP,XM2**2,MCHAIN',
     &            I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
                GOTO 300
              ENDIF
              XM2 = SQRT(XM2)
              IF((XM1+XM2).GE.XMC) THEN
                IF (LPRI.GT.4 .AND. IDEB(82).GE.10)
     &          WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
     &            'PHO_PARCOR: ',
     &            'int.rej. I,IPA,ICH,XML,XMP,XM2,XMC',
     &            I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
                GOTO 300
              ENDIF
C  conversion possible
              CALL PHO_MSHELL(PB1,PB2,XM1,XM2,PP1,PP2,IREJ)
              IF(IREJ.NE.0) THEN
                IFAIL(36) = IFAIL(36)+1
                IF (LPRI.GT.4 .AND. IDEB(82).GE.6)
     &          WRITE(LO,'(1X,A,I8,3I4)')
     &            'PHO_PARCOR: PHO_MSHELL rej. ITER,STRING,PARTON',
     &            ITER,IMODE,I
                GOTO 300
              ENDIF
C  calculate Lorentz transformation
              CALL PHO_GETLTR(PB2,PP2,GAM,GAMB,DELE,IREJ)
              IF(IREJ.NE.0) THEN
                IF (LPRI.GT.4 .AND. IDEB(82).GE.6)
     &          WRITE(LO,'(1X,A,I8,3I4)')
     &            'PHO_PARCOR: PHO_GETLTR rej. ITER,STRING,PARTON',
     &            ITER,IMODE,I
                GOTO 300
              ENDIF
              IFAI = 0
C  transform remaining partons
              DO 450 L=K1,K2,KS
                IF(L.NE.I) THEN
                  CALL PHO_MKSLTR(PL(1,L),PP2,GAM,GAMB)
                  DO 500 K=1,4
                    PL(K,L) = PP2(K)
 500              CONTINUE
                ELSE
                  DO 550 K=1,4
                    PL(K,L) = PP1(K)
 550              CONTINUE
                ENDIF
 450          CONTINUE
              XMP(I) = XM1
            ENDIF
 350      CONTINUE
        ENDIF

C  register transformed partons
 950      CONTINUE
          IREJ = 0
          IF(ICH.NE.0) THEN
            IP1 = NHEP+1
            L = 0
            DO 700 I=I1,I2
              L= L+1
              CALL PHO_REGPAR(-1,IDHEP(I),0,IMODE,0,PL(1,L),PL(2,L),
     &          PL(3,L),PL(4,L),IPHIST(1,I),IPHIST(2,I),ICOLOR(1,I),
     &          ICOLOR(2,I),IPOS,1)
 700        CONTINUE
            IP2 = IPOS
C  register string
            CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PHEP(1,IMODE),
     &        PHEP(2,IMODE),PHEP(3,IMODE),PHEP(4,IMODE),IPHIST(1,IMODE),
     &        IPHIST(2,IMODE),ICOLOR(1,IMODE),ICOLOR(2,IMODE),IPOS,1)
C  update /POSTRG/
            I = IPHIST(1,IMODE)
            NPOS(1,I) = IPOS
            NPOS(2,I) = IP1
            NPOS(3,I) = -IP2
          ENDIF
C  debug output
          IF(IDEB(82).GE.20) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,A,I7,2I4)')
     &        'PHO_PARCOR: fin.momenta,masses(C/L),(EV,ICH,L)',
     &        KEVENT,IMODE,L
            DO 850 I=1,L
              IF (LPRI.GT.4)
     &        WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
     &         XMP(I),XML(I)
 850        CONTINUE
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,A,2I5)')
     &        'PHO_PARCOR: conversion done (old/new ICH)',IMODE,IPOS
          ENDIF
          RETURN
C  rejection
 990      CONTINUE
          IREJ = 1
          IF(IDEB(82).GE.3) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(/1X,A,/,5X,3I5,E12.4)')
     &        'PHO_PARCOR: rejection I,IPAR,ICHAIN,MCHAIN',
     &         IFAI,IPAR,IMODE,XMC
            IF(IDEB(82).GE.5) THEN
              IF (LPRI.GT.4)
     &        WRITE(LO,'(1X,A,I7,2I4)')
     &          'PHO_PARCOR: momenta,masses(C/L),(EV,ICH,L)',
     &          KEVENT,IMODE,IPAR
              DO 155 I=1,IPAR
                IF (LPRI.GT.4)
     &          WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
     &           XMP(I),XML(I)
 155          CONTINUE
            ENDIF
          ENDIF
          RETURN

      ELSE IF(IMODE.EQ.-1) THEN
C  initialization
        RETURN

      ELSE IF(IMODE.EQ.-2) THEN
C  final output
        RETURN
      ENDIF

      END

 
 


CDECK  ID>, PHO_PARDAT
      SUBROUTINE PHO_PARDAT
C***********************************************************************
C
C     particle data (based on 1996 PDG naming scheme and data tables)
C
C***********************************************************************

      IMPLICIT NONE
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  particle ID translation table
      INTEGER         ID_pdg_list,ID_list,ID_pdg_max
      CHARACTER*12    name_list
      COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
     &                ID_pdg_max

C  general particle data
      DOUBLE PRECISION xm_list,tau_list,gam_list,
     &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
     &  xm_bb82_list,xm_bb102_list
      INTEGER          ich3_list,iba3_list,iq_list,
     &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
      COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
     &  xm_psm2_list(6,6),xm_vem2_list(6,6),
     &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
     &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
     &  ich3_list(300),iba3_list(300),iq_list(3,300),
     &  id_psm_list(6,6),id_vem_list(6,6),
     &  id_b8_list(6,6,6),id_b10_list(6,6,6)

C  particle decay data
      DOUBLE PRECISION wg_sec_list
      INTEGER          idec_list,isec_list
      COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
     &  isec_list(3,500)

C  external functions
      INTEGER  IPHO_PDG2ID
      EXTERNAL IPHO_PDG2ID
      DOUBLE PRECISION PHO_PMASS
      EXTERNAL         PHO_PMASS

C  local variables for storing data tables
      INTEGER number,ich3,iba3,iq_linear,idec_linear,isec_linear,
     &  id_psm_linear,id_vem_linear,id_b8_linear,id_b10_linear

      DIMENSION number(300),ich3(300),iba3(300),iq_linear(900),
     &  idec_linear(900),isec_linear(900),id_psm_linear(36),
     &  id_vem_linear(36),id_b8_linear(216),id_b10_linear(216)

      DOUBLE PRECISION xmass,gamma,wg_chan
      DIMENSION xmass(300),gamma(300),wg_chan(300)

      CHARACTER*12 name
      DIMENSION name(300)

      INTEGER i,i1,i2,ii,j,jj,k,l,ichan,i_tab_max,K8,K10,L8,L10
      DOUBLE PRECISION AM1,AM2,AM2P,AM2V,AM82,AM102,AMM

      INTEGER itmp

      DATA i_tab_max /260/

      DATA (number(K),K=    1,  171) /
     &     1,     2,     3,     4,     5,     6,  1103,  2101,  2103,
     &  2203,  3101,  3103,  3201,  3203,  3303,  4101,  4103,  4201,
     &  4203,  4301,  4303,  4403,    81,    82,    90,    91,    92,
     &   110,   990,    21,    22,    24,    23,    11,    13,    15,
     &    12,    14,    16,   211,   111,   221,   113,   213,   223,
     &   331, 10221, 10111, 10211,   333, 10223, 10113, 10213, 20113,
     & 20213,   225, 20223, 20221, 20111, 20211,   115,   215, 30223,
     & 50223, 40113, 40213, 50221,   335, 60223,   227, 10115, 10215,
     & 10333,   117,   217, 30113, 30213, 60221,   337, 20225,   229,
     & 30225, 40225,   321,   311,   310,   130,   323,   313, 10313,
     & 10323, 20313, 20323, 30313, 30323, 10311, 10321,   325,   315,
     & 40313, 40323, 10315, 10325,   317,   327, 20315, 20325,   319,
     &   329,   411,   421,   423,   413, 10423,   425,   415,   431,
     &   433, 10433,   521,   511,   513,   523,   531,   441,   443,
     & 10441, 10443,   445, 20443, 30443, 40443, 50443, 60443,   553,
     &   551, 10553,   555, 20553, 10551, 70553, 10555, 30553, 40553,
     & 50553, 60553,  2212,  2112, 12112, 12212,  1214,  2124, 22112,
     & 22212, 32112, 32212,  2116,  2216, 12116, 12216, 21214, 22124,
     & 42112, 42212, 31214, 32124,  1218,  2128,  1114,  2114,  2214/
      DATA (number(K),K=  172,  260) /
     &  2224, 31114, 32114, 32214, 32224,  1112,  1212,  2122,  2222,
     & 11114, 12114, 12214, 12224,  1116,  1216,  2126,  2226, 21112,
     & 21212, 22122, 22222, 21114, 22114, 22214, 22224, 11116, 11216,
     & 12126, 12226,  1118,  2118,  2218,  2228,  3122, 13122,  3124,
     & 23122, 33122, 13124, 43122, 53122,  3126, 13126, 23124,  3128,
     & 23126,  3222,  3212,  3112,  3224,  3214,  3114, 13112, 13212,
     & 13222, 13114, 13214, 13224, 23112, 23212, 23222,  3116,  3216,
     &  3226, 13116, 13216, 13226, 23114, 23214, 23224,  3118,  3218,
     &  3228,  3322,  3312,  3324,  3314, 13314, 13324,  3334,  4122,
     & 14122,  4222,  4212,  4112,  4322,  4312,  4332,  5122/
      DATA (name(K),K=    1,   76) /
     &'d           ','u           ','s           ','c           ',
     &'b           ','t           ','(dd)_1      ','(ud)_0      ',
     &'(ud)_1      ','(uu)_1      ','(sd)_0      ','(sd)_1      ',
     &'(su)_0      ','(su)_1      ','(ss)_1      ','(cd)_0      ',
     &'(cd)_1      ','(cu)_0      ','(cu)_1      ','(cs)_0      ',
     &'(cs)_1      ','(cc)_1      ','remnant 1   ','remnant 2   ',
     &'string      ','mod. string ','coll. string','reggeon     ',
     &'pomeron     ','gluon       ','gamma       ','W           ',
     &'Z           ','e           ','mu          ','tau         ',
     &'nu(e)       ','nu(mu)      ','nu(tau)     ','pi          ',
     &'pi          ','eta         ','rho(770)    ','rho(770)    ',
     &'ome(782)    ','etap(958)   ','f(0)(980)   ','a(0)(980)   ',
     &'a(0)(980)   ','phi(1020)   ','h(1)(1170)  ','b(1)(1235)  ',
     &'b(1)(1235)  ','a(1)(1260)  ','a(1)(1260)  ','f(2)(1270)  ',
     &'f(1)(1285)  ','eta(1295)   ','pi(1300)    ','pi(1300)    ',
     &'a(2)(1320)  ','a(2)(1320)  ','f(1)(1420)  ','ome(1420)   ',
     &'rho(1450)   ','rho(1450)   ','f(0)(1500)  ','f(2)p(1525) ',
     &'ome(1600)   ','ome(3)(1670)','pi(2)(1670) ','pi(2)(1670) ',
     &'phi(1680)   ','rho(3)(1690)','rho(3)(1690)','rho(1700)   '/
      DATA (name(K),K=   77,  152) /
     &'rho(1700)   ','f(J)(1710)  ','phi(3)(1850)','f(2)(2010)  ',
     &'f(4)(2050)  ','f(2)(2300)  ','f(2)(2340)  ','K           ',
     &'K           ','K(S)        ','K(L)        ','K*(892)     ',
     &'K*(892)     ','K(1)(1270)  ','K(1)(1270)  ','K(1)(1400)  ',
     &'K(1)(1400)  ','K*(1410)    ','K*(1410)    ','K(0)*(1430) ',
     &'K(0)*(1430) ','K(2)*(1430) ','K(2)*(1430) ','K*(1680)    ',
     &'K*(1680)    ','K(2)(1770)  ','K(2)(1770)  ','K(3)*(1780) ',
     &'K(3)*(1780) ','K(2)(1820)  ','K(2)(1820)  ','K(4)*(2045) ',
     &'K(4)*(2045) ','D           ','D           ','D*(2007)    ',
     &'D*(2010)    ','D(1)(2420)  ','D(2)*(2460) ','D(2)*(2460) ',
     &'D(s)        ','D(s)*       ','D(s1)(2536) ','B           ',
     &'B           ','B*          ','B*          ','B(s)        ',
     &'eta(c)(1S)  ','J/psi(1S)   ','chi(c0)(1P) ','chi(c1)(1P) ',
     &'chi(c2)(1P) ','psi(2S)     ','psi(3770)   ','psi(4040)   ',
     &'psi(4160)   ','psi(4415)   ','Ups(1S)     ','chi(b0)(1P) ',
     &'chi(b1)(1P) ','chi(b2)(1P) ','Ups(2S)     ','chi(b0)(2P) ',
     &'chi(b1)(2P) ','chi(b2)(2P) ','Ups(3S)     ','Ups(4S)     ',
     &'Ups(10860)  ','Ups(11020)  ','p           ','n           ',
     &'N(1440)     ','N(1440)     ','N(1520)     ','N(1520)     '/
      DATA (name(K),K=  153,  228) /
     &'N(1535)     ','N(1535)     ','N(1650)     ','N(1650)     ',
     &'N(1675)     ','N(1675)     ','N(1680)     ','N(1680)     ',
     &'N(1700)     ','N(1700)     ','N(1710)     ','N(1710)     ',
     &'N(1720)     ','N(1720)     ','N(2190)     ','N(2190)     ',
     &'Del(1232)   ','Del(1232)   ','Del(1232)   ','Del(1232)   ',
     &'Del(1600)   ','Del(1600)   ','Del(1600)   ','Del(1600)   ',
     &'Del(1620)   ','Del(1620)   ','Del(1620)   ','Del(1620)   ',
     &'Del(1700)   ','Del(1700)   ','Del(1700)   ','Del(1700)   ',
     &'Del(1905)   ','Del(1905)   ','Del(1905)   ','Del(1905)   ',
     &'Del(1910)   ','Del(1910)   ','Del(1910)   ','Del(1910)   ',
     &'Del(1920)   ','Del(1920)   ','Del(1920)   ','Del(1920)   ',
     &'Del(1930)   ','Del(1930)   ','Del(1930)   ','Del(1930)   ',
     &'Del(1950)   ','Del(1950)   ','Del(1950)   ','Del(1950)   ',
     &'Lambda      ','Lam(1405)   ','Lam(1520)   ','Lam(1600)   ',
     &'Lam(1670)   ','Lam(1690)   ','Lam(1800)   ','Lam(1810)   ',
     &'Lam(1820)   ','Lam(1830)   ','Lam(1890)   ','Lam(2100)   ',
     &'Lam(2110)   ','Sigma       ','Sigma       ','Sigma       ',
     &'Sig(1385)   ','Sig(1385)   ','Sig(1385)   ','Sig(1660)   ',
     &'Sig(1660)   ','Sig(1660)   ','Sig(1670)   ','Sig(1670)   '/
      DATA (name(K),K=  229,  260) /
     &'Sig(1670)   ','Sig(1750)   ','Sig(1750)   ','Sig(1750)   ',
     &'Sig(1775)   ','Sig(1775)   ','Sig(1775)   ','Sig(1915)   ',
     &'Sig(1915)   ','Sig(1915)   ','Sig(1940)   ','Sig(1940)   ',
     &'Sig(1940)   ','Sig(2030)   ','Sig(2030)   ','Sig(2030)   ',
     &'Xi          ','Xi          ','Xi(1530)    ','Xi(1530)    ',
     &'Xi(1820)    ','Xi(1820)    ','Omega       ','Lam(c)      ',
     &'Lam(c)(2593)','Sig(c)(2455)','Sig(c)(2455)','Sig(c)(2455)',
     &'Xi(c)       ','Xi(c)       ','Ome(c)      ','Lam(b)      '/
      DATA (ich3(K),K=    1,  260) /
     &-1, 2,-1, 2,-1, 2,-2, 1, 1, 4,-2,-2, 1, 1,-2, 1, 1, 4, 4, 1, 1, 4,
     & 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0,-3,-3,-3, 0, 0, 0, 3, 0, 0, 0, 3,
     & 0, 0, 0, 0, 3, 0, 0, 0, 3, 0, 3, 0, 0, 0, 0, 3, 0, 3, 0, 0, 0, 3,
     & 0, 0, 0, 0, 0, 3, 0, 0, 3, 0, 3, 0, 0, 0, 0, 0, 0, 3, 0, 0, 0, 3,
     & 0, 0, 3, 0, 3, 0, 3, 0, 3, 3, 0, 0, 3, 0, 3, 0, 3, 0, 3, 0, 3, 3,
     & 0, 0, 3, 0, 0, 3, 3, 3, 3, 3, 0, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 0, 3, 0, 3, 0, 3,
     & 0, 3, 0, 3, 0, 3, 0, 3, 0, 3, 0, 3, 0, 3,-3, 0, 3, 6,-3, 0, 3, 6,
     &-3, 0, 3, 6,-3, 0, 3, 6,-3, 0, 3, 6,-3, 0, 3, 6,-3, 0, 3, 6,-3, 0,
     & 3, 6,-3, 0, 3, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0,-3,
     & 3, 0,-3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3,
     & 0, 3, 0,-3, 0,-3,-3, 0,-3, 3, 3, 6, 3, 0, 3, 0, 0, 0/
      DATA (iba3(K),K=    1,  260) /
     &1,1,1,1,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,0,0,0,0,0,0,0,0,0,0,0,
     &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     &0,0,0,0,0,0,0,0,0,0,0,0,0,0,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
     &3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
     &3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
     &3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3/
      DATA (iq_linear(K),K=    1,  418) /
     & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 2,
     & 1, 0, 2, 1, 0, 2, 2, 0, 3, 1, 0, 3, 1, 0, 3, 2, 0, 3, 2, 0, 3, 3,
     & 0, 4, 1, 0, 4, 1, 0, 4, 2, 0, 4, 2, 0, 4, 3, 0, 4, 3, 0, 4, 4, 0,
     & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     & 0, 0, 0, 0, 0, 0, 0, 2,-1, 0, 1,-1, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0,
     & 2,-2, 0, 3,-3, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0, 3,-3, 0, 2,-2, 0, 1,
     &-1, 0, 2,-1, 0, 1,-1, 0, 2, 1, 0, 2,-2, 0, 2,-2, 0, 2,-2, 0, 1,-1,
     & 0, 2,-1, 0, 1,-1, 0, 2,-1, 0, 2,-2, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0,
     & 2,-2, 0, 3,-3, 0, 2,-2, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0, 3,-3, 0, 1,
     &-1, 0, 2,-1, 0, 1,-1, 0, 2,-1, 0, 2,-2, 0, 3,-3, 0, 2,-2, 0, 2,-2,
     & 0, 2,-2, 0, 2,-2, 0, 2,-3, 0, 1,-3, 0, 1,-3, 0, 3,-1, 0, 2,-3, 0,
     & 1,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 1,
     &-3, 0, 2,-3, 0, 2,-3, 0, 1,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3,
     & 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 4,-1, 0,
     & 4,-2, 0, 4,-2, 0, 4,-1, 0, 4,-2, 0, 4,-2, 0, 4,-1, 0, 4,-3, 0, 4,
     &-3, 0, 4,-3, 0, 2,-5, 0, 1,-5, 0, 1,-5, 0, 2,-5, 0, 3,-5, 0, 4,-4,
     & 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0,
     & 4,-4, 0, 4,-4, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5/
      DATA (iq_linear(K),K=  419,  780) /
     &-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 2, 2,
     & 1, 2, 1, 1, 2, 1, 1, 2, 2, 1, 1, 2, 1, 2, 1, 2, 2, 1, 1, 2, 2, 1,
     & 2, 1, 1, 2, 2, 1, 2, 2, 2, 2, 2, 1, 2, 1, 1, 2, 2, 1, 1, 2, 1, 2,
     & 1, 2, 2, 1, 1, 2, 2, 1, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 1,
     & 1, 2, 1, 1, 2, 2, 1, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 2, 1, 2, 2, 2,
     & 1, 1, 1, 1, 2, 1, 2, 1, 2, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 2, 1, 2,
     & 2, 2, 1, 1, 1, 1, 2, 1, 2, 1, 2, 2, 2, 2, 1, 1, 1, 1, 2, 1, 2, 1,
     & 2, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 1, 1, 2, 2, 2, 1, 1, 1, 1, 2, 1,
     & 2, 1, 2, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 2, 1, 2, 2, 2, 3, 1, 2, 3,
     & 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1,
     & 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 2, 2, 3, 2, 1, 3, 1, 1, 3,
     & 3, 2, 2, 3, 2, 1, 3, 1, 1, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1, 3,
     & 2, 1, 3, 2, 2, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1, 3, 2, 1, 3, 2,
     & 2, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1,
     & 3, 2, 1, 3, 2, 2, 2, 3, 3, 1, 3, 3, 2, 3, 3, 1, 3, 3, 3, 3, 1, 3,
     & 3, 2, 3, 3, 3, 2, 1, 4, 4, 1, 2, 2, 2, 4, 2, 1, 2, 1, 1, 4, 3, 2,
     & 2, 3, 1, 2, 3, 3, 4, 5, 1, 2/
      DATA (xmass(K),K=    1,  114) /
     &3.0000E-01,3.0000E-01,3.5000E-01,1.4500E+00,4.5000E+00,1.7400E+02,
     &7.7133E-01,5.7933E-01,7.7133E-01,7.7133E-01,8.0473E-01,9.2953E-01,
     &8.0473E-01,9.2953E-01,1.0936E+00,1.9691E+00,2.0081E+00,1.9691E+00,
     &2.0081E+00,2.1543E+00,2.1797E+00,3.2753E+00,0.0000E+00,0.0000E+00,
     &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
     &0.0000E+00,8.0410E+01,9.1187E+01,5.1100E-04,1.0566E-01,1.7771E+00,
     &0.0000E+00,0.0000E+00,0.0000E+00,1.3957E-01,1.3498E-01,5.4730E-01,
     &7.7000E-01,7.7000E-01,7.8194E-01,9.5778E-01,9.8000E-01,9.8340E-01,
     &9.8340E-01,1.0194E+00,1.1700E+00,1.2295E+00,1.2295E+00,1.2300E+00,
     &1.2300E+00,1.2750E+00,1.2819E+00,1.2970E+00,1.3000E+00,1.3000E+00,
     &1.3181E+00,1.3181E+00,1.4262E+00,1.4190E+00,1.4650E+00,1.4650E+00,
     &1.5000E+00,1.5250E+00,1.6490E+00,1.6670E+00,1.6700E+00,1.6700E+00,
     &1.6800E+00,1.6910E+00,1.6910E+00,1.7000E+00,1.7000E+00,1.7120E+00,
     &1.8540E+00,2.0100E+00,2.0440E+00,2.2970E+00,2.3400E+00,4.9368E-01,
     &4.9767E-01,4.9767E-01,4.9767E-01,8.9166E-01,8.9610E-01,1.2720E+00,
     &1.2720E+00,1.4020E+00,1.4020E+00,1.4140E+00,1.4140E+00,1.4290E+00,
     &1.4290E+00,1.4256E+00,1.4324E+00,1.7170E+00,1.7170E+00,1.7730E+00,
     &1.7730E+00,1.7760E+00,1.7760E+00,1.8160E+00,1.8160E+00,2.0450E+00,
     &2.0450E+00,1.8693E+00,1.8646E+00,2.0067E+00,2.0100E+00,2.4222E+00/
      DATA (xmass(K),K=  115,  228) /
     &2.4589E+00,2.4590E+00,1.9685E+00,2.1124E+00,2.5353E+00,5.2789E+00,
     &5.2792E+00,5.3249E+00,5.3249E+00,5.3693E+00,2.9798E+00,3.0969E+00,
     &3.4173E+00,3.5105E+00,3.5562E+00,3.6860E+00,3.7699E+00,4.0400E+00,
     &4.1590E+00,4.4150E+00,9.4604E+00,9.8598E+00,9.8919E+00,9.9132E+00,
     &1.0023E+01,1.0232E+01,1.0255E+01,1.0268E+01,1.0355E+01,1.0580E+01,
     &1.0865E+01,1.1019E+01,9.3827E-01,9.3957E-01,1.4400E+00,1.4400E+00,
     &1.5200E+00,1.5200E+00,1.5350E+00,1.5350E+00,1.6500E+00,1.6500E+00,
     &1.6750E+00,1.6750E+00,1.6800E+00,1.6800E+00,1.7000E+00,1.7000E+00,
     &1.7100E+00,1.7100E+00,1.7200E+00,1.7200E+00,2.1900E+00,2.1900E+00,
     &1.2320E+00,1.2320E+00,1.2320E+00,1.2320E+00,1.6000E+00,1.6000E+00,
     &1.6000E+00,1.6000E+00,1.6200E+00,1.6200E+00,1.6200E+00,1.6200E+00,
     &1.7000E+00,1.7000E+00,1.7000E+00,1.7000E+00,1.9050E+00,1.9050E+00,
     &1.9050E+00,1.9050E+00,1.9100E+00,1.9100E+00,1.9100E+00,1.9100E+00,
     &1.9200E+00,1.9200E+00,1.9200E+00,1.9200E+00,1.9300E+00,1.9300E+00,
     &1.9300E+00,1.9300E+00,1.9500E+00,1.9500E+00,1.9500E+00,1.9500E+00,
     &1.1157E+00,1.4070E+00,1.5195E+00,1.6000E+00,1.6700E+00,1.6900E+00,
     &1.8000E+00,1.8100E+00,1.8200E+00,1.8300E+00,1.8900E+00,2.1000E+00,
     &2.1100E+00,1.1894E+00,1.1926E+00,1.1974E+00,1.3828E+00,1.3837E+00,
     &1.3872E+00,1.6600E+00,1.6600E+00,1.6600E+00,1.6700E+00,1.6700E+00/
      DATA (xmass(K),K=  229,  260) /
     &1.6700E+00,1.7500E+00,1.7500E+00,1.7500E+00,1.7750E+00,1.7750E+00,
     &1.7750E+00,1.9150E+00,1.9150E+00,1.9150E+00,1.9400E+00,1.9400E+00,
     &1.9400E+00,2.0300E+00,2.0300E+00,2.0300E+00,1.3149E+00,1.3213E+00,
     &1.5318E+00,1.5350E+00,1.8230E+00,1.8230E+00,1.6724E+00,2.2849E+00,
     &2.5939E+00,2.4528E+00,2.4536E+00,2.4522E+00,2.4656E+00,2.4703E+00,
     &2.7040E+00,5.6240E+00/
      DATA (gamma(K),K=    1,  114) /
     &8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,
     &8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,
     &8.0000E-01,8.0000E-01,8.0000E-01,0.0000E+00,0.0000E+00,0.0000E+00,
     &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
     &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
     &0.0000E+00,2.0600E+00,2.4900E+00,0.0000E+00,2.9959E-19,2.2700E-12,
     &0.0000E+00,0.0000E+00,0.0000E+00,2.5284E-17,7.8000E-09,1.1800E-06,
     &1.5070E-01,1.5070E-01,8.4100E-03,2.0300E-04,0.0000E+00,0.0000E+00,
     &0.0000E+00,4.4300E-03,3.6000E-01,1.4200E-01,1.4200E-01,0.0000E+00,
     &0.0000E+00,1.8550E-01,2.4000E-02,5.3000E-02,0.0000E+00,0.0000E+00,
     &1.0700E-01,1.0700E-01,5.5000E-02,1.7000E-01,3.1000E-01,3.1000E-01,
     &1.1200E-01,7.6000E-02,2.2000E-01,1.6800E-01,2.5800E-01,2.5800E-01,
     &1.5000E-01,1.6000E-01,1.6000E-01,2.4000E-01,2.4000E-01,1.3300E-01,
     &8.7000E-02,2.0000E-01,2.0800E-01,1.5000E-01,3.2000E-01,5.3140E-17,
     &0.0000E+00,7.3730E-15,1.2730E-17,5.0800E-02,5.0500E-02,9.0000E-02,
     &9.0000E-02,1.7400E-01,1.7400E-01,2.3200E-01,2.3200E-01,2.8700E-01,
     &2.8700E-01,9.8500E-02,1.0900E-01,3.2000E-01,3.2000E-01,1.8600E-01,
     &1.8600E-01,1.5900E-01,1.5900E-01,2.7600E-01,2.7600E-01,1.9800E-01,
     &1.9800E-01,6.2300E-13,1.5860E-12,5.0000E-03,2.0000E-03,1.8900E-02/
      DATA (gamma(K),K=  115,  228) /
     &2.3000E-02,2.5000E-02,1.4100E-12,2.0000E-03,0.0000E+00,3.9900E-13,
     &4.2200E-13,0.0000E+00,0.0000E+00,4.2700E-13,1.3200E-02,8.7000E-05,
     &1.4000E-02,8.8000E-04,2.0000E-03,2.7700E-04,2.3600E-02,5.2000E-02,
     &7.8000E-02,4.3000E-02,5.2500E-05,0.0000E+00,0.0000E+00,0.0000E+00,
     &4.4000E-05,0.0000E+00,0.0000E+00,0.0000E+00,2.6300E-05,1.0000E-02,
     &1.1000E-01,7.9000E-02,0.0000E+00,7.4240E-28,3.5000E-01,3.5000E-01,
     &1.2000E-01,1.2000E-01,1.5000E-01,1.5000E-01,1.5000E-01,1.5000E-01,
     &1.5000E-01,1.5000E-01,1.3000E-01,1.3000E-01,1.0000E-01,1.0000E-01,
     &1.0000E-01,1.0000E-01,1.5000E-01,1.5000E-01,4.5000E-01,4.5000E-01,
     &1.2000E-01,1.2000E-01,1.2000E-01,1.2000E-01,3.5000E-01,3.5000E-01,
     &3.5000E-01,3.5000E-01,1.5000E-01,1.5000E-01,1.5000E-01,1.5000E-01,
     &3.0000E-01,3.0000E-01,3.0000E-01,3.0000E-01,3.5000E-01,3.5000E-01,
     &3.5000E-01,3.5000E-01,2.5000E-01,2.5000E-01,2.5000E-01,2.5000E-01,
     &2.0000E-01,2.0000E-01,2.0000E-01,2.0000E-01,3.5000E-01,3.5000E-01,
     &3.5000E-01,3.5000E-01,3.0000E-01,3.0000E-01,3.0000E-01,3.0000E-01,
     &2.5010E-15,5.0000E-02,1.5600E-02,1.5000E-01,3.5000E-02,6.0000E-02,
     &3.0000E-01,1.5000E-01,8.0000E-02,9.5000E-02,1.0000E-01,2.0000E-01,
     &2.0000E-01,8.2400E-15,8.9000E-06,4.4500E-15,3.5800E-02,3.6000E-02,
     &3.9400E-02,1.0000E-01,1.0000E-01,1.0000E-01,6.0000E-02,6.0000E-02/
      DATA (gamma(K),K=  229,  260) /
     &6.0000E-02,9.0000E-02,9.0000E-02,9.0000E-02,1.2000E-01,1.2000E-01,
     &1.2000E-01,1.2000E-01,1.2000E-01,1.2000E-01,2.2000E-01,2.2000E-01,
     &2.2000E-01,1.8000E-01,1.8000E-01,1.8000E-01,2.2700E-15,4.0200E-15,
     &9.1000E-03,9.9000E-03,2.4000E-02,2.4000E-02,8.0100E-15,3.1900E-12,
     &3.6000E-03,0.0000E+00,0.0000E+00,0.0000E+00,1.8600E-12,6.7000E-12,
     &1.0200E-11,5.3100E-13/
      DATA (idec_linear(K),K=    1,  304) /
     &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     &  0,  0,  0,  0,  0,  0,  3,  1,  1,  2,  2,  6,  0,  0,  0,  0,
     &  0,  0,  0,  0,  0,  3,  7,  7,  3,  8,  9,  1, 10, 14,  1, 15,
     & 16,  1, 17, 17,  1, 18, 20,  1, 21, 24,  0,  0,  0,  0,  0,  0,
     &  0,  0,  0,  1, 25, 29,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  1, 30, 32,
     &  1, 33, 34,  0,  0,  0,  0,  0,  0,  0,  0,  0,  1, 35, 37,  0,
     &  0,  0,  0,  0,  0,  0,  0,  0,  1, 38, 39,  0,  0,  0,  0,  0,
     &  0,  1, 40, 40,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     &  0,  0,  0,  0,  0,  0,  0,  0,  0,  3, 41, 46,  0,  0,  0,  3,
     & 47, 48,  3, 49, 52,  1, 53, 54,  1, 55, 56,  1, 57, 58,  1, 59,
     & 60,  0,  0,  0,  0,  0,  0,  1, 61, 68,  1, 69, 76,  0,  0,  0,
     &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0/
      DATA (idec_linear(K),K=  305,  608) /
     &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     &  0,  0,  0,  0,  0,  0,  0,  2, 77, 78,  2, 79, 82,  1, 83, 84,
     &  1, 85, 87,  0,  0,  0,  0,  0,  0,  0,  0,  0,  2, 88, 90,  1,
     & 91, 92,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     &  0,  0,  0,  0,  2, 93, 95,  1, 96, 98,  0,  0,  0,  0,  0,  0,
     &  0,  0,  0,  1, 99,101,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     &  0,  0,  0,  0,  0,  0,  0,  0,  0,  3,102,102,  1,103,112,  1,
     &113,122,  0,  0,  0,  0,  0,  0,  1,123,129,  1,130,136,  0,  0,
     &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     &  0,  0,  0,  0,  0,  0,  1,137,144,  1,145,152,  0,  0,  0,  0,
     &  0,  0,  0,  0,  0,  0,  0,  0,  1,153,153,  1,154,155,  1,156,
     &157,  1,158,158,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  1,159,162,  1,
     &163,169,  1,170,176,  1,177,180,  0,  0,  0,  0,  0,  0,  0,  0,
     &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0/
      DATA (idec_linear(K),K=  609,  780) /
     &  0,  0,  0,  0,  3,181,182,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  3,183,184,  3,185,
     &185,  3,186,186,  1,187,189,  1,190,192,  1,193,194,  0,  0,  0,
     &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  1,195,203,  0,  0,
     &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     &  0,  0,  0,  0,  0,  0,  1,204,216,  0,  0,  0,  3,217,217,  3,
     &218,218,  1,219,220,  1,221,222,  0,  0,  0,  0,  0,  0,  2,223,
     &225,  2,226,239,  0,  0,  0,  2,240,240,  2,241,241,  2,242,242,
     &  2,243,246,  2,247,251,  2,252,255,  0,  0,  0/
      DATA (isec_linear(K),K=    1,  152) /
     &     11,     12,    -12,     13,    -14,     16,     11,    -12,
     &     16,   -213,     16,      0,   -211,     16,      0,   -323,
     &     16,      0,    -13,     12,      0,     22,     22,      0,
     &     22,    -11,     11,     22,     22,      0,    111,     22,
     &     22,    111,    111,    111,    211,   -211,    111,    211,
     &   -211,     22,    211,   -211,      0,    111,    111,      0,
     &    211,    111,      0,    211,   -211,    111,    211,   -211,
     &      0,    111,     22,      0,    221,    211,   -211,    221,
     &    111,    111,    211,   -211,     22,     22,     22,      0,
     &    321,   -321,      0,    130,    310,      0,    113,    111,
     &      0,    211,   -211,    111,    221,     22,      0,    113,
     &    111,      0,   -213,    211,      0,    213,   -211,      0,
     &    211,   -211,      0,    111,    111,      0,    113,    111,
     &      0,   -213,    211,      0,    213,   -211,      0,    311,
     &   -313,      0,   -311,    313,      0,    113,    211,   -211,
     &    -13,     12,      0,    211,    111,      0,    211,    211,
     &   -211,    211,    111,    111,    -13,    111,     12,    -11,
     &    111,     12,    211,   -211,      0,    111,    111,      0,
     &    111,    111,    111,    211,   -211,    111,    211,     13/
      DATA (isec_linear(K),K=  153,  304) /
     &     12,    211,     11,     12,    321,    111,      0,    311,
     &    211,      0,    311,    111,      0,    321,   -211,      0,
     &    311,    111,      0,    321,   -211,      0,    321,    111,
     &      0,    311,    211,      0,    311,    111,      0,    321,
     &   -211,      0,    313,    111,      0,    323,   -211,      0,
     &    311,    113,      0,    321,   -213,      0,    311,    223,
     &      0,    311,    221,      0,    321,    111,      0,    311,
     &    211,      0,    323,    111,      0,    313,    211,      0,
     &    321,    113,      0,    311,    213,      0,    321,    223,
     &      0,    321,    221,      0,   -321,    211,    211,   -311,
     &    211,      0,   -321,    211,      0,   -321,    211,    111,
     &    311,    211,   -211,    311,    111,      0,    421,    111,
     &      0,    421,     22,      0,    421,    211,      0,    411,
     &    111,      0,    411,     22,      0,    221,    211,      0,
     &    321,   -321,    321,    321,   -311,      0,    431,     22,
     &      0,    431,     22,      0,    111,    111,      0,    211,
     &   -211,      0,     22,     22,      0,    -11,     11,      0,
     &    -13,     13,      0,    211,   -211,    111,    443,    211,
     &   -211,    443,    111,    111,    443,    221,      0,   2212/
      DATA (isec_linear(K),K=  305,  456) /
     &     11,     12,   2112,    111,      0,   2212,   -211,      0,
     &   2112,    111,    111,   2112,    211,   -211,   1114,    211,
     &      0,   2114,    111,      0,   2214,   -211,      0,   2112,
     &    113,      0,   2212,   -213,      0,   2112,    221,      0,
     &   2212,    111,      0,   2112,    211,      0,   2212,    111,
     &    111,   2212,    211,   -211,   2224,   -211,      0,   2214,
     &    111,      0,   2114,    211,      0,   2212,    113,      0,
     &   2112,    213,      0,   2212,    221,      0,   2212,   -211,
     &      0,   2112,    111,      0,   2214,   -211,      0,   2114,
     &    111,      0,   1114,    211,      0,   2212,   -213,      0,
     &   2112,    113,      0,   2212,    111,      0,   2112,    211,
     &      0,   2224,   -211,      0,   2214,    111,      0,   2114,
     &    211,      0,   2212,    113,      0,   2112,    213,      0,
     &   2212,   -211,      0,   2112,    111,      0,   2212,   -213,
     &      0,   2112,    113,      0,   3122,    311,      0,   3212,
     &    311,      0,   3112,    321,      0,   2112,    221,      0,
     &   2212,    111,      0,   2112,    211,      0,   2212,    113,
     &      0,   2112,    213,      0,   3122,    321,      0,   3222,
     &    311,      0,   3212,    321,      0,   2212,    221,      0/
      DATA (isec_linear(K),K=  457,  608) /
     &   2112,   -211,      0,   2212,   -211,      0,   2112,    111,
     &      0,   2212,    111,      0,   2112,    211,      0,   2212,
     &    211,      0,   2112,   -211,      0,   2114,   -211,      0,
     &   1114,    111,      0,   2112,   -213,      0,   2212,   -211,
     &      0,   2112,    111,      0,   2214,   -211,      0,   2114,
     &    111,      0,   1114,    211,      0,   2212,   -213,      0,
     &   2112,    113,      0,   2212,    111,      0,   2112,    211,
     &      0,   2224,   -211,      0,   2214,    111,      0,   2114,
     &    211,      0,   2212,    113,      0,   2112,    213,      0,
     &   2212,    211,      0,   2224,    111,      0,   2214,    211,
     &      0,   2212,    213,      0,   2212,   -211,      0,   2112,
     &    111,      0,   2212,    111,      0,   2112,    211,      0,
     &   3122,     22,      0,   2112,   -211,      0,   3122,    211,
     &      0,   3212,    211,      0,   3222,    111,      0,   3122,
     &    111,      0,   3222,   -211,      0,   3112,    211,      0,
     &   3122,   -211,      0,   3212,   -211,      0,   2112,   -311,
     &      0,   2212,   -321,      0,   3222,   -211,      0,   3212,
     &    111,      0,   3112,    211,      0,   3122,    221,      0,
     &   3224,   -211,      0,   3114,    211,      0,   3214,    111/
      DATA (isec_linear(K),K=  609,  760) /
     &      0,   2112,   -311,      0,   2212,   -321,      0,   3122,
     &    111,      0,   3122,    223,      0,   3122,    113,      0,
     &   3222,   -213,      0,   3112,    213,      0,   3212,    113,
     &      0,   3122,    221,      0,   3212,    221,      0,   3222,
     &   -211,      0,   3112,    211,      0,   3212,    111,      0,
     &   3122,    111,      0,   3122,   -211,      0,   3322,    111,
     &      0,   3312,    211,      0,   3322,   -211,      0,   3312,
     &    111,      0,   3322,   -211,      0,   3312,    111,      0,
     &   3122,   -321,      0,   3222,    221,      0,   3222,    331,
     &      0,   2212,   -311,      0,   3322,    321,      0,   3224,
     &    221,      0,   2214,    331,      0,   2224,   -321,      0,
     &   3122,    213,      0,   3212,    213,      0,   3222,    113,
     &      0,   3222,    223,      0,   2212,   -313,      0,   2214,
     &   -313,      0,   2224,   -323,      0,   4122,    211,      0,
     &   4122,    111,      0,   4122,   -211,      0,   3222,   -311,
     &      0,   3322,    211,      0,   3222,   -313,      0,   3322,
     &    213,      0,   3212,   -313,      0,   3222,   -323,      0,
     &   3322,    223,      0,   3312,    213,      0,   3214,   -313,
     &      0,   3322,   -311,      0,   3322,    313,      0,   3334/
      DATA (isec_linear(K),K=  761,  765) /
     &    213,      0,   3334,    211,      0/
      DATA (wg_chan(K),K=    1,  114) /
     &1.0000E+00,2.8000E-01,2.8000E-01,3.5000E-01,7.0000E-02,2.0000E-02,
     &1.0000E+00,9.9000E-01,1.0000E-02,3.8000E-01,3.0000E-02,3.0000E-01,
     &2.4000E-01,5.0000E-02,1.0000E+00,0.0000E+00,1.0000E+00,8.8800E-01,
     &2.5000E-02,8.7000E-02,4.8000E-01,2.4000E-01,2.6000E-01,2.0000E-02,
     &4.9100E-01,3.4400E-01,1.2900E-01,2.4000E-02,1.2000E-02,4.0000E-01,
     &3.0000E-01,3.0000E-01,6.0000E-01,4.0000E-01,4.0000E-01,3.0000E-01,
     &3.0000E-01,5.0000E-01,5.0000E-01,1.0000E+00,6.4000E-01,2.1000E-01,
     &6.0000E-02,2.0000E-02,3.0000E-02,4.0000E-02,6.9000E-01,3.1000E-01,
     &2.1000E-01,1.2000E-01,2.7000E-01,4.0000E-01,3.3000E-01,6.7000E-01,
     &3.3000E-01,6.7000E-01,3.3000E-01,6.7000E-01,3.3000E-01,6.7000E-01,
     &1.9000E-01,3.8000E-01,9.0000E-02,2.0000E-01,3.0000E-02,4.0000E-02,
     &5.0000E-02,2.0000E-02,1.9000E-01,3.8000E-01,9.0000E-02,2.0000E-01,
     &3.0000E-02,4.0000E-02,5.0000E-02,2.0000E-02,7.0000E-01,3.0000E-01,
     &1.0000E-01,5.0000E-01,1.6000E-01,2.4000E-01,5.5000E-01,4.5000E-01,
     &6.8000E-01,3.0000E-01,2.0000E-02,3.0000E-01,4.0000E-01,3.0000E-01,
     &9.0000E-01,1.0000E-01,4.9000E-01,4.9000E-01,2.0000E-02,1.0000E-01,
     &1.0000E-01,8.0000E-01,6.0000E-01,3.0000E-01,1.0000E-01,1.0000E+00,
     &1.5000E-01,3.5000E-01,7.0000E-02,1.8000E-01,1.1000E-01,6.0000E-02,
     &3.0000E-02,1.0000E-02,3.0000E-02,1.0000E-02,1.5000E-01,3.5000E-01/
      DATA (wg_chan(K),K=  115,  228) /
     &7.0000E-02,1.8000E-01,1.1000E-01,6.0000E-02,3.0000E-02,1.0000E-02,
     &3.0000E-02,1.0000E-02,3.7000E-01,1.8000E-01,4.0000E-02,8.0000E-02,
     &1.3000E-01,1.3000E-01,7.0000E-02,1.8000E-01,3.7000E-01,1.3000E-01,
     &8.0000E-02,4.0000E-02,7.0000E-02,1.3000E-01,1.3000E-01,7.0000E-02,
     &4.7000E-01,2.3000E-01,5.0000E-02,1.0000E-02,2.0000E-02,2.0000E-02,
     &7.0000E-02,1.3000E-01,2.3000E-01,4.7000E-01,5.0000E-02,2.0000E-02,
     &1.0000E-02,2.0000E-02,1.0000E+00,3.3000E-01,6.7000E-01,6.7000E-01,
     &3.3000E-01,1.0000E+00,2.5000E-01,1.8000E-01,2.7000E-01,3.0000E-01,
     &8.0000E-02,1.7000E-01,2.4000E-01,3.0000E-02,1.8000E-01,1.0000E-01,
     &2.0000E-01,1.7000E-01,8.0000E-02,1.8000E-01,3.0000E-02,2.4000E-01,
     &2.0000E-01,1.0000E-01,2.5000E-01,2.7000E-01,1.8000E-01,3.0000E-01,
     &6.4000E-01,3.6000E-01,5.2000E-01,4.8000E-01,1.0000E+00,1.0000E+00,
     &8.8000E-01,6.0000E-02,6.0000E-02,8.8000E-01,6.0000E-02,6.0000E-02,
     &8.8000E-01,1.2000E-01,1.9000E-01,1.9000E-01,1.6000E-01,1.6000E-01,
     &1.7000E-01,3.0000E-02,3.0000E-02,3.0000E-02,4.0000E-02,1.0000E-01,
     &1.0000E-01,2.0000E-01,1.2000E-01,1.0000E-01,4.0000E-02,4.0000E-02,
     &5.0000E-02,7.5000E-02,7.5000E-02,3.0000E-02,3.0000E-02,4.0000E-02,
     &1.0000E+00,1.0000E+00,3.3000E-01,6.7000E-01,6.7000E-01,3.3000E-01,
     &2.5000E-01,2.5000E-01,5.0000E-01,2.0000E-02,3.0000E-02,7.0000E-02/
      DATA (wg_chan(K),K=  229,  255) /
     &2.0000E-02,2.0000E-02,4.0000E-02,1.3000E-01,7.0000E-02,6.0000E-02,
     &6.0000E-02,2.0000E-01,1.4000E-01,4.0000E-02,1.0000E-01,1.0000E+00,
     &1.0000E+00,1.0000E+00,2.5000E-01,3.0000E-02,3.0000E-01,4.2000E-01,
     &2.2000E-01,3.5000E-01,1.9000E-01,1.6000E-01,8.0000E-02,3.7000E-01,
     &2.0000E-01,3.6000E-01,7.0000E-02/
      DATA (id_psm_linear(K),K=    1,   36) /
     &    111,    211,   -311,    411,      0,      0,   -211,    111,
     &   -321,    421,      0,      0,    311,    321,    221,    431,
     &      0,      0,   -411,   -421,   -431,    441,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0/
      DATA (id_vem_linear(K),K=    1,   36) /
     &    113,    213,   -313,    413,      0,      0,   -213,    113,
     &   -323,    423,      0,      0,    313,    323,    333,    433,
     &      0,      0,   -413,   -423,   -433,  20443,      0,      0,
     &      0,      0,      0,      0,      0,      0,      0,      0,
     &      0,      0,      0,      0/
      DATA (id_b8_linear(K),K=    1,  171) /
     &  1114,  2112,  3112,  4112,     0,     0,  2112,  2212,  3212,
     &  4122,     0,     0,  3112,  3212,  3312,  4312,     0,     0,
     &  4112,  4122,  4312,  4412,     0,     0,     0,     0,     0,
     &     0,     0,     0,     0,     0,     0,     0,     0,     0,
     &  2112,  2212,  3212,  4122,     0,     0,  2212,  2224,  3222,
     &  4222,     0,     0,  3212,  3222,  3322,  4322,     0,     0,
     &  4122,  4222,  4322,  4422,     0,     0,     0,     0,     0,
     &     0,     0,     0,     0,     0,     0,     0,     0,     0,
     &  3112,  3212,  3312,  4312,     0,     0,  3212,  3222,  3322,
     &  4322,     0,     0,  3312,  3322,  3334,  4332,     0,     0,
     &  4312,  4322,  4332,  4432,     0,     0,     0,     0,     0,
     &     0,     0,     0,     0,     0,     0,     0,     0,     0,
     &  4112,  4122,  4312,  4412,     0,     0,  4122,  4222,  4322,
     &  4422,     0,     0,  4312,  4322,  4332,  4432,     0,     0,
     &  4412,  4422,  4432,  4444,     0,     0,     0,     0,     0,
     &     0,     0,     0,     0,     0,     0,     0,     0,     0,
     &     0,     0,     0,     0,     0,     0,     0,     0,     0,
     &     0,     0,     0,     0,     0,     0,     0,     0,     0,
     &     0,     0,     0,     0,     0,     0,     0,     0,     0/
      DATA (id_b8_linear(K),K=  172,  216) /
     &     0,     0,     0,     0,     0,     0,     0,     0,     0,
     &     0,     0,     0,     0,     0,     0,     0,     0,     0,
     &     0,     0,     0,     0,     0,     0,     0,     0,     0,
     &     0,     0,     0,     0,     0,     0,     0,     0,     0,
     &     0,     0,     0,     0,     0,     0,     0,     0,     0/
      DATA (id_b10_linear(K),K=    1,  171) /
     &  1114,  2114,  3114,  4114,     0,     0,  2114,  2214,  3214,
     &  4214,     0,     0,  3114,  3214,  3314,  4314,     0,     0,
     &  4114,  4214,  4314,  4414,     0,     0,     0,     0,     0,
     &     0,     0,     0,     0,     0,     0,     0,     0,     0,
     &  2114,  2214,  3214,  4214,     0,     0,  2214,  2224,  3224,
     &  4224,     0,     0,  3214,  3224,  3324,  4324,     0,     0,
     &  4214,  4224,  4324,  4424,     0,     0,     0,     0,     0,
     &     0,     0,     0,     0,     0,     0,     0,     0,     0,
     &  3114,  3214,  3314,  4314,     0,     0,  3214,  3224,  3324,
     &  4324,     0,     0,  3314,  3324,  3334,  4334,     0,     0,
     &  4314,  4324,  4334,  4434,     0,     0,     0,     0,     0,
     &     0,     0,     0,     0,     0,     0,     0,     0,     0,
     &  4114,  4214,  4314,  4414,     0,     0,  4214,  4224,  4324,
     &  4424,     0,     0,  4314,  4324,  4334,  4434,     0,     0,
     &  4414,  4424,  4434,  4444,     0,     0,     0,     0,     0,
     &     0,     0,     0,     0,     0,     0,     0,     0,     0,
     &     0,     0,     0,     0,     0,     0,     0,     0,     0,
     &     0,     0,     0,     0,     0,     0,     0,     0,     0,
     &     0,     0,     0,     0,     0,     0,     0,     0,     0/
      DATA (id_b10_linear(K),K=  172,  216) /
     &     0,     0,     0,     0,     0,     0,     0,     0,     0,
     &     0,     0,     0,     0,     0,     0,     0,     0,     0,
     &     0,     0,     0,     0,     0,     0,     0,     0,     0,
     &     0,     0,     0,     0,     0,     0,     0,     0,     0,
     &     0,     0,     0,     0,     0,     0,     0,     0,     0/

      ID_pdg_max = i_tab_max

C  copy from local to global variables
      do i=1,i_tab_max
        ID_pdg_list(i) = number(i)
        name_list(i)   = name(i)
        xm_list(i)     = xmass(i)
        gam_list(i)    = gamma(i)
        ich3_list(i)   = ich3(i)
        iba3_list(i)   = iba3(i)
        do j=1,3
          iq_list(j,i)   = iq_linear(3*(i-1)+j)
          idec_list(j,i) = idec_linear(3*(i-1)+j)
        enddo
      enddo

C  initialize hash table
      CALL PHO_CPCINI(ID_pdg_max,ID_pdg_list,ID_list)

      itmp = IDEB(71)
      IDEB(71) = -1

C  quark index table for mesons
      do i=1,6
        do j=1,6
          id_psm_list(i,j) = IPHO_PDG2ID(id_psm_linear(6*(j-1)+i))
          id_vem_list(i,j) = IPHO_PDG2ID(id_vem_linear(6*(j-1)+i))
        enddo
      enddo

C  quark index table for baryons
      do i=1,6
        do j=1,6
          do k=1,6
            id_b8_list(i,j,k)  =
     &        IPHO_PDG2ID(id_b8_linear(36*(k-1)+6*(j-1)+i))
            id_b10_list(i,j,k) =
     &        IPHO_PDG2ID(id_b10_linear(36*(k-1)+6*(j-1)+i))
          enddo
        enddo
      enddo

      IDEB(71) = itmp

C  copy secondary particles
C  (translate PDG-ID to CPC and sort according to CPC)
      ichan = 0
      do i=1,i_tab_max
        if(idec_list(1,i).ne.0) then
          do j=idec_list(2,i),idec_list(3,i)
            ichan = ichan+1
            wg_sec_list(ichan) = wg_chan(j)
            do k=1,3
              if(isec_linear(3*(j-1)+k).ne.0) then
                isec_list(k,ichan) = IPHO_PDG2ID(isec_linear(3*(j-1)+k))
              else
                isec_list(k,ichan) = 0
              endif
            enddo
          enddo
        endif
      enddo

C  add two-pion background (low-mass photon dissociation)
      i = IPHO_PDG2ID(92)
      ichan = ichan+1
      idec_list(1,i) = 1
      idec_list(2,i) = ichan
      idec_list(3,i) = ichan
      wg_sec_list(ichan) = 1.D0
      isec_list(1,ichan) = IPHO_PDG2ID(211)
      isec_list(2,ichan) = IPHO_PDG2ID(-211)
      isec_list(3,ichan) = 0

C  min. mass limits for strings: q-qbar
      do i=1,6
        do j=1,6
          AM2P = 1000.D0
          AM2V = 1000.D0
          do k=1,3
C  pseudo-scalar mesons
            i1 = abs(id_psm_list(i,k))
            if(i1.ne.0) then
              AM1 = xm_list(i1)
            else
              AM1 = PHO_PMASS(i,3)+PHO_PMASS(k,3)
            endif
            i2 = abs(id_psm_list(k,j))
            if(i2.ne.0) then
              AM2 = xm_list(i2)
            else
              AM2 = PHO_PMASS(k,3)+PHO_PMASS(j,3)
            endif
            AM2P = MIN(AM2P,AM1+AM2)
C  vector mesons
            i1 = abs(id_vem_list(i,k))
            if(i1.ne.0) then
              AM1 = xm_list(i1)
            else
              AM1 = PHO_PMASS(i,3)+PHO_PMASS(k,3)
            endif
            i2 = abs(id_vem_list(k,j))
            if(i2.ne.0) then
              AM2 = xm_list(i2)
            else
              AM2 = PHO_PMASS(k,3)+PHO_PMASS(j,3)
            endif
            AM2V = MIN(AM2V,AM1+AM2)
          enddo
          xm_psm2_list(i,j) = AM2P
          xm_vem2_list(i,j) = AM2V
        enddo
      enddo

C  min. mass limits for strings: qq-q
      do i=1,6
        do j=1,6
          do k=1,6
            AM82  = 1000.D0
            AM102 = 1000.D0
            do l=1,3
C  pseudo-scalar meson
              i1 = abs(id_psm_list(k,l))
              if(i1.ne.0) then
                AM1 = xm_list(i1)
              else
                AM1 = PHO_PMASS(i,3)+PHO_PMASS(k,3)
              endif
C  vector meson
              i2 = abs(id_vem_list(k,l))
              if(i2.ne.0) then
                AM2 = xm_list(i2)
              else
                AM2 = PHO_PMASS(i,3)+PHO_PMASS(k,3)
              endif
C  octet baryon
              AMM = min(AM1,AM2)
              K8  = id_b8_list(i,j,l)
              if(K8.ne.0) then
                AM1 = xm_list(K8)
              else
                AM1 = PHO_PMASS(i,3)+PHO_PMASS(j,3)+PHO_PMASS(l,3)
              endif
              AM82  = MIN(AM82, AM1 + AMM)
C  decuplet baryon
              K10 = id_b10_list(i,j,l)
              if(K10.ne.0) then
                AM2 = xm_list(K10)
              else
                AM2 = PHO_PMASS(i,3)+PHO_PMASS(j,3)+PHO_PMASS(l,3)
              endif
              AM102 = MIN(AM102, AM2 + AMM)
            enddo
            xm_b82_list(i,j,k)  = AM82
            xm_b102_list(i,j,k) = AM102
          enddo
        enddo
      enddo

C  min. mass limits for strings: qq-qbarqbar
      do i=1,6
        do j=1,6
          do ii=1,6
            do jj=1,6
              AM82  = 1000.D0
              AM102 = 1000.D0
              do l=1,3
C  octet baryons
                K8  = id_b8_list(i,j,l)
                if(K8.ne.0) then
                  AM1 = xm_list(K8)
                else
                  AM1 = PHO_PMASS(i,3)+PHO_PMASS(j,3)+PHO_PMASS(l,3)
                endif
                L8  = id_b8_list(ii,jj,l)
                if(L8.ne.0) then
                  AM2 = xm_list(L8)
                else
                  AM2 = PHO_PMASS(ii,3)+PHO_PMASS(jj,3)+PHO_PMASS(l,3)
                endif
                AM82  = MIN(AM82, AM1+AM2)
C  decuplet baryons
                K10 = id_b10_list(i,j,l)
                if(K10.ne.0) then
                  AM1 = xm_list(K10)
                else
                  AM1 = PHO_PMASS(i,3)+PHO_PMASS(j,3)+PHO_PMASS(l,3)
                endif
                L10 = id_b10_list(ii,jj,l)
                if(L10.ne.0) then
                  AM2 = xm_list(L10)
                else
                  AM2 = PHO_PMASS(ii,3)+PHO_PMASS(jj,3)+PHO_PMASS(l,3)
                endif
                AM102 = MIN(AM102, AM1+AM2)
              enddo
              xm_bb82_list(i,j,ii,jj)  = AM82
              xm_bb102_list(i,j,ii,jj) = AM102
            enddo
          enddo
        enddo
      enddo

      END


 
 


CDECK  ID>, PHO_PARREM
      SUBROUTINE PHO_PARREM(INDX,IOUT,IREM,IREJ)
C**********************************************************************
C
C     selection of particle remnant flavour(s) (quark or diquark)
C
C     input:    INDX   index of particle in /POEVT1/
C               IOUT   parton which was taken out
C
C     output:   IREM   remnant according to valence flavours
C               IREJ   0  flavour combination possible
C                      1  flavour combination impossible
C
C     all particle ID are given according to PDG conventions
C
C**********************************************************************

      IMPLICIT NONE
      SAVE

      INTEGER INDX,IOUT,IREM,IREJ

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

C  general particle data
      DOUBLE PRECISION xm_list,tau_list,gam_list,
     &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
     &  xm_bb82_list,xm_bb102_list
      INTEGER          ich3_list,iba3_list,iq_list,
     &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
      COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
     &  xm_psm2_list(6,6),xm_vem2_list(6,6),
     &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
     &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
     &  ich3_list(300),iba3_list(300),iq_list(3,300),
     &  id_psm_list(6,6),id_vem_list(6,6),
     &  id_b8_list(6,6,6),id_b10_list(6,6,6)


C  external functions
      INTEGER IPHO_DIQU

C  local variables
      INTEGER ID,IS,ID1,ID2,i,k,K1,K2,IQUA,IDQ
      DIMENSION IQUA(3),IDQ(2)

      ID1 = IDHEP(INDX)
      ID2 = IMPART(INDX)
      IREJ = 0

      IF(ID2.EQ.0) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I6)') 'PHO_PARREM: no CPC ID available for',INDX
        CALL PHO_ABORT
      ENDIF

C**anfe more general treatment of particles with flavor mixing
      If ((id1==22) .Or. (id1==990) .Or. (id1==110)) Then
C  photon, pomeron or reggeon
        IREM = -IOUT
        GOTO 100
      End If

C  ordinary hadron
      id = abs(id2)
      is = sign(1, id2)
      iqua(1) = iq_list(1, id)*is
      iqua(2) = iq_list(2, id)*is
      iqua(3) = iq_list(3, id)*is

      If ((iqua(3) == 0) .And. (iqua(2) == -iqua(1))) Then
C meson with flavor mixing
         irem = -iout
         IF((LPRI.GT.4).AND.(IDEB(72).GE.10)) Then
            Write(6,*) 'PHO_PARREM: particle has flavor mixing ',
     &                  id, iqua(1), iqua(2), irem
         End If
         Go To 100
      End If


C  compare to flavour content
      IF(ABS(IOUT).LT.1000) THEN
C  single quark requested
        IF(IQUA(1).EQ.IOUT) THEN
          K1 = 2
          K2 = 3
        ELSE IF(IQUA(2).EQ.IOUT) THEN
          K1 = 1
          K2 = 3
        ELSE IF(IQUA(3).EQ.IOUT) THEN
          K1 = 1
          K2 = 2
        ELSE
          GOTO 150
        ENDIF
        IF(IQUA(3).EQ.0) THEN
          IREM = IQUA(K1)
        ELSE
          IREM = IPHO_DIQU(IQUA(K1),IQUA(K2))
        ENDIF
      ELSE IF(IQUA(3).NE.0) THEN
C  diquark requested from baryon
        IDQ(1) = IOUT/1000
        IDQ(2) = (IOUT-IDQ(1)*1000)/100
        do i=1,2
          do k=1,3
            if(IDQ(i).eq.IQUA(k)) then
              IQUA(k) = 0
              goto 110
            endif
          enddo
          goto 150
 110      continue
        enddo
        IREM = IQUA(1)+IQUA(2)+IQUA(3)
      ENDIF

 100  CONTINUE
C  debug output
      IF (LPRI.GT.4 .AND. IDEB(72).GE.10)
     &WRITE(LO,'(1X,A,5I6)')
     &  'PHO_PARREM: INDX,ID-PDG,ID-BAM,IOUT,IREM',
     &  INDX,ID1,ID2,IOUT,IREM
      RETURN

C  rejection
 150  CONTINUE
      IREJ = 1
      IF (LPRI.GT.4 .AND. IDEB(72).GE.2)
     &WRITE(LO,'(1X,A,5I7)')
     &  'PHO_PARREM: rejection IDPDG,Q1-3,IOUT',IDHEP(INDX),IQUA,IOUT

      END


 
 


CDECK  ID>, PHO_PARTON
      SUBROUTINE PHO_PARTON(IPROC,JM1,JM2,P1,P2,IREJ)
C********************************************************************
C
C     calculation of complete parton configuration
C
C     input:  IPROC   process ID  1 nondiffractive
C                                 2 elastic
C                                 3 quasi-ela. rho,omega,phi prod.
C                                 4 double Pomeron
C                                 5 single diff 1
C                                 6 single diff 2
C                                 7 double diff diss.
C                                 8 single-resolved / direct photon
C             JM1,2   index of mother particles in /POEVT1/
C
C
C     output: complete parton configuration in /POEVT1/
C             IREJ                1 failure
C                                 0 success
C                                50 rejection due to user cutoffs
C
C********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      DIMENSION P1(4),P2(4)

      PARAMETER ( TINY   =  1.D-10 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  table of particle indices for recursive PHOJET calls
      INTEGER MAXIPX
      PARAMETER ( MAXIPX = 500 )
      INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
      COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
     &                IPOIX1,IPOIX2,IPOIX3

C  general process information
      INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
      COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)

C  global event kinematics and particle IDs
      INTEGER IFPAP,IFPAB
      DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
      COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)

C  cross sections
      INTEGER IPFIL,IFAFIL,IFBFIL
      DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
     &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
     &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
     &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
     &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
      COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
     &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
     &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
     &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
     &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
     &                IPFIL,IFAFIL,IFBFIL

C  event weights and generated cross section
      INTEGER IPOWGC,ISWCUT,IVWGHT
      DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
      COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
     &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)

C  internal rejection counters
      INTEGER NMXJ
      PARAMETER (NMXJ=60)
      CHARACTER*10 REJTIT
      INTEGER IFAIL
      COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)


      IREJ = 0
C  clear event statistics
      KSPOM = 0
      KHPOM = 0
      KSREG = 0
      KHDIR = 0
      KSTRG = 0
      KHTRG = 0
      KSLOO = 0
      KHLOO = 0
      KHARD = 0
      KSOFT = 0
      KSDPO = 0
      KHDPO = 0

C-------------------------------------------------------------------
C  nondiffractive resolved processes

      IF(IPROC.EQ.1) THEN
C  sample number of interactions
C555    CONTINUE
        IINT = 0
        IP   = 1
C  generate only hard events
        IF(ISWMDL(2).EQ.0) THEN
          MHPOM = 1
          MSPOM = 0
          MSREG = 0
          MHDIR = 0
          HSWGHT(1) = 1.D0
        ELSE
C  minimum bias events
          IPOWGC(1) = 0
 10       CONTINUE
          CALL PHO_SAMPRB(ECM,IP,IINT,JINT,KINT)
          IPOWGC(1) = IPOWGC(1)+1
          MINT = 0
          MHDIR = 0
          MSTRG = 0
          MSLOO = 0
C
C  resolved soft processes: pomeron and reggeon
          MSPOM = IINT
          MSREG = JINT
C  resolved hard process: hard pomeron
          MHPOM = KINT
C  resolved absorptive corrections
          MPTRI = 0
          MPLOO = 0
C  restrictions given by user
          IF(MSPOM.LT.ISWCUT(1)) GOTO 10
          IF(MSREG.LT.ISWCUT(2)) GOTO 10
          IF(MHPOM.LT.ISWCUT(3)) GOTO 10
          HSWGHT(1) = 1.D0/DBLE(IPOWGC(1))
C  ----------------------------
          IF(ISWMDL(15).EQ.0) THEN
            MHPOM = 0
            IF(MSREG.GT.0) THEN
              MSPOM = 0
              MSREG = 1
            ELSE
              MSPOM = 1
              MSREG = 0
            ENDIF
          ELSE IF(ISWMDL(15).EQ.1) THEN
            IF(MHPOM.GT.0) THEN
              MHPOM = 1
              MSPOM = 0
              MSREG = 0
            ELSE IF(MSPOM.GT.0) THEN
              MSPOM = 1
              MSREG = 0
            ELSE
              MSREG = 1
            ENDIF
          ELSE IF(ISWMDL(15).EQ.2) THEN
            MHPOM = MIN(1,MHPOM)
          ELSE IF(ISWMDL(15).EQ.3) THEN
            MSPOM = MIN(1,MSPOM)
          ENDIF
        ENDIF
C  ----------------------------

C  statistics
        ISPS = ISPS+MSPOM
        IHPS = IHPS+MHPOM
        ISRS = ISRS+MSREG
        ISTS = ISTS+MSTRG
        ISLS = ISLS+MSLOO

        IF (LPRI.GT.4 .AND. IDEB(3).GE.5)
     &  WRITE(LO,'(1X,A,I10,I7,6I4)')
     &    'PHO_PARTON: EV,SP,SR,HP,HD,ET,EL',
     &    KEVENT,MSPOM,MSREG,MHPOM,MHDIR,MPTRI,MPLOO

        ITRY2 = 0
 50     CONTINUE
        ITRY2 = ITRY2+1
        IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
        KSPOM = MSPOM
        KSREG = MSREG
        KHPOM = MHPOM
        KHDIR = MHDIR
        KSTRG = MPTRI
        KSLOO = MPLOO

        CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
        IF(IREJ.NE.0) THEN
          IF(IREJ.EQ.50) RETURN
          IF(IDEB(3).GE.2) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(/1X,A,I5)')
     &        'PHO_PARTON: rejection by PHO_STDPAR ',ITRY2
            CALL PHO_PREVNT(-1)
          ENDIF
          RETURN
        ENDIF
        IF(MHPOM.GT.0) THEN
          IDNODF = 3
        ELSE IF(MSPOM.GT.0) THEN
          IDNODF = 2
        ELSE
          IDNODF = 1
        ENDIF
C  check of quantum numbers of parton configurations
        IF(IDEB(3).GE.0) THEN
          CALL PHO_CHECK(1,IREJ)
          IF(IREJ.NE.0) GOTO 50
        ENDIF
C  sample strings to prepare fragmentation
        CALL PHO_STRING(1,IREJ)
        IF(IREJ.NE.0) THEN
          IF(IREJ.EQ.50) RETURN
          IFAIL(30) = IFAIL(30)+1
          IF(IDEB(3).GE.2)  THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(/1X,A,I5)')
     &        'PHO_PARTON: rejection by PHO_STRING',ITRY2
            CALL PHO_PREVNT(-1)
          ENDIF
          IF(ITRY2.LT.20) GOTO 50
          IF(IDEB(3).GE.1) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(/1X,A,I5)')
     &        'PHO_PARTON: rejection',ITRY2
            CALL PHO_PREVNT(-1)
          ENDIF
          RETURN
        ENDIF

C  statistics
        ISPA = ISPA+KSPOM
        IHPA = IHPA+KHPOM
        ISRA = ISRA+KSREG
        ISTA = ISTA+KSTRG
        ISLA = ISLA+KSLOO

C-------------------------------------------------------------------
C  elastic scattering / quasi-elastic rho/omega/phi production

      ELSE IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
        IF (LPRI.GT.4 .AND. IDEB(3).GE.5)
     &  WRITE(LO,'(1X,A,I10,I4)')
     &    'PHO_PARTON: ela./q-ela.sca:(EV,IPROC)',KEVENT,IPROC

C  DPMJET call with special projectile / target: transform into CMS
        IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
     &    CALL PHO_DFWRAP(1,JM1,JM2)

        CALL PHO_QELAST(IPROC,JM1,JM2,IREJ)

        IF(IREJ.NE.0) THEN
C  DPMJET call with special projectile / target: clean up
          IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
     &      CALL PHO_DFWRAP(-2,JM1,JM2)
          IF(IDEB(3).GE.2) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(/1X,A,I5)')
     &        'PHO_PARTON: rejection by PHO_QELAST',IREJ
            CALL PHO_PREVNT(-1)
          ENDIF
          RETURN
        ENDIF

C  DPMJET call with special projectile / target: transform back
        IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
     &    CALL PHO_DFWRAP(2,JM1,JM2)

C  prepare possible decays
        CALL PHO_STRING(1,IREJ)
        IF(IREJ.NE.0) THEN
          IF(IREJ.EQ.50) RETURN
          IFAIL(30) = IFAIL(30)+1
          RETURN
        ENDIF

C---------------------------------------------------------------------
C  double Pomeron scattering

      ELSE IF(IPROC.EQ.4) THEN
        MSOFT = 0
        MHARD = 0
        IF (LPRI.GT.4 .AND. IDEB(3).GE.5)
     &  WRITE(LO,'(1X,A,I10)')
     &      'PHO_PARTON: EV,double-pomeron scattering',KEVENT
        IDPS = IDPS+1
        ITRY2 = 0
 60     CONTINUE
        ITRY2 = ITRY2+1
        IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
C
        CALL PHO_CDIFF(JM1,JM2,MSOFT,MHARD,1,IREJ)
        IF(IREJ.NE.0) THEN
          IF(IDEB(3).GE.2) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(/1X,A,I5)')
     &        'PHO_PARTON: rejection by PHO_CDIFF',IREJ
            CALL PHO_PREVNT(-1)
          ENDIF
          RETURN
        ENDIF
C  check of quantum numbers of parton configurations
        IF(IDEB(3).GE.0) THEN
          CALL PHO_CHECK(1,IREJ)
          IF(IREJ.NE.0) GOTO 60
        ENDIF
C  sample strings to prepare fragmentation
        CALL PHO_STRING(1,IREJ)
        IF(IREJ.NE.0) THEN
          IF(IREJ.EQ.50) RETURN
          IFAIL(30) = IFAIL(30)+1
          IF(IDEB(3).GE.2) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(/1X,A,I5)')
     &        'PHO_PARTON: rejection by PHO_STRING',ITRY2
            CALL PHO_PREVNT(-1)
          ENDIF
          IF(ITRY2.LT.10) GOTO 60
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
          CALL PHO_PREVNT(-1)
          RETURN
        ENDIF
        IDPA = IDPA+1

C-----------------------------------------------------------------------
C  single / double diffraction dissociation

      ELSE IF((IPROC.GE.5).AND.(IPROC.LE.7)) THEN
        MSOFT = 0
        MHARD = 0
        IF(IPROC.EQ.5) ID1S = ID1S+1
        IF(IPROC.EQ.6) ID2S = ID2S+1
        IF(IPROC.EQ.7) ID3S = ID3S+1
        ITRY2 = 0
 70     CONTINUE
        ITRY2 = ITRY2+1
        IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
        IPAR1 = 1
        IPAR2 = 1
        IF(IPROC.EQ.5) IPAR2 = 0
        IF(IPROC.EQ.6) IPAR1 = 0
        IF (LPRI.GT.4 .AND. IDEB(3).GE.5)
     &  Write (lo, '(1X,A,I10,3I4)') 
     &     'PHO_PARTON: diffraction, EV, IPROC, IPAR1, IPAR2',
     &     KEVENT, IPROC, IPAR1, IPAR2      
C  calculate rapidity gap survival probability
        SPROB = 1.D0
        IF(ECM.GT.10.D0) THEN
          IF((IPAR1.GE.1).AND.(IPAR2.EQ.0)) THEN
            IF(SIGTR1(1).LT.1.D-10) THEN
              SPROB = 1.D0
            ELSE
              SPROB = SIGHSD(1)/(SIGTR1(1)-2.D0*(SIGDPO(1)+SIGDPO(2)))
            ENDIF
          ELSE IF((IPAR1.EQ.0).AND.(IPAR2.GE.1)) THEN
            IF(SIGTR2(1).LT.1.D-10) THEN
              SPROB = 1.D0
            ELSE
              SPROB = SIGHSD(2)/(SIGTR2(1)-2.D0*(SIGDPO(1)+SIGDPO(3)))
            ENDIF
          ELSE IF((IPAR1.GE.1).AND.(IPAR2.GE.1)) THEN
            IF(SIGLOO.LT.1.D-10) THEN
              SPROB = 1.D0
            ELSE
              SPROB = SIGHDD/SIGLOO
            ENDIF
          ENDIF
        ENDIF

**sr
* temporary patch, r.e. 8.6.99
        IF(IPAMDL(13).GT.0) Then
          IF(LPRI.GT.4 .AND. IDEB(3).GE.15)
     &      Write (lo, '(1X,A)') 
     &        'PHO_PARTON: SPROB set to 1. (DPMJET temporary??)'
          SPROB = 1.D0
        END IF

C  DPMJET call with special projectile / target: transform into CMS
        IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
     &    CALL PHO_DFWRAP(1,JM1,JM2)

        CALL PHO_DIFDIS(IPAR1,IPAR2,JM1,JM2,SPROB,0,MSOFT,MHARD,IREJ)

        IF(IREJ.NE.0) THEN
C  DPMJET call with special projectile / target: clean up
          IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
     &      CALL PHO_DFWRAP(-2,JM1,JM2)
          IF(IDEB(3).GE.2) THEN
            IF (LPRI.GT.4)
     .      WRITE(LO,'(/1X,A,I5)')
     &        'PHO_PARTON: rejection by PHO_DIFDIS',IREJ
            CALL PHO_PREVNT(-1)
          ENDIF
          RETURN
        ENDIF

C  DPMJET call with special projectile / target: transform back
        IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
     &    CALL PHO_DFWRAP(2,JM1,JM2)

C  check of quantum numbers of parton configurations
        IF(IDEB(3).GE.0) THEN
          CALL PHO_CHECK(1,IREJ)
          IF(IREJ.NE.0) GOTO 70
        ENDIF
C  sample strings to prepare fragmentation
        CALL PHO_STRING(1,IREJ)
        IF(IREJ.NE.0) THEN
          IF(IREJ.EQ.50) RETURN
          IFAIL(30) = IFAIL(30)+1
          IF(IDEB(3).GE.2) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(/1X,A,I5)')
     &        'PHO_PARTON: rejection by PHO_STRING',ITRY2
            CALL PHO_PREVNT(-1)
          ENDIF
          IF(ITRY2.LT.10) GOTO 70
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,I5)')
     &      'PHO_PARTON: rejection',ITRY2
          CALL PHO_PREVNT(-1)
          RETURN
        ENDIF
        IF(IPROC.EQ.5) ID1A = ID1A+1
        IF(IPROC.EQ.6) ID2A = ID2A+1
        IF(IPROC.EQ.7) ID3A = ID3A+1

C-----------------------------------------------------------------------
C  single / double direct processes

      ELSE IF(IPROC.EQ.8) THEN
        MSREG = 0
        MSPOM = 0
        MHPOM = 0
        MHDIR = 1
        IF(IDEB(3).GE.5) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,I10)') 'PHO_PARTON: EV,direct proc',KEVENT
        ENDIF
        IDIS = IDIS+MHDIR
        ITRY2 = 0
 80     CONTINUE
        ITRY2 = ITRY2+1
        IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
        KSPOM = MSPOM
        KSREG = MSREG
        KHPOM = MHPOM
        KHDIR = 4

        CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
        IF(IREJ.NE.0) THEN
          IF(IREJ.EQ.50) RETURN
          IF(IDEB(3).GE.2) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(/1X,A,I5)')
     &        'PHO_PARTON: rejection by PHO_STDPAR',ITRY2
            CALL PHO_PREVNT(-1)
          ENDIF
          RETURN
        ENDIF
        IDNODF = 4
C  check of quantum numbers of parton configurations
        IF(IDEB(3).GE.0) THEN
          CALL PHO_CHECK(1,IREJ)
          IF(IREJ.NE.0) GOTO 80
        ENDIF
C  sample strings to prepare fragmentation
        CALL PHO_STRING(1,IREJ)
        IF(IREJ.NE.0) THEN
          IF(IREJ.EQ.50) RETURN
          IFAIL(30) = IFAIL(30)+1
          IF(IDEB(3).GE.2) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(/1X,A,I5)')
     &        'PHO_PARTON: rejection by PHO_STRING',ITRY2
            CALL PHO_PREVNT(-1)
          ENDIF
          IF(ITRY2.LT.10) GOTO 80
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
          CALL PHO_PREVNT(-1)
          RETURN
        ENDIF
        IF(IPROC.EQ.5) ID1A = ID1A+1
        IF(IPROC.EQ.6) ID2A = ID2A+1
        IF(IPROC.EQ.7) ID3A = ID3A+1
        IDIA = IDIA+MHDIR

C-----------------------------------------------------------------------
C  initialize control statistics

      ELSE IF(IPROC.EQ.-1) THEN
        CALL PHO_SAMPRB(ECM,-1,0,0,0)
        CALL PHO_STDPAR(-1,0,0,0,0,0,0,IREJ)
        CALL PHO_SEAFLA(-1,0,0,DUM)
        IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
     &    CALL PHO_QELAST(-1,1,2,0)
        ISPS = 0
        ISPA = 0
        ISRS = 0
        ISRA = 0
        IHPS = 0
        IHPA = 0
        ISTS = 0
        ISTA = 0
        ISLS = 0
        ISLA = 0
        ID1S = 0
        ID1A = 0
        ID2S = 0
        ID2A = 0
        ID3S = 0
        ID3A = 0
        IDPS = 0
        IDPA = 0
        IDIS = 0
        IDIA = 0
        CALL PHO_STRING(-1,IREJ)
        CALL PHO_DIFDIS(0,0,0,0,0.D0,-1,0,0,IREJ)
        RETURN

C-----------------------------------------------------------------------
C  produce statistics summary

      ELSE IF(IPROC.EQ.-2) THEN
        IF(ISWMDL(2).NE.0) CALL PHO_SAMPRB(ECM,-2,0,0,0)
        IF(IDEB(3).GE.0) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,/1X,A)')
     &      'PHO_PARTON: internal statistics on parton configurations',
     &      '--------------------------------------------------------'
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A)') 'process          sampled      accepted'
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,2I12)') 'soft pom.',ISPS,ISPA
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,2I12)') 'hard pom.',IHPS,IHPA
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,2I12)') 'soft reg.',ISRS,ISRA
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,2I12)') 'enh. tri.',ISTS,ISTA
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,2I12)') 'enh. loo.',ISLS,ISLA
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,2I12)') 'diff.pa1.',ID1S,ID1A
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,2I12)') 'diff.pa2.',ID2S,ID2A
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,2I12)') 'doub.dif.',ID3S,ID3A
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,2I12)') 'doub.pom.',IDPS,IDPA
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,2I12/)') 'dir.phot.',IDIS,IDIA
        ENDIF
        CALL PHO_STDPAR(-2,0,0,0,0,0,0,IREJ)
        IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
     &    CALL PHO_QELAST(-2,1,2,0)
        CALL PHO_STRING(-2,IREJ)
        CALL PHO_DIFDIS(0,0,0,0,0.D0,-2,0,0,IREJ)
        CALL PHO_SEAFLA(-2,0,0,DUM)
        RETURN
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I2)')
     &    'PHO_PARTON:ERROR: unknown process ID ',IPROC
        STOP
      ENDIF

      END


      DOUBLE PRECISION FUNCTION PHO_PARTONX12 (IPRTN, XX, QQ)

c  Given the parton distribution function in the array U in
c  COMMON / PEVLDT / , this routine interpolates to find
c  the parton distribution at an arbitray point in x and q.
c
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

      PARAMETER (MXX = 201, MXQ = 40, MXF = 6, MaxVal=4)
      PARAMETER (MXPQX = (MXF+1+MaxVal) * MXQ * MXX)

      COMMON
     > / CtqPar1 / qBase, XV(0:MXX), TV(0:MXQ),UPD(MXPQX),AlsCTEQ(0:mxq)
     > / CtqPar2 / Nx, Nt, NfMx, MxVal
     > / XQrange / Qini, Qmax, Xmin
     > /Setchange/ Isetch, ipdsset, ipdsformat

      DIMENSION fvec(4), fij(4)
      DIMENSION xvpow(0:mxx)
      DATA OneP / 1.00001 /
      DATA xpow / 0.3d0 /       !**** choice of interpolation variable
      DATA nqvec / 4 /
      DATA ientry / 0 /
      DATA X, Q, JX, JQ /-1D0, -1D0, 0, 0/
      SAVE xvpow
      SAVE X, Q, JX, JQ, JLX, JLQ
      SAVE ss, const1, const2, const3, const4, const5, const6
      SAVE sy2, sy3, s23, tt, t12, t13, t23, t24, t34, ty2, ty3
      SAVE tmp1, tmp2, tdet

c store the powers used for interpolation on first call...
      if(Isetch .eq. 1) then
         Isetch = 0

         xvpow(0) = 0D0
         do i = 1, nx
            xvpow(i) = xv(i)**xpow
         enddo
      elseIf((XX.eq.X).and.(QQ.eq.Q)) then
        goto 99
      endif

      X = XX
      Q = QQ
      tt = log(log(Q/qBase))

c      -------------    find lower end of interval containing x, i.e.,
c                       get jx such that xv(jx) .le. x .le. xv(jx+1)...
      JLx = -1
      JU = Nx+1
 11   If (JU-JLx .GT. 1) Then
         JM = (JU+JLx) / 2
         If (X .Ge. XV(JM)) Then
            JLx = JM
         Else
            JU = JM
         Endif
         Goto 11
      Endif
C                     Ix    0   1   2      Jx  JLx         Nx-2     Nx
C                           |---|---|---|...|---|-x-|---|...|---|---|
C                     x     0  Xmin               x                 1
C
      If     (JLx .LE. -1) Then
        IF (LPRI.GT.4)
     &      WRITE(LOUT,'(A,1pE12.4)')
     &      'PHO_PARTONX12:Severe error: x <= 0 ! x = ',x
        Stop
      ElseIf (JLx .Eq. 0) Then
         Jx = 0
      Elseif (JLx .LE. Nx-2) Then

C                For interrior points, keep x in the middle, as shown above
         Jx = JLx - 1
      Elseif (JLx.Eq.Nx-1 .or. x.LT.OneP) Then

C                  We tolerate a slight over-shoot of one (OneP=1.00001),
C              perhaps due to roundoff or whatever, but not more than that.
C                                      Keep at least 4 points >= Jx
         Jx = JLx - 2
      Else
        IF (LPRI.GT.4)
     &      WRITE(LOUT,'(A,1pE12.4)')
     &      'PHO_PARTONX12:Severe error: x > 1 in pho_PartonX12! x = ',x
        Stop
      Endif
C          ---------- Note: JLx uniquely identifies the x-bin; Jx does not.

C                       This is the variable to be interpolated in
      ss = x**xpow

      If (JLx.Ge.2 .and. JLx.Le.Nx-2) Then

c     initiation work for "interior bins": store the lattice points in s...
      svec1 = xvpow(jx)
      svec2 = xvpow(jx+1)
      svec3 = xvpow(jx+2)
      svec4 = xvpow(jx+3)

      s12 = svec1 - svec2
      s13 = svec1 - svec3
      s23 = svec2 - svec3
      s24 = svec2 - svec4
      s34 = svec3 - svec4

      sy2 = ss - svec2
      sy3 = ss - svec3

c constants needed for interpolating in s at fixed t lattice points...
      const1 = s13/s23
      const2 = s12/s23
      const3 = s34/s23
      const4 = s24/s23
      s1213 = s12 + s13
      s2434 = s24 + s34
      sdet = s12*s34 - s1213*s2434
      tmp = sy2*sy3/sdet
      const5 = (s34*sy2-s2434*sy3)*tmp/s12
      const6 = (s1213*sy2-s12*sy3)*tmp/s34

      EndIf

c         --------------Now find lower end of interval containing Q, i.e.,
c                          get jq such that qv(jq) .le. q .le. qv(jq+1)...
      JLq = -1
      JU = NT+1
 12   If (JU-JLq .GT. 1) Then
         JM = (JU+JLq) / 2
         If (tt .GE. TV(JM)) Then
            JLq = JM
         Else
            JU = JM
         Endif
         Goto 12
       Endif

      If     (JLq .LE. 0) Then
         Jq = 0
      Elseif (JLq .LE. Nt-2) Then
C                                  keep q in the middle, as shown above
         Jq = JLq - 1
      Else
C                         JLq .GE. Nt-1 case:  Keep at least 4 points >= Jq.
        Jq = Nt - 3

      Endif
C                                   This is the interpolation variable in Q

      If (JLq.GE.1 .and. JLq.LE.Nt-2) Then
c                                        store the lattice points in t...
      tvec1 = Tv(jq)
      tvec2 = Tv(jq+1)
      tvec3 = Tv(jq+2)
      tvec4 = Tv(jq+3)

      t12 = tvec1 - tvec2
      t13 = tvec1 - tvec3
      t23 = tvec2 - tvec3
      t24 = tvec2 - tvec4
      t34 = tvec3 - tvec4

      ty2 = tt - tvec2
      ty3 = tt - tvec3

      tmp1 = t12 + t13
      tmp2 = t24 + t34

      tdet = t12*t34 - tmp1*tmp2

      EndIf


c get the pdf function values at the lattice points...

 99   If (Iprtn .Gt. MxVal) Then
         Ip = - Iprtn
      Else
         Ip = Iprtn
      EndIf
      jtmp = ((Ip + NfMx)*(NT+1)+(jq-1))*(NX+1)+jx+1

      Do it = 1, nqvec
        J1  = jtmp + it*(NX+1)

       If (Jx .Eq. 0) Then
C                      For the first 4 x points, interpolate x^2*f(x,Q)
C                      This applies to the two lowest bins JLx = 0, 1
C            We can not put the JLx.eq.1 bin into the "interrior" section
C                           (as we do for q), since Upd(J1) is undefined.
         fij(1) = 0
         fij(2) = Upd(J1+1) * XV(1)**2
         fij(3) = Upd(J1+2) * XV(2)**2
         fij(4) = Upd(J1+3) * XV(3)**2
C
C                 Use Polint which allows x to be anywhere w.r.t. the grid

         CALL PHO_POLINT4F (XVpow(0), Fij(1), ss, Fx)

         If (x .GT. 0D0)  Fvec(it) =  Fx / x**2
C                                              Pdf is undefined for x.eq.0
       ElseIf  (JLx .Eq. Nx-1) Then
C                                                This is the highest x bin:

        CALL PHO_POLINT4F (XVpow(Nx-3), Upd(J1), ss, Fx)

        Fvec(it) = Fx

       Else
C                       for all interior points, use Jon's in-line function
C                              This applied to (JLx.Ge.2 .and. JLx.Le.Nx-2)
         sf2 = Upd(J1+1)
         sf3 = Upd(J1+2)

         g1 =  sf2*const1 - sf3*const2
         g4 = -sf2*const3 + sf3*const4

         Fvec(it) = (const5*(Upd(J1)-g1)
     &               + const6*(Upd(J1+3)-g4)
     &               + sf2*sy3 - sf3*sy2) / s23

       Endif

      enddo
C                                   We now have the four values Fvec(1:4)
c     interpolate in t...

      If (JLq .LE. 0) Then
C                         1st Q-bin, as well as extrapolation to lower Q
        CALL PHO_POLINT4F (TV(0), Fvec(1), tt, ff)

      ElseIf (JLq .GE. Nt-1) Then
C                         Last Q-bin, as well as extrapolation to higher Q
        CALL PHO_POLINT4F (TV(Nt-3), Fvec(1), tt, ff)
      Else
C                         Interrior bins : (JLq.GE.1 .and. JLq.LE.Nt-2)
C       which include JLq.Eq.1 and JLq.Eq.Nt-2, since Upd is defined for
C                         the full range QV(0:Nt)  (in contrast to XV)
        tf2 = fvec(2)
        tf3 = fvec(3)

        g1 = ( tf2*t13 - tf3*t12) / t23
        g4 = (-tf2*t34 + tf3*t24) / t23

        h00 = ((t34*ty2-tmp2*ty3)*(fvec(1)-g1)/t12
     &    +  (tmp1*ty2-t12*ty3)*(fvec(4)-g4)/t34)

        ff = (h00*ty2*ty3/tdet + tf2*ty3 - tf3*ty2) / t23
      EndIf

      PHO_PARTONX12 = ff

      Return
      End


 
 


CDECK  ID>, PHO_PARTPT
      SUBROUTINE PHO_PARTPT(IMODE,IF,IL,PTCUT,IREJ)
C********************************************************************
C
C    assign to soft partons
C
C    input:  IMODE   -2   output of statistics
C                    -1   initialization
C                     0   sampling of pt for soft partons belonging to
C                         soft Pomerons
C                     1   sampling of pt for soft partons belonging to
C                         hard Pomerons
C            IF           first entry in /POEVT1/ to check
C            IL           last entry in /POEVT1/ to check
C            PTCUT        current value of PTCUT to distinguish
C                         between soft and hard
C
C    output: IREJ     0   success
C                     1   failure
C
C    (soft pt is sampled by call to PHO_SOFTPT)
C
C********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( DEPS = 1.D-15 )

      INTEGER IMODE,IF,IL,IREJ
      DOUBLE PRECISION PTCUT

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

C  data of c.m. system of Pomeron / Reggeon exchange
      INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
      DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
     &                 SIDP,CODP,SIFP,COFP
      COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
     &                SIDP,CODP,SIFP,COFP,NPOSP(2),
     &                IDPDG1,IDBAM1,IDPDG2,IDBAM2

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

      DOUBLE PRECISION PTS,PB,XP,XPB,PC
      DIMENSION PTS(0:2,50),PB(0:2,2),XP(50),XPB(2),PC(4)

      INTEGER MODIFY,IV,IVB
      DIMENSION MODIFY(50),IV(50),IVB(2)

C  debug output
      IF (LPRI.GT.4 .AND. IDEB(6).GE.10)
     &WRITE(LO,'(1X,A,3I4,1P,E11.3)')
     &  'PHO_PARTPT: called with IMODE,IF,IL,PTCUT',
     &  IMODE,IF,IL,PTCUT

      IF(IMODE.LT.0) GOTO 1000

      IREJ = 0
      IF((ISWMDL(3).EQ.10).AND.(ISWMDL(4).EQ.10)) RETURN

C  count entries to modify
      IENTRY = 0
      PTCUT2 = PTCUT**2
      EMIN = 1.D20
      IPEAK = 1
      ISTART = IF

C  soft Pomerons

      IF(IMODE.EQ.0) THEN
        DO 300 I=ISTART,IL
          IF((ISTHEP(I).EQ.-1).AND.(ABS(IPHIST(1,I)).LT.100)) THEN
            IENTRY = IENTRY+1
            MODIFY(IENTRY) = I
            XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
            IV(IENTRY) = 0
            IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
            IF(PHEP(4,I).LT.EMIN) THEN
              EMIN = PHEP(4,I)
              IPEAK = IENTRY
            ENDIF
          ENDIF
 300    CONTINUE

C  hard Pomeron associated remnants (IPHIST(1,)=100,200,...)

      ELSE IF(IMODE.EQ.1) THEN

        DO 350 I=ISTART,IL
          IF((ISTHEP(I).EQ.-1).AND.(IPHIST(1,I).GE.100)) THEN
            IF(MOD(IPHIST(1,I),100).EQ.0) THEN
              IENTRY = IENTRY+1
              MODIFY(IENTRY) = I
              XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
              IF(ISWMDL(24).EQ.0) THEN
                IV(IENTRY) = 0
                IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
              ELSE IF(ISWMDL(24).EQ.1) THEN
                IV(IENTRY) = -1
              ELSE
                IV(IENTRY) = 1
              ENDIF
              IF(PHEP(4,I).LT.EMIN) THEN
                EMIN = PHEP(4,I)
                IPEAK = IENTRY
              ENDIF
            ENDIF
          ENDIF
 350    CONTINUE

C  something wrong

      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,I5)') 'PHO_PARTPT:ERROR: invalid mode',IMODE
        CALL PHO_ABORT
      ENDIF

C  debug output
      IF(IDEB(6).GE.5) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,2A,3I4)') 'PHO_PARTPT: ',
     &    'number of partons, IPEAK,MODE',IENTRY,IPEAK,IMODE
        IF(IDEB(6).GE.20) CALL PHO_PREVNT(0)
      ENDIF

C  nothing to do
      IF(IENTRY.LE.1) RETURN

C  sample pt of soft partons

      IF(ISWMDL(5).LE.1) THEN
        ITER = 0
        IPEAK = DT_RNDM(DUM)*IENTRY+1
        CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
        CALL PHO_SWAPD(XP(IPEAK),XP(1))
        CALL PHO_SWAPI(IV(IPEAK),IV(1))
 400    CONTINUE
C  energy limited sampling
          PSUMX = 0.D0
          PSUMY = 0.D0
          ITER = ITER+1
          IF(ITER.GE.1000) THEN
            IF(IDEB(6).GE.3) THEN
              IF (LPRI.GT.4)
     &        WRITE(LO,'(1X,A,3I5)')
     &          'PHO_PARTPT: rejection for MODE,ENTRY,ITER',
     &          IMODE,IENTRY,ITER
              IF (LPRI.GT.4)
     &        WRITE(LO,'(8X,A,I5)') 'I  II  IV       XP         EP',
     &          IPEAK
              DO 405 I=1,IENTRY
                II = MODIFY(I)
                IF (LPRI.GT.4)
     &          WRITE(LO,'(5X,3I5,1P,2E13.4)')
     &            I,II,IV(I),XP(I),PHEP(4,II)
 405          CONTINUE
              IF(IDEB(6).GE.5) CALL PHO_PREVNT(0)
            ENDIF
            IREJ = 1
            RETURN
          ENDIF
          DO 410 I=2,IENTRY
            II = MODIFY(I)
            PTMX = MIN(PHEP(4,II),PTCUT)
            XPB(1) = XP(I)
            IVB(1) = IV(I)
            IF(ISWMDL(5).EQ.0) THEN
              CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
            ELSE
              CALL PHO_SOFTPT(1,PTMX,PTMX,XPB,IVB,PB)
            ENDIF
            PTS(0,I) = PB(0,1)
            PTS(1,I) = PB(1,1)
            PTS(2,I) = PB(2,1)
            PSUMX = PSUMX+PB(1,1)
            PSUMY = PSUMY+PB(2,1)
 410      CONTINUE
          PTREM = SQRT(PSUMX**2+PSUMY**2)
        IF(PTREM.GT.MIN(PHEP(4,MODIFY(1)),PTCUT)) GOTO 400
        PTS(1,1) = -PSUMX
        PTS(2,1) = -PSUMY
      ELSE IF((ISWMDL(5).EQ.2)
     &        .OR.((IMODE.EQ.1).AND.(ISWMDL(5).EQ.3))) THEN
C  unlimited sampling
        IPEAK = DT_RNDM(PSUMX)*IENTRY+1
        CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
        CALL PHO_SWAPD(XP(IPEAK),XP(1))
        CALL PHO_SWAPI(IV(IPEAK),IV(1))
        CALL PHO_SOFTPT(IENTRY,PTCUT,PTCUT,XP,IV,PTS)
      ELSE IF(ISWMDL(5).EQ.3) THEN
C  each string has balanced pt
        DO 500 K=1,IENTRY
          IF(IV(K).LE.-90) GOTO 499
          I1 = MODIFY(K)
          IC1 = -ICOLOR(1,I1)
          DO 510 L=K+1,IENTRY
            IF(ICOLOR(1,MODIFY(L)).EQ.IC1) GOTO 511
 510      CONTINUE
          IF (LPRI.GT.4)
     &    WRITE(LO,'(//1X,A,I5)')
     &      'PHO_PARTPT:ERROR: no color found for (line,color)',I1,-IC1
          CALL PHO_ABORT
 511      CONTINUE
          I2 = MODIFY(L)
          AMSQR = (PHEP(4,I1)+PHEP(4,I2))**2-(PHEP(1,I1)+PHEP(1,I2))**2
     &           -(PHEP(2,I1)+PHEP(2,I2))**2-(PHEP(3,I1)+PHEP(3,I2))**2
          AM   = SQRT(AMSQR)
          PTMX = AM/2.D0
          IVB(1) = MAX(IV(K),IV(L))
          XPB(1) = XP(K)
          CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
          PTS(1,K) = PB(1,1)
          PTS(2,K) = PB(2,1)
          PTS(1,L) = -PB(1,1)
          PTS(2,L) = -PB(2,1)
          GAM    = (PHEP(4,I1)+PHEP(4,I2))/AM
          GAMBEZ = (PHEP(3,I1)+PHEP(3,I2))/AM
          PC(1) = PB(1,1)
          PC(2) = PB(2,1)
          PLONG = SQRT(PTMX**2-PB(0,1)**2+1.D-12)
          PC(3) = SIGN(PLONG,PHEP(3,I1))
          PC(4) = PTMX
          CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
     &               PTOT,PHEP(1,I1),PHEP(2,I1),PHEP(3,I1),PHEP(4,I1))
          PC(1) = -PC(1)
          PC(2) = -PC(2)
          PC(3) = -PC(3)
          CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
     &               PTOT,PHEP(1,I2),PHEP(2,I2),PHEP(3,I2),PHEP(4,I2))
          IV(K) = IV(K)-100
          IV(L) = IV(L)-100
 499      CONTINUE
 500    CONTINUE
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,I4)')
     &    'PHO_PARTPT:ERROR: invalid value of ISWMDL(5):',ISWMDL(5)
        CALL PHO_ABORT
      ENDIF

C  change partons in /POEVT1/
      DO 900 II=1,IENTRY
        IF(IV(II).GT.-90) THEN
          I = MODIFY(II)
          PHEP(1,I) = PHEP(1,I)+PTS(1,II)
          PHEP(2,I) = PHEP(2,I)+PTS(2,II)
          AMSQR = PHEP(4,I)**2
     &             -PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
          PHEP(5,I) = SIGN(SQRT(ABS(AMSQR)),AMSQR)
        ENDIF
 900  CONTINUE

C  debug output
      IF(IDEB(6).GE.15) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,/,8X,A,I5)') 'PHO_PARTPT: table of momenta',
     &    'I  II  IV    XP    EP    PTS   PTX   PTY',IPEAK
        DO 505 I=1,IENTRY
          II = MODIFY(I)
          IF (LPRI.GT.4)
     &    WRITE(LO,'(2X,3I5,1P,5E12.4)')
     &      I,II,IV(I),XP(I),PHEP(4,II),PTS(0,I),PTS(1,I),PTS(2,I)
 505    CONTINUE
        CALL PHO_PREVNT(0)
      ENDIF
      RETURN

C  initialization / output of statistics
 1000 CONTINUE
      CALL PHO_SOFTPT(IMODE,PTM,PTM,XP,IV,PTS)

      END


 
 


CDECK  ID>, PHO_PDF
      SUBROUTINE PHO_PDF(NPAR,X,SCALE2,P2VIR,PD)
C***************************************************************
C
C     call different PDF sets for different particle types
C
C     input:      NPAR     1     IGRP(1),ISET(1)
C                          2     IGRP(2),ISET(2)
C                 X        momentum fraction
C                 SCALE2   squared scale (GeV**2)
C                 P2VIR    particle virtuality (positive, GeV**2)
C
C     output      PD(-6:6) field containing the x*PDF fractions
C
C***************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      DIMENSION PD(-6:6)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  currently activated parton density parametrizations
      CHARACTER*8 PDFNAM
      INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
      DOUBLE PRECISION PDFLAM,PDFQ2M
      COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
     &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  general particle data      
      DOUBLE PRECISION xm_list,tau_list,gam_list,
     &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
     &  xm_bb82_list,xm_bb102_list
      INTEGER          ich3_list,iba3_list,iq_list,
     &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
      COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
     &  xm_psm2_list(6,6),xm_vem2_list(6,6),
     &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
     &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
     &  ich3_list(300),iba3_list(300),iq_list(3,300),
     &  id_psm_list(6,6),id_vem_list(6,6),
     &  id_b8_list(6,6,6),id_b10_list(6,6,6)

      DIMENSION PARAM(20),VALUE(20)
      CHARACTER*20 PARAM

      INTEGER  IPHO_PDG2ID
      EXTERNAL IPHO_PDG2ID
      REAL XR,P2R,Q2R,F2GM,XPDFGM
      DIMENSION XPDFGM(-6:6)

C  check of kinematic boundaries
      XI = X
      IF(X.GT.1.D0) THEN
        IF(IDEB(37).GE.0) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/,1X,A,E15.8/)')
     &      'PHO_PDF: x>1 (corrected to x=1)',X
          CALL PHO_PREVNT(-1)
        ENDIF
        XI = 0.99999999999D0
      ELSE IF(X.LE.0.D0) THEN
        IF(IDEB(37).GE.0) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/,1X,A,E15.8/)') 'PHO_PDF: X <= 0 ',X
          CALL PHO_PREVNT(-1)
        ENDIF
        XI = 0.0001D0
      ENDIF

      DO 100 I=-6,6
        PD(I) = 0.D0
 100  CONTINUE
      IRET = 1

      SCALE = SQRT(SCALE2)  
      
      IF ((NPAR.EQ.1) .OR. (NPAR.EQ.2)) THEN

c  INTERNAL PDFS

        IF (IEXT(NPAR).EQ.0) THEN
          IF (IGRP(NPAR).EQ.2) THEN
c  CTEQ-TEA 14 LO PDFS + LO ALPHA_S
              PD(-5) = XI*PHO_CT14PDF( -5, XI, SCALE) !BBAR
              PD(-4) = XI*PHO_CT14PDF( -4, XI, SCALE) !CBAR
              PD(-3) = XI*PHO_CT14PDF( -3, XI, SCALE) !SBAR
              PD(-2) = XI*PHO_CT14PDF( -1, XI, SCALE) !DBAR
              PD(-1) = XI*PHO_CT14PDF( -2, XI, SCALE) !UBAR
              PD(0) = XI*PHO_CT14PDF( 0, XI, SCALE) !G
              PD(1) = XI*PHO_CT14PDF( 2, XI, SCALE) !D
              PD(2) = XI*PHO_CT14PDF( 1, XI, SCALE) !U
              PD(3) = XI*PHO_CT14PDF( 3, XI, SCALE) !S
              PD(4) = XI*PHO_CT14PDF( 4, XI, SCALE) !C
              PD(5) = XI*PHO_CT14PDF( 5, XI, SCALE) !B

              IRET = 0
          ELSE IF (ITYPE(NPAR).EQ.1) THEN
C  proton PDFs
            IF(IGRP(NPAR).EQ.5) THEN
              IF(ISET(NPAR).EQ.3) THEN
                CALL PHO_DOR92HO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
                UV = UDV-DV
                UDB = 2.D0*UDB
                DEL = 0.D0
                IRET = 0
              ELSE IF(ISET(NPAR).EQ.4) THEN
                CALL PHO_DOR92LO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
                UV = UDV-DV
                UDB = 2.D0*UDB
                DEL = 0.D0
                IRET = 0
              ELSE IF(ISET(NPAR).EQ.5) THEN
                CALL PHO_DOR94HO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
C  heavy quarks from GRV92-HO
                AMU2  = 0.3
                ALAM2 = 0.248 * 0.248
                S  = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
                SC  =  0.820
                ALC =   0.98
                BEC =   0.0
                AKC = -0.625 - 0.523 * S
                AGC =   0.0
                BC  =  1.896 + 1.616 * S
                DC  =   4.12 + 0.683 * S
                EC  =   4.36 + 1.328 * S
                ESC =  0.677 + 0.679 * S
                CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
                SBO =  1.297
                ALB =   0.99
                BEB =   0.0
                AKB =   0.0  - 0.193 * S
                AGB =   0.0
                BBO =   0.0
                DB  =  3.447 + 0.927 * S
                EB  =   4.68 + 1.259 * S
                ESB =  1.892 + 2.199 * S
                BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
                IRET = 0
              ELSE IF(ISET(NPAR).EQ.6) THEN
                CALL PHO_DOR94LO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
C  heavy quarks from GRV92-LO
                AMU2  = 0.25
                ALAM2 = 0.232D0**2
                S  = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
                SC  =  0.888
                ALC =   1.01
                BEC =   0.37
                AKC =   0.0
                AGC =   0.0
                BC  =   4.24 - 0.804 * S
                DC  =   3.46 + 1.076 * S
                EC  =   4.61 + 1.490 * S
                ESC =  2.555 + 1.961 * S
                CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
                SBO =  1.351
                ALB =   1.00
                BEB =   0.51
                AKB =   0.0
                AGB =   0.0
                BBO =  1.848
                DB  =  2.929 + 1.396 * S
                EB  =   4.71 + 1.514 * S
                ESB =   4.02 + 1.239 * S
                BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
                IRET = 0
              ELSE IF(ISET(NPAR).EQ.7) THEN
                CALL PHO_DOR94DI(XI,SCALE2, UV, DV, DEL, UDB, SB, GL)
C  heavy quarks from GRV92-HO
                AMU2  = 0.3
                ALAM2 = 0.248 * 0.248
                S  = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
                SC  =  0.820
                ALC =   0.98
                BEC =   0.0
                AKC = -0.625 - 0.523 * S
                AGC =   0.0
                BC  =  1.896 + 1.616 * S
                DC  =   4.12 + 0.683 * S
                EC  =   4.36 + 1.328 * S
                ESC =  0.677 + 0.679 * S
                CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
                SBO =  1.297
                ALB =   0.99
                BEB =   0.0
                AKB =   0.0  - 0.193 * S
                AGB =   0.0
                BBO =   0.0
                DB  =  3.447 + 0.927 * S
                EB  =   4.68 + 1.259 * S
                ESB =  1.892 + 2.199 * S
                BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
                IRET = 0
              ELSE IF(ISET(NPAR).EQ.8) THEN
                CALL PHO_DOR98LO(XI,SCALE2,UV,DV,US,DS,SB,GL)
                DEL = DS-US
                UDB = DS+US
C  heavy quarks from GRV92-LO
                AMU2  = 0.25
                ALAM2 = 0.232D0**2
                S  = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
                SC  =  0.888
                ALC =   1.01
                BEC =   0.37
                AKC =   0.0
                AGC =   0.0
                BC  =   4.24 - 0.804 * S
                DC  =   3.46 + 1.076 * S
                EC  =   4.61 + 1.490 * S
                ESC =  2.555 + 1.961 * S
                CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
                SBO =  1.351
                ALB =   1.00
                BEB =   0.51
                AKB =   0.0
                AGB =   0.0
                BBO =  1.848
                DB  =  2.929 + 1.396 * S
                EB  =   4.71 + 1.514 * S
                ESB =   4.02 + 1.239 * S
                BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
                IRET = 0
              ELSE IF(ISET(NPAR).EQ.9) THEN
*               CALL PHO_DOR98SC(XI,SCALE2,UV,DV,US,DS,SB,GL)
                DEL = DS-US
                UDB = DS+US
C  heavy quarks from GRV92-LO
                AMU2  = 0.25
                ALAM2 = 0.232D0**2
                S  = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
                SC  =  0.888
                ALC =   1.01
                BEC =   0.37
                AKC =   0.0
                AGC =   0.0
                BC  =   4.24 - 0.804 * S
                DC  =   3.46 + 1.076 * S
                EC  =   4.61 + 1.490 * S
                ESC =  2.555 + 1.961 * S
                CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
                SBO =  1.351
                ALB =   1.00
                BEB =   0.51
                AKB =   0.0
                AGB =   0.0
                BBO =  1.848
                DB  =  2.929 + 1.396 * S
                EB  =   4.71 + 1.514 * S
                ESB =   4.02 + 1.239 * S
                BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
                IRET = 0
              ENDIF
              PD(-5) = BB
              PD(-4) = CB
              PD(-3) = SB
              PD(-2) = 0.5D0*(UDB-DEL)
              PD(-1) = 0.5D0*(UDB+DEL)
              PD(0)  = GL
              PD(1)  = DV+PD(-1)
              PD(2)  = UV+PD(-2)
              PD(3)  = PD(-3)
              PD(4)  = PD(-4)
              PD(5)  = PD(-5)
            ENDIF
          ELSE IF(ITYPE(NPAR).EQ.2) THEN
C  pion PDFs (default for pi+)
            IF(IGRP(NPAR).EQ.5) THEN
              IF(ISET(NPAR).EQ.1) THEN
                CALL PHO_DORPHO (XI,SCALE2,VA,GL,QB,CB,BB)
                IRET = 0
              ELSE IF(ISET(NPAR).EQ.2) THEN
                CALL PHO_DORPLO (XI,SCALE2,VA,GL,QB,CB,BB)
                IRET = 0
              ENDIF
              PD(-5) = BB
              PD(-4) = CB
              PD(-3) = QB
              PD(-2) = QB
              PD(-1) = QB+VA
              PD(0)  = GL
              PD(1)  = QB
              PD(2)  = VA+QB
              PD(3)  = QB
              PD(4)  = CB
              PD(5)  = BB
            ENDIF
          ELSE IF(ITYPE(NPAR).EQ.3) THEN
C  photon PDFs
            IF(IGRP(NPAR).EQ.5) THEN
              IF(ISET(NPAR).EQ.1) THEN
                CALL PHO_DORGH0 (XI,SCALE2,UB,DB,SB,CB,BB,GL)
                IRET = 0
              ELSE IF(ISET(NPAR).EQ.2) THEN
                CALL PHO_DORGHO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
                IRET = 0
              ELSE IF(ISET(NPAR).EQ.3) THEN
                CALL PHO_DORGLO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
                IRET = 0
              ENDIF
C  reweight with Drees-Godbole factor
              WGX = 1.D0
              IF(P2VIR.GT.0.001D0) THEN
                WGX = LOG(SCALE2/(P2VIR+PARMDL(144)))
     &               /LOG(SCALE2/PARMDL(144))
                WGX = MAX(WGX,0.D0)
              ENDIF
              PD(-5) = BB*WGX/137.D0
              PD(-4) = CB*WGX/137.D0
              PD(-3) = SB*WGX/137.D0
              PD(-2) = UB*WGX/137.D0
              PD(-1) = DB*WGX/137.D0
              PD(0)  = GL*WGX*WGX/137.D0
              PD(1)  = PD(-1)
              PD(2)  = PD(-2)
              PD(3)  = PD(-3)
              PD(4)  = PD(-4)
              PD(5)  = PD(-5)
            ELSE IF(IGRP(NPAR).EQ.8) THEN
              IF(ISET(NPAR).EQ.1) THEN
                CALL PHO_PHGAL (XI,SCALE2,PD)
                IRET = 0
              ENDIF
            ENDIF
          ELSE IF(ITYPE(NPAR).EQ.20) THEN
C  Pomeron PDFs
            MODE = IGRP(NPAR)
            IF(MODE.EQ.1) THEN
              PD(0) = 6.D0*(1.D0-XI)**5*PARMDL(26)*PARMDL(78)
              IRET = 0
            ELSE IF(MODE.EQ.2) THEN
              PD(0) = 6.D0*XI*(1.D0-XI)*PARMDL(26)*PARMDL(78)
              IRET = 0
            ELSE IF(MODE.EQ.3) THEN
              PD(0) = (0.18D0/XI+5.46D0)*(1.D0-XI)*PARMDL(26)*PARMDL(78)
              IRET = 0
            ELSE IF(MODE.EQ.4) THEN
              CALL PHO_CKMTPD(990,XI,SCALE2,PD)
              DO 105 I=-4,4
                PD(I) = PD(I)*PARMDL(78)
 105          CONTINUE
              IRET = 0
            ENDIF
          ENDIF

C  external PDFs

        ELSE IF(IEXT(NPAR).EQ.2) THEN
C  PDFLIB call: new PDF numbering
          IF(NPAR.NE.NPAOLD) THEN
            PARAM(1) = 'NPTYPE'
            PARAM(2) = 'NGROUP'
            PARAM(3) = 'NSET'
            PARAM(4) = ' '
            VALUE(1) = ITYPE(NPAR)
            VALUE(2) = ABS(IGRP(NPAR))
            VALUE(3) = ISET(NPAR)
            CALL PDFSET(PARAM,VALUE)
          ENDIF
          IF(ITYPE(NPAR).EQ.3) THEN
            IP2 = 0
            CALL STRUCTP(XI,SCALE2,P2VIR,IP2,PD(2),PD(1),PD(-2),PD(-1),
     &                   PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
          ELSE
            SCALE = SQRT(SCALE2)
            CALL STRUCTM(XI,SCALE,PD(2),PD(1),PD(-2),PD(-1),
     &                   PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
          ENDIF
          DO 115 I=3,6
            PD(I) = PD(-I)
 115      CONTINUE
          IF(ITYPE(NPAR).EQ.1) THEN
C  proton valence quarks
            PD(1) = PD(1)+PD(-1)
            PD(2) = PD(2)+PD(-2)
          ELSE IF(ITYPE(NPAR).EQ.2) THEN
C  pi+ valences
            DVAL = PD(1)
            PD(1) = PD(-1)
            PD(-1) = DVAL+PD(1)
            PD(2) = PD(2)+PD(-2)
          ELSE IF(ITYPE(NPAR).EQ.3) THEN
C  photon conventions
            PD(1) = PD(-1)
            PD(2) = PD(-2)
          ENDIF
          IRET = 0

        ELSE IF(IEXT(NPAR).EQ.3) THEN
C  PHOLIB call: version 2.0
          CALL PHVAL(IGRP(NPAR),ISET(NPAR),XI,SCALE2,PD,IRET)
          IF(IRET.LT.0) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(/1X,A,I2)')
     &        'PHO_PDF:ERROR: non-vanishing PHVAL return code',IRET
            CALL PHO_ABORT
          ENDIF
          IRET = 0

C  photon PDFs depending on photon virtuality

        ELSE IF(IEXT(NPAR).EQ.4) THEN
          IF(IGRP(NPAR).EQ.1) THEN
C  Schuler/Sjostrand PDF (interface to single precision)
            XR = SNGL(XI)
            Q2R = SNGL(SCALE2)
            P2R = SNGL(P2VIR)
            IP2 = 0
            CALL PHO_SASGAM(ISET(NPAR),XR,Q2R,P2R,IP2,F2GM,XPDFGM)
            DO 120 I=-6,6
              PD(I) = DBLE(XPDFGM(I))
 120        CONTINUE
            IRET = 0
          ELSE IF(IGRP(NPAR).EQ.5) THEN
C  Gluck/Reya/Stratmann
            IF(ISET(NPAR).EQ.4) THEN
              CALL PHO_DORGLV (XI,SCALE2,P2VIR, UB, DB, SB, GL)
              CALL PHO_QPMPDF(4,XI,SCALE2,0.D0,P2VIR,CB)
              IRET = 0
              PD(-5) = 0.D0
              PD(-4) = CB
              PD(-3) = SB/137.D0
              PD(-2) = UB/137.D0
              PD(-1) = DB/137.D0
              PD(0)  = GL/137.D0
              PD(1)  = PD(-1)
              PD(2)  = PD(-2)
              PD(3)  = PD(-3)
              PD(4)  = PD(-4)
              PD(5)  = PD(-5)
            ENDIF
          ENDIF
        ENDIF

C  check for errors

        IF(IRET.NE.0) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,/10X,5I6)')
     &      'PHO_PDF:ERROR:unsupported PDF(NPAR,IEXT,ITYPE,IGRP,ISET)',
     &      NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
          CALL PHO_ABORT
        ENDIF
C  error in NPAR
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,I5)') 'PHO_PDF:ERROR:invalid NPAR(1,2) ',NPAR
        CALL PHO_ABORT
      ENDIF
      NPAOLD = NPAR

C  valence quark treatment
      ipabs = abs(iparid(npar))
      ipsign = sign(1,iparid(npar))
      If ((itype(npar).EQ.2) .And. (ipabs.NE.211)) Then
C  valence quarks for mesons but pi+
        idcpc = IPHO_PDG2ID(ipabs)
        If (iq_list(3, idcpc) .NE. 0) Then
          IF (LPRI.GT.4)
     .    Write(lo,*) 'PHO_PDF: Error determining meson valences.'
          CALL PHO_ABORT
        End If

C  Ordinary meson with fixed valence quarks
        If (iq_list(1, idcpc) .NE. iq_list(2, idcpc)) Then
C  down-flavor valence
          dfval = pd(-1) - pd(1)
C  up-flavor valence 
          ufval = pd(2) - pd(-2)
C   set valence density to sea density
          pd(-1) = pd(1)
          pd(2) = pd(-2)
          Do iv=1,2
C    Valence is up-type (u, c, t)
            If (mod(iq_list(iv, idcpc),2) .EQ. 0) Then
              pd(iq_list(iv, idcpc)) = pd(iq_list(iv, idcpc)) + ufval
            Else
C    Valence is down-type (d,s,b)
              pd(iq_list(iv, idcpc)) = pd(iq_list(iv, idcpc)) + dfval
            End If
          End Do

C    neutral kaon mixed state
        Else If ((ipabs.EQ.310) .Or. (ipabs.EQ.130)) Then
          vals = pd(-1) - pd(1)
          valu = pd(2) - pd(-2)
          pd(-1) = pd(1)
          pd(2) = pd(-2)
          pd(2) = pd(2) + valu/2.D0
          pd(-2) = pd(-2) + valu/2.D0
          pd(3) = pd(3) + vals/2.D0
          pd(-3) = pd(-3) + vals/2.D0
C   unflavored meson: pi0, eta,...
        Else
          ifmax = max(2,abs(iq_list(1, idcpc)))
          dfval = pd(-1) - pd(1)
          ufval = pd(2) - pd(-2)
          avval = (dfval + ufval)/(2.D0*dble(ifmax))
C    set valence density to sea density
          pd(-1) = pd(1)
          pd(2) = pd(-2)
C    Add average valence density to all contributing flavors
          Do ifl = 1,ifmax
            pd(ifl) = pd(ifl) + avval
            pd(-ifl) = pd(-ifl) + avval
          End Do

        End If

      Else If ((itype(npar).EQ.1) .And. (ipabs.NE.2212)) Then
C  valence quarks for nucleons but proton
        If (ipabs.EQ.2112) Then
C  neutron
          CALL PHO_SWAPFLAV(pd, 1, 2)
        Else 
          idcpc = IPHO_PDG2ID(ipabs)
          iq_list(1, idcpc) = iq_list(1, idcpc)
          iq_list(2, idcpc) = iq_list(2, idcpc)
          ival3 = iq_list(3, idcpc)
          If (iq_list(3, idcpc) .EQ. 0) Then
            IF (LPRI.GT.4) 
     &      Write(LO,*) 'PHO_PDF: Error determining baryon valences.'
            Write(6,*) ipabs, idcpc, (iq_list(i,idcpc),i=1,3)
            CALL PHO_ABORT
          End If

C   Ordinary baryon
C   down-flavor valence
          dfval = pd(1) - pd(-1)
C   up-flavor valence 
          ufval = (pd(2) - pd(-2))/2.D0
C    set valence density to sea density
          pd(1) = pd(-1)
          pd(2) = pd(-2)

          Do iv = 1,3
            If (mod(iq_list(iv, idcpc),2) .EQ. 0) Then
C    Valence 1 is up-type (u, c, t)
              pd(iq_list(iv, idcpc)) = pd(iq_list(iv, idcpc)) + ufval
            Else
C    Valence 1 is down-type (d,s,b)
              pd(iq_list(iv, idcpc)) = pd(iq_list(iv, idcpc)) + dfval
            End If
          End Do
        End If
      End If

C  antiparticle
      IF(IPARID(NPAR).LT.0) THEN
        DO 190 I=1,4
          DUM=PD(I)
          PD(I)=PD(-I)
          PD(-I)=DUM
 190    CONTINUE
      ENDIF
      
C  optionally remove valence quarks
      IF(IPAVA(NPAR).EQ.0) THEN
        DO 200 I=1,4
          PD(I) = MIN(PD(-I),PD(I))
          PD(-I) = PD(I)
 200    CONTINUE
      ENDIF


C  debug information
      IF (LPRI.GT.4 .AND. IDEB(37).GE.30)
     &WRITE(LO,
     &  '(1X,A,I4,1P,3E12.4/,2X,A,6E10.3,/2X,A,E10.3,/2X,A,6E10.3)')
     &  'PHO_PDF: NPAR,X,SCALE**2,P2VIR',
     &  NPAR,X,SCALE2,P2VIR,'PD(-6..-1)',(PD(I),I=-6,-1),
     &  'PD(0)     ',PD(0),'PD(1..6)  ',(PD(I),I=1,6)

      END


 
 


CDECK  ID>, PHO_PDFTST
      SUBROUTINE PHO_PDFTST(IDPDG,SCALE2,P2MASS)
C*********************************************************************
C
C     structure function test utility
C
C     input:    IDPDG    PDG ID of particle
C               SCALE2   squared scale (GeV**2)
C               P2MASS   particle virtuality (pos, GeV**2)
C
C     output:   tables of PDF, sum rule checking, table of F2
C
C*********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  currently activated parton density parametrizations
      CHARACTER*8 PDFNAM
      INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
      DOUBLE PRECISION PDFLAM,PDFQ2M
      COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
     &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)


      DIMENSION PD(-6:6),PDSUM(-6:6),PDAVE(-6:6),FXP(4)
      CHARACTER*8 PDFNA

      CALL PHO_ACTPDF(IDPDG,1)
      CALL PHO_GETPDF(1,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)

      IF (LPRI.GT.4)
     &WRITE(LO,'(/,A)') ' *** Structure Function Test Utility ***'
      IF (LPRI.GT.4)
     &WRITE(LO,'(A)') ' ======================================='

      IF (LPRI.GT.4)
     &WRITE(LO,'(/,A,3I10)')
     &  ' used structure function:',ITYPE(1),IGRP(1),ISET(1)
      IF (LPRI.GT.4)
     &WRITE(LO,'(A,A)')     ' corresponds to ',PDFNA
      IF (LPRI.GT.4)
     &WRITE(LO,'(A,E12.3)') '  used squared scale (GeV**2):',SCALE2
      IF (LPRI.GT.4)
     &WRITE(LO,'(A,E12.3)') ' particle virtuality (GeV**2):',P2MASS
      IF (LPRI.GT.4)
     &WRITE(LO,'(/1X,A)') 'x times parton densities'
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A)') '    X         PD(-4 - 4)'
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A)')
     &   ' ============================================================'

C  logarithmic loop over x values
C  upper bound
      XUPPER=0.9999D0
C  lower bound
      XLOWER=1.D-4
C  number of steps
      NSTEP=50

      XFIRST=LOG(XLOWER)
      XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
      DO 100 I=1,NSTEP
        X=EXP(XFIRST)
        XCONTR=X
        CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
        IF(X.NE.XCONTR) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,*) ' PHO_PDFTST: x changed! old: ',XCONTR,' new: ',X
        ENDIF
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,1P,10E11.4)') XCONTR,(PD(K),K=-4,4)
        XFIRST=XFIRST+XDELTA
 100  CONTINUE

      IF(IDPDG.EQ.22) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A)')
     &   'comparison PDF to contribution due to box diagram'
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A)') '    X   PD(1),PB(1), .... ,PD(4),PB(4)'
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A)')
     &   ' ============================================================'
        XFIRST=LOG(XLOWER)
        XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
        DO 110 I=1,NSTEP
          X=EXP(XFIRST)
          CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
          DO 120 K=1,4
            CALL PHO_QPMPDF(K,X,SCALE2,0.D0,P2MASS,FXP(K))
 120      CONTINUE
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,1P,9E11.4)') X,(PD(K),FXP(K),K=1,4)
          XFIRST=XFIRST+XDELTA
 110    CONTINUE
      ENDIF

C  check momentum sum rule

      IF (LPRI.GT.4)
     &WRITE(LO,'(/1X,A)') 'PHO_PDFTST: estimate of quark sum rules'
      DO 199 I=-6,6
        PDSUM(I) = 0.D0
        PDAVE(I) = 0.D0
 199  CONTINUE
      ITER=5000
      DO 200 I=1,ITER
        XX=DBLE(I)/DBLE(ITER)
        IF(XX.EQ.1.D0) XX = 0.999999D0
        CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
        DO 202 K=-6,6
          PDSUM(K) = PDSUM(K)+PD(K)/XX
          PDAVE(K) = PDAVE(K)+PD(K)
 202    CONTINUE
 200  CONTINUE
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A)')
     &  'Table: parton-ID, dx-integral over Q(X,Q**2), X*Q(X,Q**2)'
      XSUM = 0.D0
      DO 204 I=-6,6
        PDSUM(I) = PDSUM(I)/DBLE(ITER)
        PDAVE(I) = PDAVE(I)/DBLE(ITER)
        XSUM = XSUM+PDAVE(I)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(9X,I3,3X,2E15.4)') I,PDSUM(I),PDAVE(I)
 204  CONTINUE
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A)') 'PHO_PDFTST: valence flavours'
      DO 205 I=1,6
        IF (LPRI.GT.4)
     &  WRITE(LO,'(9X,I3,E12.4)') I,PDSUM(I)-PDSUM(-I)
 205  CONTINUE
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,E12.4)') 'momentum sum rule',XSUM
      IF (LPRI.GT.4)
     &WRITE(LO,'(A/)') ' ============================================='

C  table of F2

      IF (LPRI.GT.4)
     &WRITE(LO,'(/1X,A,E12.4,/1X,A)')
     &  'PHO_PDFTST: TABLE OF X, F2(X,Q**2) FOR Q**2',SCALE2,
     &  '-----------------------------------------------------'
      ITER=100
      DO 300 I=1,ITER
        XX=DBLE(I)/DBLE(ITER)
        IF(XX.EQ.1.D0) XX = 0.9999D0
        CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
        F2 = 0.D0
        DO 302 K=-6,6
          IF(K.NE.0) F2 = F2 + Q_ch2(K)*PD(K)
 302    CONTINUE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,1P,2E14.5)') XX,F2
 300  CONTINUE
      IF (LPRI.GT.4)
     &WRITE(LO,'(A/)') ' ============================================='

      END

 
 


CDECK  ID>, PHO_PECMS
      SUBROUTINE PHO_PECMS(ID,PMASS1,PMASS2,ECM,PP,EE)
C*******************************************************************
C
C     calculation of cms momentum and energy of massive particle
C     (ID=  1 using PMASS1,  2 using PMASS2)
C
C     output:  PP    cms momentum
C              EE    energy in CMS of particle ID
C
C********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)


      S=ECM**2
      PM1 = SIGN(PMASS1**2,PMASS1)
      PM2 = SIGN(PMASS2**2,PMASS2)
      PP = SQRT(S**2 - 2.D0*PM1*S - 2.D0*PM2*S - 2.D0*PM1*PM2
     &          + PM1**2 + PM2**2)/(2.D0*ECM)

      IF(ID.EQ.1) THEN
        EE = SQRT( PM1 + PP**2 )
      ELSE IF(ID.EQ.2) THEN
        EE = SQRT( PM2 + PP**2 )
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,I3,/)')
     &    'PHO_PECMS:ERROR: invalid ID number:',ID
        EE = PP
      ENDIF

      END


 
 


CDECK  ID>, PHO_PHGAL
      SUBROUTINE PHO_PHGAL(X,Q2,XPDF)
C***********************************************************************
C
C     photon parton densities with built-in momentum sum rule and
C     Regge-based low-x behaviour
C
C     H. Abramowicz, E. Gurvich, A. Levy: Phys.Lett.B420:104-108,1998
C     e-Print Archive: hep-ph/9711355
C
C     code submitted by E.Gurvich, slightly modified (R.Engel, 09/1998)
C
C***********************************************************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      SAVE

      PARAMETER(IX=100,IQ=7,NARG=2,NFUN=4)
      DOUBLE PRECISION
     &       XT(IX),Q2T(IQ),ARG(NARG),ENT(IX+IQ),
     &       XPV(IX,IQ,0:NFUN),XPDF(-6:6)

      DIMENSION NA(NARG)

      DATA ZEROD/0.D0/

C...100 x values; in (D-4,.77) log spaced (78 points)
C...              in (.78,.995) lineary spaced (22 points)
      DATA Q2T/4.D0,10.D0,50.D0,1.D2,1.D3,1.D4,1.D5/
      DATA XT/
     &0.1000D-03,0.1123D-03,0.1262D-03,0.1417D-03,0.1592D-03,0.1789D-03,
     &0.2009D-03,0.2257D-03,0.2535D-03,0.2848D-03,0.3199D-03,0.3593D-03,
     &0.4037D-03,0.4534D-03,0.5093D-03,0.5722D-03,0.6427D-03,0.7220D-03,
     &0.8110D-03,0.9110D-03,0.1023D-02,0.1150D-02,0.1291D-02,0.1451D-02,
     &0.1629D-02,0.1830D-02,0.2056D-02,0.2310D-02,0.2594D-02,0.2914D-02,
     &0.3274D-02,0.3677D-02,0.4131D-02,0.4640D-02,0.5212D-02,0.5855D-02,
     &0.6577D-02,0.7388D-02,0.8299D-02,0.9323D-02,0.1047D-01,0.1176D-01,
     &0.1321D-01,0.1484D-01,0.1667D-01,0.1873D-01,0.2104D-01,0.2363D-01,
     &0.2655D-01,0.2982D-01,0.3350D-01,0.3763D-01,0.4227D-01,0.4748D-01,
     &0.5334D-01,0.5992D-01,0.6731D-01,0.7560D-01,0.8493D-01,0.9540D-01,
     &0.1072D+00,0.1204D+00,0.1352D+00,0.1519D+00,0.1706D+00,0.1917D+00,
     &0.2153D+00,0.2419D+00,0.2717D+00,0.3052D+00,0.3428D+00,0.3851D+00,
     &0.4326D+00,0.4859D+00,0.5458D+00,0.6131D+00,0.6887D+00,0.7737D+00,
     &0.7837D+00,0.7937D+00,0.8037D+00,0.8137D+00,0.8237D+00,0.8337D+00,
     &0.8437D+00,0.8537D+00,0.8637D+00,0.8737D+00,0.8837D+00,0.8937D+00,
     &0.9037D+00,0.9137D+00,0.9237D+00,0.9337D+00,0.9437D+00,0.9537D+00,
     &0.9637D+00,0.9737D+00,0.9837D+00,0.9937D+00/

C...place for DATA blocks
      DATA (XPV(I,1,0),I=1,100)/
     &0.6632D-01,0.6536D-01,0.6390D-01,0.6196D-01,0.5952D-01,0.5663D-01,
     &0.5339D-01,0.5124D-01,0.5029D-01,0.4893D-01,0.4718D-01,0.4505D-01,
     &0.4259D-01,0.4038D-01,0.3966D-01,0.3860D-01,0.3721D-01,0.3551D-01,
     &0.3354D-01,0.3206D-01,0.3134D-01,0.3031D-01,0.2902D-01,0.2747D-01,
     &0.2608D-01,0.2543D-01,0.2451D-01,0.2335D-01,0.2202D-01,0.2132D-01,
     &0.2051D-01,0.1950D-01,0.1851D-01,0.1783D-01,0.1696D-01,0.1609D-01,
     &0.1539D-01,0.1454D-01,0.1386D-01,0.1310D-01,0.1242D-01,0.1169D-01,
     &0.1104D-01,0.1036D-01,0.9694D-02,0.9046D-02,0.8400D-02,0.7792D-02,
     &0.7173D-02,0.6573D-02,0.5978D-02,0.5411D-02,0.4853D-02,0.4307D-02,
     &0.3791D-02,0.3292D-02,0.2818D-02,0.2382D-02,0.1976D-02,0.1606D-02,
     &0.1275D-02,0.9866D-03,0.7403D-03,0.5351D-03,0.3713D-03,0.2450D-03,
     &0.1524D-03,0.8849D-04,0.4730D-04,0.2278D-04,0.9707D-05,0.3518D-05,
     &0.1041D-05,0.2356D-06,0.3682D-07,0.3365D-08,0.1333D-09,0.1188D-11,
     &0.6095D-12,0.3031D-12,0.1457D-12,0.6733D-13,0.2986D-13,0.1262D-13,
     &0.5060D-14,0.1912D-14,0.6734D-15,0.2199D-15,0.6498D-16,0.1729D-16,
     &0.4059D-17,0.8091D-18,0.1324D-18,0.1691D-19,0.1518D-20,0.8785D-22,
     &0.2519D-23,0.2197D-25,0.2840D-28,0.1908D-33/
      DATA (XPV(I,1,1),I=1,100)/
     &0.5848D-03,0.5838D-03,0.5793D-03,0.5713D-03,0.5597D-03,0.5447D-03,
     &0.5270D-03,0.5167D-03,0.5143D-03,0.5087D-03,0.4998D-03,0.4879D-03,
     &0.4731D-03,0.4599D-03,0.4584D-03,0.4538D-03,0.4461D-03,0.4355D-03,
     &0.4223D-03,0.4133D-03,0.4109D-03,0.4053D-03,0.3970D-03,0.3859D-03,
     &0.3763D-03,0.3739D-03,0.3686D-03,0.3605D-03,0.3504D-03,0.3473D-03,
     &0.3426D-03,0.3355D-03,0.3286D-03,0.3253D-03,0.3196D-03,0.3138D-03,
     &0.3102D-03,0.3047D-03,0.3014D-03,0.2971D-03,0.2939D-03,0.2901D-03,
     &0.2875D-03,0.2849D-03,0.2824D-03,0.2805D-03,0.2787D-03,0.2780D-03,
     &0.2772D-03,0.2771D-03,0.2773D-03,0.2784D-03,0.2799D-03,0.2820D-03,
     &0.2850D-03,0.2886D-03,0.2930D-03,0.2985D-03,0.3050D-03,0.3126D-03,
     &0.3215D-03,0.3316D-03,0.3432D-03,0.3564D-03,0.3714D-03,0.3883D-03,
     &0.4073D-03,0.4287D-03,0.4526D-03,0.4794D-03,0.5092D-03,0.5425D-03,
     &0.5796D-03,0.6207D-03,0.6664D-03,0.7171D-03,0.7733D-03,0.8356D-03,
     &0.8429D-03,0.8502D-03,0.8574D-03,0.8647D-03,0.8719D-03,0.8791D-03,
     &0.8863D-03,0.8935D-03,0.9007D-03,0.9079D-03,0.9151D-03,0.9222D-03,
     &0.9294D-03,0.9365D-03,0.9436D-03,0.9508D-03,0.9579D-03,0.9650D-03,
     &0.9720D-03,0.9791D-03,0.9862D-03,0.9932D-03/
      DATA (XPV(I,1,2),I=1,100)/
     &0.2339D-02,0.2335D-02,0.2317D-02,0.2285D-02,0.2239D-02,0.2179D-02,
     &0.2108D-02,0.2067D-02,0.2057D-02,0.2035D-02,0.1999D-02,0.1951D-02,
     &0.1892D-02,0.1840D-02,0.1833D-02,0.1815D-02,0.1784D-02,0.1742D-02,
     &0.1689D-02,0.1653D-02,0.1643D-02,0.1621D-02,0.1588D-02,0.1544D-02,
     &0.1505D-02,0.1496D-02,0.1474D-02,0.1442D-02,0.1402D-02,0.1389D-02,
     &0.1370D-02,0.1342D-02,0.1314D-02,0.1301D-02,0.1278D-02,0.1255D-02,
     &0.1241D-02,0.1219D-02,0.1205D-02,0.1188D-02,0.1176D-02,0.1160D-02,
     &0.1150D-02,0.1139D-02,0.1130D-02,0.1122D-02,0.1115D-02,0.1112D-02,
     &0.1109D-02,0.1108D-02,0.1109D-02,0.1114D-02,0.1120D-02,0.1128D-02,
     &0.1140D-02,0.1154D-02,0.1172D-02,0.1194D-02,0.1220D-02,0.1251D-02,
     &0.1286D-02,0.1326D-02,0.1373D-02,0.1426D-02,0.1485D-02,0.1553D-02,
     &0.1629D-02,0.1715D-02,0.1811D-02,0.1917D-02,0.2037D-02,0.2170D-02,
     &0.2318D-02,0.2483D-02,0.2666D-02,0.2868D-02,0.3093D-02,0.3342D-02,
     &0.3372D-02,0.3401D-02,0.3430D-02,0.3459D-02,0.3488D-02,0.3517D-02,
     &0.3545D-02,0.3574D-02,0.3603D-02,0.3632D-02,0.3660D-02,0.3689D-02,
     &0.3717D-02,0.3746D-02,0.3775D-02,0.3803D-02,0.3831D-02,0.3860D-02,
     &0.3888D-02,0.3916D-02,0.3945D-02,0.3973D-02/
      DATA (XPV(I,1,3),I=1,100)/
     &0.1755D-03,0.1751D-03,0.1738D-03,0.1714D-03,0.1679D-03,0.1634D-03,
     &0.1581D-03,0.1550D-03,0.1543D-03,0.1526D-03,0.1499D-03,0.1464D-03,
     &0.1419D-03,0.1380D-03,0.1375D-03,0.1361D-03,0.1338D-03,0.1306D-03,
     &0.1267D-03,0.1240D-03,0.1233D-03,0.1216D-03,0.1191D-03,0.1158D-03,
     &0.1129D-03,0.1122D-03,0.1106D-03,0.1082D-03,0.1051D-03,0.1042D-03,
     &0.1028D-03,0.1006D-03,0.9857D-04,0.9759D-04,0.9587D-04,0.9414D-04,
     &0.9305D-04,0.9140D-04,0.9041D-04,0.8912D-04,0.8817D-04,0.8702D-04,
     &0.8626D-04,0.8546D-04,0.8472D-04,0.8415D-04,0.8362D-04,0.8339D-04,
     &0.8317D-04,0.8312D-04,0.8318D-04,0.8352D-04,0.8398D-04,0.8459D-04,
     &0.8550D-04,0.8658D-04,0.8789D-04,0.8956D-04,0.9151D-04,0.9379D-04,
     &0.9644D-04,0.9948D-04,0.1030D-03,0.1069D-03,0.1114D-03,0.1165D-03,
     &0.1222D-03,0.1286D-03,0.1358D-03,0.1438D-03,0.1528D-03,0.1628D-03,
     &0.1739D-03,0.1862D-03,0.1999D-03,0.2151D-03,0.2320D-03,0.2507D-03,
     &0.2529D-03,0.2551D-03,0.2572D-03,0.2594D-03,0.2616D-03,0.2637D-03,
     &0.2659D-03,0.2681D-03,0.2702D-03,0.2724D-03,0.2745D-03,0.2767D-03,
     &0.2788D-03,0.2810D-03,0.2831D-03,0.2852D-03,0.2874D-03,0.2895D-03,
     &0.2916D-03,0.2937D-03,0.2959D-03,0.2980D-03/
      DATA (XPV(I,1,4),I=1,100)/
     &0.7018D-03,0.7006D-03,0.6951D-03,0.6855D-03,0.6716D-03,0.6537D-03,
     &0.6324D-03,0.6200D-03,0.6172D-03,0.6104D-03,0.5998D-03,0.5854D-03,
     &0.5677D-03,0.5519D-03,0.5500D-03,0.5445D-03,0.5353D-03,0.5226D-03,
     &0.5068D-03,0.4960D-03,0.4930D-03,0.4864D-03,0.4764D-03,0.4631D-03,
     &0.4516D-03,0.4487D-03,0.4423D-03,0.4326D-03,0.4205D-03,0.4167D-03,
     &0.4111D-03,0.4026D-03,0.3943D-03,0.3903D-03,0.3835D-03,0.3765D-03,
     &0.3722D-03,0.3656D-03,0.3616D-03,0.3565D-03,0.3527D-03,0.3481D-03,
     &0.3450D-03,0.3418D-03,0.3389D-03,0.3366D-03,0.3345D-03,0.3336D-03,
     &0.3327D-03,0.3325D-03,0.3327D-03,0.3341D-03,0.3359D-03,0.3383D-03,
     &0.3420D-03,0.3463D-03,0.3516D-03,0.3582D-03,0.3660D-03,0.3752D-03,
     &0.3858D-03,0.3979D-03,0.4118D-03,0.4277D-03,0.4456D-03,0.4660D-03,
     &0.4887D-03,0.5145D-03,0.5432D-03,0.5752D-03,0.6111D-03,0.6510D-03,
     &0.6955D-03,0.7448D-03,0.7997D-03,0.8605D-03,0.9280D-03,0.1003D-02,
     &0.1011D-02,0.1020D-02,0.1029D-02,0.1038D-02,0.1046D-02,0.1055D-02,
     &0.1064D-02,0.1072D-02,0.1081D-02,0.1089D-02,0.1098D-02,0.1107D-02,
     &0.1115D-02,0.1124D-02,0.1132D-02,0.1141D-02,0.1149D-02,0.1158D-02,
     &0.1166D-02,0.1175D-02,0.1183D-02,0.1192D-02/
      DATA (XPV(I,2,0),I=1,100)/
     &0.1024D+00,0.1007D+00,0.9821D-01,0.9497D-01,0.9093D-01,0.8617D-01,
     &0.8086D-01,0.7731D-01,0.7566D-01,0.7338D-01,0.7048D-01,0.6700D-01,
     &0.6300D-01,0.5939D-01,0.5814D-01,0.5638D-01,0.5410D-01,0.5135D-01,
     &0.4819D-01,0.4580D-01,0.4460D-01,0.4293D-01,0.4087D-01,0.3843D-01,
     &0.3624D-01,0.3517D-01,0.3372D-01,0.3192D-01,0.2988D-01,0.2879D-01,
     &0.2755D-01,0.2602D-01,0.2454D-01,0.2352D-01,0.2224D-01,0.2097D-01,
     &0.1995D-01,0.1875D-01,0.1779D-01,0.1673D-01,0.1580D-01,0.1480D-01,
     &0.1393D-01,0.1305D-01,0.1218D-01,0.1136D-01,0.1055D-01,0.9801D-02,
     &0.9052D-02,0.8337D-02,0.7641D-02,0.6989D-02,0.6357D-02,0.5747D-02,
     &0.5179D-02,0.4637D-02,0.4127D-02,0.3663D-02,0.3232D-02,0.2840D-02,
     &0.2487D-02,0.2174D-02,0.1901D-02,0.1662D-02,0.1459D-02,0.1285D-02,
     &0.1137D-02,0.1010D-02,0.9006D-03,0.8023D-03,0.7126D-03,0.6276D-03,
     &0.5458D-03,0.4661D-03,0.3876D-03,0.3101D-03,0.2334D-03,0.1570D-03,
     &0.1486D-03,0.1404D-03,0.1322D-03,0.1242D-03,0.1162D-03,0.1084D-03,
     &0.1007D-03,0.9304D-04,0.8554D-04,0.7817D-04,0.7086D-04,0.6372D-04,
     &0.5670D-04,0.4982D-04,0.4307D-04,0.3647D-04,0.3005D-04,0.2382D-04,
     &0.1781D-04,0.1208D-04,0.6720D-05,0.1928D-05/
      DATA (XPV(I,2,1),I=1,100)/
     &0.1449D-02,0.1433D-02,0.1407D-02,0.1370D-02,0.1324D-02,0.1268D-02,
     &0.1204D-02,0.1163D-02,0.1147D-02,0.1123D-02,0.1089D-02,0.1048D-02,
     &0.1000D-02,0.9567D-03,0.9446D-03,0.9250D-03,0.8981D-03,0.8642D-03,
     &0.8244D-03,0.7951D-03,0.7821D-03,0.7623D-03,0.7362D-03,0.7043D-03,
     &0.6759D-03,0.6640D-03,0.6459D-03,0.6223D-03,0.5945D-03,0.5817D-03,
     &0.5660D-03,0.5455D-03,0.5256D-03,0.5132D-03,0.4963D-03,0.4794D-03,
     &0.4669D-03,0.4510D-03,0.4394D-03,0.4261D-03,0.4151D-03,0.4031D-03,
     &0.3934D-03,0.3838D-03,0.3747D-03,0.3666D-03,0.3591D-03,0.3533D-03,
     &0.3477D-03,0.3433D-03,0.3397D-03,0.3376D-03,0.3364D-03,0.3361D-03,
     &0.3375D-03,0.3399D-03,0.3437D-03,0.3492D-03,0.3562D-03,0.3648D-03,
     &0.3751D-03,0.3871D-03,0.4009D-03,0.4167D-03,0.4344D-03,0.4543D-03,
     &0.4760D-03,0.5003D-03,0.5268D-03,0.5558D-03,0.5876D-03,0.6226D-03,
     &0.6610D-03,0.7035D-03,0.7509D-03,0.8041D-03,0.8638D-03,0.9294D-03,
     &0.9367D-03,0.9440D-03,0.9511D-03,0.9581D-03,0.9648D-03,0.9714D-03,
     &0.9776D-03,0.9836D-03,0.9891D-03,0.9942D-03,0.9987D-03,0.1003D-02,
     &0.1006D-02,0.1008D-02,0.1008D-02,0.1007D-02,0.1004D-02,0.9977D-03,
     &0.9868D-03,0.9681D-03,0.9347D-03,0.8678D-03/
      DATA (XPV(I,2,2),I=1,100)/
     &0.3175D-02,0.3156D-02,0.3117D-02,0.3057D-02,0.2976D-02,0.2876D-02,
     &0.2760D-02,0.2689D-02,0.2666D-02,0.2625D-02,0.2566D-02,0.2489D-02,
     &0.2398D-02,0.2316D-02,0.2299D-02,0.2266D-02,0.2217D-02,0.2152D-02,
     &0.2073D-02,0.2018D-02,0.1998D-02,0.1962D-02,0.1911D-02,0.1847D-02,
     &0.1791D-02,0.1773D-02,0.1739D-02,0.1692D-02,0.1636D-02,0.1614D-02,
     &0.1586D-02,0.1545D-02,0.1506D-02,0.1485D-02,0.1452D-02,0.1420D-02,
     &0.1398D-02,0.1368D-02,0.1348D-02,0.1324D-02,0.1306D-02,0.1285D-02,
     &0.1271D-02,0.1256D-02,0.1243D-02,0.1233D-02,0.1224D-02,0.1220D-02,
     &0.1217D-02,0.1217D-02,0.1220D-02,0.1227D-02,0.1237D-02,0.1249D-02,
     &0.1267D-02,0.1288D-02,0.1313D-02,0.1345D-02,0.1381D-02,0.1422D-02,
     &0.1469D-02,0.1522D-02,0.1582D-02,0.1648D-02,0.1722D-02,0.1804D-02,
     &0.1893D-02,0.1992D-02,0.2099D-02,0.2216D-02,0.2345D-02,0.2486D-02,
     &0.2641D-02,0.2812D-02,0.3002D-02,0.3216D-02,0.3455D-02,0.3718D-02,
     &0.3748D-02,0.3777D-02,0.3806D-02,0.3833D-02,0.3861D-02,0.3887D-02,
     &0.3912D-02,0.3936D-02,0.3958D-02,0.3978D-02,0.3996D-02,0.4012D-02,
     &0.4024D-02,0.4032D-02,0.4035D-02,0.4031D-02,0.4018D-02,0.3993D-02,
     &0.3949D-02,0.3875D-02,0.3741D-02,0.3474D-02/
      DATA (XPV(I,2,3),I=1,100)/
     &0.1046D-02,0.1031D-02,0.1008D-02,0.9768D-03,0.9381D-03,0.8923D-03,
     &0.8410D-03,0.8074D-03,0.7928D-03,0.7720D-03,0.7450D-03,0.7121D-03,
     &0.6741D-03,0.6398D-03,0.6287D-03,0.6123D-03,0.5906D-03,0.5640D-03,
     &0.5332D-03,0.5101D-03,0.4988D-03,0.4827D-03,0.4624D-03,0.4380D-03,
     &0.4161D-03,0.4059D-03,0.3914D-03,0.3732D-03,0.3524D-03,0.3416D-03,
     &0.3290D-03,0.3133D-03,0.2981D-03,0.2878D-03,0.2747D-03,0.2616D-03,
     &0.2515D-03,0.2392D-03,0.2296D-03,0.2191D-03,0.2100D-03,0.2004D-03,
     &0.1923D-03,0.1842D-03,0.1764D-03,0.1694D-03,0.1627D-03,0.1571D-03,
     &0.1517D-03,0.1469D-03,0.1427D-03,0.1394D-03,0.1367D-03,0.1345D-03,
     &0.1333D-03,0.1327D-03,0.1329D-03,0.1340D-03,0.1360D-03,0.1387D-03,
     &0.1424D-03,0.1469D-03,0.1522D-03,0.1584D-03,0.1654D-03,0.1733D-03,
     &0.1819D-03,0.1915D-03,0.2019D-03,0.2132D-03,0.2257D-03,0.2396D-03,
     &0.2553D-03,0.2737D-03,0.2956D-03,0.3227D-03,0.3570D-03,0.4009D-03,
     &0.4064D-03,0.4119D-03,0.4175D-03,0.4231D-03,0.4287D-03,0.4344D-03,
     &0.4400D-03,0.4457D-03,0.4512D-03,0.4567D-03,0.4621D-03,0.4673D-03,
     &0.4723D-03,0.4769D-03,0.4811D-03,0.4848D-03,0.4875D-03,0.4891D-03,
     &0.4888D-03,0.4853D-03,0.4756D-03,0.4518D-03/
      DATA (XPV(I,2,4),I=1,100)/
     &0.1564D-02,0.1548D-02,0.1521D-02,0.1483D-02,0.1434D-02,0.1375D-02,
     &0.1308D-02,0.1265D-02,0.1249D-02,0.1223D-02,0.1188D-02,0.1145D-02,
     &0.1094D-02,0.1048D-02,0.1035D-02,0.1015D-02,0.9868D-03,0.9509D-03,
     &0.9086D-03,0.8776D-03,0.8644D-03,0.8436D-03,0.8161D-03,0.7822D-03,
     &0.7521D-03,0.7400D-03,0.7212D-03,0.6963D-03,0.6669D-03,0.6538D-03,
     &0.6377D-03,0.6163D-03,0.5956D-03,0.5832D-03,0.5658D-03,0.5486D-03,
     &0.5363D-03,0.5203D-03,0.5091D-03,0.4962D-03,0.4859D-03,0.4746D-03,
     &0.4661D-03,0.4578D-03,0.4502D-03,0.4441D-03,0.4387D-03,0.4355D-03,
     &0.4329D-03,0.4318D-03,0.4320D-03,0.4342D-03,0.4379D-03,0.4429D-03,
     &0.4503D-03,0.4594D-03,0.4704D-03,0.4839D-03,0.4996D-03,0.5177D-03,
     &0.5383D-03,0.5613D-03,0.5869D-03,0.6152D-03,0.6462D-03,0.6802D-03,
     &0.7167D-03,0.7565D-03,0.7995D-03,0.8461D-03,0.8972D-03,0.9538D-03,
     &0.1018D-02,0.1092D-02,0.1181D-02,0.1290D-02,0.1428D-02,0.1604D-02,
     &0.1626D-02,0.1649D-02,0.1671D-02,0.1694D-02,0.1716D-02,0.1739D-02,
     &0.1762D-02,0.1784D-02,0.1806D-02,0.1828D-02,0.1850D-02,0.1871D-02,
     &0.1891D-02,0.1909D-02,0.1926D-02,0.1941D-02,0.1952D-02,0.1958D-02,
     &0.1957D-02,0.1943D-02,0.1905D-02,0.1811D-02/
      DATA (XPV(I,3,0),I=1,100)/
     &0.1761D+00,0.1728D+00,0.1680D+00,0.1619D+00,0.1544D+00,0.1456D+00,
     &0.1358D+00,0.1292D+00,0.1260D+00,0.1218D+00,0.1165D+00,0.1101D+00,
     &0.1029D+00,0.9643D-01,0.9409D-01,0.9087D-01,0.8680D-01,0.8192D-01,
     &0.7638D-01,0.7217D-01,0.7000D-01,0.6708D-01,0.6352D-01,0.5934D-01,
     &0.5561D-01,0.5375D-01,0.5129D-01,0.4829D-01,0.4491D-01,0.4309D-01,
     &0.4104D-01,0.3857D-01,0.3618D-01,0.3454D-01,0.3252D-01,0.3053D-01,
     &0.2896D-01,0.2712D-01,0.2565D-01,0.2407D-01,0.2268D-01,0.2123D-01,
     &0.1997D-01,0.1870D-01,0.1748D-01,0.1634D-01,0.1523D-01,0.1422D-01,
     &0.1321D-01,0.1227D-01,0.1137D-01,0.1053D-01,0.9723D-02,0.8952D-02,
     &0.8241D-02,0.7563D-02,0.6926D-02,0.6345D-02,0.5801D-02,0.5298D-02,
     &0.4833D-02,0.4407D-02,0.4017D-02,0.3657D-02,0.3327D-02,0.3021D-02,
     &0.2735D-02,0.2469D-02,0.2217D-02,0.1976D-02,0.1746D-02,0.1522D-02,
     &0.1307D-02,0.1098D-02,0.8959D-03,0.7002D-03,0.5112D-03,0.3292D-03,
     &0.3097D-03,0.2906D-03,0.2718D-03,0.2534D-03,0.2354D-03,0.2178D-03,
     &0.2005D-03,0.1836D-03,0.1672D-03,0.1511D-03,0.1354D-03,0.1203D-03,
     &0.1055D-03,0.9128D-04,0.7756D-04,0.6440D-04,0.5185D-04,0.3998D-04,
     &0.2891D-04,0.1876D-04,0.9776D-05,0.2464D-05/
      DATA (XPV(I,3,1),I=1,100)/
     &0.3351D-02,0.3297D-02,0.3217D-02,0.3112D-02,0.2981D-02,0.2828D-02,
     &0.2656D-02,0.2543D-02,0.2493D-02,0.2422D-02,0.2332D-02,0.2223D-02,
     &0.2097D-02,0.1984D-02,0.1946D-02,0.1892D-02,0.1821D-02,0.1734D-02,
     &0.1635D-02,0.1560D-02,0.1523D-02,0.1471D-02,0.1406D-02,0.1329D-02,
     &0.1260D-02,0.1228D-02,0.1182D-02,0.1126D-02,0.1061D-02,0.1028D-02,
     &0.9902D-03,0.9426D-03,0.8967D-03,0.8664D-03,0.8274D-03,0.7890D-03,
     &0.7596D-03,0.7240D-03,0.6969D-03,0.6671D-03,0.6417D-03,0.6149D-03,
     &0.5928D-03,0.5708D-03,0.5502D-03,0.5317D-03,0.5144D-03,0.5002D-03,
     &0.4867D-03,0.4753D-03,0.4655D-03,0.4582D-03,0.4526D-03,0.4487D-03,
     &0.4475D-03,0.4480D-03,0.4506D-03,0.4559D-03,0.4632D-03,0.4729D-03,
     &0.4849D-03,0.4991D-03,0.5155D-03,0.5343D-03,0.5552D-03,0.5783D-03,
     &0.6033D-03,0.6307D-03,0.6600D-03,0.6915D-03,0.7256D-03,0.7626D-03,
     &0.8031D-03,0.8482D-03,0.8993D-03,0.9582D-03,0.1026D-02,0.1099D-02,
     &0.1107D-02,0.1115D-02,0.1122D-02,0.1129D-02,0.1136D-02,0.1142D-02,
     &0.1148D-02,0.1152D-02,0.1156D-02,0.1159D-02,0.1161D-02,0.1161D-02,
     &0.1160D-02,0.1156D-02,0.1150D-02,0.1141D-02,0.1127D-02,0.1107D-02,
     &0.1078D-02,0.1036D-02,0.9685D-03,0.8413D-03/
      DATA (XPV(I,3,2),I=1,100)/
     &0.5039D-02,0.4982D-02,0.4889D-02,0.4761D-02,0.4597D-02,0.4401D-02,
     &0.4179D-02,0.4036D-02,0.3979D-02,0.3893D-02,0.3777D-02,0.3634D-02,
     &0.3466D-02,0.3315D-02,0.3273D-02,0.3206D-02,0.3114D-02,0.2997D-02,
     &0.2860D-02,0.2760D-02,0.2717D-02,0.2650D-02,0.2562D-02,0.2454D-02,
     &0.2359D-02,0.2321D-02,0.2262D-02,0.2184D-02,0.2092D-02,0.2052D-02,
     &0.2003D-02,0.1938D-02,0.1875D-02,0.1839D-02,0.1787D-02,0.1736D-02,
     &0.1700D-02,0.1653D-02,0.1622D-02,0.1585D-02,0.1557D-02,0.1526D-02,
     &0.1504D-02,0.1483D-02,0.1464D-02,0.1450D-02,0.1438D-02,0.1433D-02,
     &0.1430D-02,0.1432D-02,0.1438D-02,0.1450D-02,0.1466D-02,0.1487D-02,
     &0.1515D-02,0.1547D-02,0.1585D-02,0.1631D-02,0.1683D-02,0.1742D-02,
     &0.1808D-02,0.1880D-02,0.1960D-02,0.2048D-02,0.2142D-02,0.2245D-02,
     &0.2354D-02,0.2471D-02,0.2596D-02,0.2729D-02,0.2872D-02,0.3025D-02,
     &0.3193D-02,0.3378D-02,0.3587D-02,0.3827D-02,0.4100D-02,0.4397D-02,
     &0.4429D-02,0.4461D-02,0.4490D-02,0.4519D-02,0.4545D-02,0.4570D-02,
     &0.4592D-02,0.4611D-02,0.4627D-02,0.4639D-02,0.4646D-02,0.4647D-02,
     &0.4642D-02,0.4628D-02,0.4604D-02,0.4566D-02,0.4510D-02,0.4431D-02,
     &0.4317D-02,0.4147D-02,0.3877D-02,0.3370D-02/
      DATA (XPV(I,3,3),I=1,100)/
     &0.2958D-02,0.2904D-02,0.2827D-02,0.2727D-02,0.2604D-02,0.2461D-02,
     &0.2301D-02,0.2195D-02,0.2146D-02,0.2079D-02,0.1995D-02,0.1894D-02,
     &0.1778D-02,0.1674D-02,0.1637D-02,0.1586D-02,0.1520D-02,0.1440D-02,
     &0.1349D-02,0.1280D-02,0.1245D-02,0.1197D-02,0.1138D-02,0.1068D-02,
     &0.1005D-02,0.9742D-03,0.9325D-03,0.8812D-03,0.8233D-03,0.7922D-03,
     &0.7568D-03,0.7138D-03,0.6722D-03,0.6438D-03,0.6084D-03,0.5735D-03,
     &0.5460D-03,0.5138D-03,0.4883D-03,0.4609D-03,0.4371D-03,0.4123D-03,
     &0.3912D-03,0.3704D-03,0.3507D-03,0.3327D-03,0.3158D-03,0.3012D-03,
     &0.2873D-03,0.2751D-03,0.2641D-03,0.2551D-03,0.2474D-03,0.2410D-03,
     &0.2365D-03,0.2334D-03,0.2318D-03,0.2321D-03,0.2339D-03,0.2372D-03,
     &0.2421D-03,0.2485D-03,0.2562D-03,0.2652D-03,0.2755D-03,0.2870D-03,
     &0.2995D-03,0.3131D-03,0.3278D-03,0.3438D-03,0.3615D-03,0.3814D-03,
     &0.4046D-03,0.4328D-03,0.4682D-03,0.5142D-03,0.5747D-03,0.6529D-03,
     &0.6625D-03,0.6722D-03,0.6819D-03,0.6916D-03,0.7012D-03,0.7107D-03,
     &0.7200D-03,0.7292D-03,0.7380D-03,0.7464D-03,0.7544D-03,0.7617D-03,
     &0.7681D-03,0.7735D-03,0.7776D-03,0.7798D-03,0.7796D-03,0.7761D-03,
     &0.7676D-03,0.7510D-03,0.7195D-03,0.6522D-03/
      DATA (XPV(I,3,4),I=1,100)/
     &0.3464D-02,0.3410D-02,0.3329D-02,0.3222D-02,0.3090D-02,0.2933D-02,
     &0.2758D-02,0.2643D-02,0.2593D-02,0.2521D-02,0.2430D-02,0.2318D-02,
     &0.2190D-02,0.2075D-02,0.2037D-02,0.1982D-02,0.1910D-02,0.1821D-02,
     &0.1720D-02,0.1643D-02,0.1607D-02,0.1554D-02,0.1489D-02,0.1410D-02,
     &0.1340D-02,0.1308D-02,0.1262D-02,0.1205D-02,0.1140D-02,0.1108D-02,
     &0.1070D-02,0.1023D-02,0.9772D-03,0.9482D-03,0.9103D-03,0.8732D-03,
     &0.8458D-03,0.8121D-03,0.7877D-03,0.7607D-03,0.7388D-03,0.7157D-03,
     &0.6981D-03,0.6812D-03,0.6662D-03,0.6540D-03,0.6438D-03,0.6377D-03,
     &0.6331D-03,0.6316D-03,0.6326D-03,0.6376D-03,0.6453D-03,0.6560D-03,
     &0.6708D-03,0.6887D-03,0.7102D-03,0.7361D-03,0.7656D-03,0.7991D-03,
     &0.8365D-03,0.8777D-03,0.9226D-03,0.9714D-03,0.1024D-02,0.1080D-02,
     &0.1138D-02,0.1201D-02,0.1267D-02,0.1338D-02,0.1415D-02,0.1501D-02,
     &0.1599D-02,0.1717D-02,0.1863D-02,0.2051D-02,0.2296D-02,0.2612D-02,
     &0.2650D-02,0.2689D-02,0.2729D-02,0.2767D-02,0.2806D-02,0.2844D-02,
     &0.2882D-02,0.2919D-02,0.2954D-02,0.2988D-02,0.3020D-02,0.3049D-02,
     &0.3075D-02,0.3097D-02,0.3114D-02,0.3123D-02,0.3122D-02,0.3108D-02,
     &0.3074D-02,0.3008D-02,0.2881D-02,0.2614D-02/
      DATA (XPV(I,4,0),I=1,100)/
     &0.2113D+00,0.2071D+00,0.2012D+00,0.1936D+00,0.1844D+00,0.1736D+00,
     &0.1616D+00,0.1536D+00,0.1497D+00,0.1445D+00,0.1380D+00,0.1303D+00,
     &0.1215D+00,0.1136D+00,0.1108D+00,0.1069D+00,0.1019D+00,0.9605D-01,
     &0.8939D-01,0.8432D-01,0.8171D-01,0.7821D-01,0.7395D-01,0.6897D-01,
     &0.6452D-01,0.6231D-01,0.5938D-01,0.5583D-01,0.5185D-01,0.4969D-01,
     &0.4728D-01,0.4438D-01,0.4158D-01,0.3967D-01,0.3731D-01,0.3500D-01,
     &0.3318D-01,0.3105D-01,0.2936D-01,0.2754D-01,0.2595D-01,0.2429D-01,
     &0.2285D-01,0.2141D-01,0.2003D-01,0.1874D-01,0.1749D-01,0.1635D-01,
     &0.1523D-01,0.1418D-01,0.1317D-01,0.1223D-01,0.1134D-01,0.1048D-01,
     &0.9692D-02,0.8938D-02,0.8227D-02,0.7578D-02,0.6967D-02,0.6398D-02,
     &0.5867D-02,0.5377D-02,0.4922D-02,0.4497D-02,0.4101D-02,0.3730D-02,
     &0.3379D-02,0.3048D-02,0.2732D-02,0.2429D-02,0.2139D-02,0.1858D-02,
     &0.1588D-02,0.1328D-02,0.1077D-02,0.8361D-03,0.6052D-03,0.3850D-03,
     &0.3616D-03,0.3387D-03,0.3162D-03,0.2943D-03,0.2728D-03,0.2518D-03,
     &0.2314D-03,0.2114D-03,0.1919D-03,0.1731D-03,0.1546D-03,0.1369D-03,
     &0.1197D-03,0.1032D-03,0.8729D-04,0.7214D-04,0.5778D-04,0.4429D-04,
     &0.3179D-04,0.2044D-04,0.1053D-04,0.2601D-05/
      DATA (XPV(I,4,1),I=1,100)/
     &0.4299D-02,0.4223D-02,0.4115D-02,0.3974D-02,0.3799D-02,0.3595D-02,
     &0.3367D-02,0.3216D-02,0.3148D-02,0.3054D-02,0.2934D-02,0.2790D-02,
     &0.2625D-02,0.2476D-02,0.2426D-02,0.2353D-02,0.2260D-02,0.2147D-02,
     &0.2018D-02,0.1920D-02,0.1871D-02,0.1804D-02,0.1720D-02,0.1620D-02,
     &0.1532D-02,0.1489D-02,0.1431D-02,0.1359D-02,0.1277D-02,0.1234D-02,
     &0.1185D-02,0.1125D-02,0.1067D-02,0.1028D-02,0.9791D-03,0.9308D-03,
     &0.8936D-03,0.8491D-03,0.8150D-03,0.7777D-03,0.7459D-03,0.7125D-03,
     &0.6849D-03,0.6575D-03,0.6318D-03,0.6088D-03,0.5872D-03,0.5693D-03,
     &0.5524D-03,0.5380D-03,0.5254D-03,0.5159D-03,0.5084D-03,0.5028D-03,
     &0.5003D-03,0.4998D-03,0.5017D-03,0.5066D-03,0.5139D-03,0.5237D-03,
     &0.5360D-03,0.5508D-03,0.5679D-03,0.5875D-03,0.6093D-03,0.6334D-03,
     &0.6593D-03,0.6876D-03,0.7177D-03,0.7500D-03,0.7848D-03,0.8225D-03,
     &0.8639D-03,0.9103D-03,0.9634D-03,0.1025D-02,0.1097D-02,0.1174D-02,
     &0.1183D-02,0.1191D-02,0.1199D-02,0.1206D-02,0.1212D-02,0.1219D-02,
     &0.1224D-02,0.1229D-02,0.1232D-02,0.1235D-02,0.1236D-02,0.1235D-02,
     &0.1232D-02,0.1227D-02,0.1219D-02,0.1207D-02,0.1190D-02,0.1167D-02,
     &0.1133D-02,0.1085D-02,0.1009D-02,0.8680D-03/
      DATA (XPV(I,4,2),I=1,100)/
     &0.5972D-02,0.5895D-02,0.5773D-02,0.5610D-02,0.5402D-02,0.5156D-02,
     &0.4878D-02,0.4698D-02,0.4623D-02,0.4513D-02,0.4369D-02,0.4191D-02,
     &0.3984D-02,0.3798D-02,0.3743D-02,0.3659D-02,0.3544D-02,0.3402D-02,
     &0.3235D-02,0.3113D-02,0.3058D-02,0.2976D-02,0.2870D-02,0.2740D-02,
     &0.2626D-02,0.2578D-02,0.2507D-02,0.2414D-02,0.2305D-02,0.2257D-02,
     &0.2198D-02,0.2121D-02,0.2046D-02,0.2003D-02,0.1942D-02,0.1882D-02,
     &0.1840D-02,0.1786D-02,0.1749D-02,0.1707D-02,0.1674D-02,0.1639D-02,
     &0.1613D-02,0.1589D-02,0.1567D-02,0.1551D-02,0.1538D-02,0.1533D-02,
     &0.1530D-02,0.1533D-02,0.1540D-02,0.1554D-02,0.1573D-02,0.1597D-02,
     &0.1628D-02,0.1665D-02,0.1709D-02,0.1760D-02,0.1818D-02,0.1884D-02,
     &0.1957D-02,0.2038D-02,0.2125D-02,0.2221D-02,0.2324D-02,0.2434D-02,
     &0.2551D-02,0.2676D-02,0.2807D-02,0.2946D-02,0.3095D-02,0.3254D-02,
     &0.3428D-02,0.3621D-02,0.3839D-02,0.4092D-02,0.4382D-02,0.4698D-02,
     &0.4731D-02,0.4764D-02,0.4795D-02,0.4824D-02,0.4851D-02,0.4876D-02,
     &0.4898D-02,0.4917D-02,0.4931D-02,0.4941D-02,0.4945D-02,0.4943D-02,
     &0.4933D-02,0.4913D-02,0.4881D-02,0.4833D-02,0.4766D-02,0.4671D-02,
     &0.4538D-02,0.4344D-02,0.4039D-02,0.3475D-02/
      DATA (XPV(I,4,3),I=1,100)/
     &0.3908D-02,0.3834D-02,0.3728D-02,0.3592D-02,0.3425D-02,0.3231D-02,
     &0.3015D-02,0.2871D-02,0.2804D-02,0.2714D-02,0.2600D-02,0.2464D-02,
     &0.2309D-02,0.2169D-02,0.2119D-02,0.2050D-02,0.1962D-02,0.1855D-02,
     &0.1735D-02,0.1643D-02,0.1596D-02,0.1532D-02,0.1453D-02,0.1361D-02,
     &0.1278D-02,0.1237D-02,0.1183D-02,0.1116D-02,0.1040D-02,0.9992D-03,
     &0.9531D-03,0.8972D-03,0.8434D-03,0.8065D-03,0.7608D-03,0.7159D-03,
     &0.6806D-03,0.6392D-03,0.6067D-03,0.5717D-03,0.5414D-03,0.5098D-03,
     &0.4831D-03,0.4567D-03,0.4317D-03,0.4090D-03,0.3877D-03,0.3693D-03,
     &0.3517D-03,0.3363D-03,0.3224D-03,0.3109D-03,0.3010D-03,0.2928D-03,
     &0.2869D-03,0.2826D-03,0.2801D-03,0.2799D-03,0.2814D-03,0.2848D-03,
     &0.2899D-03,0.2967D-03,0.3051D-03,0.3151D-03,0.3263D-03,0.3390D-03,
     &0.3528D-03,0.3678D-03,0.3841D-03,0.4018D-03,0.4214D-03,0.4437D-03,
     &0.4700D-03,0.5022D-03,0.5431D-03,0.5965D-03,0.6670D-03,0.7574D-03,
     &0.7684D-03,0.7795D-03,0.7905D-03,0.8015D-03,0.8124D-03,0.8230D-03,
     &0.8335D-03,0.8436D-03,0.8533D-03,0.8624D-03,0.8708D-03,0.8784D-03,
     &0.8849D-03,0.8901D-03,0.8934D-03,0.8945D-03,0.8925D-03,0.8863D-03,
     &0.8739D-03,0.8517D-03,0.8113D-03,0.7282D-03/
      DATA (XPV(I,4,4),I=1,100)/
     &0.4411D-02,0.4336D-02,0.4226D-02,0.4084D-02,0.3907D-02,0.3700D-02,
     &0.3469D-02,0.3316D-02,0.3248D-02,0.3153D-02,0.3032D-02,0.2886D-02,
     &0.2718D-02,0.2567D-02,0.2516D-02,0.2444D-02,0.2349D-02,0.2235D-02,
     &0.2103D-02,0.2004D-02,0.1956D-02,0.1888D-02,0.1804D-02,0.1703D-02,
     &0.1613D-02,0.1571D-02,0.1514D-02,0.1441D-02,0.1359D-02,0.1317D-02,
     &0.1269D-02,0.1210D-02,0.1153D-02,0.1116D-02,0.1069D-02,0.1022D-02,
     &0.9882D-03,0.9465D-03,0.9161D-03,0.8828D-03,0.8558D-03,0.8276D-03,
     &0.8060D-03,0.7854D-03,0.7672D-03,0.7526D-03,0.7404D-03,0.7330D-03,
     &0.7277D-03,0.7261D-03,0.7277D-03,0.7338D-03,0.7434D-03,0.7565D-03,
     &0.7745D-03,0.7963D-03,0.8222D-03,0.8532D-03,0.8886D-03,0.9283D-03,
     &0.9728D-03,0.1021D-02,0.1074D-02,0.1131D-02,0.1192D-02,0.1257D-02,
     &0.1325D-02,0.1397D-02,0.1473D-02,0.1554D-02,0.1642D-02,0.1739D-02,
     &0.1852D-02,0.1988D-02,0.2158D-02,0.2377D-02,0.2664D-02,0.3029D-02,
     &0.3074D-02,0.3119D-02,0.3163D-02,0.3207D-02,0.3251D-02,0.3294D-02,
     &0.3336D-02,0.3377D-02,0.3416D-02,0.3452D-02,0.3486D-02,0.3517D-02,
     &0.3543D-02,0.3564D-02,0.3578D-02,0.3582D-02,0.3574D-02,0.3549D-02,
     &0.3500D-02,0.3411D-02,0.3249D-02,0.2916D-02/
      DATA (XPV(I,5,0),I=1,100)/
     &0.3395D+00,0.3321D+00,0.3219D+00,0.3090D+00,0.2933D+00,0.2751D+00,
     &0.2550D+00,0.2414D+00,0.2348D+00,0.2261D+00,0.2153D+00,0.2025D+00,
     &0.1881D+00,0.1751D+00,0.1704D+00,0.1640D+00,0.1559D+00,0.1464D+00,
     &0.1357D+00,0.1276D+00,0.1233D+00,0.1178D+00,0.1110D+00,0.1032D+00,
     &0.9616D-01,0.9268D-01,0.8813D-01,0.8262D-01,0.7648D-01,0.7317D-01,
     &0.6948D-01,0.6506D-01,0.6083D-01,0.5795D-01,0.5442D-01,0.5097D-01,
     &0.4827D-01,0.4513D-01,0.4265D-01,0.4000D-01,0.3769D-01,0.3529D-01,
     &0.3322D-01,0.3117D-01,0.2920D-01,0.2737D-01,0.2561D-01,0.2402D-01,
     &0.2245D-01,0.2098D-01,0.1958D-01,0.1829D-01,0.1704D-01,0.1585D-01,
     &0.1476D-01,0.1370D-01,0.1270D-01,0.1178D-01,0.1090D-01,0.1007D-01,
     &0.9286D-02,0.8547D-02,0.7848D-02,0.7182D-02,0.6551D-02,0.5949D-02,
     &0.5372D-02,0.4823D-02,0.4298D-02,0.3794D-02,0.3314D-02,0.2852D-02,
     &0.2413D-02,0.1995D-02,0.1599D-02,0.1223D-02,0.8693D-03,0.5397D-03,
     &0.5052D-03,0.4716D-03,0.4388D-03,0.4068D-03,0.3757D-03,0.3454D-03,
     &0.3160D-03,0.2875D-03,0.2599D-03,0.2332D-03,0.2073D-03,0.1825D-03,
     &0.1587D-03,0.1359D-03,0.1142D-03,0.9370D-04,0.7445D-04,0.5655D-04,
     &0.4018D-04,0.2553D-04,0.1296D-04,0.3149D-05/
      DATA (XPV(I,5,1),I=1,100)/
     &0.7886D-02,0.7728D-02,0.7505D-02,0.7221D-02,0.6873D-02,0.6469D-02,
     &0.6022D-02,0.5723D-02,0.5585D-02,0.5398D-02,0.5164D-02,0.4885D-02,
     &0.4568D-02,0.4283D-02,0.4181D-02,0.4041D-02,0.3864D-02,0.3650D-02,
     &0.3408D-02,0.3225D-02,0.3131D-02,0.3005D-02,0.2850D-02,0.2668D-02,
     &0.2506D-02,0.2427D-02,0.2321D-02,0.2191D-02,0.2045D-02,0.1968D-02,
     &0.1880D-02,0.1774D-02,0.1672D-02,0.1604D-02,0.1519D-02,0.1435D-02,
     &0.1371D-02,0.1295D-02,0.1236D-02,0.1172D-02,0.1118D-02,0.1062D-02,
     &0.1015D-02,0.9690D-03,0.9257D-03,0.8867D-03,0.8503D-03,0.8197D-03,
     &0.7906D-03,0.7655D-03,0.7432D-03,0.7255D-03,0.7107D-03,0.6987D-03,
     &0.6911D-03,0.6864D-03,0.6850D-03,0.6876D-03,0.6934D-03,0.7025D-03,
     &0.7147D-03,0.7300D-03,0.7482D-03,0.7692D-03,0.7926D-03,0.8187D-03,
     &0.8465D-03,0.8768D-03,0.9089D-03,0.9431D-03,0.9801D-03,0.1020D-02,
     &0.1065D-02,0.1116D-02,0.1177D-02,0.1250D-02,0.1336D-02,0.1431D-02,
     &0.1441D-02,0.1451D-02,0.1460D-02,0.1468D-02,0.1476D-02,0.1483D-02,
     &0.1489D-02,0.1494D-02,0.1497D-02,0.1499D-02,0.1499D-02,0.1497D-02,
     &0.1492D-02,0.1483D-02,0.1471D-02,0.1454D-02,0.1430D-02,0.1398D-02,
     &0.1354D-02,0.1291D-02,0.1195D-02,0.1022D-02/
      DATA (XPV(I,5,2),I=1,100)/
     &0.9523D-02,0.9362D-02,0.9127D-02,0.8821D-02,0.8442D-02,0.7997D-02,
     &0.7501D-02,0.7174D-02,0.7029D-02,0.6828D-02,0.6569D-02,0.6258D-02,
     &0.5901D-02,0.5579D-02,0.5475D-02,0.5323D-02,0.5125D-02,0.4884D-02,
     &0.4606D-02,0.4399D-02,0.4301D-02,0.4162D-02,0.3986D-02,0.3776D-02,
     &0.3590D-02,0.3508D-02,0.3391D-02,0.3242D-02,0.3073D-02,0.2992D-02,
     &0.2897D-02,0.2777D-02,0.2663D-02,0.2592D-02,0.2499D-02,0.2408D-02,
     &0.2344D-02,0.2263D-02,0.2207D-02,0.2144D-02,0.2095D-02,0.2043D-02,
     &0.2005D-02,0.1970D-02,0.1939D-02,0.1917D-02,0.1898D-02,0.1891D-02,
     &0.1887D-02,0.1891D-02,0.1901D-02,0.1921D-02,0.1948D-02,0.1981D-02,
     &0.2025D-02,0.2076D-02,0.2134D-02,0.2204D-02,0.2281D-02,0.2367D-02,
     &0.2463D-02,0.2566D-02,0.2678D-02,0.2798D-02,0.2925D-02,0.3060D-02,
     &0.3199D-02,0.3347D-02,0.3500D-02,0.3659D-02,0.3827D-02,0.4007D-02,
     &0.4203D-02,0.4424D-02,0.4679D-02,0.4981D-02,0.5336D-02,0.5723D-02,
     &0.5764D-02,0.5803D-02,0.5840D-02,0.5875D-02,0.5906D-02,0.5934D-02,
     &0.5959D-02,0.5978D-02,0.5992D-02,0.6000D-02,0.6000D-02,0.5991D-02,
     &0.5971D-02,0.5938D-02,0.5890D-02,0.5821D-02,0.5726D-02,0.5597D-02,
     &0.5419D-02,0.5166D-02,0.4781D-02,0.4089D-02/
      DATA (XPV(I,5,3),I=1,100)/
     &0.7505D-02,0.7347D-02,0.7127D-02,0.6848D-02,0.6508D-02,0.6113D-02,
     &0.5677D-02,0.5385D-02,0.5248D-02,0.5065D-02,0.4837D-02,0.4566D-02,
     &0.4259D-02,0.3982D-02,0.3881D-02,0.3744D-02,0.3571D-02,0.3365D-02,
     &0.3131D-02,0.2953D-02,0.2861D-02,0.2738D-02,0.2589D-02,0.2414D-02,
     &0.2257D-02,0.2179D-02,0.2077D-02,0.1952D-02,0.1812D-02,0.1736D-02,
     &0.1651D-02,0.1549D-02,0.1451D-02,0.1384D-02,0.1302D-02,0.1222D-02,
     &0.1159D-02,0.1086D-02,0.1028D-02,0.9666D-03,0.9136D-03,0.8587D-03,
     &0.8123D-03,0.7666D-03,0.7236D-03,0.6846D-03,0.6479D-03,0.6163D-03,
     &0.5861D-03,0.5595D-03,0.5354D-03,0.5152D-03,0.4975D-03,0.4824D-03,
     &0.4710D-03,0.4620D-03,0.4558D-03,0.4530D-03,0.4527D-03,0.4552D-03,
     &0.4601D-03,0.4675D-03,0.4771D-03,0.4889D-03,0.5026D-03,0.5181D-03,
     &0.5351D-03,0.5540D-03,0.5746D-03,0.5972D-03,0.6228D-03,0.6525D-03,
     &0.6882D-03,0.7329D-03,0.7908D-03,0.8669D-03,0.9668D-03,0.1092D-02,
     &0.1106D-02,0.1121D-02,0.1136D-02,0.1150D-02,0.1164D-02,0.1178D-02,
     &0.1191D-02,0.1203D-02,0.1214D-02,0.1225D-02,0.1234D-02,0.1242D-02,
     &0.1247D-02,0.1250D-02,0.1251D-02,0.1247D-02,0.1239D-02,0.1224D-02,
     &0.1199D-02,0.1159D-02,0.1093D-02,0.9633D-03/
      DATA (XPV(I,5,4),I=1,100)/
     &0.7997D-02,0.7838D-02,0.7615D-02,0.7329D-02,0.6980D-02,0.6573D-02,
     &0.6123D-02,0.5823D-02,0.5684D-02,0.5497D-02,0.5261D-02,0.4981D-02,
     &0.4662D-02,0.4375D-02,0.4274D-02,0.4134D-02,0.3955D-02,0.3741D-02,
     &0.3497D-02,0.3313D-02,0.3221D-02,0.3095D-02,0.2940D-02,0.2758D-02,
     &0.2596D-02,0.2518D-02,0.2414D-02,0.2285D-02,0.2140D-02,0.2065D-02,
     &0.1981D-02,0.1877D-02,0.1779D-02,0.1715D-02,0.1634D-02,0.1555D-02,
     &0.1497D-02,0.1427D-02,0.1376D-02,0.1320D-02,0.1276D-02,0.1229D-02,
     &0.1194D-02,0.1161D-02,0.1131D-02,0.1108D-02,0.1089D-02,0.1077D-02,
     &0.1069D-02,0.1067D-02,0.1070D-02,0.1080D-02,0.1095D-02,0.1116D-02,
     &0.1144D-02,0.1178D-02,0.1218D-02,0.1265D-02,0.1318D-02,0.1378D-02,
     &0.1444D-02,0.1516D-02,0.1594D-02,0.1677D-02,0.1764D-02,0.1858D-02,
     &0.1954D-02,0.2056D-02,0.2162D-02,0.2275D-02,0.2398D-02,0.2536D-02,
     &0.2696D-02,0.2890D-02,0.3134D-02,0.3450D-02,0.3859D-02,0.4365D-02,
     &0.4425D-02,0.4485D-02,0.4544D-02,0.4602D-02,0.4658D-02,0.4713D-02,
     &0.4765D-02,0.4815D-02,0.4861D-02,0.4903D-02,0.4940D-02,0.4970D-02,
     &0.4993D-02,0.5007D-02,0.5008D-02,0.4994D-02,0.4961D-02,0.4900D-02,
     &0.4801D-02,0.4642D-02,0.4373D-02,0.3853D-02/
      DATA (XPV(I,6,0),I=1,100)/
     &0.4823D+00,0.4713D+00,0.4562D+00,0.4371D+00,0.4141D+00,0.3874D+00,
     &0.3580D+00,0.3381D+00,0.3284D+00,0.3157D+00,0.3000D+00,0.2816D+00,
     &0.2609D+00,0.2422D+00,0.2354D+00,0.2262D+00,0.2147D+00,0.2012D+00,
     &0.1860D+00,0.1744D+00,0.1685D+00,0.1606D+00,0.1511D+00,0.1401D+00,
     &0.1304D+00,0.1255D+00,0.1192D+00,0.1116D+00,0.1031D+00,0.9852D-01,
     &0.9345D-01,0.8740D-01,0.8162D-01,0.7769D-01,0.7289D-01,0.6822D-01,
     &0.6457D-01,0.6033D-01,0.5700D-01,0.5343D-01,0.5035D-01,0.4714D-01,
     &0.4439D-01,0.4166D-01,0.3905D-01,0.3663D-01,0.3429D-01,0.3219D-01,
     &0.3012D-01,0.2819D-01,0.2634D-01,0.2464D-01,0.2300D-01,0.2142D-01,
     &0.1997D-01,0.1857D-01,0.1723D-01,0.1600D-01,0.1482D-01,0.1370D-01,
     &0.1263D-01,0.1162D-01,0.1065D-01,0.9734D-02,0.8858D-02,0.8020D-02,
     &0.7218D-02,0.6455D-02,0.5727D-02,0.5031D-02,0.4372D-02,0.3743D-02,
     &0.3148D-02,0.2587D-02,0.2059D-02,0.1563D-02,0.1101D-02,0.6756D-03,
     &0.6315D-03,0.5886D-03,0.5468D-03,0.5062D-03,0.4667D-03,0.4284D-03,
     &0.3913D-03,0.3553D-03,0.3206D-03,0.2871D-03,0.2547D-03,0.2238D-03,
     &0.1942D-03,0.1660D-03,0.1392D-03,0.1139D-03,0.9030D-04,0.6843D-04,
     &0.4849D-04,0.3074D-04,0.1557D-04,0.3784D-05/
      DATA (XPV(I,6,1),I=1,100)/
     &0.1205D-01,0.1178D-01,0.1142D-01,0.1096D-01,0.1041D-01,0.9763D-02,
     &0.9053D-02,0.8577D-02,0.8354D-02,0.8057D-02,0.7688D-02,0.7251D-02,
     &0.6756D-02,0.6310D-02,0.6149D-02,0.5929D-02,0.5654D-02,0.5325D-02,
     &0.4953D-02,0.4670D-02,0.4526D-02,0.4332D-02,0.4097D-02,0.3822D-02,
     &0.3577D-02,0.3456D-02,0.3297D-02,0.3102D-02,0.2885D-02,0.2769D-02,
     &0.2639D-02,0.2483D-02,0.2333D-02,0.2232D-02,0.2107D-02,0.1985D-02,
     &0.1891D-02,0.1781D-02,0.1696D-02,0.1604D-02,0.1526D-02,0.1445D-02,
     &0.1377D-02,0.1310D-02,0.1248D-02,0.1192D-02,0.1139D-02,0.1094D-02,
     &0.1052D-02,0.1015D-02,0.9816D-03,0.9544D-03,0.9311D-03,0.9114D-03,
     &0.8975D-03,0.8872D-03,0.8810D-03,0.8801D-03,0.8830D-03,0.8899D-03,
     &0.9007D-03,0.9151D-03,0.9330D-03,0.9541D-03,0.9781D-03,0.1005D-02,
     &0.1034D-02,0.1065D-02,0.1099D-02,0.1135D-02,0.1174D-02,0.1217D-02,
     &0.1266D-02,0.1323D-02,0.1392D-02,0.1478D-02,0.1581D-02,0.1696D-02,
     &0.1708D-02,0.1720D-02,0.1731D-02,0.1741D-02,0.1751D-02,0.1759D-02,
     &0.1766D-02,0.1772D-02,0.1776D-02,0.1778D-02,0.1778D-02,0.1775D-02,
     &0.1769D-02,0.1759D-02,0.1744D-02,0.1723D-02,0.1695D-02,0.1657D-02,
     &0.1604D-02,0.1530D-02,0.1417D-02,0.1218D-02/
      DATA (XPV(I,6,2),I=1,100)/
     &0.1365D-01,0.1339D-01,0.1302D-01,0.1254D-01,0.1195D-01,0.1127D-01,
     &0.1051D-01,0.1001D-01,0.9777D-02,0.9465D-02,0.9073D-02,0.8604D-02,
     &0.8069D-02,0.7589D-02,0.7425D-02,0.7195D-02,0.6900D-02,0.6544D-02,
     &0.6138D-02,0.5834D-02,0.5686D-02,0.5481D-02,0.5226D-02,0.4925D-02,
     &0.4658D-02,0.4536D-02,0.4367D-02,0.4157D-02,0.3918D-02,0.3801D-02,
     &0.3667D-02,0.3499D-02,0.3340D-02,0.3241D-02,0.3112D-02,0.2987D-02,
     &0.2897D-02,0.2787D-02,0.2709D-02,0.2624D-02,0.2557D-02,0.2487D-02,
     &0.2436D-02,0.2387D-02,0.2346D-02,0.2315D-02,0.2290D-02,0.2279D-02,
     &0.2273D-02,0.2277D-02,0.2289D-02,0.2313D-02,0.2346D-02,0.2387D-02,
     &0.2441D-02,0.2503D-02,0.2575D-02,0.2660D-02,0.2755D-02,0.2859D-02,
     &0.2974D-02,0.3099D-02,0.3232D-02,0.3374D-02,0.3523D-02,0.3680D-02,
     &0.3841D-02,0.4010D-02,0.4183D-02,0.4363D-02,0.4552D-02,0.4754D-02,
     &0.4976D-02,0.5229D-02,0.5526D-02,0.5885D-02,0.6313D-02,0.6782D-02,
     &0.6832D-02,0.6879D-02,0.6924D-02,0.6966D-02,0.7004D-02,0.7038D-02,
     &0.7067D-02,0.7091D-02,0.7108D-02,0.7117D-02,0.7116D-02,0.7105D-02,
     &0.7081D-02,0.7041D-02,0.6982D-02,0.6899D-02,0.6786D-02,0.6631D-02,
     &0.6421D-02,0.6123D-02,0.5672D-02,0.4871D-02/
      DATA (XPV(I,6,3),I=1,100)/
     &0.1167D-01,0.1141D-01,0.1105D-01,0.1060D-01,0.1005D-01,0.9414D-02,
     &0.8715D-02,0.8245D-02,0.8024D-02,0.7730D-02,0.7367D-02,0.6937D-02,
     &0.6451D-02,0.6013D-02,0.5853D-02,0.5637D-02,0.5366D-02,0.5044D-02,
     &0.4680D-02,0.4403D-02,0.4259D-02,0.4069D-02,0.3839D-02,0.3571D-02,
     &0.3331D-02,0.3212D-02,0.3055D-02,0.2866D-02,0.2654D-02,0.2540D-02,
     &0.2413D-02,0.2260D-02,0.2114D-02,0.2014D-02,0.1892D-02,0.1773D-02,
     &0.1680D-02,0.1572D-02,0.1488D-02,0.1398D-02,0.1320D-02,0.1240D-02,
     &0.1173D-02,0.1106D-02,0.1044D-02,0.9874D-03,0.9342D-03,0.8881D-03,
     &0.8442D-03,0.8052D-03,0.7698D-03,0.7399D-03,0.7134D-03,0.6903D-03,
     &0.6722D-03,0.6574D-03,0.6463D-03,0.6397D-03,0.6365D-03,0.6368D-03,
     &0.6405D-03,0.6473D-03,0.6570D-03,0.6695D-03,0.6844D-03,0.7019D-03,
     &0.7213D-03,0.7431D-03,0.7673D-03,0.7943D-03,0.8253D-03,0.8617D-03,
     &0.9063D-03,0.9627D-03,0.1036D-02,0.1133D-02,0.1259D-02,0.1412D-02,
     &0.1430D-02,0.1448D-02,0.1465D-02,0.1482D-02,0.1499D-02,0.1514D-02,
     &0.1529D-02,0.1543D-02,0.1556D-02,0.1567D-02,0.1576D-02,0.1583D-02,
     &0.1587D-02,0.1588D-02,0.1586D-02,0.1578D-02,0.1563D-02,0.1539D-02,
     &0.1504D-02,0.1448D-02,0.1358D-02,0.1189D-02/
      DATA (XPV(I,6,4),I=1,100)/
     &0.1216D-01,0.1189D-01,0.1153D-01,0.1107D-01,0.1051D-01,0.9868D-02,
     &0.9154D-02,0.8677D-02,0.8454D-02,0.8157D-02,0.7787D-02,0.7349D-02,
     &0.6851D-02,0.6404D-02,0.6244D-02,0.6025D-02,0.5749D-02,0.5420D-02,
     &0.5047D-02,0.4764D-02,0.4621D-02,0.4429D-02,0.4195D-02,0.3920D-02,
     &0.3677D-02,0.3559D-02,0.3402D-02,0.3211D-02,0.2996D-02,0.2884D-02,
     &0.2759D-02,0.2608D-02,0.2463D-02,0.2369D-02,0.2251D-02,0.2138D-02,
     &0.2053D-02,0.1952D-02,0.1879D-02,0.1800D-02,0.1736D-02,0.1670D-02,
     &0.1619D-02,0.1572D-02,0.1531D-02,0.1498D-02,0.1470D-02,0.1454D-02,
     &0.1442D-02,0.1439D-02,0.1442D-02,0.1455D-02,0.1475D-02,0.1502D-02,
     &0.1539D-02,0.1584D-02,0.1637D-02,0.1699D-02,0.1769D-02,0.1847D-02,
     &0.1934D-02,0.2027D-02,0.2128D-02,0.2235D-02,0.2348D-02,0.2468D-02,
     &0.2591D-02,0.2721D-02,0.2857D-02,0.3001D-02,0.3158D-02,0.3333D-02,
     &0.3538D-02,0.3788D-02,0.4102D-02,0.4506D-02,0.5022D-02,0.5648D-02,
     &0.5720D-02,0.5792D-02,0.5862D-02,0.5931D-02,0.5997D-02,0.6060D-02,
     &0.6120D-02,0.6176D-02,0.6226D-02,0.6271D-02,0.6308D-02,0.6337D-02,
     &0.6354D-02,0.6359D-02,0.6348D-02,0.6316D-02,0.6257D-02,0.6163D-02,
     &0.6019D-02,0.5797D-02,0.5436D-02,0.4755D-02/
      DATA (XPV(I,7,0),I=1,100)/
     &0.6367D+00,0.6216D+00,0.6010D+00,0.5752D+00,0.5440D+00,0.5081D+00,
     &0.4686D+00,0.4418D+00,0.4287D+00,0.4116D+00,0.3907D+00,0.3662D+00,
     &0.3385D+00,0.3137D+00,0.3045D+00,0.2923D+00,0.2772D+00,0.2594D+00,
     &0.2393D+00,0.2241D+00,0.2163D+00,0.2060D+00,0.1936D+00,0.1792D+00,
     &0.1665D+00,0.1602D+00,0.1520D+00,0.1421D+00,0.1311D+00,0.1252D+00,
     &0.1187D+00,0.1109D+00,0.1035D+00,0.9842D-01,0.9228D-01,0.8630D-01,
     &0.8164D-01,0.7624D-01,0.7200D-01,0.6747D-01,0.6355D-01,0.5948D-01,
     &0.5601D-01,0.5255D-01,0.4926D-01,0.4620D-01,0.4326D-01,0.4061D-01,
     &0.3801D-01,0.3557D-01,0.3324D-01,0.3109D-01,0.2903D-01,0.2705D-01,
     &0.2521D-01,0.2344D-01,0.2175D-01,0.2018D-01,0.1868D-01,0.1725D-01,
     &0.1589D-01,0.1460D-01,0.1337D-01,0.1219D-01,0.1107D-01,0.9999D-02,
     &0.8975D-02,0.8003D-02,0.7079D-02,0.6199D-02,0.5369D-02,0.4581D-02,
     &0.3839D-02,0.3144D-02,0.2492D-02,0.1883D-02,0.1320D-02,0.8054D-03,
     &0.7523D-03,0.7006D-03,0.6504D-03,0.6016D-03,0.5543D-03,0.5084D-03,
     &0.4640D-03,0.4210D-03,0.3796D-03,0.3397D-03,0.3011D-03,0.2644D-03,
     &0.2292D-03,0.1957D-03,0.1640D-03,0.1342D-03,0.1063D-03,0.8046D-04,
     &0.5699D-04,0.3611D-04,0.1829D-04,0.4453D-05/
      DATA (XPV(I,7,1),I=1,100)/
     &0.1667D-01,0.1629D-01,0.1577D-01,0.1511D-01,0.1431D-01,0.1340D-01,
     &0.1239D-01,0.1171D-01,0.1139D-01,0.1097D-01,0.1045D-01,0.9835D-02,
     &0.9139D-02,0.8514D-02,0.8286D-02,0.7979D-02,0.7594D-02,0.7137D-02,
     &0.6621D-02,0.6230D-02,0.6029D-02,0.5762D-02,0.5438D-02,0.5061D-02,
     &0.4726D-02,0.4560D-02,0.4342D-02,0.4078D-02,0.3784D-02,0.3626D-02,
     &0.3451D-02,0.3240D-02,0.3038D-02,0.2902D-02,0.2735D-02,0.2572D-02,
     &0.2446D-02,0.2299D-02,0.2185D-02,0.2064D-02,0.1960D-02,0.1852D-02,
     &0.1762D-02,0.1673D-02,0.1591D-02,0.1516D-02,0.1446D-02,0.1386D-02,
     &0.1329D-02,0.1278D-02,0.1233D-02,0.1195D-02,0.1162D-02,0.1134D-02,
     &0.1113D-02,0.1096D-02,0.1084D-02,0.1078D-02,0.1077D-02,0.1081D-02,
     &0.1090D-02,0.1103D-02,0.1119D-02,0.1140D-02,0.1164D-02,0.1191D-02,
     &0.1220D-02,0.1253D-02,0.1288D-02,0.1325D-02,0.1367D-02,0.1413D-02,
     &0.1466D-02,0.1530D-02,0.1609D-02,0.1708D-02,0.1830D-02,0.1967D-02,
     &0.1981D-02,0.1995D-02,0.2008D-02,0.2021D-02,0.2032D-02,0.2042D-02,
     &0.2051D-02,0.2058D-02,0.2063D-02,0.2066D-02,0.2066D-02,0.2063D-02,
     &0.2057D-02,0.2045D-02,0.2029D-02,0.2005D-02,0.1973D-02,0.1929D-02,
     &0.1869D-02,0.1784D-02,0.1655D-02,0.1427D-02/
      DATA (XPV(I,7,2),I=1,100)/
     &0.1825D-01,0.1787D-01,0.1734D-01,0.1666D-01,0.1584D-01,0.1488D-01,
     &0.1382D-01,0.1312D-01,0.1280D-01,0.1236D-01,0.1182D-01,0.1117D-01,
     &0.1044D-01,0.9780D-02,0.9550D-02,0.9233D-02,0.8830D-02,0.8348D-02,
     &0.7799D-02,0.7387D-02,0.7184D-02,0.6906D-02,0.6565D-02,0.6163D-02,
     &0.5808D-02,0.5642D-02,0.5418D-02,0.5140D-02,0.4827D-02,0.4670D-02,
     &0.4493D-02,0.4274D-02,0.4067D-02,0.3936D-02,0.3769D-02,0.3607D-02,
     &0.3489D-02,0.3347D-02,0.3246D-02,0.3136D-02,0.3050D-02,0.2959D-02,
     &0.2893D-02,0.2830D-02,0.2777D-02,0.2736D-02,0.2703D-02,0.2687D-02,
     &0.2678D-02,0.2680D-02,0.2693D-02,0.2720D-02,0.2757D-02,0.2805D-02,
     &0.2867D-02,0.2940D-02,0.3024D-02,0.3123D-02,0.3233D-02,0.3355D-02,
     &0.3489D-02,0.3632D-02,0.3785D-02,0.3948D-02,0.4118D-02,0.4297D-02,
     &0.4479D-02,0.4668D-02,0.4863D-02,0.5063D-02,0.5274D-02,0.5499D-02,
     &0.5750D-02,0.6038D-02,0.6381D-02,0.6800D-02,0.7306D-02,0.7864D-02,
     &0.7924D-02,0.7980D-02,0.8034D-02,0.8085D-02,0.8131D-02,0.8172D-02,
     &0.8208D-02,0.8236D-02,0.8258D-02,0.8270D-02,0.8271D-02,0.8259D-02,
     &0.8233D-02,0.8188D-02,0.8122D-02,0.8027D-02,0.7897D-02,0.7721D-02,
     &0.7480D-02,0.7139D-02,0.6624D-02,0.5709D-02/
      DATA (XPV(I,7,3),I=1,100)/
     &0.1630D-01,0.1592D-01,0.1540D-01,0.1475D-01,0.1396D-01,0.1305D-01,
     &0.1205D-01,0.1138D-01,0.1107D-01,0.1065D-01,0.1013D-01,0.9526D-02,
     &0.8839D-02,0.8222D-02,0.7995D-02,0.7690D-02,0.7310D-02,0.6860D-02,
     &0.6352D-02,0.5966D-02,0.5766D-02,0.5502D-02,0.5183D-02,0.4813D-02,
     &0.4483D-02,0.4318D-02,0.4103D-02,0.3844D-02,0.3555D-02,0.3399D-02,
     &0.3225D-02,0.3018D-02,0.2820D-02,0.2685D-02,0.2521D-02,0.2360D-02,
     &0.2235D-02,0.2091D-02,0.1978D-02,0.1857D-02,0.1754D-02,0.1647D-02,
     &0.1557D-02,0.1468D-02,0.1385D-02,0.1310D-02,0.1239D-02,0.1177D-02,
     &0.1118D-02,0.1066D-02,0.1018D-02,0.9774D-03,0.9411D-03,0.9091D-03,
     &0.8835D-03,0.8619D-03,0.8450D-03,0.8338D-03,0.8268D-03,0.8242D-03,
     &0.8257D-03,0.8312D-03,0.8403D-03,0.8529D-03,0.8686D-03,0.8875D-03,
     &0.9087D-03,0.9331D-03,0.9605D-03,0.9915D-03,0.1028D-02,0.1070D-02,
     &0.1124D-02,0.1191D-02,0.1279D-02,0.1395D-02,0.1545D-02,0.1725D-02,
     &0.1746D-02,0.1766D-02,0.1786D-02,0.1805D-02,0.1823D-02,0.1841D-02,
     &0.1857D-02,0.1872D-02,0.1886D-02,0.1897D-02,0.1907D-02,0.1913D-02,
     &0.1916D-02,0.1915D-02,0.1909D-02,0.1897D-02,0.1877D-02,0.1846D-02,
     &0.1799D-02,0.1729D-02,0.1618D-02,0.1411D-02/
      DATA (XPV(I,7,4),I=1,100)/
     &0.1678D-01,0.1640D-01,0.1587D-01,0.1522D-01,0.1442D-01,0.1350D-01,
     &0.1249D-01,0.1181D-01,0.1149D-01,0.1107D-01,0.1055D-01,0.9935D-02,
     &0.9238D-02,0.8611D-02,0.8385D-02,0.8078D-02,0.7694D-02,0.7237D-02,
     &0.6721D-02,0.6331D-02,0.6132D-02,0.5867D-02,0.5545D-02,0.5170D-02,
     &0.4837D-02,0.4676D-02,0.4462D-02,0.4202D-02,0.3912D-02,0.3761D-02,
     &0.3592D-02,0.3388D-02,0.3194D-02,0.3068D-02,0.2911D-02,0.2759D-02,
     &0.2646D-02,0.2513D-02,0.2415D-02,0.2310D-02,0.2226D-02,0.2139D-02,
     &0.2072D-02,0.2010D-02,0.1955D-02,0.1911D-02,0.1875D-02,0.1852D-02,
     &0.1836D-02,0.1830D-02,0.1833D-02,0.1848D-02,0.1872D-02,0.1905D-02,
     &0.1950D-02,0.2004D-02,0.2069D-02,0.2145D-02,0.2231D-02,0.2327D-02,
     &0.2432D-02,0.2547D-02,0.2669D-02,0.2800D-02,0.2937D-02,0.3082D-02,
     &0.3232D-02,0.3389D-02,0.3553D-02,0.3727D-02,0.3917D-02,0.4130D-02,
     &0.4378D-02,0.4681D-02,0.5061D-02,0.5547D-02,0.6163D-02,0.6897D-02,
     &0.6981D-02,0.7063D-02,0.7144D-02,0.7221D-02,0.7296D-02,0.7367D-02,
     &0.7433D-02,0.7494D-02,0.7548D-02,0.7595D-02,0.7632D-02,0.7658D-02,
     &0.7671D-02,0.7667D-02,0.7644D-02,0.7595D-02,0.7513D-02,0.7388D-02,
     &0.7203D-02,0.6923D-02,0.6476D-02,0.5646D-02/

C..fetching pdfs
      DO  5 IP=-6,6
        XPDF(IP)=ZEROD
 5    CONTINUE
      DO 2 I=1,IX
        ENT(I)=LOG10(XT(I))
  2   CONTINUE
      NA(1)=IX
      NA(2)=IQ
      DO 3 I=1,IQ
        ENT(IX+I)=LOG10(Q2T(I))
   3  CONTINUE
      ARG(1)=LOG10(X)
      ARG(2)=LOG10(Q2)
C..various flavours (u-->2,d-->1)
      XPDF(0)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,0))
      XPDF(1)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,1))
      XPDF(2)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,2))
      XPDF(3)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,3))
      XPDF(4)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,4))
      DO 21 JF=1,4
        XPDF(-JF)=XPDF(JF)
 21   CONTINUE

      END


 
 


CDECK  ID>, PHO_PMASS
      DOUBLE PRECISION FUNCTION PHO_PMASS(ID,mode)
C***********************************************************************
C
C     particle mass
C
C     input:  mode  -1   initialization
C                    0   ID gives CPC particle number
C                    1   ID gives PDG particle number,
C                        (for quarks current masses are returned)
C                    2   ID gives position of particle in /POEVT1/
C                    3   ID gives PDG parton number,
C                        (for quarks constituent masses are returned)
C
C     output: average particle mass (in GeV)
C
C***********************************************************************

      IMPLICIT NONE
      SAVE

      INTEGER ID,mode,MSTJ24

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

C  particle ID translation table
      integer         ID_pdg_list,ID_list,ID_pdg_max
      CHARACTER*12    name_list
      COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
     &                ID_pdg_max

C  general particle data
      DOUBLE PRECISION xm_list,tau_list,gam_list,
     &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
     &  xm_bb82_list,xm_bb102_list
      INTEGER          ich3_list,iba3_list,iq_list,
     &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
      COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
     &  xm_psm2_list(6,6),xm_vem2_list(6,6),
     &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
     &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
     &  ich3_list(300),iba3_list(300),iq_list(3,300),
     &  id_psm_list(6,6),id_vem_list(6,6),
     &  id_b8_list(6,6,6),id_b10_list(6,6,6)

      INTEGER MSTU,MSTJ
      DOUBLE PRECISION PARU,PARJ
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      SAVE /PYDAT1/

C  external functions
      INTEGER  IPHO_PDG2ID,IPHO_ID2PDG
      EXTERNAL IPHO_PDG2ID,IPHO_ID2PDG

      DOUBLE PRECISION PYMASS

C  local variables
      INTEGER i,IDpdg

      PHO_PMASS = 0.D0

      if(mode.eq.0) then
        i = ID
      else if(mode.eq.1) then
        i = IPHO_PDG2ID(ID)
        if(i.eq.0) return
      else if(mode.eq.2) then
        if(ISTHEP(ID).gt.11) return
        i     = IMPART(ID)
        IDpdg = IDHEP(ID)
        IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
          PHO_PMASS = PHEP(5,ID)
          return
        endif
      else if(mode.eq.3) then
        i = abs(ID)
        if((i.gt.0).and.(i.le.6)) then
          PHO_PMASS = PARMDL(150+i)
          return
        else
          i = IPHO_PDG2ID(ID)
          if(i.eq.0) return
        endif
      else if(mode.eq.-1) then
C  initialization: take masses for quarks and di-quarks from JETSET
        MSTJ24 = MSTJ(24)
        MSTJ(24) = 0
        do i=1,22
          IDpdg = IPHO_ID2PDG(i)

          xm_list(i) = PYMASS(IDpdg)

        enddo
        MSTJ(24) = MSTJ24
        return
      else
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1x,a,2i4)')
     &    'PHO_PMASS: invalid arguments (ID,mode): ',ID,mode
        return
      endif

      if((i.eq.0).or.(abs(i).gt.ID_pdg_max)) then
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1x,a,2i8)')
     &    'PHO_PMASS: invalid arguments (ID,mode): ',ID,mode
        PHO_PMASS = 1.D0/dble(i)
        return
      endif

      PHO_PMASS = xm_list(abs(i))

      END


 
 


CDECK  ID>, pho_pname
      CHARACTER*15 FUNCTION PHO_PNAME(ID,mode)
C***********************************************************************
C
C     returns particle name for given ID number
C
C     input:  ID      particle ID number
C             mode    0:   ID treated as compressed particle code
C                     1:   ID treated as PDG number
C
C***********************************************************************

      IMPLICIT NONE
      SAVE

      INTEGER ID,mode

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

C  particle ID translation table
      INTEGER         ID_pdg_list,ID_list,ID_pdg_max
      CHARACTER*12    name_list
      COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
     &                ID_pdg_max

C  general particle data
      DOUBLE PRECISION xm_list,tau_list,gam_list,
     &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
     &  xm_bb82_list,xm_bb102_list
      INTEGER          ich3_list,iba3_list,iq_list,
     &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
      COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
     &  xm_psm2_list(6,6),xm_vem2_list(6,6),
     &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
     &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
     &  ich3_list(300),iba3_list(300),iq_list(3,300),
     &  id_psm_list(6,6),id_vem_list(6,6),
     &  id_b8_list(6,6,6),id_b10_list(6,6,6)

C  external functions
      INTEGER  IPHO_ID2PDG,IPHO_PDG2ID
      EXTERNAL IPHO_ID2PDG,IPHO_PDG2ID

C  local variables
      INTEGER  IDpdg,i,ii,k,l,ichar,i_anti
      CHARACTER*15 name

      PHO_PNAME = '(?????????????)'

      if(mode.eq.0) then
        i = ID
        IDpdg = IPHO_ID2PDG(ID)
        if(IDpdg.eq.0) return
      else if(mode.eq.1) then
        i = IPHO_PDG2ID(ID)
        if(i.eq.0) return
        IDpdg = ID
      else if(mode.eq.2) then
        if(ISTHEP(ID).gt.11) then
          if(ISTHEP(ID).eq.20) then
            pho_pname = 'hard ini. part.'
          else if(ISTHEP(ID).eq.21) then
            pho_pname = 'hard fin. part.'
          else if(ISTHEP(ID).eq.25) then
            pho_pname = 'hard scattering'
          else if(ISTHEP(ID).eq.30) then
            pho_pname = 'diff. diss.    '
          else if(ISTHEP(ID).eq.35) then
            pho_pname = 'elastic scatt. '
          else if(ISTHEP(ID).eq.40) then
            pho_pname = 'central scatt. '
          endif
          return
        endif
        IDpdg = IDHEP(ID)
        i     = IMPART(ID)
      else
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1x,a,2i4)')
     &    'PHO_PNAME: invalid arguments (ID,mode): ',ID,mode
        return
      endif

      ii = abs(i)
      if((ii.eq.0).or.(ii.gt.ID_pdg_max)) return

      name = name_list(ii)
      ichar = ich3_list(ii)*sign(1,i)
      if(mod(ichar,3).ne.0) then
        ichar = 0
      else
        ichar = ichar/3
      endif

C  find position of first blank character
      k = 1
 100  continue
        k = k+1
      if(name(k:k).ne.' ') goto 100

C  append anti-particle sign
      if(i.lt.0) then
        i_anti = 0
        do l=1,3
          i_anti = i_anti+iq_list(l,ii)
        enddo
        if(iba3_list(ii).ne.0) then
          name(k:k) = '~'
          k = K+1
        else if(((i_anti.ne.0).and.(ichar.eq.0))
     &          .or.(IDpdg.eq.-12)
     &          .or.(IDpdg.eq.-14)
     &          .or.(IDpdg.eq.-16)) then
          name(k:k) = '~'
          k = K+1
        endif
      endif

C  append charge sign
      if(ichar.eq.-2) then
        name(k:k+1) = '--'
      else if(ichar.eq.-1) then
        name(k:k) = '-'
      else if(ichar.eq.1) then
        name(k:k) = '+'
      else if(ichar.eq.2) then
        name(k:k+1) = '++'
      endif

      PHO_PNAME = name

      END


      SUBROUTINE PHO_POLINT4F (XA,YA,X,Y)

C  The POLINT4 routine is based on the POLINT routine from "Numerical Recipes",
C  but assuming N=4, and ignoring the error estimation.
C  suggested by Z. Sullivan.
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      SAVE
      DIMENSION XA(*),YA(*)

      H1=XA(1)-X
      H2=XA(2)-X
      H3=XA(3)-X
      H4=XA(4)-X

      W=YA(2)-YA(1)
      DEN=W/(H1-H2)
      D1=H2*DEN
      C1=H1*DEN

      W=YA(3)-YA(2)
      DEN=W/(H2-H3)
      D2=H3*DEN
      C2=H2*DEN

      W=YA(4)-YA(3)
      DEN=W/(H3-H4)
      D3=H4*DEN
      C3=H3*DEN

      W=C2-D1
      DEN=W/(H1-H3)
      CD1=H3*DEN
      CC1=H1*DEN

      W=C3-D2
      DEN=W/(H2-H4)
      CD2=H4*DEN
      CC2=H2*DEN

      W=CC2-CD1
      DEN=W/(H1-H4)
      DD1=H4*DEN
      DC1=H1*DEN

      If((H3+H4).lt.0D0) Then
         Y=YA(4)+D3+CD2+DD1
      Elseif((H2+H3).lt.0D0) Then
         Y=YA(3)+D2+CD1+DC1
      Elseif((H1+H2).lt.0D0) Then
         Y=YA(2)+C2+CD1+DC1
      ELSE
         Y=YA(1)+C1+CC1+DC1
      ENDIF

      RETURN
C               *************************
      END


 
 


CDECK  ID>, PHO_POMCOR
      SUBROUTINE PHO_POMCOR(IREJ)
C********************************************************************
C
C    join quarks to gluons in case of too small masses
C
C    input:              /POEVT1/
C                        /POSTRG/
C                IREJ    -1          initialization
C                        -2          output of statistics
C
C    output:             /POEVT1/
C                        /POSTRG/
C                IREJ    0  successful
C                        1  failure
C
C
C********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( EPS    =  1.D-10 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

C  color string configurations including collapsed strings and hadrons
      INTEGER MSTR
      PARAMETER (MSTR=2000)
      INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
      COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
     &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
     &                NNCH(MSTR),IBHAD(MSTR),ISTR

      DIMENSION PJ(4)

      IF(IREJ.EQ.-1) THEN
        ICTOT = 0
        ICCOR = 0
        RETURN
      ELSE IF(IREJ.EQ.-2) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,2I8)')
     &    'PHO_POMCOR: total/joined strings',ICTOT,ICCOR
        RETURN
      ENDIF
C
      IREJ = 0
C
      NITER = 100
      ITER = 0
      ICTOT = ICTOT+ISTR
      IF(ISWMDL(25).LE.0) RETURN
C  debug string entries
      IF(IDEB(83).GE.25) CALL PHO_PRSTRG
C
C50   CONTINUE
      ITER = ITER+1
      IF(ITER.GE.NITER) THEN
        IREJ = 1
        IF(IDEB(83).GE.2) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,2I5)') 'PHO_POMCOR: rejection',ITER,NITER
          IF(IDEB(83).GE.10) CALL PHO_PREVNT(0)
        ENDIF
        RETURN
      ENDIF
C
C  check mass limits
      ISTRO = ISTR
      DO 100 I=1,ISTRO
        IF(NCODE(I).LT.0) GOTO 99
        J1 = NPOS(1,I)
        NRPOM = IPHIST(2,J1)
        IF(NRPOM.GE.100) GOTO 99
        CMASS0 = PHEP(5,J1)
C  get masses
        IF(NCODE(I).EQ.3) THEN
          CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
        ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
          CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
     &                AM1,AM2,AM3,AM4,IP1,IP2)
        ELSE IF(NCODE(I).EQ.5) THEN
          CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
     &                AM1,AM2)
          AM3 = 0.D0
          AM4 = 0.D0
          IP1 = 0
          IP2 = 0
        ELSE IF(NCODE(I).EQ.7) THEN
          GOTO 99
        ELSE IF(NCODE(I).LT.0) THEN
          GOTO 99
        ELSE
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/,1X,A,2I5)') 'PHO_POMCOR:ERROR:STRING NO,NCODE ',
     &                            J1,NCODE(I)
          CALL PHO_ABORT
        ENDIF
        IF(IDEB(83).GE.5 .AND. LPRI.GT.4)
     &    WRITE(LO,'(1X,A,/3X,2I4,5E11.3,2I5)')
     &      'PHO_POMCOR: STRING,POM,CHMASS,AM1,AM2,AM3,AM4,IP1,IP2',
     &      I,NRPOM,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
C  select masses to correct
        IF(CMASS0.LT.MAX(AM2,AM4)) THEN
          DO 200 K=1,ISTRO
            IF((K.NE.I).AND.(NCODE(K).GE.0)) THEN
              J2 = NPOS(1,K)
C  join quarks to gluon
              IF(NRPOM.EQ.IPHIST(2,J2)) THEN
C  flavour check
                IFL1 = 0
                IFL2 = 0
                PROB1 = 0.D0
                PROB2 = 0.D0
                KK1 = NPOS(2,I)
                KK2 = NPOS(2,K)
                IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
                  CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
     &                   -(PHEP(1,KK1)+PHEP(1,KK2))**2
     &                   -(PHEP(2,KK1)+PHEP(2,KK2))**2
     &                   -(PHEP(2,KK1)+PHEP(2,KK2))**2
                  IFL1 = ABS(IDHEP(KK1))
                  IF(IFL1.GT.2) THEN
                    PROB1 = 0.1D0/MAX(CMASS,EPS)
                  ELSE
                    PROB1 = 0.9D0/MAX(CMASS,EPS)
                  ENDIF
                ENDIF
                KK1 = ABS(NPOS(3,I))
                KK2 = ABS(NPOS(3,K))
                IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
                  CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
     &                   -(PHEP(1,KK1)+PHEP(1,KK2))**2
     &                   -(PHEP(2,KK1)+PHEP(2,KK2))**2
     &                   -(PHEP(2,KK1)+PHEP(2,KK2))**2
                  IFL2 = ABS(IDHEP(KK1))
                  IF(IFL2.GT.2) THEN
                    PROB2 = 0.1D0/MAX(CMASS,EPS)
                  ELSE
                    PROB2 = 0.9D0/MAX(CMASS,EPS)
                  ENDIF
                ENDIF
                IF(IFL1+IFL2.EQ.0) GOTO 99
C  fusion possible
                ICCOR = ICCOR+1
                IF((DT_RNDM(CMASS)*(PROB1+PROB2)).LT.PROB1) THEN
                  JJ = 2
                  JE = 3
                ELSE
                  JJ = 3
                  JE = 2
                ENDIF
                KK1 = ABS(NPOS(JJ,I))
                KK2 = ABS(NPOS(JJ,K))
                I1 = ABS(NPOS(JE,I))
                I2 = KK1
                IS = SIGN(1,I2-I1)
                I2 = I2 - IS
                K1 = KK2
                K2 = ABS(NPOS(JE,K))
                KS = SIGN(1,K2-K1)
                K1 = K1 + KS
                IP1 = NHEP+1
C  copy mother partons of string I
                DO 300 II=I1,I2,IS
                  CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
     &              PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
     &              ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
 300            CONTINUE
C  register gluon
                DO 350 II=1,4
                  PJ(II) = PHEP(II,KK1)+PHEP(II,KK2)
 350            CONTINUE
                CALL PHO_REGPAR(-1,21,0,J1,J2,PJ(1),PJ(2),PJ(3),PJ(4),
     &            I,IPHIST(2,KK2),ICOLOR(1,KK1),ICOLOR(1,KK2),IPOS,1)
C  copy mother partons of string K
                DO 400 II=K1,K2,KS
                  CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
     &              PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
     &              ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
 400            CONTINUE
C  create new string entry
                DO 450 II=1,4
                  PJ(II) = PHEP(II,J1)+PHEP(II,J2)
 450            CONTINUE
                IP2 = IPOS
                CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PJ(1),PJ(2),PJ(3),
     &            PJ(4),I,IPHIST(2,J1),ICOLOR(1,J1)+ICOLOR(1,J2),
     &            ICOLOR(2,J1)+ICOLOR(2,J2),IPOS,1)
C  delete string K in /POSTRG/
                NCODE(K) = -999
C  update string I in /POSTRG/
                NPOS(1,I) = IPOS
                NPOS(2,I) = IP1
                NPOS(3,I) = -IP2
C  calculate new CPC string codes
                CALL PHO_ID2STR(IDHEP(IP1),IDHEP(IP2),NCODE(I),IPAR1(I),
     &            IPAR2(I),IPAR3(I),IPAR4(I))
                GOTO 99
              ENDIF
            ENDIF
 200      CONTINUE
        ENDIF
 99     CONTINUE
 100  CONTINUE
      IF(IDEB(83).GE.20) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A)') 'PHO_POMCOR: after string recombination'
        IF(IDEB(83).GE.22) THEN
          CALL PHO_PRSTRG
          CALL PHO_PREVNT(0)
        ENDIF
      ENDIF

      END


 
 


CDECK  ID>, PHO_POMSCA
      SUBROUTINE PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,
     &                     MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
C**********************************************************************
C
C     parton orientated formulation of soft and hard inelastic events
C
C
C     input:    II        particle combiantion (1..4)
C               MSPOM     number of soft pomerons
C               MHPOM     number of semihard pomerons
C               MSREG     number of soft reggeons
C
C     output:   IVAL1,2   0 no valence quark engaged
C                         otherwise:  position of valence quark engaged
C                         neg.number: gluon connected to valence quark
C                                     by color flow
C               MSPAR1,2  number of realized soft partons
C               MHPAR1,2  number of realized hard partons
C               IREJ      1 failure
C                         0 success
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER (TINY   =  1.D-30 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  current beam selection
      INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN
      INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL
      DOUBLE PRECISION SQSGLOBMAX
      PARAMETER (MPARMAX=40)
      PARAMETER (MAXMAPPS=40)
      PARAMETER (IKNOWN=9)
      DIMENSION IPAVAIL(IKNOWN)
      DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/
      COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS),
     &           MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP

C  general process information
      INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
      COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)

C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
      INTEGER IDEQP,IDEQB,IHFLD,IHFLS
      DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
      COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
     &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)

C  event weights and generated cross section
      INTEGER IPOWGC,ISWCUT,IVWGHT
      DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
      COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
     &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)

C  hard cross sections and MC selection weights
      INTEGER Max_pro_2
      PARAMETER ( Max_pro_2 = 16 )
      INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
     &  MH_acc_1,MH_acc_2
      DOUBLE PRECISION HFAC, HWGX, HSIG, HDPT, HECM_LAST, 
     &   HQ2A_LAST, HQ2B_LAST
      COMMON /POHRCS/HFAC(-1:MAX_PRO_2, MPARMAX), 
     &   HWGX(-1:MAX_PRO_2, MPARMAX),
     &   HSIG(-1:MAX_PRO_2, MPARMAX), HDPT(-1:MAX_PRO_2, MPARMAX), 
     &   HECM_LAST, HQ2A_LAST, HQ2B_LAST, IHA_LAST, IHB_LAST, 
     &   MH_PRO_ON(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_TRIED(-1:MAX_PRO_2, 0:4, MPARMAX), 
     &   MH_ACC_1(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_ACC_2(-1:MAX_PRO_2, 0:4, MPARMAX) 

C  hard scattering parameters used for most recent hard interaction
      INTEGER NFbeta,NF
      DOUBLE PRECISION ALQCD2,BQCD
      COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF

C  data of c.m. system of Pomeron / Reggeon exchange
      INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
      DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
     &                 SIDP,CODP,SIFP,COFP
      COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
     &                SIDP,CODP,SIFP,COFP,NPOSP(2),
     &                IDPDG1,IDBAM1,IDPDG2,IDBAM2

C  obsolete cut-off information
      DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
      COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN

C  some hadron information, will be deleted in future versions
      INTEGER NFS
      DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
      COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS

C  data on most recent hard scattering
      INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
      DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
     &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
      COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
     &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
     &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
     &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC

C  light-cone x fractions and c.m. momenta of soft cut string ends
      INTEGER MAXSOF
      PARAMETER ( MAXSOF = 2000 )
      INTEGER IJSI2,IJSI1
      DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
      COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
     &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
     &                IJSI1(MAXSOF),IJSI2(MAXSOF)

C  hard scattering data
      INTEGER MSCAHD
      PARAMETER ( MSCAHD = 1000 )
      INTEGER LSCAHD,LSC1HD,LSIDX,
     &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
      DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
      COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
     &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
     &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
     &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
     &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
     &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
     &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)

C  table of particle indices for recursive PHOJET calls
      INTEGER MAXIPX
      PARAMETER ( MAXIPX = 500 )
      INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
      COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
     &                IPOIX1,IPOIX2,IPOIX3

C  internal rejection counters
      INTEGER NMXJ
      PARAMETER (NMXJ=60)
      CHARACTER*10 REJTIT
      INTEGER IFAIL
      COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)

      DIMENSION P1(4),P2(4),PD1(-6:6)

      IF (LPRI.GT.4 .AND. IDEB(24).GT.20)
     &WRITE(LO,'(1X,A,3I5)')
     &  'PHO_POMSCA: MSPOM,MHPOM,MSREG',MSPOM,MHPOM,MSREG

      ITRY  = 0
      NTRY  = 10
      IREJ  = 0
      INMAX = 10
      MHARD = MHPOM

C  phase space limitation (single hard valence-valence quark scattering)
      IF(MHPOM.GT.0) THEN
        Emin = 2.D0*PTWANT + 0.2D0
        IF(ECMP.LT.Emin) THEN
          IF (LPRI.GT.4 .AND. IDEB(24).GE.1)
     &    WRITE(LO,'(1X,A,1P,3E10.3)') 'PHO_POMSCA: ',
     &      'kin. rejection (1) (Ecm,Ptcut,Emin)',ECMP,PTWANT,Emin
          IREJ = 50
          IFAIL(6) = IFAIL(6) + 1
          RETURN
        ENDIF
      ENDIF

      SAS    = PARMDL(160+II)/ECMP
      SAH    = 2.D0*PTWANT/ECMP
      AS     = SAS**2
      AH     = SAH**2

C  save energy for leading particle effect
      XMAXP1 = 1.D0
      if(IHFLS(1).ne.0) XMAXP1 = 1.D0-PARMDL(165)*XPSUB
      XMAXP2 = 1.D0
      if(IHFLS(2).ne.0) XMAXP2 = 1.D0-PARMDL(165)*XTSUB

C
C  main loop to select hard and soft parton kinematics
C -----------------------------------------------------
      IFAIL(31) = IFAIL(31)+MHARD
 20   CONTINUE
        IREJ  = 0
        IHARD = 0
        LSC1HD = 0
        ITRY  = ITRY+1
        IF(ITRY.GT.1) IFAIL(5) = IFAIL(5)+1
        IF(ITRY.GE.NTRY) THEN
          IREJ = 1
          GOTO 450
        ENDIF
        LINE   = 0
        LSCAHD = 0
        IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
          XSS1   = MAX(0.D0,1.D0-XPSUB)
          XSS2   = MAX(0.D0,1.D0-XTSUB)
        ELSE
          XSS1   = 0.D0
          XSS2   = 0.D0
        ENDIF
 22     continue

C  partons needed to construct soft/hard interactions
        MSPAR1 = 2*MSPOM+MSREG+MHPOM
        MSPAR2 = MSPAR1
        MHPAR1 = MHPOM
        MHPAR2 = MHPOM

C  number of strings
        MSCHA = 2*MSPOM+MSREG
        MHCHA = 2*MHPOM

        KSOFT = MSCHA
        KHARD = MHCHA

C  check actual phase space limit
        XX = SAS*DBLE(MSCHA)+SAH*DBLE(MHCHA)/2.D0
        IF(XX.GE.1.D0) THEN
          IF (LPRI.GT.4 .AND. IDEB(24).GE.3)
     &    WRITE(LO,'(1X,2A,/1X,4I3,1P4E12.4)')
     &      'PHO_POMSCA: internal kin. rejection ',
     &      '(MSpom,MHpom,MSchain,MHchain,Ecm,AS,AH,XX):',
     &      MSPOM,MHPOM,MSCHA,MHCHA,ECMP,AS,AH,XX
          if(MSPOM+MSREG+MHPOM.gt.1) then
            if(MSREG.gt.0) then
              MSREG = MSREG-1
            else if(MSPOM.gt.0) THEN
              MSPOM = MSPOM-1
            else if(MHPOM.gt.1) then
              MHPOM = MHPOM-1
            endif
            goto 22
          endif
          IF (LPRI.GT.4 .AND. IDEB(24).GE.1)
     &    WRITE(LO,'(1X,A,1P2E10.3)')
     &      'PHO_POMSCA: kin. rejection (2) (Ecm,Ptcut)',ECMP,PTWANT
          IREJ = 50
          IFAIL(6) = IFAIL(6) + 1
          RETURN
        ENDIF

        XMAXX1 = MAX(TINY,1.D0-MIN(MSPAR1,1)*AS-MIN(MHPAR1,1)*AH)
        XMAXX2 = MAX(TINY,1.D0-MIN(MSPAR2,1)*AS-MIN(MHPAR2,1)*AH)

C  very low energy phase space restriction
        if(MHARD.gt.0) then
          if((XMAXX1*XMAXX2.le.AH)) then
            IF (LPRI.GT.4 .AND. IDEB(24).GE.1)
     &      WRITE(LO,'(1X,A,1P2E10.3)')
     &        'PHO_POMSCA: kin. rejection (3) (Ecm,Ptcut)',ECMP,PTWANT
            IREJ = 50
            IFAIL(6) = IFAIL(6) + 1
            RETURN
          endif
        endif

        AS = MAX(AS,PSOMIN/PCMP)
        ALNS  = LOG(AS)
        ALNH  = LOG(AH)
        Z1MAX = LOG(XMAXX1)
        Z2MAX = LOG(XMAXX2)
        Z1DIF = Z1MAX+Z2MAX-ALNH
        Z2DIF = Z1DIF
        PTMAX = 0.D0
C
C  select hard parton momenta
C ------------------- begin of inner loop -------------------
        IF(IPOIX3.EQ.0) IPOWGC(4+II) = 0

        IF(MHARD.GT.MSCAHD) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,2A,2I3)') 'PHO_POMSCA: ',
     &      'no space left in /POHSLT/ (MHARD,MSCAHD):',MHARD,MSCAHD
          IREJ = 1
          RETURN
        ENDIF

        DO 11 NN=1,MHARD
C
C  generate one resolved hard scattering
C
C  high-pt option
          IF((NN.EQ.1).AND.(II.EQ.1).AND.(HSWCUT(4+II).GT.PTWANT)) THEN
            CALL PHO_HARINT(-1,ECMP,PVIRTP(1),PVIRTP(2),
     &                  -1,Max_pro_2,1,4,MSPOM+MHPOM)
            XSCUT = HSig(9,idxmpar)
            AHS    = AH
            ALNHS  = ALNH
            Z1DIFS = Z1DIF
            Z2DIFS = Z2DIF
            AH    = (2.D0*PTWANT/ECMP)**2
            ALNH  = LOG(AH)
            Z1DIF = Z1MAX+Z2MAX-ALNH
            Z2DIF = Z1DIF
            IF((Z1DIF.LE.0.01D0).OR.(Z2DIF.LE.0.01D0)) THEN
              IF (LPRI.GT.4 .AND. IDEB(24).GE.1)
     &        WRITE(LO,'(1X,2A,/1X,1P4E12.3)')
     &          'PHO_POMSCA: kin.rejection, high-pt option ',
     &          '(Z1/2max,ALNH,Z1dif):',Z1MAX,Z2MAX,ALNH,Z1DIF
              IREJ = 5
              RETURN
            ENDIF
            CALL PHO_HARSCA(2,II)
            CALL PHO_HARINT(1,ECMP,PVIRTP(1),PVIRTP(2),
     &                  -1,Max_pro_2,1,4,MSPOM+MHPOM)
            AH    = AHS
            ALNH  = ALNHS
            Z1DIF = Z1DIFS
            Z2DIF = Z2DIFS
            IPOWGC(4+II) = IPOWGC(4+II)+1
            HSWGHT(4+II) = XSCUT/HSig(9,idxmpar)*DBLE(MHARD)
C  minimum bias option
          ELSE
            CALL PHO_HARSCA(2,II)
          ENDIF

C  fill /POHSLT/
          LSIDX(NN)    = NN
          LSCAHD       = NN
          XHD(NN,1)    = X1
          XHD(NN,2)    = X2
          X0HD(NN,1)   = X1
          X0HD(NN,2)   = X2
          VHD(NN)      = V
          ETAHD(NN,1)  = ETAC
          ETAHD(NN,2)  = ETAD
          PTHD(NN)     = PT
          NPROHD(NN)   = MSPR
          Q2SCA(NN,1)  = QQPD
          Q2SCA(NN,2)  = QQPD
          PDFVA(NN,1)  = PDF1(IA)
          PDFVA(NN,2)  = PDF2(IB)
          NINHD(NN,1)  = IA
          NINHD(NN,2)  = IB
          N0INHD(NN,1) = IA
          N0INHD(NN,2) = IB
          NIVAL(NN,1)  = IV1
          NIVAL(NN,2)  = IV2
          N0IVAL(NN,1) = IV1
          N0IVAL(NN,2) = IV2
          NOUTHD(NN,1) = IC
          NOUTHD(NN,2) = ID
          NBRAHD(NN,1) = IDPDG1
          NBRAHD(NN,2) = IDPDG2
          I3 = 8*(NN-1)
          I4 = 8*(NN-1)+4
          DO 50 I=1,4
            PPH(I3+I,1) = PHI1(I)
            PPH(I3+I,2) = PHI2(I)
            PPH(I4+I,1) = PHO1(I)
            PPH(I4+I,2) = PHO2(I)
 50       CONTINUE

 11     CONTINUE

C  sort according to pt-hat
        DO 12 NN=1,MHARD
          PTMX = PTHD(LSIDX(NN))
          IPTM = NN
          DO 13 I=NN+1,MHARD
            IF(PTHD(LSIDX(I)).GT.PTMX) THEN
              IPTM = I
              PTMX = PTHD(LSIDX(I))
            ENDIF
 13       CONTINUE
          IF(IPTM.NE.NN) CALL PHO_SWAPI(LSIDX(NN),LSIDX(IPTM))
 12     CONTINUE
        IPTM = LSIDX(1)

C  copy partons, generate ISR
        DO 15 L=1,MHARD
          NN = LSIDX(L)
          XSSS1  = XSS1+XHD(NN,1)
          XSSS2  = XSS2+XHD(NN,2)
C  debug output
          IF (LPRI.GT.4 .AND. IDEB(24).GE.10)
     &    WRITE(LO,'(1X,A,3I4,1P,3E11.3)')
     &      'PHO_POMSCA: NR,LSIDX,MSPR,X1,X2,PT',
     &      L,NN,NPROHD(NN),XHD(NN,1),XHD(NN,2),PTHD(NN)
C  check phase space
          IF(    (XSSS1.GT.XMAXX1)
     &       .OR.(XSSS2.GT.XMAXX2)
     &       .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
            IF(IHARD.EQ.0) THEN
              IF(ISWMDL(2).NE.1) GOTO 20
              MHPOM = 0
              MSPOM = 1
              MSREG = 0
            ENDIF
            GOTO 199
          ENDIF

C  reweight according to photon virtuality
          IF(IPAMDL(115).GE.1) THEN
            QQPD = Q2SCA(NN,1)
            WGX = 1.D0
            IF(IDPDG1.EQ.22) THEN
              IF(IPAMDL(115).EQ.1) THEN
                IF(QQPD.LT.PVIRTP(1)+PARMDL(144)) THEN
                  WG1 = 0.D0
                ELSE
                  WG1 = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
     &                 /LOG(QQPD/PARMDL(144))
                ENDIF
                IF(NINHD(NN,1).EQ.0) WG1 = WG1*WG1
              ELSE IF(IPAMDL(115).EQ.2) THEN
                CALL PHO_PDF(1,X0HD(NN,1),QQPD,PVIRTP(1),PD1)
                WG1 = PD1(NINHD(NN,1))/PDFVA(NN,1)
              ENDIF
              WGX = WG1
            ENDIF
            QQPD = Q2SCA(NN,2)
            IF(IDPDG2.EQ.22) THEN
              IF(IPAMDL(115).EQ.1) THEN
                IF(QQPD.LT.PVIRTP(2)+PARMDL(144)) THEN
                  WG1 = 0.D0
                ELSE
                  WG1 = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
     &                 /LOG(QQPD/PARMDL(144))
                ENDIF
                IF(NINHD(NN,2).EQ.0) WG1 = WG1*WG1
              ELSE IF(IPAMDL(115).EQ.2) THEN
                CALL PHO_PDF(2,X0HD(NN,2),QQPD,PVIRTP(2),PD1)
                WG1 = PD1(NINHD(NN,2))/PDFVA(NN,2)
              ENDIF
              WGX = WGX*WG1
            ENDIF

            IF(IDEB(24).GE.25 .AND. LPRI.GT.4)
     &        WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_POMSCA: ',
     &          ' re-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
     &          KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX

            IF(WGX.LT.DT_RNDM(WGX)) THEN
              IF(L.EQ.1) THEN
                IREJ = 50
                RETURN
              ELSE
                GOTO 199
              ENDIF
            ENDIF

            IF (LPRI.GT.4 .AND. WGX.GT.1.D0)
     &      WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)')
     &        'PHO_POMSCA: ',
     &        'weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
     &        KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX

          ENDIF

C  generate ISR
          IF((ISWMDL(8).GE.2)
     &       .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
            IF(IPAMDL(109).EQ.1) THEN
              Q2H = PARMDL(93)*PTHD(NN)**2
            ELSE
              Q2H = -PARMDL(93)*VHD(NN)
     &              *XHD(NN,1)*XHD(NN,2)*ECMP*ECMP
            ENDIF
            XHMAX1 = 1.D0 - XSSS1 - MSCHA*AS + XHD(NN,1)
            XHMAX2 = 1.D0 - XSSS2 - MSCHA*AS + XHD(NN,2)
            I3     = 8*NN-4
            DO 42 J=1,4
              P1(J) = PPH(I3+J,1)
              P2(J) = PPH(I3+J,2)
 42         CONTINUE
            IF(IDEB(24).GE.10 .AND. LPRI.GT.4)
     &        WRITE(LO,'(1X,A,/5X,2I3,1P,3E12.4)')
     &          'PHO_POMSCA: generate ISR for (L,NN,X1,X2,Q2H)',
     &          L,NN,XHD(NN,1),XHD(NN,2),Q2H
            J = NN
            IF(L.EQ.1) J = -NN
            CALL PHO_HARISR(J,P1,P2,NOUTHD(NN,1),NOUTHD(NN,2),
     &        N0INHD(NN,1),N0INHD(NN,2),N0IVAL(NN,1),N0IVAL(NN,2),Q2H,
     &        X0HD(NN,1),X0HD(NN,2),XHMAX1,XHMAX2,IFL1,IFL2,
     &        NIVAL(NN,1),NIVAL(NN,2),XISR1,XISR2,IREJ)
            XSSS1 = XSSS1+XISR1-XHD(NN,1)
            XSSS2 = XSSS2+XISR2-XHD(NN,2)
            NINHD(NN,1) = IFL1
            NINHD(NN,2) = IFL2
            XHD(NN,1) = XISR1
            XHD(NN,2) = XISR2
          ENDIF

C  check phase space
          IF(    (XSSS1.GT.XMAXX1)
     &       .OR.(XSSS2.GT.XMAXX2)
     &       .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
            IF(IHARD.EQ.0) THEN
              IF(ISWMDL(2).NE.1) GOTO 20
              MHPOM = 0
              MSPOM = 1
              MSREG = 0
            ENDIF
            GOTO 199
          ENDIF

C  leave energy for leading particle effect
          IF((IHARD.GT.0).AND.
     &       ((XSSS1.GT.XMAXP1).OR.(XSSS2.GT.XMAXP2))) then
            GOTO 199
          endif

C  hard scattering accepted
          IHARD = IHARD+1
          XSS1 = XSSS1
          XSS2 = XSSS2
          IFAIL(31) = IFAIL(31)-1

 15     CONTINUE

C ------------------- end of inner (hard) loop -------------------
 199    CONTINUE

        MHPOM =  IHARD
        MHPAR1 = IHARD
        MHPAR2 = IHARD

C  count valences involved in hard scattering
        IVAL1  = 0
        IVAL2  = 0
        DO 17 L=1,IHARD
          NN = LSIDX(L)
          IF((NIVAL(NN,1).NE.0).AND.(IVAL1.EQ.0)) IVAL1 = NN
          IF((NIVAL(NN,2).NE.0).AND.(IVAL2.EQ.0)) IVAL2 = NN
 17     CONTINUE

        IQUA1  = 0
        IQUA2  = 0
        IVGLU1 = 0
        IVGLU2 = 0
        DO 18 L=1,IHARD
          NN = LSIDX(L)

C  photon, pomeron valences
          IF((IVAL1.EQ.0).AND.(NINHD(NN,1).NE.0)) THEN
            IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
              NIVAL(NN,1) = 1
              IVAL1 = NN
            ENDIF
          ENDIF
          IF((IVAL2.EQ.0).AND.(NINHD(NN,2).NE.0)) THEN
            IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
              NIVAL(NN,2) = 1
              IVAL2 = NN
            ENDIF
          ENDIF

C  total number of quarks
          IF(NINHD(NN,1).NE.0) THEN
            IQUA1 = IQUA1+1
          ELSE IF(IVGLU1.EQ.0) THEN
            IVGLU1 = NN
          ENDIF
          IF(NINHD(NN,2).NE.0) THEN
            IQUA2 = IQUA2+1
          ELSE IF(IVGLU2.EQ.0) THEN
            IVGLU2 = NN
          ENDIF
 18     CONTINUE

C  gluons emitted by valence quarks
        VALPRO = 1.D0
        IF(II.EQ.1) VALPRO = VALPRG(1)
        IVQ1 = 1
        IVG1 = 0
        IVAL1 = MAX(IVAL1,0)
        IF(IVAL1.EQ.0) THEN
          IVQ1 = 0
          IF((IVGLU1.NE.0).AND.(DT_RNDM(XSS1).LT.VALPRO)) THEN
            IVAL1 = -IVGLU1
            IVG1 = 1
          ENDIF
        ENDIF
        VALPRO = 1.D0
        IF(II.EQ.1) VALPRO = VALPRG(2)
        IVQ2 = 1
        IVG2 = 0
        IVAL2 = MAX(IVAL2,0)
        IF(IVAL2.EQ.0) THEN
          IVQ2 = 0
          IF((IVGLU2.NE.0).AND.(DT_RNDM(XSS2).LT.VALPRO)) THEN
            IVAL2 = -IVGLU2
            IVG2 = 1
          ENDIF
        ENDIF
        MSPOM = MAX(0,MSPOM-IQUA1-IQUA2)
C  debug output
        IF (LPRI.GT.4 .AND. IDEB(24).GE.5)
     &  WRITE(LO,'(1X,A,6I4)')
     &    'PHO_POMSCA: IVAL1/2,IQUA1/2,IVGLU1/2',
     &    IVAL1,IVAL2,IQUA1,IQUA2,IVGLU1,IVGLU2

C  select soft X values
 25     CONTINUE
C  number of soft/remnant quarks
        IF(MSPOM.EQ.0) THEN
          IF(IPAMDL(18).EQ.0) THEN
            MSPAR1 = 2+2*MHPOM+MSREG-IQUA1-2*IVQ1-2*IVG1
            MSPAR2 = 2+2*MHPOM+MSREG-IQUA2-2*IVQ2-2*IVG2
          ELSE
            MSPAR1 = 2+MSREG+IQUA1-2*IVQ1
            MSPAR2 = 2+MSREG+IQUA2-2*IVQ2
          ENDIF
        ELSE
          IF(IPAMDL(18).EQ.0) THEN
            MSPAR1 = 2*MSPOM+MSREG+2*MHPOM-IQUA1
            MSPAR2 = 2*MSPOM+MSREG+2*MHPOM-IQUA2
          ELSE
            MSPAR1 = 2*MSPOM+MSREG+IQUA1+2*IVG1
            MSPAR2 = 2*MSPOM+MSREG+IQUA2+2*IVG2
          ENDIF
        ENDIF
C  debug output
        IF (LPRI.GT.4 .AND. IDEB(24).GE.15)
     &  WRITE(LO,'(1X,A,9I3)')
     &    'PHO_POMSCA: MSP,MSR,MHP,IVQ1/2,IVG1/2,MSPAR1/2',
     &    MSPOM,MSREG,MHPOM,IVQ1,IVQ2,IVG1,IVG2,MSPAR1,MSPAR2

        XMAX1  = 1.D0 - MAX(MSPAR1-1,0)*AS - XSS1
        XMAX2  = 1.D0 - MAX(MSPAR2-1,0)*AS - XSS2
        I1 = IVQ1
        I2 = IVQ2
        IF(IVAL1.LE.0) I1 = 0
        IF(IVAL2.LE.0) I2 = 0
        IF((IVQ1+IVG1)*(IVQ2+IVG2).NE.0) THEN
          MSDIFF = 2*MSPOM
        ELSE
          MSDIFF = 2*MAX(0,MSPOM-1)
        ENDIF
        MSG1 = MSPAR1
        MSG2 = MSPAR2
        MSM1 = MSPAR1-MSDIFF
        MSM2 = MSPAR2-MSDIFF
        XMAXH1 = MIN(XMAX1,PARMDL(44))
        XMAXH2 = MIN(XMAX2,PARMDL(44))
        CALL PHO_SOFTXX(NPOSP(1),NPOSP(2),MSG1,MSG2,I1,I2,MSM1,MSM2,
     &              XSS1,XSS2,XMAXH1,XMAXH2,XS1,XS2,IREJ)

C  correct for proper simulation of high pt tail
        IF(IREJ.NE.0) THEN
          IF (LPRI.GT.4 .AND. IDEB(48).GE.2)
     &    WRITE(LO,'(1X,A,4I4)')
     &      'PHO_POMSCA: rejection (PHO_SOFTXX): MSPOM,MHPOM,I1,I2',
     &      MSPOM,MHPOM,I1,I2
          IF(MSPOM*MHPOM.GT.0) THEN
            MSPOM = MSPOM-1
            GOTO 25
          ELSE IF(MSPOM.GT.1) THEN
            MSPOM = MSPOM-1
            GOTO 25
          ELSE IF(MHPOM.GT.1) THEN
            IHARD = IHARD-1
            IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0)
     &         .AND.(IPROCE.EQ.1)) THEN
              XSS1   = MAX(0.D0,1.D0-XPSUB)
              XSS2   = MAX(0.D0,1.D0-XTSUB)
            ELSE
              XSS1   = 0.D0
              XSS2   = 0.D0
            ENDIF
            DO 103 K=1,IHARD
              I = LSIDX(K)
              XSS1 = XSS1+ XHD(I,1)
              XSS2 = XSS2+ XHD(I,2)
 103        CONTINUE
            GOTO 199
          ENDIF
          IREJ = 4
          GOTO 450
        ENDIF
C  accepted
        MSPOM  = MSPOM-(MSPAR1-MSG1)/2
        MSPAR1 = MSG1
        MSPAR2 = MSG2
C  ------------ kinematics sampled ---------------
C  debug output
        IF(IDEB(24).GE.10) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,I3)')
     &      'PHO_POMSCA: soft x values, ITRY',ITRY
          DO 104 I=2,MAX(MSPAR1,MSPAR2)
            IF (LPRI.GT.4)
     &      WRITE(LO,'(10X,I3,2E12.3)') I,XS1(I),XS2(I)
 104      CONTINUE
        ENDIF
      IF((1.D0-XSS1)*(1.D0-XSS2).LT.AS) GOTO 20

C  end of loop
      XS1(1) = 1.D0 - XSS1
      XS2(1) = 1.D0 - XSS2

C  process counting
      DO 30 N=1,LSCAHD
        MH_acc_1(NPROHD(N),II,IDXMPAR) = 
     &    MH_acc_1(NPROHD(N),II,IDXMPAR)+1
 30   CONTINUE

C  soft particle momenta

      IF(MAX(MSPAR1,MSPAR2).GT.MAXSOF) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,2A,3I4)') 'PHO_POMSCA: no space left in ',
     &    '/POSOFT/ (MSPAR1/2,MAXSOF):',MSPAR1,MSPAR2,MAXSOF
        IREJ = 1
        RETURN
      ENDIF

      DO 55 I=1,MSPAR1
        PSOFT1(1,I) = 0.D0
        PSOFT1(2,I) = 0.D0
        PSOFT1(3,I) = XS1(I)*ECMP/2.D0
        PSOFT1(4,I) = XS1(I)*ECMP/2.D0
 55   CONTINUE
      DO 60 I=1,MSPAR2
        PSOFT2(1,I) = 0.D0
        PSOFT2(2,I) = 0.D0
        PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
        PSOFT2(4,I) = XS2(I)*ECMP/2.D0
 60   CONTINUE

      KSOFT = MAX(MSPAR1,MSPAR2)
      KHARD = MAX(MHPAR1,MHPAR2)
      KSPOM = MSPOM
      KSREG = MSREG
      KHPOM = MHPOM

C  debug output
      IF(IDEB(24).GE.10) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,2I3,2I5)')
     &    'PHO_POMSCA: accepted IVAL1,IVAL2,ITRY,NTRY',
     &     IVAL1,IVAL2,ITRY,NTRY
        IF(MSPAR1+MSPAR2.GT.0) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A)') 'soft x particle1   particle2:'
          XTMP1 = 0.D0
          XTMP2 = 0.D0
          DO 105 I=1,MAX(MSPAR1,MSPAR2)
            IF(I.LE.MIN(MSPAR1,MSPAR2)) THEN
              IF (LPRI.GT.4)
     &        WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),XS2(I)
              XTMP1 = XTMP1+XS1(I)
              XTMP2 = XTMP2+XS2(I)
            ELSE IF(I.LE.MSPAR1) THEN
              IF (LPRI.GT.4)
     &        WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),0.D0
              XTMP1 = XTMP1+XS1(I)
            ELSE IF(I.LE.MSPAR2) THEN
              IF (LPRI.GT.4)
     &        WRITE(LO,'(10X,I3,2E13.4)') I,0.D0,XS2(I)
              XTMP2 = XTMP2+XS2(I)
            ENDIF
 105      CONTINUE
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,2E13.4)') 'sum X1/2 (soft):',XTMP1,XTMP2
        ENDIF
        IF(MHPAR1.GT.0) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A)')
     &      'NR  IDX  MSPR hard X / hard X ISR / flavor particle 1,2:'
          DO 107 K=1,MHPAR1
            I = LSIDX(K)
            IF (LPRI.GT.4)
     &      WRITE(LO,'(5X,3I3,4E12.3,2I3)')
     &        K,I,NPROHD(I),X0HD(I,1),X0HD(I,2),XHD(I,1),XHD(I,2),
     &        NINHD(I,1),NINHD(I,2)
              XTMP1 = XTMP1+XHD(I,1)
              XTMP2 = XTMP2+XHD(I,2)
 107      CONTINUE
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,2E13.4)') 'sum X1/2 (soft+hard):',XTMP1,XTMP2
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A)') 'hard momenta  particle1:'
          DO 108 K=1,MHPAR1
            I = LSIDX(K)
            I3 = 8*I-4
            IF (LPRI.GT.4)
     &      WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,1),L=1,4),
     &        NOUTHD(I,1)
 108      CONTINUE
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A)') 'hard momenta  particle2:'
          DO 110 K=1,MHPAR2
            I = LSIDX(K)
            I3 = 8*I-4
            IF (LPRI.GT.4)
     &      WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,2),L=1,4),
     &        NOUTHD(I,2)
 110      CONTINUE
        ENDIF
      ENDIF
      RETURN

C  event rejected, print debug information
 450  CONTINUE
      IFAIL(4) = IFAIL(4)+1
      IF(IDEB(24).GE.2) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,2A,/,10X,7I5)') 'PHO_POMSCA: ',
     &    'rejection (MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ)',
     &    MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,I4,1P,2E12.4)') 'IP,Ecm,PTcut:',II,ECMP,PTWANT
        IF(IDEB(24).GE.5) THEN
          CALL PHO_PREVNT(0)
        ELSE
          CALL PHO_PREVNT(-1)
        ENDIF
      ENDIF

      END


 
 


CDECK  ID>, PHO_POSPOM
      SUBROUTINE PHO_POSPOM(IP,IND1,IND2,IGEN,IPOM,KCUT,ISWAP,IREJ)
C***********************************************************************
C
C     registration of one cut pomeron (soft/semihard)
C
C     input:   IP      particle combination the pomeron belongs to
C              IND1,2  position of X values in /POSOFT/
C                      1 corresponds to a valence-pomeron
C              IGEN    production process of mother particles
C              IPOM    pomeron number
C              KCUT    total number of cut pomerons and reggeons
C
C     output:  ISWAP   exchange of x values
C              IND1,2  increased by the number of partons belonging
C                      to the generated pomeron cut
C              IREJ    success/failure
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( DEPS   =  1.D-8 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  internal rejection counters
      INTEGER NMXJ
      PARAMETER (NMXJ=60)
      CHARACTER*10 REJTIT
      INTEGER IFAIL
      COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)

C  current beam selection
      INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN
      INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL
      DOUBLE PRECISION SQSGLOBMAX
      PARAMETER (MPARMAX=40)
      PARAMETER (MAXMAPPS=40)
      PARAMETER (IKNOWN=9)
      DIMENSION IPAVAIL(IKNOWN)
      DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/
      COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS),
     &           MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  general process information
      INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
      COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)

C  global event kinematics and particle IDs
      INTEGER IFPAP,IFPAB
      DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
      COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)

C  data of c.m. system of Pomeron / Reggeon exchange
      INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
      DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
     &                 SIDP,CODP,SIFP,COFP
      COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
     &                SIDP,CODP,SIFP,COFP,NPOSP(2),
     &                IDPDG1,IDBAM1,IDPDG2,IDBAM2

C  obsolete cut-off information
      DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
      COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN

C  energy-interpolation table
      INTEGER IEETA2
      PARAMETER ( IEETA2 = 20 )
      INTEGER ISIMAX
      DOUBLE PRECISION SIGTAB,SIGECM, ECMF
      COMMON /POTABL/ SIGTAB(80, IEETA2, 4, MPARMAX),
     &                SIGECM(IEETA2, 4, MPARMAX), ECMF(4, MPARMAX),
     &                ISIMAX(MPARMAX)

C  light-cone x fractions and c.m. momenta of soft cut string ends
      INTEGER MAXSOF
      PARAMETER ( MAXSOF = 2000 )
      INTEGER IJSI2,IJSI1
      DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
      COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
     &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
     &                IJSI1(MAXSOF),IJSI2(MAXSOF)

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

C  table of particle indices for recursive PHOJET calls
      INTEGER MAXIPX
      PARAMETER ( MAXIPX = 500 )
      INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
      COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
     &                IPOIX1,IPOIX2,IPOIX3
      INTEGER  IPHO_PDG2ID
      EXTERNAL IPHO_PDG2ID

      DIMENSION P1(4),P2(4),WGXHSD(2),WGX(6)

      IREJ = 0
      ISWAP = 0
      JM1 = NPOSP(1)
      JM2 = NPOSP(2)
      INDX1 = IND1
      INDX2 = IND2
      EA1 = XS1(IND1)*ECMP/2.D0
      EA2 = XS1(IND1+1)*ECMP/2.D0
      EB1 = XS2(IND2)*ECMP/2.D0
      EB2 = XS2(IND2+1)*ECMP/2.D0
      CMASS1 = MIN(EA1,EA2)
      CMASS2 = MIN(EB1,EB2)
      IPOS1 = 0
      IPOS2 = 0
      IPOS = 0

C  debug output
      IF(IDEB(9).GE.20) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,2A,5I4)') 'PHO_POSPOM: ',
     &    'IP,IND1,IND2,KCUT,IPOIX1',IP,IND1,IND2,KCUT,IPOIX1
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,2I4,1P2E12.4)') 'MOTHER1/2,MASS1/2',JM1,JM2,
     &    CMASS1,CMASS2
      ENDIF

C  flavours
      IF(IND1.EQ.1) THEN
        CALL PHO_VALFLA(JM1,IFLA1,IFLA2,EA1,EA2)
      ELSE
        CALL PHO_SEAFLA(JM1,IFLA1,IFLA2,CMASS1)
      ENDIF
      IF(IND2.EQ.1) THEN
        CALL PHO_VALFLA(JM2,IFLB1,IFLB2,EB1,EB2)
      ELSE
        CALL PHO_SEAFLA(JM2,IFLB1,IFLB2,CMASS2)
      ENDIF
      DO 75 I=1,4
        P1(I) = PSOFT1(I,IND1)+PSOFT1(I,IND1+1)
        P2(I) = PSOFT2(I,IND2)+PSOFT2(I,IND2+1)
 75   CONTINUE

C  pomeron resolved?
      IF((ISWMDL(14).GT.0).AND.(IPOIX1.GT.0)) THEN
C  find energy for cross section calculation
        IF(IPAMDL(16).EQ.2) THEN
          ESUB = ECMP
        ELSE IF(IPAMDL(16).EQ.3) THEN
          IF(IPROCE.EQ.1) THEN
            ESUB = ECM
          ELSE
            ESUB = ECMP
          ENDIF
        ELSE
          ESUB = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2
     &                -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2)
        ENDIF
C  load cross sections from interpolation table
        IF(ESUB.LE.SIGECM(1,IP,IDXMPAR)) THEN
          I1 = 1
          I2 = 2
        ELSE IF(ESUB.LT.SIGECM(ISIMAX(IDXMPAR),IP,IDXMPAR)) THEN
          DO 50 I=2,ISIMAX(IDXMPAR)
            IF(ESUB.LE.SIGECM(I,IP,IDXMPAR)) GOTO 200
 50       CONTINUE
 200      CONTINUE
          I1 = I-1
          I2 = I
        ELSE
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,2E12.3)')
     &      'PHO_POSPOM: energy too high',ESUB,
     &       SIGECM(ISIMAX(IDXMPAR),IP,IDXMPAR)
          CALL PHO_PREVNT(-1)
          I1 = ISIMAX(IDXMPAR)-1
          I2 = ISIMAX(IDXMPAR)
        ENDIF
        FAC2=0.D0
        IF(I1.NE.I2) FAC2=LOG(ESUB/SIGECM(I1,IP,IDXMPAR))
     &                    /LOG(SIGECM(I2,IP,IDXMPAR)/
     &                     SIGECM(I1,IP,IDXMPAR))
        FAC1=1.D0-FAC2

        WGXPOM = FAC2*(SIGTAB(56,I2,IP,IDXMPAR)+
     &           SIGTAB(57,I2,IP,IDXMPAR))+
     &           FAC1*(SIGTAB(56,I1,IP,IDXMPAR)+
     &           SIGTAB(57,I1,IP,IDXMPAR))
        WGXHSD(1) = FAC2*SIGTAB(60,I2,IP,IDXMPAR)+
     &              FAC1*SIGTAB(60,I1,IP,IDXMPAR)
        WGXHSD(2) = FAC2*SIGTAB(62,I2,IP,IDXMPAR)+
     &              FAC1*SIGTAB(62,I1,IP,IDXMPAR)
        WGXHDD = FAC2*(SIGTAB(61,I2,IP,IDXMPAR)+
     &           SIGTAB(63,I2,IP,IDXMPAR)+
     &           SIGTAB(64,I2,IP,IDXMPAR))+
     &           FAC1*(SIGTAB(61,I1,IP,IDXMPAR)+
     &           SIGTAB(63,I1,IP,IDXMPAR)+
     &           SIGTAB(64,I1,IP,IDXMPAR))
        WGXCDF = FAC2*(SIGTAB(65,I2,IP,IDXMPAR)+
     &           SIGTAB(66,I2,IP,IDXMPAR)+
     &           SIGTAB(67,I2,IP,IDXMPAR)+
     &           SIGTAB(68,I2,IP,IDXMPAR))+
     &           FAC1*(SIGTAB(65,I1,IP,IDXMPAR)+
     &           SIGTAB(66,I1,IP,IDXMPAR)+
     &           SIGTAB(67,I1,IP,IDXMPAR)+
     &           SIGTAB(68,I1,IP,IDXMPAR))

C  one-pomeron cut
        WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
C  central diff. cut
        WGX(2) = WGXCDF
C  diff. diss. of particle 1
        WGX(3) = WGXHSD(1)
C  diff. diss. of particle 2
        WGX(4) = WGXHSD(2)
C  double diff. dissociation
        WGX(5) = WGXHDD
C  two-pomeron cut
        WGX(6) = 2.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)

*       IF((WGX(1).LT.0.D0).AND.((IP.EQ.1).OR.(IDEB(9).GE.1))) THEN
*         WRITE(LO,'(1X,A,/1X,A,I3,1P,2E11.3)') ' PHO_POSPOM: ',
*    &      ' unitarity bound reached for ',IP,ESUB,WGX(1)
*         WRITE(LO,'(5X,A)') 'WGXHSD(1),WGXHSD(2),WGXHDD,WGXCDF,WGXPOM:'
*         WRITE(LO,'(5X,1P5E11.3)') WGXHSD,WGXHDD,WGXCDF,WGXPOM
*         WRITE(LO,'(5X,A,/,5X,1P,6E11.3)') 'weight factors WG(1-6)',WGX
*       ENDIF

        SUM  = WGX(1)+WGX(2)+WGX(3)+WGX(4)+WGX(5)+WGX(6)

C  selection loop
 205    CONTINUE
        XI = DT_RNDM(SUM)*SUM
        I = 0
        SUM = 0.D0
 210    CONTINUE
          I = I+1
          SUM = SUM+WGX(I)
        IF((XI.GT.SUM).AND.(I.LT.6)) GOTO 210
C  phase space correction
        IF(I.NE.1) THEN
          ISAM = 4
          IF(I.EQ.6) ISAM = 8
          PACC = EXP(-PARMDL(8)*DBLE(ISAM*PARMDL(160+IP))/ESUB)
*         IF(DT_RNDM(SUM).GT.PACC) I=1
          IF(DT_RNDM(SUM).GT.PACC) GOTO 205
        ENDIF

C  do not generate diffraction for events with only one cut pomeron
        IF((KCUT.EQ.1).AND.(I.LT.6)) I = 1

C  do not generate recursive calls for remants with
C  diquark-anti-diquark flavour contents
        if((abs(IFLA1).gt.1000).and.(IFLA1+IFLA2.eq.0)) I = 1
        if((abs(IFLB1).gt.1000).and.(IFLB1+IFLB2.eq.0)) I = 1

C  debug output
        IF (LPRI.GT.4 .AND. IDEB(9).GE.20)
     &  WRITE(LO,'(1X,A,/1X,I2,1P7E11.3)')
     &    'PHO_POSPOM: IPRO,ESUB,WGX(1-6)',I,ESUB,WGX

        IF(I.GT.1) THEN
          CALL PHO_HACODE(IFLA1,IFLA2,IDHA1,IDUM)
          CALL PHO_HACODE(IFLB1,IFLB2,IDHA2,IDUM)
          IDPD1 = IPHO_ID2PDG(IDHA1)
          IDPD2 = IPHO_ID2PDG(IDHA2)
C**anfe Replace pi0 as lightest possible u-u~/d-d~ hadron and
C     and rho as lightest c-c~ hadron with f(0) and f(2)
          IF (IFLA1==IFLA2) THEN
            IF (ABS(IFLA1)<=2) THEN
              IDPD1 = 10221
              IDHA1 = IPHO_PDG2ID(10221)
            ELSE
              IDPD1 = 225
              IDHA1 = IPHO_PDG2ID(225)
            END IF
          END IF
          IF (IFLB1==IFLB2) THEN
            IF (ABS(IFLB1)<=2) THEN
              IDPD2 = 10221
              IDHA2 = IPHO_PDG2ID(10221)
            ELSE
              IDPD2 = 225
              IDHA2 = IPHO_PDG2ID(225)
            END IF
          END IF

          CALL PHO_REGPAR(1,IDPD1,IDHA1,JM1,JM2,P1(1),P1(2),P1(3), 
     &       P1(4), IPOM, IGEN, 0, 0, IPOS1, 1)
          CALL PHO_REGPAR(1,IDPD2,IDHA2,JM2,JM1,P2(1),P2(2),P2(3), 
     &       P2(4),IPOM,IGEN,0,0,IPOS1,1)

          IND1 = IND1 + 2
          IND2 = IND2 + 2
C  update index
          IPOIX2 = IPOIX2+1

          IF(IPOIX2.GT.MAXIPX) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,2A,2I5)') 'PHO_POSPOM: no space left in ',
     &        '/PORECU/ (IPOIX2,MAXIPX):',IPOIX2,MAXIPX
            IREJ = 1
            RETURN
          ENDIF

          IPORES(IPOIX2) = I+2
          IPOPOS(1,IPOIX2) = IPOS1-1
          IPOPOS(2,IPOIX2) = IPOS1
          RETURN
        ENDIF
      ENDIF

C100  CONTINUE
      IF(ISWMDL(12).EQ.0) THEN
C  sample colors
        CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
        CALL PHO_SELCOL(0,0,ICC1,ICC2,ICD1,ICD2,1)

C  purely gluonic pomeron or sea strings formed by gluons

        IF(    ((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0))
     &     .OR.((IPAMDL(19).EQ.1).AND.(IND1.NE.1))) THEN
          IFLA1 = 21
          IFLA2 = 21
        ENDIF
        IF(    ((IDHEP(JM2).EQ.990).AND.(IPAMDL(20).GT.0))
     &     .OR.((IPAMDL(19).EQ.1).AND.(IND2.NE.1))) THEN
          IFLB1 = 21
          IFLB2 = 21
        ENDIF

C  color connection
        IF(IFLA1.NE.21) THEN
          IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
     &      .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
     &      CALL PHO_SWAPI(ICA1,ICD1)
        ENDIF
        IF(IFLB1.NE.21) THEN
          IF(((ABS(IFLB1).GT.6).AND.(IFLB1.LT.0))
     &      .OR.((ABS(IFLB1).LE.6).AND.(IFLB1.GT.0)))
     &      CALL PHO_SWAPI(ICB1,ICC1)
        ENDIF
        ISWAP = 0
        IF(ICA1*ICB1.GT.0) THEN
          IF((IND1.NE.1).AND.(IND2.NE.1)) THEN
            IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
              CALL PHO_SWAPI(IFLA1,IFLA2)
              CALL PHO_SWAPI(ICA1,ICD1)
            ELSE
              CALL PHO_SWAPI(IFLB1,IFLB2)
              CALL PHO_SWAPI(ICB1,ICC1)
            ENDIF
          ELSE IF(IND1.NE.1) THEN
            CALL PHO_SWAPI(IFLA1,IFLA2)
            CALL PHO_SWAPI(ICA1,ICD1)
          ELSE IF(IND2.NE.1) THEN
            CALL PHO_SWAPI(IFLB1,IFLB2)
            CALL PHO_SWAPI(ICB1,ICC1)
          ELSE IF((IFLA1.EQ.-IFLA2).AND.(IFLB1.EQ.-IFLB2)) THEN
            IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
              CALL PHO_SWAPI(IFLA1,IFLA2)
              CALL PHO_SWAPI(ICA1,ICD1)
            ELSE
              CALL PHO_SWAPI(IFLB1,IFLB2)
              CALL PHO_SWAPI(ICB1,ICC1)
            ENDIF
          ELSE IF(IFLA1.EQ.-IFLA2) THEN
            CALL PHO_SWAPI(IFLA1,IFLA2)
            CALL PHO_SWAPI(ICA1,ICD1)
          ELSE IF(IFLB1.EQ.-IFLB2) THEN
            CALL PHO_SWAPI(IFLB1,IFLB2)
            CALL PHO_SWAPI(ICB1,ICC1)
          ELSE
            ISWAP = 1
            IF(IDEB(9).GE.5) THEN
              IF (LPRI.GT.4)
     &        WRITE(LO,'(1X,A,I12)')
     &          'PHO_POSPOM: string end swap (KEVENT)',KEVENT
                IF (LPRI.GT.4)
     &          WRITE(LO,'(5X,A,4I7)')
     &          'flavors:',IFLA1,IFLA2,IFLB1,IFLB2
              IF (LPRI.GT.4)
     &        WRITE(LO,'(5X,A,4I7)') 'colors :',ICA1,ICD1,ICB1,ICC1
            ENDIF
          ENDIF
        ENDIF

C  registration

C  purely gluonic pomeron or sea strings formed by gluons
        IF(IFLA1.EQ.21) THEN
          CALL PHO_REGPAR(-1,21,0,JM1,JM2,P1(1),P1(2),P1(3),P1(4),
     &      IPOM,IGEN,ICA1,ICD1,IPOS1,1)
          IND1 = IND1+2

C  strings formed by quarks
        ELSE
C  valence quark labels
          IF((INDX1.EQ.1).and.(IPHIST(2,JM1).GE.0)
     &       .and.(IDHEP(JM1).NE.990)) THEN
            ICA2 = 1
            ICD2 = 1
          ENDIF
C  registration
          CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
     &      PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICA1,
     &      ICA2,IPOS1,1)
          IND1 = IND1+1
          CALL PHO_REGPAR(-1,IFLA2,0,JM1,JM2,PSOFT1(1,IND1),
     &      PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICD1,
     &      ICD2,IPOS,1)
          IND1 = IND1+1

        ENDIF

C  purely gluonic pomeron or sea strings formed by gluons
        IF(IFLB1.EQ.21) THEN
          CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,P2(1),P2(2),P2(3),P2(4),
     &      IPOM,IGEN,ICB1,ICC1,IPOS2,1)
          IND2 = IND2+2

C  strings formed by quarks
        ELSE
C  valence quark labels
          IF((INDX2.EQ.1).and.(IPHIST(2,JM2).GE.0)
     &       .and.(IDHEP(JM2).NE.990)) THEN
            ICB2 = 1
            ICC2 = 1
          ENDIF
C  registration
          CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
     &      PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICB1,
     &      ICB2,IPOS,1)
          IND2 = IND2+1
          CALL PHO_REGPAR(-1,IFLB2,0,JM2,JM1,PSOFT2(1,IND2),
     &      PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICC1,
     &      ICC2,IPOS2,1)
          IND2 = IND2+1

        ENDIF

C  soft pt assignment
        IF(ISWMDL(18).EQ.0) THEN
          CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(IP),IREJ)
          IF(IREJ.NE.0) THEN
            IFAIL(25) = IFAIL(25)+1
            RETURN
          ENDIF
        ENDIF
      ELSE
*       CALL PHO_BFKL(P1,P2,IPART,IREJ)
*       IF(IREJ.NE.0) RETURN
      ENDIF

      END


 
 


CDECK  ID>, PHO_PRBDIS
      SUBROUTINE PHO_PRBDIS(IP,ECM,IE)
C*********************************************************************
C
C     calculation of multi interactions probabilities
C
C     input:  IP        particle combination to scatter
C             ECM       CMS energy
C             IE        index for weight storing
C             /PROBAB/
C             IMAX      max. number of soft pomeron interactions
C             KMAX      max. number of hard pomeron interactions
C
C     output: /PROBAB/
C             PROB      field of probabilities
C
C*********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( EPS=1.D-10 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  Reggeon phenomenology parameters
      DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
     &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
      COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
     &                ALREG,ALREGP,GR(2),B0REG(2),
     &                GPPP,GPPR,B0PPP,B0PPR,
     &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC

C  parameters of 2x2 channel model
      DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
      COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC

C  Born graph cross sections and slopes
      INTEGER Max_pro_3
      PARAMETER ( Max_pro_3 = 16 )
      COMPLEX*16      SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
     &                SIGD1,SIGD2,DSIGH
      COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
     &                SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)

C  obsolete cut-off information
      DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
      COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN

C  Born graph cross sections after applying diffraction model
      DOUBLE PRECISION SBOPOM,SBOREG,SBOHAR,SBOHAD,SBOTR1,SBOTR2,
     &                 SBOLPO,SBODPO
      COMMON /POINT1/ SBOPOM(0:4),SBOREG(0:4),SBOHAR(0:4),SBOHAD(0:4),
     &                SBOTR1(0:4,2),SBOTR2(0:4,2),SBOLPO(0:4),
     &                SBODPO(0:4,4)

C  cross sections
      INTEGER IPFIL,IFAFIL,IFBFIL
      DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
     &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
     &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
     &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
     &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
      COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
     &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
     &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
     &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
     &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
     &                IPFIL,IFAFIL,IFBFIL

C  current beam selection
      INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN
      INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL
      DOUBLE PRECISION SQSGLOBMAX
      PARAMETER (MPARMAX=40)
      PARAMETER (MAXMAPPS=40)
      PARAMETER (IKNOWN=9)
      DIMENSION IPAVAIL(IKNOWN)
      DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/
      COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS),
     &           MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP

C  cut probability distribution
      INTEGER IEETA1,IIMAX,KKMAX
      PARAMETER( IEETA1=20, IIMAX=20, KKMAX=500 )
      INTEGER IEEMAX,IMAX,KMAX
      DOUBLE PRECISION EPTAB, PROB
      COMMON /POPROB/ PROB(IEETA1, 0:IIMAX, 0:KKMAX, 4, MPARMAX),
     &          EPTAB(IEETA1, 4, MPARMAX), IEEMAX, IMAX, KMAX

C  energy-interpolation table
      INTEGER IEETA2
      PARAMETER ( IEETA2 = 20 )
      INTEGER ISIMAX
      DOUBLE PRECISION SIGTAB,SIGECM, ECMF
      COMMON /POTABL/ SIGTAB(80, IEETA2, 4, MPARMAX),
     &                SIGECM(IEETA2, 4, MPARMAX), ECMF(4, MPARMAX),
     &                ISIMAX(MPARMAX)

C  average number of cut soft and hard ladders (obsolete)
      DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
      COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

C  integration precision for hard cross sections (obsolete)
      INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
      COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  unitarized amplitudes for different diffraction channels
      DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
     &                 ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
     &                 ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
     &                 ZXL,BXL
      COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
     &                ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
     &                ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
     &                ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
     &                ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
     &                ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
     &                ZXL(4,4),BXL(4,4)

C  local variables
      DIMENSION  AB(4,4),CHI2(4),ABSUM2(4,4),ABSTMP(4),CHITMP(4)
C**anfe Increased ICHMAX from 40 -> 100
      PARAMETER ( ICHMAX=100 )
      DIMENSION CHIFAC(4,4),AMPCOF(4)
      DIMENSION PCHAIN(2,ICHMAX),XPNT(96),WGHT(96)
      DIMENSION FACLOG(0:KKMAX),PSOFT(0:IIMAX),PHARD(0:KKMAX)

C  combinatorical factors
      DATA      CHIFAC / 1.D0, 1.D0,-1.D0,-1.D0,
     &                   1.D0,-1.D0, 1.D0,-1.D0,
     &                   1.D0,-1.D0,-1.D0, 1.D0,
     &                   1.D0, 1.D0, 1.D0, 1.D0 /

      DATA  ELAST / 0.D0 /
      DATA  IPLAST / 0 /
      DATA  IDXMLAST / 0 /
      DATA  INIT / 0 /

      IF(INIT.EQ.0) THEN
        FACLOG(0) = 0.D0
        DO I=1,KKMAX
          FACLOG(I) = LOG(DBLE(I))
        ENDDO
        INIT = 1
      ENDIF
C  test for redundant calculation: skip cs calculation
      IF((ECM.NE.ELAST).OR.(IP.NE.IPLAST) .Or.
     &    (idxmpar.NE.idxmlast)) THEN
        ELAST = ECM
        IPLAST = IP
        IDXMLAST = IDXMPAR
        CALL PHO_XSECT(IP,0,ELAST)
        ISIMAX(idxmpar) = IE
        SIGECM(IE,IP,IDXMPAR) = ECM
        SIGTAB(1,IE,IP,IDXMPAR) = SIGTOT
        SIGTAB(2,IE,IP,IDXMPAR) = SIGELA
        J = 2
        DO 5 I=0,4
          DO 6 K=0,4
            J = J+1
            SIGTAB(J,IE,IP,IDXMPAR) = SIGVM(I,K)
 6        CONTINUE
 5      CONTINUE
        SIGTAB(28,IE,IP,IDXMPAR) = SIGINE
        SIGTAB(29,IE,IP,IDXMPAR) = SIGDIR
        SIGTAB(30,IE,IP,IDXMPAR) = SIGLSD(1)
        SIGTAB(31,IE,IP,IDXMPAR) = SIGLSD(2)
        SIGTAB(32,IE,IP,IDXMPAR) = SIGHSD(1)
        SIGTAB(33,IE,IP,IDXMPAR) = SIGHSD(2)
        SIGTAB(34,IE,IP,IDXMPAR) = SIGLDD
        SIGTAB(35,IE,IP,IDXMPAR) = SIGHDD
        SIGTAB(36,IE,IP,IDXMPAR) = SIGCDF(0)
        SIGTAB(37,IE,IP,IDXMPAR) = SIG1SO
        SIGTAB(38,IE,IP,IDXMPAR) = SIG1HA
        SIGTAB(39,IE,IP,IDXMPAR) = SLOEL
        J = 39
        DO 7 I=1,4
          DO 8 K=1,4
            J = J+1
            SIGTAB(J,IE,IP,IDXMPAR) = SLOVM(I,K)
 8        CONTINUE
 7      CONTINUE
        SIGTAB(56,IE,IP,IDXMPAR) = SIGPOM
        SIGTAB(57,IE,IP,IDXMPAR) = SIGREG
        SIGTAB(58,IE,IP,IDXMPAR) = SIGHAR
        SIGTAB(59,IE,IP,IDXMPAR) = SIGDIR
        SIGTAB(60,IE,IP,IDXMPAR) = SIGTR1(1)
        SIGTAB(61,IE,IP,IDXMPAR) = SIGTR1(2)
        SIGTAB(62,IE,IP,IDXMPAR) = SIGTR2(1)
        SIGTAB(63,IE,IP,IDXMPAR) = SIGTR2(2)
        SIGTAB(64,IE,IP,IDXMPAR) = SIGLOO
        SIGTAB(65,IE,IP,IDXMPAR) = SIGDPO(1)
        SIGTAB(66,IE,IP,IDXMPAR) = SIGDPO(2)
        SIGTAB(67,IE,IP,IDXMPAR) = SIGDPO(3)
        SIGTAB(68,IE,IP,IDXMPAR) = SIGDPO(4)
C  consistency check
        SIGNDF = SIGTOT-SIGELA-SIGVM(0,0)-SIGCDF(0)-SIGDIR
     &          -SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
     &          -SIGLDD-SIGHDD
        IF(SIGNDF.LE.0.D0) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(//1X,A,/)')
     &      'PHO_PRBDIS:ERROR: neg.cross section for unitarization!'
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,I3,1P,2E12.4)')
     &      'PHO_PRBDIS: IP,ECM,SIGNDF:',IP,ECM,SIGNDF
          IF (LPRI.GT.4)
     &    WRITE(LO,'(4X,A,/1P,8E10.3)')
     &'(SIGTOT,SIGELA,SIGVM,SIGCDF,SIGDIR,SIGLSD(1),SIGLSD(2),SIGLDD):',
     &      SIGTOT,SIGELA,SIGVM(0,0),SIGCDF(0),SIGDIR,SIGLSD(1),
     &      SIGLSD(2),SIGLDD
          STOP
        ENDIF
        IF((IDEB(55).GE.2).AND.(IP.EQ.1)) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,*)'------------------------------------------------'
          IF (LPRI.GT.4)
     &    WRITE(LO,*)'IP,ECM:',IP,ECM
          IF (LPRI.GT.4)
     &    WRITE(LO,*)'SIGTOT:',SIGTOT
          IF (LPRI.GT.4)
     &    WRITE(LO,*)'SIGELA:',SIGELA
          IF (LPRI.GT.4)
     &    WRITE(LO,*)'SIGVM :',SIGVM(0,0)
          IF (LPRI.GT.4)
     &    WRITE(LO,*)'SIGCDF:',SIGCDF(0)
          IF (LPRI.GT.4)
     &    WRITE(LO,*)'SIGDIR:',SIGDIR
          IF (LPRI.GT.4)
     &    WRITE(LO,*)'SIGLSD:',SIGLSD
          IF (LPRI.GT.4)
     &    WRITE(LO,*)'SIGHSD:',SIGHSD
          IF (LPRI.GT.4)
     &    WRITE(LO,*)'SIGLDD:',SIGLDD
          IF (LPRI.GT.4)
     &    WRITE(LO,*)'SIGHDD:',SIGHDD
          IF (LPRI.GT.4)
     &    WRITE(LO,*)'SIGNDF:',SIGNDF

          IF (LPRI.GT.4)
     &    WRITE(LO,*)'SIGPOM:',SIGPOM
          IF (LPRI.GT.4)
     &    WRITE(LO,*)'SIGREG:',SIGREG
          IF (LPRI.GT.4)
     &    WRITE(LO,*)'SIGHAR:',SIGHAR
          IF (LPRI.GT.4)
     &    WRITE(LO,*)'SIGDIR:',SIGDIR
          IF (LPRI.GT.4)
     &    WRITE(LO,*)'SIGTR1:',SIGTR1
          IF (LPRI.GT.4)
     &    WRITE(LO,*)'SIGTR2:',SIGTR2
          IF (LPRI.GT.4)
     &    WRITE(LO,*)'SIGLOO:',SIGLOO
          IF (LPRI.GT.4)
     &    WRITE(LO,*)'SIGDPO:',SIGDPO
          IF (LPRI.GT.4)
     &    WRITE(LO,*)'SIG1SO:',SIG1SO
          IF (LPRI.GT.4)
     &    WRITE(LO,*)'SIG1HA:',SIG1HA
        ENDIF
        SIGTAB(77,IE,IP,IDXMPAR) = PTCUT(IP)
        SIGTAB(78,IE,IP,IDXMPAR) = SIGNDF
        AUXFAC = PI2/SIGNDF
        IF(ISWMDL(1).EQ.3) THEN
          DO 133 I=1,4
            AMPCOF(I) = 0.D0
            DO 135 K=1,4
              AMPCOF(I) = AMPCOF(I) + 0.25D0*ELAFAC(K)*CHIFAC(K,I)
 135        CONTINUE
            AMPCOF(I) = AMPCOF(I)*AUXFAC
 133      CONTINUE
        ENDIF
C
*       BMAX=5.D0*SQRT(DBLE(BPOM))
        BMAX=10.D0
        EPTAB(IE,IP,IDXMPAR) = ECM
        CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
C
      ENDIF
C
      DO 160 K=0,KMAX
        DO 170 I=0,IMAX
          PROB(IE,I,K,IP,IDXMPAR) = 0.D0
 170    CONTINUE
 160  CONTINUE
      DO 120 I=1,ICHMAX
        PCHAIN(1,I) = 0.D0
        PCHAIN(2,I) = 0.D0
 120  CONTINUE
C
C  main cross section loop
C**********************************************************
      DO 5000 IB=1,NGAUSO
        B24=XPNT(IB)**2/4.D0
        FAC = XPNT(IB)*WGHT(IB)
C
        IF((ISWMDL(1).EQ.3).OR.(ISWMDL(1).EQ.4)) THEN
C
C  amplitude construction
          DO 525 I=1,4
            AB(1,I)=ZXP(1,I)*EXP(-B24/BXP(1,I))
     &              +ZXR(1,I)*EXP(-B24/BXR(1,I))
            AB(2,I)=ZXH(1,I)*EXP(-B24/BXH(1,I))
            AB(3,I)=-ZXT1A(1,I)*EXP(-B24/BXT1A(1,I))
     &              -ZXT1B(1,I)*EXP(-B24/BXT1B(1,I))
     &              -ZXT2A(1,I)*EXP(-B24/BXT2A(1,I))
     &              -ZXT2B(1,I)*EXP(-B24/BXT2B(1,I))
     &              -ZXL(1,I)*EXP(-B24/BXL(1,I))
            AB(4,I)=ZXDPE(1,I)*EXP(-B24/BXDPE(1,I))
     &              +ZXDPA(1,I)*EXP(-B24/BXDPA(1,I))
     &              +ZXDPB(1,I)*EXP(-B24/BXDPB(1,I))
     &              +ZXDPD(1,I)*EXP(-B24/BXDPD(1,I))
            AB(1,I) = AB(1,I)+AB(3,I)+AB(4,I)
            AB(2,I) = AB(2,I)
            AB(3,I) = 0.D0
            AB(4,I) = 0.D0
* 
 525      CONTINUE
C
          DO 460 I=1,4
            DO 500 K=1,4
              ABSUM2(I,K) = 0.D0
              DO 550 L=1,4
                ABSUM2(I,K) = ABSUM2(I,K) + CHIFAC(L,K)*AB(I,L)
 550          CONTINUE
              ABSUM2(I,K) = 2.D0*ABSUM2(I,K)
 500        CONTINUE
 460      CONTINUE
          DO 600 I=1,4
            CHI2(I) = 0.D0
            DO 650 K=1,4
              CHI2(I) = CHI2(I) + ABSUM2(K,I)
 650        CONTINUE
 600      CONTINUE
C  sums instead of products
          DO 660 I=1,4
            DO 670 KD=1,4
              DTMP = ABS(ABSUM2(I,KD))
              IF(DTMP.LT.1.D-15) THEN
                ABSUM2(I,KD) = -50.D0
              ELSE
                ABSUM2(I,KD) = LOG(DTMP)
              ENDIF
 670        CONTINUE
 660      CONTINUE
C **anfe   Conditional changed to reflect increase in array size
          IF((IMAX.GT.IIMAX).OR.(KMAX.GT.KKMAX)) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,2A,3I6)') 'PHO_PRBDIS: internal field ',
     &        'dimensions too small (IMAX,KMAX,IIMAX,KKMAX):',
     &        IMAX,KMAX,IIMAX,KKMAX
            CALL PHO_ABORT
          ENDIF
          DO 700 KD=1,4
            DO 750 I=1,4
              ABSTMP(I) = ABSUM2(I,KD)
 750        CONTINUE
C  recursive sum
            CHITMP(1) = -ABSUM2(1,KD)
            DO 800 I=0,IMAX
              CHITMP(1) = CHITMP(1)+ABSTMP(1)-FACLOG(I)
              CHITMP(2) = -ABSTMP(2)
              DO 810 K=0,KMAX
                CHITMP(2) = CHITMP(2)+ABSTMP(2)-FACLOG(K)
C  calculation of elastic part
                DTMP = -CHI2(KD)+CHITMP(1)+CHITMP(2)
                IF(DTMP.LT.-30.D0) THEN
                  DTMP = 0.D0
                ELSE
                  DTMP = EXP(DTMP)*FAC*AMPCOF(KD)
                ENDIF
                PROB(IE,I,K,IP,IDXMPAR) = PROB(IE,I,K,IP,IDXMPAR) + DTMP
 810          CONTINUE
 800        CONTINUE
 700      CONTINUE
          PROB(IE,0,0,IP,IDXMPAR) = 0.D0
C
C**********************************************************
        ELSE
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,I3)')
     &      'PHO_PRBDIS:ERROR: invalid setting of ISWMDL(1)',ISWMDL(1)
          STOP
        ENDIF
 5000 CONTINUE

C  debug output
      IF(IDEB(55).GE.15) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/,1X,A,I3,E11.4)')
     &    'PHO_PRBDIS: list of probabilities (uncorrected,IP,ECM)',
     &    IP,ECM
        DO 905 I=0,MIN(IMAX,5)
          DO 915 K=0,MIN(KMAX,5)
            IF(ABS(PROB(IE,I,K,IP,IDXMPAR)).GT.1.D-10 .AND. LPRI.GT.4)
     &        WRITE(LO,'(10X,2I3,5X,E15.8)') I,K,PROB(IE,I,K,IP,IDXMPAR)
 915      CONTINUE
 905    CONTINUE
      ENDIF
C  string probability (uncorrected)
      IF(IDEB(55).GE.5) THEN
        DO 955 I=0,IMAX
          DO 965 K=0,KMAX
            INDX = 2*I+2*K
            IF((INDX.LE.ICHMAX).AND.(INDX.GT.0)) THEN
              PCHAIN(1,INDX) = PCHAIN(1,INDX) + PROB(IE,I,K,IP,IDXMPAR)
            ENDIF
 965      CONTINUE
 955    CONTINUE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,2A,E11.4)') 'PHO_PRBDIS: ',
     &    'list of selected probabilities (uncorr,ECM)',ECM
        IF (LPRI.GT.4)
     &  WRITE(LO,'(10X,A)') 'I,   0HPOM,   1HPOM,   2HPOM'
        DO 183 I=0,IIMAX
          IF(ABS(PROB(IE,I,0,IP,IDXMPAR)).GT.1.D-10 .AND. LPRI.GT.4)
     &      WRITE(LO,'(5X,I4,3E12.4)') I,PROB(IE,I,0,IP,IDXMPAR),
     &      PROB(IE,I,1,IP,IDXMPAR),PROB(IE,I,2,IP,IDXMPAR)
 183    CONTINUE
      ENDIF
C  substract high-mass single and double diffraction
      PROB(IE,1,0,IP,IDXMPAR) = PROB(IE,1,0,IP,IDXMPAR)
     &                 -(SIGHSD(1)+SIGHSD(2)+SIGHDD+SIGCDF(0))/SIGNDF
      PROB(IE,1,0,IP,IDXMPAR) = MAX(0.01,PROB(IE,1,0,IP,IDXMPAR))
C
C  probability check
      CHKSUM = 0.D0
      PRONEG = 0.D0
      AVERI =  0.D0
      AVERK =  0.D0
      AVERL =  0.D0
      AVERM =  0.D0
      AVERN =  0.D0
      SIGMI =  0.D0
      SIGMK =  0.D0
      SIGML =  0.D0
      SIGMM =  0.D0
      DO 1001 I=0,IMAX
        PSOFT(I) = 0.D0
 1001 CONTINUE
      DO 1002 K=0,KMAX
        PHARD(K) = 0.D0
 1002 CONTINUE
      DO 1000 K=0,KMAX
        DO 1010 I=0,IMAX
          TMP = PROB(IE,I,K,IP,IDXMPAR)
          IF(TMP.LT.0.D0) THEN
            IF((IDEB(55).GE.0).AND.(TMP.LT.-EPS)) THEN
              IF (LPRI.GT.4)
     &        WRITE(LO,'(1X,A,4I4,E14.4)')
     &          'PHO_PRBDIS: neg.probability:',
     &              IP,IE,I,K,PROB(IE,I,K,IP,IDXMPAR)
            ENDIF
            PRONEG = PRONEG+TMP
            TMP = 0.D0
          ENDIF
          CHKSUM = CHKSUM+TMP
          AVERI = AVERI+DBLE(I)*TMP
          AVERK = AVERK+DBLE(K)*TMP
          SIGMI = SIGMI+DBLE(I**2)*TMP
          SIGMK = SIGMK+DBLE(K**2)*TMP
          PSOFT(I) = PSOFT(I)+PROB(IE,I,K,IP,IDXMPAR)
          PHARD(K) = PHARD(K)+PROB(IE,I,K,IP,IDXMPAR)
          PROB(IE,I,K,IP,IDXMPAR) = CHKSUM
 1010   CONTINUE
 1000 CONTINUE
C
      IF (LPRI.GT.4 .AND. IDEB(55).GE.1)
     &WRITE(LO,'(/,1X,A,2E15.6)')
     &  'PHO_PRBDIS: first sum of probabilities',CHKSUM,PRONEG
C  cut probabilites output
      IF(IDEB(55).GE.5) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A)') 'list of cut probabilities (uncorr/corr)'
        DO 185 I=1,ICHMAX
          IF(ABS(PCHAIN(1,I)).GT.1.D-10 .AND. LPRI.GT.4)
     &      WRITE(LO,'(5X,I4,2E12.3)') I,PCHAIN(1,I),PCHAIN(1,I)/CHKSUM
 185    CONTINUE
      ENDIF
C  rescaling necessary
      IF(ABS(CHKSUM-1.D0).GT.1.D-15) THEN
        FAC = 1.D0/CHKSUM
        IF (LPRI.GT.4 .AND. IDEB(55).GE.1)
     &  WRITE(LO,'(/,1X,A,E15.6)')
     &    'PHO_PRBDIS: rescaling of probabilities with factor',FAC
        DO 40 K=0,KMAX
          DO 50 I=0,IMAX
            PROB(IE,I,K,IP,IDXMPAR) = PROB(IE,I,K,IP,IDXMPAR)*FAC
  50      CONTINUE
  40    CONTINUE
        AVERI = AVERI*FAC
        AVERK = AVERK*FAC
        AVERL = AVERL*FAC
        AVERM = AVERM*FAC
        SIGMI = SIGMI*FAC**2
        SIGMK = SIGMK*FAC**2
        SIGML = SIGML*FAC**2
        SIGMM = SIGMM*FAC**2
      ENDIF
C
C  probability to find Reggeon/Pomeron
      PROB(IE,0,0,IP,IDXMPAR) = -SIGREG/(SIGPOM+SIGREG)
      AVERJ = -PROB(IE,0,0,IP,IDXMPAR)*AVERI
      AVERII = AVERI-AVERJ
C
      SIGTAB(74,IE,IP,IDXMPAR) = AVERII
      SIGTAB(75,IE,IP,IDXMPAR) = AVERK
      SIGTAB(76,IE,IP,IDXMPAR) = AVERJ
C
      SIGTAB(79,IE,IP,IDXMPAR) = PROB(IE,IMAX,0,IP,IDXMPAR)*SIGNDF
      SIGTAB(80,IE,IP,IDXMPAR) = SIGNDF-SIGTAB(79,IE,IP,IDXMPAR)
C
      IF(IDEB(55).GE.1) THEN

C  average interaction probabilities
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,/1X,A)')
     &    'PHO_PRBDIS: expected interaction statistics',
     &    '-------------------------------------------'
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,E12.4,2I3)')
     &    'energy,IP,table index:',EPTAB(IE,IP,IDXMPAR),IP,IE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,2I4)') 'current limitations (soft,hard):',
     &    IMAX,KMAX
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,E12.4/,4X,A,/,1X,6E11.3)')
     &    'averaged number of cuts per event (eff. cs):',SIGNDF,
     &    ' (Pom / Pom-h / Reg / enh-tri-loop / enh-dble / sum):',
     &    AVERII,AVERK,AVERJ,AVERL,AVERM,
     &    AVERI+AVERK+AVERL+AVERM
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,/,4X,A,/,1X,4E11.3)')
     &    'standard deviation ( sqrt(sigma) ):',
     &    ' (Pomeron / Pomeron-h / enh-tri-loop / enh-dble):',
     &    SQRT(ABS(SIGMI-AVERI**2)),SQRT(ABS(SIGMK-AVERK**2)),
     &    SQRT(ABS(SIGML-AVERL**2)),SQRT(ABS(SIGMM-AVERM**2))
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A)') 'cross section / probability  soft, hard'
        DO I=0,MIN(IMAX,KMAX)
          IF (LPRI.GT.4)
     &    WRITE(LO,'(I5,2E15.7,3X,2E15.7)')
     &      I,PSOFT(I)*SIGNDF,PSOFT(I),PHARD(I)*SIGNDF,PHARD(I)
        ENDDO

C  cross check of probability distribution and inclusive cross section
        PSsum_1 = 0.D0
        PSsum_2 = 0.D0
        PHsum_1 = 0.D0
        PHsum_2 = 0.D0
        do i=1,IMAX
          PSsum_1 = PSsum_1+PSOFT(i)*FAC
          PSsum_2 = PSsum_2+PSOFT(i)*FAC*dble(i)
        enddo
        do k=1,KMAX
          PHsum_1 = PHsum_1+PHARD(k)
          PHsum_2 = PHsum_2+PHARD(k)*FAC*dble(k)
        enddo
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1x,a,2E12.4,3X,2E12.4)') 'sum:',
     &    PSsum_2*SIGNDF,PSsum_1,PHsum_2*SIGNDF,PHsum_1

      ENDIF

      END


 
 


CDECK  ID>, PHO_PRESEL
      SUBROUTINE PHO_PRESEL(MODE,IREJ)
C**********************************************************************
C
C     user specific function to pre-select events during generation
C
C     input:   MODE  5  electron and photon kinematics
C                   10  process and number of cut Pomerons
C                   15  partons without construction of strings
C                   20  partons assigned to strings
C                   25  after fragmentation, complete final state
C
C     output:  IREJ  0  event accepted
C                   50  event rejected
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

C  global event kinematics and particle IDs
      INTEGER IFPAP,IFPAB
      DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
      COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)

C  gamma-lepton or gamma-hadron vertex information
      INTEGER IGHEL,IDPSRC,IDBSRC
      DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
     &                 RADSRC,AMSRC,GAMSRC
      COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
     &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
     &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)

C  hard scattering data
      INTEGER MSCAHD
      PARAMETER ( MSCAHD = 1000 )
      INTEGER LSCAHD,LSC1HD,LSIDX,
     &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
      DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
      COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
     &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
     &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
     &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
     &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
     &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
     &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)

C  event weights and generated cross section
      INTEGER IPOWGC,ISWCUT,IVWGHT
      DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
      COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
     &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)


      IREJ = 0

*     XBJ = GQ2(2)/(GGECM**2+GQ2(2))
*     IF(XBJ.LT.0.002D0) IREJ = 1

      END


 
 


CDECK  ID>, PHO_PREVNT
      SUBROUTINE PHO_PREVNT(NPART)
C**********************************************************************
C
C     print all information of event generation and history
C
C     input:        NPART  -1   minimal output: process IDs
C                           0   additional output of /POEVT1/
C                           1   additional output of /POSTRG/
C                           2   additional output of /HEPEVT/
C                               (call LULIST(1))
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  global event kinematics and particle IDs
      INTEGER IFPAP,IFPAB
      DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
      COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)

C  general process information
      INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
      COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)


C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
      INTEGER IDEQP,IDEQB,IHFLD,IHFLS
      DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
      COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
     &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)

      CHARACTER*15 PHO_PNAME

      IF (LPRI.GT.4 .AND. NPART.GE.0)
     &WRITE(LO,'(/)')
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A,1PE10.3)')
     &  'PHO_PREVNT: c.m. energy',ECM
      CALL PHO_SETPAR(-2,IH,NPART,0.D0)
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,A,/1X,I10,10I6)')
     &  'EV-CALL,ISPOM,IHPOM,ISREG,IHDIR,KSTRG,',
     &  'KHTRG,KSLOO,KHLOO,KSDPO,KHDPO',
     &  KEVENT,KSPOM,KHPOM,KSREG,KHDIR,KSTRG,KHTRG,KSLOO,KHLOO,KSDPO,
     &  KHDPO
      IF (LPRI.GT.4)
     &WRITE(LO,'(6X,A,I4,4I3)')
     &  'PROCESS-ID,IDNODF,IDIFF1,IDIFF2,IDDPOM',IPROCE,IDNODF,IDIFR1,
     &  IDIFR2,IDDPOM

      IF(IPAMDL(13).GT.0) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A)') 'PHO_PREVNT: DPMJET special settings:'
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,1P,4E11.3)') 'ECMN,PCMN,SECM,SPCM',
     &    ECMN,PCMN,SECM,SPCM
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,1P,2E11.3)') 'XPSUB,XTSUB',XPSUB,XTSUB
      ENDIF

      IF(NPART.LT.0) RETURN

      IF(NPART.GE.1) CALL PHO_PRSTRG

      IF (LPRI.GT.4)
     &WRITE(LO,'(/1X,A)') 'COMMON /POEVT1/:'
      ICHAS  = 0
      IBARFS = 0
      IMULC  = 0
      IMUL   = 0
      IF (LPRI.GT.4)
     &WRITE(LO,'(/1X,A,A,/,1X,A,A)')
     &  '   NO  IST    NAME         MO-1 MO-2 DA-1 DA-2  CHA  BAR',
     &  '  IH1  IH2  CO1  CO2',
     &  '========================================================',
     &  '===================='
      DO 20 IH=1,NHEP
        CH = DBLE(IPHO_CHR3(IH,2)/3.D0)
        BA = DBLE(IPHO_BAR3(IH,2)/3.D0)
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,2I5,1X,A15,4I5,2F5.1,2I5,2I5)')
     &    IH,ISTHEP(IH),PHO_PNAME(IH,2),
     &    JMOHEP(1,IH),JMOHEP(2,IH),JDAHEP(1,IH),JDAHEP(2,IH),
     &    CH,BA,IPHIST(1,IH),IPHIST(2,IH),
     &    ICOLOR(1,IH),ICOLOR(2,IH)
        IF(ABS(ISTHEP(IH)).EQ.1) THEN
          ICHAS  = ICHAS  + IPHO_CHR3(IH,2)
          IBARFS = IBARFS + IPHO_BAR3(IH,2)
        ENDIF
        IF(ABS(ISTHEP(IH)).EQ.1) THEN
          IF(IPHO_CHR3(IH,2).NE.0) IMULC = IMULC+1
          IMUL = IMUL+1
        ENDIF
   20 CONTINUE
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,2(3X,A,I3),2X,2(5X,A,I5))') 'sum charge:',ICHAS/3,
     &  'baryon:',IBARFS/3,'chr.mult:',IMULC,'tot.mult:',IMUL

      IF (LPRI.GT.4)
     &WRITE(LO,7)
      PXS    = 0.D0
      PYS    = 0.D0
      PZS    = 0.D0
      P0S    = 0.D0
      DO 30 IN=1,NHEP
        IF(     (ABS(PHEP(3,IN)).LT.99999.D0)
     &     .AND.(PHEP(4,IN).LT.99999.D0)) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,8) IN,ISTHEP(IN),PHO_PNAME(IN,2),
     &      (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
        ELSE
          IF (LPRI.GT.4)
     &    WRITE(LO,11) IN,ISTHEP(IN),PHO_PNAME(IN,2),
     &      (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
        ENDIF
        IF(ABS(ISTHEP(IN)).EQ.1) THEN
          PXS = PXS + PHEP(1,IN)
          PYS = PYS + PHEP(2,IN)
          PZS = PZS + PHEP(3,IN)
          P0S = P0S + PHEP(4,IN)
        ENDIF
   30 CONTINUE
      AMFS = P0S**2-PXS**2-PYS**2-PZS**2
      AMFS = SIGN(SQRT(ABS(AMFS)),AMFS)
      IF(P0S.LT.99999.D0) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,10) '      sum:    ',PXS,PYS,PZS,P0S,AMFS
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,12) '      sum:    ',PXS,PYS,PZS,P0S,AMFS
      ENDIF
      IF (LPRI.GT.4)
     &WRITE(LO,'(//)')

C   5 FORMAT(2X,8H NUMBER ,8H STATUS ,8H IDENT. ,
C    &  8H 1.MOTH.,8H 2.MOTH.,8H 1.DAUG.,8H L.DAUG.,
C    &  8H CHARGE ,8H BARYON ,/)
C   6 FORMAT(7I8,2F8.3)
    7 FORMAT(/,2X,' NR STAT NAME        X-MOMENTA',
     &  ' Y-MOMENTA Z-MOMENTA  ENERGY    MASS     PT',/,
     &         2X,'-------------------------------',
     &  '--------------------------------------------')
    8 FORMAT(I5,I4,1X,A15,2F8.3,3F10.3,F8.3)
C   9 FORMAT(I10,14X,5F10.3)
   10 FORMAT(10X,A14,1X,2F8.3,3F10.3)
   11 FORMAT(I5,I4,1X,A15,2F8.2,2F10.1,F10.3,F8.3)
   12 FORMAT(10X,A14,1X,2F8.2,2F10.1,F10.3)

cdh  print event list only in case of debugging
      IF (LPRI.GT.4) THEN
        IF(NPART.GE.2) CALL PYLIST(1)
      ENDIF

      END


 
 


CDECK  ID>, PHO_PRIMKT
      SUBROUTINE PHO_PRIMKT(IMODE,IF,IL,PTCUT,IREJ)
C***********************************************************************
C
C    give primordial kt to partons entering hard scatterings and
C    remants connected to hard parton-parton interactions by color flow
C
C    input:  IMODE   -2   output of statistics
C                    -1   initialization
C                     1   sampling of primordial kt
C            IF           first entry in /POEVT1/ to check
C            IL           last entry in /POEVT1/ to check
C            PTCUT        current value of PTCUT to distinguish
C                         between soft and hard
C
C    output: IREJ     0   success
C                     1   failure
C
C***********************************************************************

      IMPLICIT NONE
      SAVE

      DOUBLE PRECISION DEPS
      PARAMETER ( DEPS = 1.D-15 )

      INTEGER IMODE,IF,IL,IREJ
      DOUBLE PRECISION PTCUT

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

C  data of c.m. system of Pomeron / Reggeon exchange
      INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
      DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
     &                 SIDP,CODP,SIFP,COFP
      COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
     &                SIDP,CODP,SIFP,COFP,NPOSP(2),
     &                IDPDG1,IDBAM1,IDPDG2,IDBAM2

C  hard scattering data
      INTEGER MSCAHD
      PARAMETER ( MSCAHD = 1000 )
      INTEGER LSCAHD,LSC1HD,LSIDX,
     &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
      DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
      COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
     &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
     &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
     &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
     &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
     &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
     &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

      DOUBLE PRECISION PTS,XP,XP2,POLD,PNEW,GA,PP
      DIMENSION PTS(0:2,5),XP(5),
     &  XP2(5,2),POLD(2,2),PNEW(4,2),GA(4),PP(4)

      INTEGER IROTT,IBALT,IBAL,IV,IV2,IRMAX

      PARAMETER (IRMAX=200)
      DIMENSION IROTT(IRMAX),IBALT(5,2),IBAL(2),IV(5),IV2(5,2)

      DOUBLE PRECISION SI,EI,SF,EF,PTOT,EE,XX,YY,ZZ,ANORF,FAC,DEL,PT2,
     &                 DEL2,GAE,GAZ,SID,COD,SIF,COF,ESUM
      INTEGER IROT,I,J,K,NHD,ISTART,INEXT,ICOM

C  debug output
      IF (LPRI.GT.4 .AND. IDEB(10).GE.10)
     .WRITE(LO,'(1X,A,3I4,1P,E11.3)')
     &  'PHO_PRIMKT: called with IMODE,IF,IL,PTCUT',
     &  IMODE,IF,IL,PTCUT

C  give primordial kt to partons engaged in a hard scattering

      IF(IMODE.EQ.1) THEN

        ISTART = IF

 100    CONTINUE

        NHD = 0
        IBAL(1) = 0
        IBAL(2) = 0
        IROT = 0
        ICOM = 0
        DO 110 I=ISTART,IL
          IF(ISTHEP(I).EQ.25) THEN
C  hard scattering number
            NHD = IPHIST(1,I+1)
            ICOM = I
            K = LSIDX(NHD/100)
C  calculate momenta of incoming partons
            POLD(1,1) = XHD(K,1)*ECMP/2.D0
            POLD(2,1) = POLD(1,1)
            POLD(1,2) = -XHD(K,2)*ECMP/2.D0
            POLD(2,2) = -POLD(1,2)
            ISTART = I+3
            GOTO 150
          ENDIF
 110    CONTINUE
        RETURN

 150    CONTINUE

C  search for partons involved in hard interaction
        INEXT = 0
        IROT = 0
        DO 500 I=ISTART,IL
          IF(ABS(ISTHEP(I)).EQ.1) THEN
C  hard scatterd partons (including ISR)
            IF((IPHIST(1,I).EQ.-NHD)
     &         .OR.(IPHIST(1,I).EQ.NHD+1)
     &         .OR.(IPHIST(1,I).EQ.NHD+2)) THEN
              IROT = IROT+1

              IF(IROT.GT.IRMAX) THEN
                IF (LPRI.GT.4)
     &          WRITE(LO,'(1X,/,2A,2I5)') 'PHO_PRIMKT: ',
     &            'no memory left in IROTT, event rejected (max/IROT)',
     &            IRMAX,IROT
                CALL PHO_PREVNT(0)
                IREJ = 1
                RETURN
              ENDIF

              IROTT(IROT) = I
C  hard remnant
            ELSE IF(IPHIST(1,I).EQ.NHD) THEN
              IF(PHEP(3,I).GT.0.D0) THEN
                J = 1
              ELSE
                J = 2
              ENDIF
              IBAL(J) = IBAL(J)+1
              IBALT(IBAL(J),J) = I
              XP2(IBAL(J),J) = PHEP(3,I)/ECMP
              IF(ISWMDL(24).EQ.0) THEN
                IV2(IBAL(J),J) = 0
                IF(IDHEP(I).NE.21) IV2(IBAL(J),J) = ICOLOR(2,I)
              ELSE IF(ISWMDL(24).EQ.1) THEN
                IV2(IBAL(J),J) = -1
              ELSE
                IV2(IBAL(J),J) = 1
              ENDIF
            ENDIF
C  possibly further hard scattering
          ELSE IF(ISTHEP(I).EQ.25) THEN
            INEXT = 1
            ISTART = I
            GOTO 550
          ENDIF
 500    CONTINUE
 550    CONTINUE

C debug output
        if(IDEB(10).ge.15) then
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,2A,I4)') 'PHO_PRIMKT: ',
     &      'hard scattering number: ',NHD/100
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,2A,I5)') 'PHO_PRIMKT: ',
     &      'number of entries to rotate: ',IROT
          DO I=1,IROT
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
     &        'entries to rotate: ',I,IROTT(I)
          ENDDO
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
     &      'number of entries to balance: ',IBAL
          DO J=1,2
            DO I=1,IBAL(J)
              IF (LPRI.GT.4)
     &        WRITE(LO,'(1X,2A,I2,2I5)')
     &          'PHO_PRIMKT: entries to balance (side,no,line)',
     &          J,I,IBALT(I,J)
            ENDDO
          ENDDO
        endif

C  incoming partons (comment lines), skip direct interacting particles
        DO 120 K=1,2
          IF((IDHEP(ICOM+K).NE.22).AND.(IDHEP(ICOM+K).NE.990)) THEN
            IF(PHEP(3,ICOM+K).GT.0.D0) THEN
              J = 1
            ELSE
              J = 2
            ENDIF
            IBAL(J) = IBAL(J)+1
            IBALT(IBAL(J),J) = -ICOM-K
            XP2(IBAL(J),J) = POLD(1,J)/ECMP
            IV2(IBAL(J),J) = -1
          ENDIF
 120    CONTINUE

C  check consistency
        IF((IBAL(1).GT.4).OR.(IBAL(2).GT.4)) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,2A,I10)') 'PHO_PRIMKT: ',
     &      'inconsistent hard scattering remnant for event: ',KEVENT
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,3I4,1P,E11.3)')
     &      'PHO_PRIMKT called with IMODE,IF,IL,PTCUT',
     &      IMODE,IF,IL,PTCUT
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,I4)') 'hard scattering number: ',NHD/100
          DO 390 I=1,IROT
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,A,2I5)') 'entries to rotate',I,IROTT(I)
 390      CONTINUE
          DO 392 J=1,2
            DO 395 I=1,IBAL(J)
              IF (LPRI.GT.4)
     &        WRITE(LO,'(1X,A,I2,2I5)')
     &          'entries to balance (side,no,line)',J,I,IBALT(I,J)
 395        CONTINUE
 392      CONTINUE
          IF(IBAL(1)+IBAL(2).GT.0) CALL PHO_PREVNT(0)
        ENDIF

C  calculate primordial kt

C  something to do?
        IF((IBAL(1).GT.1).OR.(IBAL(2).GT.1)) THEN

C  add transverse momentum (overwrite /POEVT1/ entries)
        DO 200 J=1,2
          IF(IBAL(J).GT.1) THEN
C  sample from truncated distribution
            K = IBAL(J)
            DO 180 I=1,K
              IV(I) = IV2(I,J)
              XP(I) = XP2(I,J)
 180        CONTINUE
 190        CONTINUE
              CALL PHO_SOFTPT(K,PTCUT,PTCUT,XP,IV,PTS)
            IF(PTS(0,K).GE.PARMDL(100)) GOTO 190
C  transform incoming partons of hard scattering
            DEL = ABS(POLD(1,J))+POLD(2,J)
            PT2 = PTS(0,K)**2
            DEL2 = DEL*DEL
            PNEW(1,J) = PTS(1,K)
            PNEW(2,J) = PTS(2,K)
            PNEW(3,J) = (-1)**J*(PT2 - DEL2)/(2.D0*DEL)
            PNEW(4,J) = (DEL2 + PT2)/(2.D0*DEL)
C  spectator partons
            ESUM = 0.D0
            DO 220 I=1,IBAL(J)-1
              K = IBALT(I,J)
              PHEP(1,K) = PHEP(1,K)+PTS(1,I)
              PHEP(2,K) = PHEP(2,K)+PTS(2,I)
              ESUM = ESUM+PHEP(4,K)
 220        CONTINUE
C  long. momentum transfer
            PP(3) = PNEW(3,J) - POLD(1,J)
            PP(4) = PNEW(4,J) - POLD(2,J)
            DO 230 I=1,IBAL(J)-1
              K = IBALT(I,J)
              FAC = PHEP(4,K)/ESUM
              PHEP(3,K) = PHEP(3,K) - FAC*PP(3)
              PHEP(4,K) = PHEP(4,K) - FAC*PP(4)
 230        CONTINUE

C  debug output
            IF(IDEB(10).GE.15) THEN
              IF (LPRI.GT.4)
     &        WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
     &          'old incoming:',J,0.D0,0.D0,(POLD(I,J),I=1,2)
              IF (LPRI.GT.4)
     &        WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
     &          'new incoming:',J,(PNEW(I,J),I=1,4)
            ENDIF

          ELSE
            PNEW(1,J) = 0.D0
            PNEW(2,J) = 0.D0
            PNEW(3,J) = POLD(1,J)
            PNEW(4,J) = POLD(2,J)
          ENDIF
 200    CONTINUE

C  transformation of hard scattering final states (including ISR)

C  old parton c.m. energy
        SI = (POLD(2,1)+POLD(2,2))**2-(POLD(1,1)+POLD(1,2))**2
        EI = SQRT(SI)
C  new parton c.m. energy
        SF = (PNEW(4,1)+PNEW(4,2))**2-(PNEW(1,1)+PNEW(1,2))**2
     &       -(PNEW(2,1)+PNEW(2,2))**2-(PNEW(3,1)+PNEW(3,2))**2
        EF = SQRT(SF)
        FAC = EF/EI
C  debug output
        IF (LPRI.GT.4 .AND. IDEB(10).GE.25)
     &  WRITE(LO,'(1X,A,1P,E12.4)')
     &    'PHO_PRIMKT: scaling factor (E-final/E-initial): ',FAC

C  calculate Lorentz transformation
        GAZ = -(POLD(1,1)+POLD(1,2))/EI
        GAE = (POLD(2,1)+POLD(2,2))/EI
        DO 240 I=1,4
          GA(I) = (PNEW(I,1)+PNEW(I,2))/EF
 240    CONTINUE
        CALL PHO_ALTRA(GA(4),-GA(1),-GA(2),-GA(3),PNEW(1,1),PNEW(2,1),
     &    PNEW(3,1),PNEW(4,1),PTOT,PP(1),PP(2),PP(3),PP(4))
        PTOT = MAX(DEPS,PTOT)
        COD= PP(3)/PTOT
        SID= SQRT(PP(1)**2+PP(2)**2)/PTOT
        COF= 1.D0
        SIF= 0.D0
        IF(PTOT*SID.GT.1.D-5) THEN
          COF=PP(1)/(SID*PTOT)
          SIF=PP(2)/(SID*PTOT)
          ANORF=SQRT(COF*COF+SIF*SIF)
          COF=COF/ANORF
          SIF=SIF/ANORF
        ENDIF

C  debug output
C  check consistency initial/final configuration before rotation
        IF(IDEB(10).GE.25) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,1P,4E11.3)') 'PHO_PRIMKT: ini. momentum (1):',
     &      0.D0,0.D0,(POLD(I,1)+POLD(I,2),I=1,2)
          DO I=1,4
            PP(I) = 0.D0
          ENDDO
          DO I=1,IROT
            K = IROTT(I)
            DO J=1,4
              PP(J) = PP(J)+PHEP(J,K)
            ENDDO
          ENDDO
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,1P,4E11.3)')
     &      'PHO_PRIMKT: fin. momentum (1):',PP
        ENDIF

C  apply rotation/boost to scattered particles
        DO 400 I=1,IROT
          K = IROTT(I)
          DO 350 J=1,4
            PP(J) = FAC*PHEP(J,K)
 350      CONTINUE
          CALL PHO_ALTRA(GAE,0.D0,0.D0,GAZ,PP(1),PP(2),PP(3),
     &      PP(4),PTOT,PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
          CALL PHO_TRANS(PHEP(1,K),PHEP(2,K),PHEP(3,K),
     &      COD,SID,COF,SIF,XX,YY,ZZ)
          EE = PHEP(4,K)
          CALL PHO_ALTRA(GA(4),GA(1),GA(2),GA(3),XX,YY,ZZ,EE,PTOT,
     &      PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
 400    CONTINUE

C  debug output
C  check consistency initial/final configuration after rotation
        IF(IDEB(10).GE.25) THEN
          DO I=1,4
            PP(I) = PNEW(I,1)+PNEW(I,2)
          ENDDO
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,1P,4E11.3)')
     &      'PHO_PRIMKT: ini. momentum (2):',PP
          DO I=1,4
            PP(I) = 0.D0
          ENDDO
          DO I=1,IROT
            K = IROTT(I)
            DO J=1,4
              PP(J) = PP(J)+PHEP(J,K)
            ENDDO
          ENDDO
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,1P,4E11.3)')
     &      'PHO_PRIMKT: fin. momentum (2):',PP
        ENDIF

        ENDIF

        IF(INEXT.EQ.1) GOTO 100

C  initialization

      ELSE IF(IMODE.EQ.-1) THEN

C  output of statistics etc.

      ELSE IF(IMODE.EQ.-2) THEN

C  something wrong

      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,I4)')
     &    'PHO_PRIMKT:ERROR: invalid value of IMODE:',IMODE
        CALL PHO_ABORT
      ENDIF

      END


 
 


CDECK  ID>, PHO_PRSTRG
      SUBROUTINE PHO_PRSTRG
C**********************************************************************
C
C     print information of /POSTRG/
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

C  color string configurations including collapsed strings and hadrons
      INTEGER MSTR
      PARAMETER (MSTR=2000)
      INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
      COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
     &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
     &                NNCH(MSTR),IBHAD(MSTR),ISTR


      IF (LPRI.GT.4)
     &WRITE(LO,'(/,1X,A,I5)')
     &  'PHO_PRSTRG: number of strings soft+hard:',ISTR
      IF (LPRI.GT.4)
     &WRITE(LO,'(/,1X,A/,1X,A)') 'COMMON /POSTRG/:',
     &  ' NOBAM  ID1  ID2  ID3  ID4     NPO1/2/3/4        MASS'
      IF (LPRI.GT.4)
     &WRITE(LO,'(1X,A)')
     &  ' ======================================================='
      DO 800 I=1,ISTR
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,9I5,1P,E11.3)')
     &         NCODE(I),IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),NPOS(1,I),
     &         NPOS(2,I),NPOS(3,I),NPOS(4,I),PHEP(5,NPOS(1,I))
 800  CONTINUE

      END


 
 


      DOUBLE PRECISION FUNCTION PHO_PTCUT(ECM,IP)
C***********************************************************************
C
C     calculate energy-dependent transverse momentum cutoff
C
C***********************************************************************

      IMPLICIT NONE
      SAVE

      DOUBLE PRECISION ECM
      INTEGER IP

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)


      SELECT CASE (IPAMDL(7))
      CASE (0)
C  energy-independent cutoff
        PHO_PTCUT = PARMDL(35+IP)
      CASE (1)
C  Bopp et al. type (DPMJET)
        PHO_PTCUT = PARMDL(35+IP) + 
     &              MAX(0.D0, 0.12D0*(LOG10(ECM/50.D0))**3)
      CASE (2)
C  Gribov-Levin-Ryskin type energy dependence
        PHO_PTCUT = PARMDL(35+IP) + 
     &              0.065D0*EXP(0.9D0*SQRT(2.D0*LOG(ECM)))
      CASE (3)
C  Golec-Biernat-Wusthoff type dependence
        PHO_PTCUT = PARMDL(250)*((ECM + PARMDL(251))/
     &              PARMDL(252))**PARMDL(253)
      CASE DEFAULT
        PHO_PTCUT = 0.D0
        WRITE(LO,*) 'PHO_PTCUT: UNKNOWN MODEL SWITCH',IPAMDL(7)
        CALL PHO_ABORT
      END SELECT

      END


 
 


CDECK  ID>, PHO_QELAST
      SUBROUTINE PHO_QELAST(IPROC,JM1,JM2,IREJ)
C**********************************************************************
C
C     sampling of quasi elastic processes
C
C     input:   IPROC  2   purely elastic scattering
C              IPROC  3   q-ela. omega/omega/phi/pi+pi- production
C              IPROC  4   double pomeron scattering
C              IPROC  -1  initialization
C              IPROC  -2  output of statistics
C              JM1/2      index of initial particle 1/2
C
C     output:  initial and final particles in /POEVT1/ involving
C              polarized resonances in /POEVT1/ and decay
C              products
C
C              IREJ    0  successful
C                      1  failure
C                     50  user rejection
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( NTAB = 20,
     &            EPS  = 1.D-10,
     &            PIMASS = 0.13D0,
     &            DEPS = 1.D-10)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  global event kinematics and particle IDs
      INTEGER IFPAP,IFPAB
      DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
      COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)

C  c.m. kinematics of diffraction
      INTEGER NPOSD
      DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
     &                 SIDD,CODD,SIFD,COFD,PDCMS
      COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
     &                SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

C  cross sections
      INTEGER IPFIL,IFAFIL,IFBFIL
      DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
     &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
     &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
     &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
     &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
      COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
     &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
     &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
     &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
     &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
     &                IPFIL,IFAFIL,IFBFIL

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

      DOUBLE PRECISION P,PK1,PK2,PMI,RMASS
      DIMENSION   P(4,2),PK1(5),PK2(5),PMI(2),RMASS(2)
      DIMENSION   IFL(2),IDPRO(4)
      CHARACTER*15 pho_pname
      CHARACTER*8  VMESA(0:4),VMESB(0:4)
      DIMENSION   ISAMVM(4,4)
      DOUBLE PRECISION PHO_PMASS
      EXTERNAL         PHO_PMASS
      DATA IDPRO / 113,223,333,92 /
      DATA VMESA / 'vmeson  ','rho     ','omega   ','phi     ',
     &             'pi+pi-  ' /
      DATA VMESB / 'vmeson  ','rho     ','omega   ','phi     ',
     &             'pi+pi-  ' /

C  sampling of elastic/quasi-elastic processes
      IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
        IREJ = 0
        NPOSD(1) = JM1
        NPOSD(2) = JM2
        DO 55 I=1,2
          PMI(I) = PHEP(5,NPOSD(I))
          IF(PMI(I).LT.0.1D0) PMI(I) = 0.765D0
 55     CONTINUE
C  get CM system
        PK1(1) = PHEP(1,JM1)+PHEP(1,JM2)
        PK1(2) = PHEP(2,JM1)+PHEP(2,JM2)
        PK1(3) = PHEP(3,JM1)+PHEP(3,JM2)
        PK1(4) = PHEP(4,JM1)+PHEP(4,JM2)
        SS = (PK1(4)+PK1(3))*(PK1(4)-PK1(3))-PK1(1)**2-PK1(2)**2
        ECMD = SQRT(SS)

        IF(ECMD.LE.PMI(1)+PMI(2)) THEN
          IF (LPRI.GT.4 .AND. IDEB(34).GE.3)
     &    WRITE(LO,'(1X,A,I12,3E12.4)')
     &      'PHO_QELAST: too small mass (EV,ECM,M1,M2)',KEVENT,
     &      ECMD,PMI
          IREJ = 5
          RETURN
        ENDIF

        DO 60 I=1,4
          GAMBED(I) = PK1(I)/ECMD
 60     CONTINUE
        CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
     &           PHEP(1,NPOSD(1)),PHEP(2,NPOSD(1)),PHEP(3,NPOSD(1)),
     &           PHEP(4,NPOSD(1)),PTOT1,PK1(1),PK1(2),PK1(3),PK1(4))
C  rotation angles
        CODD = PK1(3)/PTOT1
        SIDD = SQRT(PK1(1)**2+PK1(2)**2)/PTOT1
        COFD = 1.D0
        SIFD = 0.D0
        IF(PTOT1*SIDD.GT.1.D-5) THEN
          COFD = PK1(1)/(SIDD*PTOT1)
          SIFD = PK1(2)/(SIDD*PTOT1)
          ANORF = SQRT(COFD*COFD+SIFD*SIFD)
          COFD = COFD/ANORF
          SIFD = SIFD/ANORF
        ENDIF
C  get CM momentum
        AM12 = PMI(1)**2
        AM22 = PMI(2)**2
        PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)

C  production process of mother particles
        IGEN = IPHIST(2,NPOSD(1))
        if(IGEN.eq.0) IGEN = IPROC

        ICALL = ICALL + 1
C  main rejection label
 50     CONTINUE
C  determine process and final particles
        IFL(1) = IDHEP(NPOSD(1))
        IFL(2) = IDHEP(NPOSD(2))
        IF(IPROC.EQ.3) THEN
          ITRY = 0
 100      CONTINUE
          ITRY = ITRY+1
          IF(ITRY.GT.50) THEN
            IF (LPRI.GT.4 .AND. IDEB(34).GE.3)
     &      WRITE(LO,'(1X,A,I12,I5,E12.4)')
     &        'PHO_QELAST: mass rejection (EV,ITRY,ECM)',KEVENT,
     &        ITRY,ECMD
            IREJ = 5
            RETURN
          ENDIF
          XI = DT_RNDM(PCMD)*SIGVM(0,0)-DEPS
          DO 110 I=1,4
            DO 120 J=1,4
              XI = XI-SIGVM(I,J)
              IF(XI.LE.0.D0) GOTO 130
 120        CONTINUE
 110      CONTINUE
 130      CONTINUE
          IF(IFL(1).EQ.22) IFL(1) = IDPRO(I)
          IF(IFL(2).EQ.22) IFL(2) = IDPRO(J)
          ISAMVM(I,J) = ISAMVM(I,J)+1
          ISAMQE = ISAMQE+1
C  sample new masses
          CALL PHO_SAMASS(IFL(1),RMASS(1))
          CALL PHO_SAMASS(IFL(2),RMASS(2))
          IF(RMASS(1)+RMASS(2).GE.ECMD) GOTO 100
        ELSE IF(IPROC.EQ.2) THEN
          I = 0
          J = 0
          ISAMEL = ISAMEL+1
          RMASS(1) = PHO_PMASS(NPOSD(1),2)
          RMASS(2) = PHO_PMASS(NPOSD(2),2)
        ELSE
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,I6)') 'PHO_QELAST:ERROR: invalid IPROC',IPROC
          CALL PHO_ABORT
        ENDIF
C  sample momentum transfer
        CALL PHO_DIFSLP(0,0,I,J,RMASS(1),RMASS(2),RMASS(1),TT,
     &    SLWGHT,IREJ)
        IF (LPRI.GT.4 .AND. IDEB(34).GE.5)
     &  WRITE(LO,'(1X,A,2I6,I3,3E11.3)')
C  calculate new momenta
     &    'PHO_QELAST: IF1,2,T,RM1,RM2',IFL,IPROC,TT,RMASS
        CALL PHO_DIFKIN(RMASS(1),RMASS(2),TT,PK1,PK2,IREJ)
        IF(IREJ.NE.0) GOTO 50
        DO K=1,4
          P(K,1) = PK1(K)
          P(K,2) = PK2(K)
        ENDDO
C  comment line for elastic/quasi-elastic scattering
        CALL PHO_REGPAR(35,IPROC,0,NPOSD(1),NPOSD(2),RMASS(1),RMASS(2),
     &    TT,ECMD,IFL(1),IFL(2),IDHEP(NPOSD(1)),IDHEP(NPOSD(2)),ICPOS,1)

        I1 = NHEP+1
C  fill /POEVT1/
        DO 200 I=1,2
          K = 3-I
          IF((IFL(I).EQ.92).OR.(IFL(I).EQ.91)) THEN
C  pi+/pi- isotropic background
            IGEN = 3
            CALL PHO_REGPAR(1,113,0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
     &        P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
            ICOLOR(I,ICPOS) = IPOS
            CALL PHO_SDECAY(IPOS,0,-2)
          ELSE
C  registration
            IGEN = 2
            if(IFL(I).ne.IDHEP(NPOSD(I))) IGEN = 3
            CALL PHO_REGPAR(1,IFL(I),0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
     &        P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
            ICOLOR(I,ICPOS) = IPOS
          ENDIF
 200    CONTINUE
        I2 = NHEP
C  search for vector mesons
        DO 300 I=I1,I2
C  decay according to polarization
          IF((IDHEP(JMOHEP(1,I)).EQ.22).AND.(ISWMDL(21).GE.0)) THEN
            ISP = IPAMDL(3)
            IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
            CALL PHO_SDECAY(I,ISP,2)
          ENDIF
 300    CONTINUE
        I2 = NHEP
C  back transformation
        CALL PHO_LTRHEP(I1,I2,CODD,SIDD,COFD,SIFD,GAMBED(4),GAMBED(1),
     &              GAMBED(2),GAMBED(3))

C  initialization of tables
      ELSE IF(IPROC.EQ.-1) THEN
        DO 10 I=1,4
          DO 20 J=1,4
            ISAMVM(I,J) = 0
 20       CONTINUE
 10     CONTINUE
        ISAMEL = 0
        ISAMQE = 0
        IF(IFPAP(1).NE.22) VMESA(1) = PHO_PNAME(IFPAP(1),1)
        IF(IFPAP(2).NE.22) VMESB(1) = PHO_PNAME(IFPAP(2),1)
        CALL PHO_SAMASS(-1,RMASS(1))
        ICALL = 0

C  output of statistics
      ELSE IF(IPROC.EQ.-2) THEN
        IF(ICALL.LT.10) RETURN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/,1X,A,I10/,1X,A)')
     &    'PHO_QELAST: statistics of (quasi-)elastic processes',ICALL,
     &    '---------------------------------------------------'
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I10)')
     &    'sampled elastic processes:',ISAMEL
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I10)')
     &    'sampled quasi-elastic vectormeson production:',ISAMQE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(15X,4(4X,A))') (VMESB(I),I=1,4)
        DO 30 I=1,4
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,4I12)') VMESA(I),(ISAMVM(I,K),K=1,4)
 30     CONTINUE
        CALL PHO_SAMASS(-2,RMASS(1))
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,2A,I3)') 'PHO_QELAST:ERROR: ',
     &    'unknown process ID',IPROC
        CALL PHO_ABORT
      ENDIF

      END


 
 


CDECK  ID>, PHO_QPMPDF
      SUBROUTINE PHO_QPMPDF(IQ,X,SCALE2,PTREF,PVIRT,FXP)
C***************************************************************
C
C     contribution to photon PDF from box graph
C     (Bethe-Heitler process)
C
C     input:      IQ       quark flavour
C                 SCALE2   scale (GeV**2, positive)
C                 PTREF    reference scale (GeV, positive)
C                 X        parton momentum fraction
C                 PVIRT    photon virtuality (GeV**2, positive)
C                 FXP      x*f(x,Q**2), x times parton density
C
C***************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  internal rejection counters
      INTEGER NMXJ
      PARAMETER (NMXJ=60)
      CHARACTER*10 REJTIT
      INTEGER IFAIL
      COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

      DIMENSION QM(6)
      DATA QM / 0.2D0,0.25D0,0.5D0,1.5D0,4.5D0,174.D0 /

      FXP = 0.D0
      I = ABS(IQ)
C
*     QM2 = MAX(QM(I),PTREF)**2
*     QM2 = MAX(QM2,PVIRT)
*     BBE = (1.D0-X)*SCALE2
*     IF(BBE.LE.0.D0) THEN
*       IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
*    &    'PHO_QPMPDF: over mass limit (X,Q2,P2,QM)',X,SCALE2,
*    &    PVIRT,QM(I)
*     ENDIF
*     FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(2.D0*137.D0*PI)
*    &  *((X**2+(1.D0-X)**2)*LOG(BBE/(QM2*X))+8.D0*X*(1.D0-X)-1.D0)
C  Bethe-Heitler process approximation for 2*x*p2/q2 << 1
      QM2 = MAX(QM(I),PTREF)**2
      W2 = SCALE2/X*(1.D0-X-X*PVIRT/SCALE2)
      IF(W2.GT.4.D0*QM2) THEN
        BE = SQRT(1.D0-4.D0*QM2/W2)
        BP = SQRT(1.D0+BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
        BM = SQRT(1.D0-BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
*       FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(137.D0*PI)*(BE*(-1.D0
        FXP = X*Q_ch2(I)*3.D0/(137.D0*PI)*(BE*(-1.D0
     &         +6.D0*X-6.D0*X*X)+2.D0*X*X*((2.D0*QM2-PVIRT)/SCALE2
     &         -4.D0*QM2*QM2/SCALE2**2)*(1.D0/BM-1.D0/BP)
     &         +(X*X+(1.D0-X)**2+X*(1-3.D0*X)*4.D0*QM2/SCALE2
     &         -X*X*8.D0*QM2*QM2/SCALE2**2)*LOG(BP/BM))
      ELSE
        IF (LPRI.GT.4 .AND. IDEB(27).GE.5)
     .  WRITE(LO,'(1X,A,4E10.3)')
     &    'PHO_QPMPDF: under mass limit (X,Q2,P2,QM)',X,SCALE2,
     &    PVIRT,QM(I)
      ENDIF
C  debug output
      IF (LPRI.GT.4 .AND. IDEB(27).GE.20)
     .WRITE(LO,'(1X,A,I3,1P,5E10.3)')
     &  'PHO_QPMPDF: X,Q2,P2,QM',I,X,SCALE2,PVIRT,QM(I),FXP
      END






      SUBROUTINE PHO_READPDS0 (Nu)
C***************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

      CHARACTER Line*80
      INTEGER ipdsformat
      PARAMETER (MXX = 201, MXQ = 40, MXF = 6, MaxVal=4)
      PARAMETER (MXPQX = (MXF+1+MaxVal) * MXQ * MXX)
      DOUBLE PRECISION qv(0:mxq)

      COMMON
     > / CtqPar1 / qBase,XV(0:MXX),TV(0:MXQ),UPD(MXPQX), AlsCTEQ(0:mxq)
     > / CtqPar2 / Nx, Nt, NfMx, MxVal
     > / XQrange / Qini, Qmax, Xmin
     > / Masstbl / Amass(6)
     > / QCDtbl /  AlfaQ, Qalfa, Ipk, Iorder, Nfl !for external use
     > /Setchange/ Isetch, ipdsset, ipdsformat

      Read  (Nu, '(A)') Line
      Read  (Nu, '(A)') Line

      if (Line(1:11) .eq. '  ipk, Ordr') then !post-CT10 .pds format;
c Set alphas(MZ) at scale Zm, quark masses, and evolution type
        ipdsformat = 10           !Post-CT10 .pds format
        Read (Nu, *) ipk, Dr, Qalfa, AlfaQ, (amass(i),i=1,6) 
        Iorder = Nint(Dr)        
        read (Nu, '(A)') Line
        if (Line(1:7) .eq. '  IMASS' ) then
          ipdsformat = 11         !CT14 .pds format
          read (Nu, *) aimass, fswitch, N0, N0, N0, Nfmx, MxVal
          Nfl=Nfmx
        else                      !Pre-CT14 format
          Read  (Nu, *) N0, N0, N0, NfMx, MxVal
        endif                     !Line(1:7)
        
      else                        !old .pds format;      
        ipdsformat = 6            !CTEQ6.6 .pds format; alpha_s  is not specified        
        Read (Nu, *) Dr, fl, Alambda, (amass(i),i=1,6)  !set Lambda_QCD
        Iorder = Nint(Dr); Nfl = Nint(fl)

        Read  (Nu, '(A)') Line
        Read  (Nu, *) dummy,dummy,dummy, NfMx, MxVal, N0
      endif                       !Line(1:11...
      
      Read  (Nu, '(A)') Line
      Read  (Nu, *) NX,  NT, N0, NG, N0
      
      if (ng.gt.0) Read  (Nu, '(A)') (Line, i=1,ng+1)

      Read  (Nu, '(A)') Line
      if (ipdsformat.ge.11) then  !CT14 format with alpha_s values
        Read  (Nu, *) QINI, QMAX, (qv(i),TV(I), AlsCTEQ(I), I =0, NT)
      else                        !pre-CT14 format
        Read  (Nu, *) QINI, QMAX, (qv(i),TV(I), I =0, NT)
      endif                       !ipdsformat.ge.11

c check that qBase is consistent with the definition of Tv(0:nQ) for 2 values of Qv
      qbase1 = Qv(1)/Exp(Exp(Tv(1)))
      qbase2 = Qv(nT)/Exp(Exp(Tv(NT)))
      if (abs(qbase1-qbase2).gt.1e-5) then
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A)') 'PHO_READPDS0: something wrong with qbase'
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A)')'qbase1, qbase2=',qbase1,qbase2
        stop
      else
        qbase=(qbase1+qbase2)/2.0d0
      endif                     !abs(qbase1...

      Read  (Nu, '(A)') Line
      Read  (Nu, *) XMIN, aa, (XV(I), I =1, NX)
      XV(0)=0D0
      
      Nblk = (NX+1) * (NT+1)
      Npts =  Nblk  * (NfMx+1+MxVal)
      Read  (Nu, '(A)') Line
      Read  (Nu, *, IOSTAT=IRET) (UPD(I), I=1,Npts)

      Return
C                        ****************************
      END


 
 


CDECK  ID>, PHO_REGFLA
      SUBROUTINE PHO_REGFLA(JM1,JM2,IFLR1,IFLR2,IREJ)
C**********************************************************************
C
C     selection of reggeon flavours
C
C     input:    JM1,JM2      position index of mother hadrons
C
C     output:   IFLR1,IFLR2  valence flavours according to
C                            PDG conventions and JM1,JM2
C               IREJ         0  reggeon possible
C                            1  reggeon impossible
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( EPS    =  0.1D0,
     &            DEPS   =  1.D-15)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
      INTEGER IDEQP,IDEQB,IHFLD,IHFLS
      DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
      COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
     &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)


      IF(JM1.GT.0) THEN
        IREJ = 0
        ITER = 0
C  available energy
        E1   = SQRT((PHEP(4,JM1)+PHEP(4,JM2))**2
     &             -(PHEP(1,JM1)+PHEP(1,JM2))**2
     &             -(PHEP(2,JM1)+PHEP(2,JM2))**2
     &             -(PHEP(3,JM1)+PHEP(3,JM2))**2)/2.D0
 50     CONTINUE
        ITER = ITER+1
        IF(ITER.GT.50) THEN
          IREJ = 1
C  debug output
          IF (LPRI.GT.4 .AND. IDEB(41).GE.2)
     &    WRITE(LO,'(/1X,A,2I7,1P,E12.4)')
     &      'PHO_REGFLA: rejection, no reggeon found for',
     &      IDHEP(JM1),IDHEP(JM2),E1
          RETURN
        ENDIF

        CALL PHO_VALFLA(JM1,IFLA1,IFLA2,E1,E1)
        CALL PHO_VALFLA(JM2,IFLB1,IFLB2,E1,E1)
        IF(IFLA1.EQ.-IFLB1) THEN
          IFLR1 = IFLA2
          IFLR2 = IFLB2
        ELSE IF(IFLA1.EQ.-IFLB2) THEN
          IFLR1 = IFLA2
          IFLR2 = IFLB1
        ELSE IF(IFLA2.EQ.-IFLB1) THEN
          IFLR1 = IFLA1
          IFLR2 = IFLB2
        ELSE IF(IFLA2.EQ.-IFLB2) THEN
          IFLR1 = IFLA1
          IFLR2 = IFLB1
        ELSE
C  debug output
          IF (LPRI.GT.4 .AND. IDEB(41).GE.25)
     &    WRITE(LO,'(/1X,A,3I4)')
     &      'PHO_REGFLA: int.rejection JM1,JM2,ITRY',JM1,JM2,ITER
          GOTO 50
        ENDIF
C  debug output
        IF (LPRI.GT.4 .AND. IDEB(41).GE.10)
     &  WRITE(LO,'(1X,A,/5X,2I4,2I6,2I5,1PE10.3)')
     &    'PHO_REGFLA: JM1/2,PDG-ID1/2,IFLR1/2,MASS',
     &    JM1,JM2,IDHEP(JM1),IDHEP(JM2),IFLR1,IFLR2,E1
      ELSE IF(JM1.EQ.-1) THEN
C  initialization
      ELSE IF(JM1.EQ.-2) THEN
C  output of statistics
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I10)')
     &    'PHO_REGFLA: invalid mother particle (JM1)',JM1
        CALL PHO_ABORT
      ENDIF

      END


 
 


CDECK  ID>, PHO_REGPAR
      SUBROUTINE PHO_REGPAR(ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4,
     &                  IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE)
C**********************************************************************
C
C     registration of particle in /POEVT1/ and /POEVT2/
C
C     input:    ISTH             status code of particle
C                                 -2     initial parton hard scattering
C                                 -1     parton
C                                  0     string
C                                  1     visible particle (no color)
C                                  2     decayed particle
C               IDPDG            PDG particle ID code
C               IDBAM            CPC particle ID code
C               JM1,JM2          first and second mother index
C               P1..P4           four momentum
C               IPHIS1           extended history information
C                                  IPHIS1<100: JM1 from particle 1
C                                  IPHIS1>100: JM1 from particle 2
C                                  1    valence quark
C                                  2    valence diquark
C                                  3    sea quark
C                                  4    sea diquark
C                                  (neg. for antipartons)
C               IPHIS2           extended history information
C                                  positive: JM2 from particle 1
C                                  negative: JM2 from particle 2
C                                  (see IPHIS1)
C               IC1,IC2          color labels for partons
C               IMODE            1  register given parton
C                                0  reset /POEVT1/ and /POEVT2/
C                                2  return data of entry IPOS
C
C               IPOS             position of particle in /POEVT1/
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER (DEPS = 1.D-20)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
      INTEGER  IPHO_PDG2ID
      EXTERNAL IPHO_PDG2ID


      IF(IMODE.EQ.1) THEN
        IF(IDEB(76).GE.26) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,/2X,I3,I6,3I4,4E10.3)')
     &      'PHO_REGPAR: ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4',
     &      ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,/2X,6I6)')
     &      'PHO_REGPAR: IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE',
     &      IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE
        ENDIF
        IF(NHEP.EQ.NMXHEP) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,2A,2I6/)') 'PHO_REGPAR: ',
     &      'no space left in /POEVT1/ (NHEP,NMXHEP):',NHEP,NMXHEP
          CALL PHO_ABORT
        ENDIF
        NHEP = NHEP+1
        IDBAMI = IDBAM
        IDPDGI = IDPDG
        IF(ABS(ISTH).LE.2) THEN
          IF((IDBAM.NE.0).AND.(IDPDG.EQ.0)) THEN
            IDPDGI = IPHO_ID2PDG(IDBAM)
          ELSE IF((IDBAM.EQ.0).AND.(IDPDG.NE.0)) THEN
            IDBAMI = IPHO_PDG2ID(IDPDG)
          ENDIF
        ENDIF
C  standard data
        ISTHEP(NHEP) = ISTH
        IDHEP(NHEP)  = IDPDGI
        JMOHEP(1,NHEP) = JM1
        JMOHEP(2,NHEP) = JM2
C  update of mother-daugther relations
        IF(ABS(ISTH).LE.1) THEN
          IF(JM1.GT.0) THEN
            IF(JDAHEP(1,JM1).EQ.0) THEN
              JDAHEP(1,JM1) = NHEP
              ISTHEP(JM1) = 2
            ENDIF
            JDAHEP(2,JM1) = NHEP
          ENDIF
          IF((JM2.NE.JM1).AND.(JM2.GT.0)) THEN
            IF(JDAHEP(1,JM2).EQ.0) THEN
              JDAHEP(1,JM2) = NHEP
              ISTHEP(JM2) = 2
            ENDIF
            JDAHEP(2,JM2) = NHEP
          ELSE IF(JM2.LT.0) THEN
            DO 100 II=JM1+1,-JM2
              IF(JDAHEP(1,II).EQ.0) THEN
                JDAHEP(1,II) = NHEP
                ISTHEP(II) = 2
              ENDIF
              JDAHEP(2,II) = NHEP
100         CONTINUE
          ENDIF
        ENDIF
        PHEP(1,NHEP) = P1
        PHEP(2,NHEP) = P2
        PHEP(3,NHEP) = P3
        PHEP(4,NHEP) = P4
        IF((ABS(ISTH).LE.3).OR.(ISTH.EQ.20).OR.(ISTH.EQ.21)) THEN
          TMP=(P4-P3)*(P4+P3)-P1**2-P2**2
          PHEP(5,NHEP) = SIGN(SQRT(ABS(TMP)),TMP)
        ELSE
          PHEP(5,NHEP) = 0.D0
        ENDIF
        JDAHEP(1,NHEP) = 0
        JDAHEP(2,NHEP) = 0
C  extended information
        IMPART(NHEP) = IDBAMI
C  extended history information
        IPHIST(1,NHEP) = IPHIS1
        IPHIST(2,NHEP) = IPHIS2
C  charge/baryon number or color labels
        IF(ISTH.EQ.1) THEN
          ICOLOR(1,NHEP) = IPHO_CHR3(NHEP,2)
          ICOLOR(2,NHEP) = IPHO_BAR3(NHEP,2)
        ELSE
          ICOLOR(1,NHEP) = IC1
          ICOLOR(2,NHEP) = IC2
        ENDIF

        IPOS = NHEP
        IF(IDEB(76).GE.26) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,2I4,2X,2I4,E12.3,I5)')
     &      'PHO_REGPAR: IPHIST1/2,IC1/2,MASS,IPOS',IPHIST(1,NHEP),
     &      IPHIST(2,NHEP),ICOLOR(1,NHEP),ICOLOR(2,NHEP),
     &      PHEP(5,NHEP),IPOS
        ENDIF

      ELSE IF(IMODE.EQ.0) THEN
        NHEP   = 0
      ELSE IF(IMODE.EQ.2) THEN
        IF((IPOS.LT.1).OR.(IPOS.GT.NHEP)) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,2A,2I8)') 'PHO_REGPAR: ',
     &      'index out of bounds (NHEP,IPOS)',NHEP,IPOS
          RETURN
        ENDIF
        ISTH  = ISTHEP(IPOS)
        IDPDG = IDHEP(IPOS)
        IDBAM = IMPART(IPOS)
        JM1   = JMOHEP(1,IPOS)
        JM2   = JMOHEP(2,IPOS)
        P1    = PHEP(1,IPOS)
        P2    = PHEP(2,IPOS)
        P3    = PHEP(3,IPOS)
        P4    = PHEP(4,IPOS)
        IPHIS1= IPHIST(1,IPOS)
        IPHIS2= IPHIST(2,IPOS)
        IC1   = ICOLOR(1,IPOS)
        IC2   = ICOLOR(2,IPOS)
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I8)') 'PHO_REGPAR: invalid mode',IMODE
      ENDIF

      END

 
 


CDECK  ID>, PHO_REJSTA
      SUBROUTINE PHO_REJSTA(IMODE)
C********************************************************************
C
C     MC rejection counting
C
C     input IMODE    -1   initialization
C                    -2   output of statistics
C
C********************************************************************

      IMPLICIT NONE
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  internal rejection counters
      INTEGER NMXJ
      PARAMETER (NMXJ=60)
      CHARACTER*10 REJTIT
      INTEGER IFAIL
      COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)

      INTEGER IMODE
      INTEGER I

C  initialization
      IF(IMODE.EQ.-1) THEN
        DO 100 I=1,NMXJ
          IFAIL(I) = 0
 100    CONTINUE
C
        REJTIT(1)  = 'PARTON ALL'
        REJTIT(2)  = 'STDPAR ALL'
        REJTIT(3)  = 'STDPAR DPO'
        REJTIT(4)  = 'POMSCA ALL'
        REJTIT(5)  = 'POMSCA INT'
        REJTIT(6)  = 'POMSCA KIN'
        REJTIT(7)  = 'DIFDIS ALL'
        REJTIT(8)  = 'POSPOM ALL'
        REJTIT(9)  = 'HRES.DIF.1'
        REJTIT(10) = 'HDIR.DIF.1'
        REJTIT(11) = 'HRES.DIF.2'
        REJTIT(12) = 'HDIR.DIF.2'
        REJTIT(13) = 'DIFDIS INT'
        REJTIT(14) = 'HADRON SP2'
        REJTIT(15) = 'HADRON SP3'
        REJTIT(16) = 'HARDIR ALL'
        REJTIT(17) = 'HARDIR INT'
        REJTIT(18) = 'HARDIR KIN'
        REJTIT(19) = 'MCHECK BAR'
        REJTIT(20) = 'MCHECK MES'
        REJTIT(21) = 'DIF.DISS.1'
        REJTIT(22) = 'DIF.DISS.2'
        REJTIT(23) = 'STRFRA ALL'
        REJTIT(24) = 'MSHELL CHA'
        REJTIT(25) = 'PARTPT SOF'
        REJTIT(26) = 'PARTPT HAR'
        REJTIT(27) = 'INTRINS KT'
        REJTIT(28) = 'HACHEK DIR'
        REJTIT(29) = 'HACHEK RES'
        REJTIT(30) = 'STRING ALL'
        REJTIT(31) = 'POMSCA INT'
        REJTIT(32) = 'DIFF SLOPE'
        REJTIT(33) = 'GLU2QU ALL'
        REJTIT(34) = 'MASCOR ALL'
        REJTIT(35) = 'PARCOR ALL'
        REJTIT(36) = 'MSHELL PAR'
        REJTIT(37) = 'MSHELL ALL'
        REJTIT(38) = 'POMCOR ALL'
        REJTIT(39) = 'DB-POM KIN'
        REJTIT(40) = 'DB-POM ALL'
        REJTIT(41) = 'SOFTXX ALL'
        REJTIT(42) = 'SOFTXX PSP'

C  write output
      ELSE IF(IMODE.EQ.-2) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/,1X,A,/,1X,A)') 'PHO_REJSTA: rejection statistics',
     &                             '--------------------------------'
        DO 300 I=1,NMXJ
          IF(IFAIL(I).GT.0 .AND. LPRI.GT.4)
     &      WRITE(LO,'(1X,I3,1X,A,5X,I15)') I,REJTIT(I),IFAIL(I)
 300    CONTINUE
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I3)') 'PHO_REJSTA: invalid mode ',IMODE
      ENDIF

      END


 
 


CDECK  ID>, PHO_RNDBET
      DOUBLE PRECISION FUNCTION PHO_RNDBET(GAM,ETA)
C********************************************************************
C
C     RANDOM NUMBER GENERATION FROM BETA
C     DISTRIBUTION IN REGION  0 < X < 1.
C     F(X) = X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM) / (GAMM(GAM
C                                                        *GAMM(ETA))
C
C********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      Y = PHO_RNDGAM(1.D0,GAM)
      Z = PHO_RNDGAM(1.D0,ETA)

      PHO_RNDBET = Y/(Y+Z)

      END


 
 


CDECK  ID>, PHO_RNDGAM
      DOUBLE PRECISION FUNCTION PHO_RNDGAM(ALAM,ETA)
C********************************************************************
C
C     RANDOM NUMBER SELECTION FROM GAMMA DISTRIBUTION
C     F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)
C
C********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE
C
      NCOU=0
      N = ETA
      F = ETA - N
      IF(F.EQ.0.D0) GOTO 20
   10 R = DT_RNDM(ETA)
      NCOU=NCOU+1
      IF (NCOU.GE.11) GOTO 20
      IF(R.LT.F/(F+2.71828D0)) GOTO 30
      YYY=LOG(DT_RNDM(F)+1.0D-9)/F
      IF(ABS(YYY).GT.50.D0) GOTO 20
      Y = EXP(YYY)
      IF(LOG(DT_RNDM(Y)+1.0D-9).GT.-Y) GOTO 10
      GOTO 40
   20 Y = 0.D0
      GOTO 50
   30 Y = 1.D0-LOG(DT_RNDM(R)+1.0D-9)
      IF(DT_RNDM(Y).GT.Y**(F-1.D0)) GOTO 10
   40 IF(N.EQ.0) GOTO 70
   50 Z = 1.D0
      DO 60 I = 1,N
   60 Z = Z*DT_RNDM(Y)
      Y = Y-LOG(Z+1.0D-9)
   70 PHO_RNDGAM = Y/ALAM
      RETURN

      END

 
 


CDECK  ID>, PHO_RREGPAR
      SUBROUTINE PHO_RREGPAR
c*********************************************************************
c
c     Restore reggeon and pomeron parameter common block according
c     to current multiparticle index
c
c     input:   in /popreg/
c
c     output:  in /pospre/
c
c*********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      SAVE

      INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN
      INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL
      DOUBLE PRECISION SQSGLOBMAX
      PARAMETER (MPARMAX=40)
      PARAMETER (MAXMAPPS=40)
      PARAMETER (IKNOWN=9)
      DIMENSION IPAVAIL(IKNOWN)
      DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/
      COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS),
     &           MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP

      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

      DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
     &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
      COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
     &                ALREG,ALREGP,GR(2),B0REG(2),
     &                GPPP,GPPR,B0PPP,B0PPR,
     &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC

      DOUBLE PRECISION SALPOM,SALPOMP,SGP,SB0POM,SALREG,SALREGP,SGR,
     &  SB0REG,SGPPP,SGPPR,SB0PPP,SB0PPR,SVDMFAC,SVDMQ2F,SB0HAR,SAKFAC,
     &  SPHISUP, SRMASS
      COMMON /POSPRE/ SALPOM(MPARMAX),SALPOMP(MPARMAX),SGP(2,MPARMAX),
     &  SB0POM(2,MPARMAX),SALREG(MPARMAX),SALREGP(MPARMAX),
     &  SGR(2,MPARMAX),SB0REG(2,MPARMAX),SGPPP(MPARMAX),SGPPR(MPARMAX),
     &  SB0PPP(MPARMAX),SB0PPR(MPARMAX),SVDMFAC(4,MPARMAX),
     &  SVDMQ2F(4,MPARMAX),SB0HAR(MPARMAX),SAKFAC(MPARMAX),
     &  SPHISUP(2,MPARMAX),SRMASS(2,MPARMAX)

      DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
      COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC

      
      IF (LPRI.GT.4) Then 
        If (ideb(90) > 10) Write(lo,'(1X,A,I2)') 
     &    'PHO_RREGPAR: Restoring reggeon parameters.', idxmpar 
      End If
      alpom = salpom(idxmpar)
      alpomp = salpomp(idxmpar)
      alreg = salreg(idxmpar)
      alregp = salregp(idxmpar)
      gppp = sgppp(idxmpar)
      gppr = sgppr(idxmpar)
      b0ppp = sb0ppp(idxmpar)
      b0ppr = sb0ppr(idxmpar)
      b0har = sb0har(idxmpar)
      akfac = sakfac(idxmpar)
      Do i=1,2
        gp(i) = sgp(i,idxmpar)
        gr(i) = sgr(i,idxmpar)
        b0pom(i) = sb0pom(i,idxmpar)
        b0reg(i) = sb0reg(i,idxmpar)
      End Do
      Do i=1,4
        vdmfac(i) = svdmfac(i,idxmpar)
        vdmq2f(i) = svdmq2f(i,idxmpar)
      End Do
      Do i=1,2
        phisup(i) = sphisup(i,idxmpar)
        rmass(i) = srmass(i,idxmpar)
      End Do

      END 


 
 


CDECK  ID>, PHO_SAMASS
      SUBROUTINE PHO_SAMASS(IFLA,RMASS)
C**********************************************************************
C
C     resonance mass sampling of quasi elastic processes
C
C     input:   IFLA       PDG number of particle
C              IFLA   -1  initialization
C              IFLA   -2  output of statistics
C
C     output:  RMASS      particle mass (in GeV)
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER(EPS  = 1.D-10 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  parameters of the "simple" Vector Dominance Model
      DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
      COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)

      PARAMETER(NTABM=50)
      DIMENSION XMA(4,NTABM),XMC(4,NTABM),RMA(4,NTABM)
      DIMENSION SUM(4),ICALL(4)
      DOUBLE PRECISION PHO_PMASS
      EXTERNAL         PHO_PMASS

C*****************************************************************
C  initialization of tables
      IF(IFLA.EQ.-1) THEN
C
        NSTEP = NTABM
        DO 102 I=1,4
          ICALL(I) = 0

          DELTAM=(RMAX(I)-RMIN(I))/DBLE(NSTEP-1)
          DO 105 K=1,NSTEP
            RMA(I,K)=RMIN(I)+DELTAM*DBLE(K-1)
 105      CONTINUE
 102    CONTINUE
C  calculate table of dsig/dm
        CALL PHO_DSIGDM(RMA,XMA,NSTEP)
C  output of table
        IF(IDEB(35).GE.1) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/5X,A)') 'table:   mass (GeV)  DSIG/DM (mub/GeV)'
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,/1X,A)')
     &      '  (m,  rho,     m,  omega,      m,   phi,    m,  pi+pi-)',
     &      ' -------------------------------------------------------'
          DO 106 K=1,NSTEP
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMA(1,K),
     &        RMA(2,K),XMA(2,K),RMA(3,K),XMA(3,K),RMA(4,K),XMA(4,K)
 106      CONTINUE
        ENDIF
C  make second table for sampling
        DO 109 I=1,4
          SUM(I) = 0.D0
          DO 108 K=2,NSTEP
            SUM(I) = SUM(I) + (XMA(I,K-1)+XMA(I,K))/2.D0
            XMC(I,K) = SUM(I)
 108      CONTINUE
 109    CONTINUE
C  normalization
        DO 118 K=1,NSTEP
          DO 119 I=1,4
            XMC(I,K) = XMC(I,K)/XMC(I,NSTEP)
 119      CONTINUE
 118    CONTINUE
        IF(IDEB(35).GE.10) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/5X,A)') 'PHO_SAMASS: normalized summed table:'
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,/1X,A)')
     &      '  (m,  rho,     m,  omega,      m,   phi,    m,  pi+pi-)',
     &      ' -------------------------------------------------------'
          DO 120 K=1,NSTEP
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMC(1,K),
     &        RMA(2,K),XMC(2,K),RMA(3,K),XMC(3,K),RMA(4,K),XMC(4,K)
 120      CONTINUE
        ENDIF
C
C**************************************************
C  output of statistics
      ELSE IF(IFLA.EQ.-2) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(2(/1X,A))') 'PHO_SAMASS: statistics',
     &                        '----------------------'
        IF (LPRI.GT.4)
     &  WRITE(LO,'(4(/8X,A,I10))') 'rho:   ',ICALL(1),
     &    'omega: ',ICALL(2),'phi:   ',ICALL(3),'pi+pi-:',ICALL(4)

C
C********************************************************
C  sampling of RMASS
      ELSE
C  quasi-elastic vector meson production
        IF(IFLA.EQ.113) THEN
          KP = 1
        ELSE IF(IFLA.EQ.223) THEN
          KP = 2
        ELSE IF(IFLA.EQ.333) THEN
          KP = 3
        ELSE IF(IFLA.EQ.92) THEN
          KP = 4
C  quasi-elastic production of h*
        ELSE IF(IFLA.EQ.91) THEN
          RMASS = 0.35D0
          RETURN
C  elastic hadron scattering
        ELSE
          RMASS = PHO_PMASS(IFLA,1)
          IF (LPRI.GT.4 .AND. IDEB(35).GE.20)
     &    WRITE(LO,'(1X,A,I7,E12.3)')
     &      'PHO_SAMASS: IFLA,MASS',IFLA,RMASS
          RETURN
        ENDIF
C
C  sample mass of vector mesonsn / two-pi background
        XI = DT_RNDM(RMASS) + EPS
C  binary search
        IF((XMC(KP,1).LE.XI).AND.(XMC(KP,NSTEP).GE.XI)) THEN
          KMIN=1
          KMAX=NSTEP
 300      CONTINUE
          IF((KMAX-KMIN).EQ.1) GOTO 400
          KK=(KMAX+KMIN)/2
          IF(XI.LE.XMC(KP,KK)) THEN
            KMAX=KK
          ELSE
            KMIN=KK
          ENDIF
          GOTO 300
 400      CONTINUE
        ELSE
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A)') 'PHO_SAMASS:ERROR:XI out of range'
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,I7,I6,3E12.4)') 'EVENT,IFLA,XI,XImin,XImax',
     &      KEVENT,IFLA,XI,XMC(KP,1),XMC(KP,NSTEP)
          CALL PHO_ABORT
        ENDIF
C  fine interpolation
        RMASS = RMA(KP,KMIN)+
     &          (RMA(KP,KMAX)-RMA(KP,KMIN))/
     &          (XMC(KP,KMAX)-XMC(KP,KMIN))
     &          *(XI-XMC(KP,KMIN))
        IF(IDEB(35).GE.20) THEN
          IF (LPRI.GT.4 .AND. IDEB(35).GE.25)
     &    WRITE(LO,'(1X,A,3E15.3)')
     &      'PHO_SAMASS: MLEFT,MRIGHT,RMASS',
     &      RMA(KP,KMIN),RMA(KP,KMAX),RMASS
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,I7,E12.3)') 'PHO_SAMASS: IFLA,MASS',
     &      IFLA,RMASS
        ENDIF
        ICALL(KP) = ICALL(KP)+1
      ENDIF

      END

 
 


CDECK  ID>, pho_samp1d
      SUBROUTINE PHO_SAMP1D(IMODE,X_inp,F_inp,F_int,N_dim,X_out)
C***********************************************************************
C
C     Monte Carlo sampling from arbitrary 1d distribution
C     (linear interpolation to improve reproduction of initial function)
C
C     input: IMODE          -1  initialization
C                            1  sampling (after initialization)
C            X_inp(N_dim)   array with x values
C            F_inp(N_dim)   array with function values
C            F_int(N_dim)   array with integral
C
C     output:  X_out        sampled value (Imode=1)
C
C                                                 (R.E. 10/99)
C
C***********************************************************************
      IMPLICIT NONE
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

      INTEGER IMODE,N_dim
      DOUBLE PRECISION X_inp,F_inp,F_int,X_out
      DIMENSION        X_inp(N_dim),F_inp(N_dim),F_int(N_dim)

C  local variables
      INTEGER i
      DOUBLE PRECISION dum,xi,a,b

C  external functions
      DOUBLE PRECISION DT_RNDM
      EXTERNAL DT_RNDM

      if(IMODE.eq.-1) then

C  initialization

        F_int(1) = 0.D0
        do i=2,N_dim
          F_int(i) = F_int(i-1)
     &       +0.5D0*(F_inp(i)+F_inp(i-1))*(X_inp(i)-X_inp(i-1))
        enddo

      else if(IMODE.eq.1) then

C  sample from previously calculated integral

        xi = DT_RNDM(dum)*F_int(N_dim)

        do i=2,N_dim
          if(xi.lt.F_int(i)) then
            a = (F_inp(i)-F_inp(i-1))/(X_inp(i)-X_inp(i-1))
            b = F_inp(i)-a*X_inp(i)
            xi = xi-F_int(i-1)+0.5D0*a*X_inp(i-1)**2+b*X_inp(i-1)
            X_out = (sqrt(b**2+2.D0*a*xi)-b)/a
            return
          endif
        enddo
        X_out = X_inp(N_dim)

      else

C  invalid option Imode

        IF (LPRI.GT.4)
     &  WRITE(LO,'(1x,a,i6)') 'PHO_SAMP1D: invalid option Imode: ',IMODE
        X_out = 0.D0

      endif

      END


 
 


CDECK  ID>, PHO_SAMPRB
      SUBROUTINE PHO_SAMPRB(ECMI,IP,ISAM,JSAM,KSAM)
C********************************************************************
C
C     routine to sample number of cut graphs of different kind
C
C     input:  IP      scattering particle combination
C             ECMI    CMS energy
C             IP      -1         initialization
C                     -2         output of statistics
C                     others     sampling of cuts
C
C     output: ISAM    number of soft Pomerons cut
C             JSAM    number of soft Reggeons cut
C             KSAM    number of hard Pomerons cut
C
C     PHO_PRBDIS has to be called before
C
C********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  current beam selection
      INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN
      INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL
      DOUBLE PRECISION SQSGLOBMAX
      PARAMETER (MPARMAX=40)
      PARAMETER (MAXMAPPS=40)
      PARAMETER (IKNOWN=9)
      DIMENSION IPAVAIL(IKNOWN)
      DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/
      COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS),
     &           MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP

C  general process information
      INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
      COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)

C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
      INTEGER IDEQP,IDEQB,IHFLD,IHFLS
      DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
      COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
     &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)

C  obsolete cut-off information
      DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
      COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN

C  cut probability distribution
      INTEGER IEETA1,IIMAX,KKMAX
      PARAMETER( IEETA1=20, IIMAX=20, KKMAX=500 )
      INTEGER IEEMAX,IMAX,KMAX
      DOUBLE PRECISION EPTAB, PROB
      COMMON /POPROB/ PROB(IEETA1, 0:IIMAX, 0:KKMAX, 4, MPARMAX),
     &          EPTAB(IEETA1, 4, MPARMAX), IEEMAX, IMAX, KMAX

C  global event kinematics and particle IDs
      INTEGER IFPAP,IFPAB
      DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
      COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)

C  cross sections
      INTEGER IPFIL,IFAFIL,IFBFIL
      DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
     &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
     &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
     &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
     &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
      COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
     &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
     &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
     &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
     &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
     &                IPFIL,IFAFIL,IFBFIL

C  table of particle indices for recursive PHOJET calls
      INTEGER MAXIPX
      PARAMETER ( MAXIPX = 500 )
      INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
      COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
     &                IPOIX1,IPOIX2,IPOIX3

C**anfe Common blocks included to provide MAXSOF and MSCAHD params 
C  light-cone x fractions and c.m. momenta of soft cut string ends
      INTEGER MAXSOF
      PARAMETER ( MAXSOF = 2000 )
      INTEGER IJSI2,IJSI1
      DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
      COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
     &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
     &                IJSI1(MAXSOF),IJSI2(MAXSOF)

C  hard scattering data
      INTEGER MSCAHD
      PARAMETER ( MSCAHD = 1000 )
      INTEGER LSCAHD,LSC1HD,LSIDX,
     &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
      DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
      COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
     &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
     &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
     &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
     &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
     &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
     &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)

      DIMENSION ECMS1(4),ECMS2(4),AVERB(0:3,4),AVERC(0:3,4)

C  sample number of interactions
      IF(IP.GE.0) THEN
        ITER = 0
        ECMX = ECMI
        ECMC = ECMI
        KLIM = 1
        IF((IPAMDL(13).GT.0).AND.(IPROCE.EQ.1).AND.(IPOIX3.EQ.0)) THEN
          IF(IPAMDL(16).EQ.0) ECMC = SECM
          KLIM = 0
        ENDIF

C  sample up to kinematic limits only
        IMAX1 = MIN(IMAX,INT(0.4D0*ECMC/PARMDL(161)))
        IF(IMAX1.LT.1) THEN
          IF(IPAMDL(2).EQ.1) THEN
C  reggeon allowed
            ISAM = 0
            JSAM = 1
            KSAM = 0
            AVERB(3,IP) = AVERB(3,IP)+1.D0
          ELSE
C  only pomeron even at very low energies
            ISAM = 1
            JSAM = 0
            KSAM = 0
            AVERB(1,IP) = AVERB(1,IP)+1.D0
          ENDIF
          AVERB(0,IP) = AVERB(0,IP)+1.D0
          GOTO 150
        ENDIF
C  find interpolation factors
        IF(ECMX.LE.EPTAB(1,IP,IDXMPAR)) THEN
          I1 = 1
          I2 = 1
        ELSE IF(ECMX.LT.EPTAB(IEEMAX,IP,IDXMPAR)) THEN
          DO 50 I=2,IEEMAX
            IF(ECMX.LE.EPTAB(I,IP,IDXMPAR)) GOTO 200
 50       CONTINUE
 200      CONTINUE
          I1 = I-1
          I2 = I
        ELSE
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,2E12.3)')
     &      'PHO_SAMPRB:too high energy',ECMX,EPTAB(IEEMAX,IP,IDXMPAR)
          CALL PHO_PREVNT(-1)
          I1 = IEEMAX
          I2 = IEEMAX
        ENDIF
        FAC2 = 0.D0
        IF(I1.NE.I2)
     &    FAC2=LOG(ECMX/EPTAB(I1,IP,IDXMPAR))/
     &         LOG(EPTAB(I2,IP,IDXMPAR)/EPTAB(I1,IP,IDXMPAR))
        FAC1=1.D0-FAC2
C  reggeon probability
        PREG = -(PROB(I1,0,0,IP,IDXMPAR)*FAC1+
     &           PROB(I2,0,0,IP,IDXMPAR)*FAC2)
C  calculate soft suppression factor
        IF(IP.EQ.1) FSUPP = PARMDL(35)**2
     &         /((PVIRT(1)+PARMDL(35))*(PVIRT(2)+PARMDL(35)))
C
 10     CONTINUE
        ITER = ITER+1
        XI = DT_RNDM(FAC2)
        DO 260 KSAM=0,KMAX
          DO 270 ISAM=0,IMAX
            PRO = PROB(I1,ISAM,KSAM,IP,IDXMPAR)*FAC1
     &           +PROB(I2,ISAM,KSAM,IP,IDXMPAR)*FAC2
            IF(PRO.GT.XI) GOTO 100
 270      CONTINUE
 260    CONTINUE
        ISAM = MIN(IMAX,ISAM)
        KSAM = MIN(KMAX,KSAM)

 100    CONTINUE

        IF(ITER.GT.100) THEN

          ISAM = 0
          JSAM = 1
          KSAM = 0
          IF (LPRI.GT.4 .AND. IDEB(12).GE.3)
     &    WRITE(LO,'(1X,A,I10,E11.3,I6)')
     &      'PHO_SAMPRB: rejection (EV,ECM,ITER)',KEVENT,ECMX,ITER

        ELSE

C  reggeon contribution
          JSAM = 0
          IF(IPAMDL(2).EQ.1) THEN
            DO 90 I=1,ISAM
              IF(DT_RNDM(PRO).LT.PREG) JSAM = JSAM+1
 90         CONTINUE
            ISAM = ISAM-JSAM
          ENDIF
C  statistics of bare cuts
          IF(ITER.EQ.1) THEN
            AVERB(0,IP) = AVERB(0,IP)+1.D0
            AVERB(1,IP) = AVERB(1,IP)+DBLE(ISAM)
            AVERB(2,IP) = AVERB(2,IP)+DBLE(KSAM)
            AVERB(3,IP) = AVERB(3,IP)+DBLE(JSAM)
          ENDIF
C  limitation given by field dimensions
C**anfe  Conditional changed according to increased field sizes
          IF((KSAM.GT.MSCAHD).OR.(2*KSAM+JSAM+2*ISAM.GT.MAXSOF)) GOTO 10

          IF(IP.EQ.1) THEN

C  reweight according to virtualities and PDF treatment
            IF(IPAMDL(115).GE.1) THEN
              IF(KSAM.EQ.0) THEN
                IF(FSUP(1)*FSUP(2).LT.DT_RNDM(ECMI)) GOTO 10
              ENDIF
            ENDIF

C  reduce number of cuts according to photon virtualities
            IF(IPAMDL(114).GE.1) THEN
 110          CONTINUE
              I = ISAM+JSAM
              WGX = FSUPP**I
              IF(DT_RNDM(WGX).GT.WGX) THEN
                IF(ISAM+JSAM+KSAM.GT.1) THEN
                  IF(JSAM.GT.0) THEN
                    JSAM = JSAM-1
                    GOTO 110
                  ELSE IF(ISAM.GT.0) THEN
                    ISAM = ISAM-1
                    GOTO 110
                  ENDIF
                ENDIF
              ENDIF
            ENDIF

          ENDIF

C  phase space limitation
 120      CONTINUE
          XM = DBLE(2*ISAM+JSAM)*PARMDL(160+IP)
     &        +DBLE(2*KSAM)*PTCUT(IP)
          PACC = EXP(PARMDL(9)*(PARMDL(160+IP)-XM)/ECMC)
          IF(DT_RNDM(XM).GT.PACC) THEN
            IF(ISAM+JSAM+KSAM.GT.1) THEN
              IF(JSAM.GT.0) THEN
                JSAM = JSAM-1
                GOTO 120
              ELSE IF(ISAM.GT.0) THEN
                ISAM = ISAM-1
                GOTO 120
              ELSE IF(KSAM.GT.KLIM) THEN
                KSAM = KSAM-1
                GOTO 120
              ENDIF
            ENDIF
          ENDIF

        ENDIF

        ISAM = ISAM+JSAM/2
        JSAM = MOD(JSAM,2)
C  collect statistics
 150    CONTINUE
        ECMS1(IP) = ECMS1(IP)+ECMX
        ECMS2(IP) = ECMS2(IP)+ECMC

        AVERC(0,IP) = AVERC(0,IP)+1.D0
        AVERC(1,IP) = AVERC(1,IP)+DBLE(ISAM)
        AVERC(2,IP) = AVERC(2,IP)+DBLE(KSAM)
        AVERC(3,IP) = AVERC(3,IP)+DBLE(JSAM)
C
        IF (LPRI.GT.4 .AND. IDEB(12).GE.10)
     &  WRITE(LO,'(1X,A,2E11.4,3I4)')
     &    'PHO_SAMPRB: ECM,I,J,K',ECM,ECMX,ISAM,JSAM,KSAM
C
C  initialize statistics
      ELSE IF(IP.EQ.-1) THEN
        DO 60 I=1,4
          ECMS1(I) = 0.D0
          ECMS2(I) = 0.D0
          DO 65 K=0,3
            AVERB(K,I) = 0.D0
            AVERC(K,I) = 0.D0
 65       CONTINUE

 60     CONTINUE
        RETURN
C
C  write out statistics
      ELSE IF(IP.EQ.-2) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(2(/1X,A))') 'PHO_SAMPRB: interaction statistics',
     &                        '----------------------------------'
        DO 70 I=1,4
          IF(AVERB(0,I).LT.2.D0) GOTO 75
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,I3,1P,2E13.3)')
     &      'statistics for IP,<Ecm_1>,<Ecm_2>',I,
     &      ECMS1(I)/MAX(AVERB(0,I),1.D0),ECMS2(I)/MAX(AVERB(0,I),1.D0)
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A)')
     &      'average number of s-pom,h-pom,reg cuts (bare)'
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,F12.0,1P3E12.4)') AVERB(0,I),
     &      (AVERB(K,I)/AVERB(0,I),K=1,3)
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A)')
     &      'average (with energy/virtuality corrections)'
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,F12.0,1P3E12.4)') AVERC(0,I),
     &      (AVERC(K,I)/AVERC(0,I),K=1,3)

 75       CONTINUE
 70     CONTINUE
        RETURN
      ENDIF

      END

 
 


CDECK  ID>, PHO_SAMPRO
      SUBROUTINE PHO_SAMPRO(IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB,IPROC)
C***********************************************************************
C
C     routine to sample kind of process
C
C     input:   IP        particle combination
C              IFP1/2    PDG number of particle 1/2
C              ECM       c.m. energy (GeV)
C              PVIR1/2   virtuality of particle 1/2 (GeV**2, positive)
C              SPROB     suppression factor for processes 1-7
C                        due to rapidity gap survival probability
C              IPROC     mode
C                          -2     output of statistics
C                          -1     initialization
C                           0     sampling of process
C
C     output:  IPROC     kind of interaction process:
C                           1  non-diffractive resolved process
C                           2  elastic scattering
C                           3  quasi-elastic rho/omega/phi production
C                           4  central diffraction
C                           5  single diffraction according to IDIFF1
C                           6  single diffraction according to IDIFF2
C                           7  double diffraction
C                           8  single-resolved / direct processes
C
C***********************************************************************

      IMPLICIT NONE
      SAVE

      INTEGER IP,IFP1,IFP2,IPROC
      DOUBLE PRECISION ECM,PVIR1,PVIR2,SPROB

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  cross sections
      INTEGER IPFIL,IFAFIL,IFBFIL
      DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
     &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
     &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
     &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
     &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
      COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
     &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
     &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
     &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
     &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
     &                IPFIL,IFAFIL,IFBFIL

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  general process information
      INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
      COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)

C  event weights and generated cross section
      INTEGER IPOWGC,ISWCUT,IVWGHT
      DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
      COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
     &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)

      DOUBLE PRECISION PRO,XPROB,SIGSDI,CALLS,SIGSUM,ECMSUM
      DIMENSION PRO(8,4),XPROB(8),SIGSDI(2)
      DIMENSION CALLS(4),SIGSUM(4),ECMSUM(4)
      INTEGER I,K,KMAX
      DOUBLE PRECISION DT_RNDM
      DOUBLE PRECISION SIGDDI,SIGHD,SIGHR,SIGNDR,XI

      IF (LPRI.GT.4 .AND. IDEB(11).GE.15)
     &WRITE(LO,'(/,1X,A,/5X,I3,2I6,1P4E11.3)')
     &  'PHO_SAMPRO: called with IP,IFP1/2,ECM,PVIR1/2,SPROB',
     &  IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB

      IF(IPROC.GE.0) THEN

C  interpolate cross sections
        CALL PHO_CSINT(IP,IFP1,IFP2,-1,-1,ECM,PVIR1,PVIR2)

C  cross check
        IF((IP.EQ.1).and.((SPROB.gt.1.D0).or.(SPROB.lt.0.D0))) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/,1X,A,/5X,I12,I3,2I6,1P4E11.3)')
     &      'PHO_SAMPRO: inconsistent gap survival probability',
     &      'EVENT,IP,IFP1/2,ECM,PVIR1/2,SPROB:',
     &      KEVENT,IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB
        ENDIF

C  calculate cumulative probabilities
        IF(ISWMDL(1).EQ.3) THEN
          IF(ISWMDL(2).GE.1) THEN
            SIGSDI(1) = SIGLSD(1)+SIGHSD(1)
            SIGSDI(2) = SIGLSD(2)+SIGHSD(2)
            SIGDDI    = SIGLDD+SIGHDD
            SIGNDR    = SIGINE-SIGVM(0,0)-SIGCDF(0)-SIGDIR
     &                - SIGSDI(1)-SIGSDI(2)-SIGDDI
            XPROB(1)  = SIGNDR*SPROB*DBLE(IPRON(1,IP))
            XPROB(2)  = XPROB(1)+SIGELA*SPROB*DBLE(IPRON(2,IP))
            XPROB(3)  = XPROB(2)+SIGVM(0,0)*SPROB*DBLE(IPRON(3,IP))
            XPROB(4)  = XPROB(3)+SIGCDF(0)*SPROB*DBLE(IPRON(4,IP))
            XPROB(5)  = XPROB(4)+SIGSDI(1)*SPROB*DBLE(IPRON(5,IP))
            XPROB(6)  = XPROB(5)+SIGSDI(2)*SPROB*DBLE(IPRON(6,IP))
            XPROB(7)  = XPROB(6)+SIGDDI*SPROB*DBLE(IPRON(7,IP))
            XPROB(8)  = XPROB(7)+SIGDIR*DBLE(IPRON(8,IP))
          ELSE
            SIGHR = 0.D0
            IF(IPRON(1,IP).EQ.1) SIGHR = SIGHAR
            SIGHD = 0.D0
            IF(IPRON(8,IP).EQ.1) SIGHD = SIGDIR
            XPROB(1) = SIGHR/(SIGHR+SIGHD)
            XPROB(2) = XPROB(1)
            XPROB(3) = XPROB(1)
            XPROB(4) = XPROB(1)
            XPROB(5) = XPROB(1)
            XPROB(6) = XPROB(1)
            XPROB(7) = XPROB(1)
            XPROB(8) = XPROB(1)+SIGHD/(SIGHR+SIGHD)
          ENDIF

          IF(IDEB(11).GE.15) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,A,I3)')
     &        'PHO_SAMPRO: partial cross sections for IP',IP
            IF (LPRI.GT.4)
     &      WRITE(LO,'(5X,I3,2X,1PE12.4)') 1,XPROB(1)
            DO 240 I=2,8
              IF (LPRI.GT.4)
     &        WRITE(LO,'(5X,I3,2X,1PE12.4)') I,XPROB(I)-XPROB(I-1)
 240        CONTINUE
          ENDIF

        ELSE
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/,1X,A,I4)') 'PHO_SAMPRO:ERROR: unsupported model',
     &      ISWMDL(1)
          CALL PHO_ABORT
        ENDIF

        IF(XPROB(8).LT.1.D-20) THEN
          IF(IDEB(11).GE.2 .AND. LPRI.GT.4)
     &      WRITE(LO,'(1X,2A,/10X,A,1P3E11.3)') 'PHO_SAMPRO:ERROR: ',
     &      'activated processes have vanishing cross section sum',
     &      'IP,ECM,SIG_sum:',IP,ECM,XPROB(8)
          IPROC = 0
          RETURN
        ENDIF

C  sample process
        XI = DT_RNDM(XI)*XPROB(8)
        DO 100 I=1,8
          IF(XI.LE.XPROB(I)) GOTO 110
 100    CONTINUE
 110    CONTINUE
        IPROC = MIN(I,8)

        CALLS(IP)     = CALLS(IP)+1.D0
        PRO(IPROC,IP) = PRO(IPROC,IP)+1.D0
        ECMSUM(IP)    = ECMSUM(IP)+ECM
        IF(ISWMDL(2).GE.1) THEN
          SIGSUM(IP) = SIGSUM(IP)+XPROB(8)
        ELSE
          SIGSUM(IP) = SIGSUM(IP)+SIGGEN(3)
        ENDIF

C  debug output
        IF (LPRI.GT.4 .AND. IDEB(11).GE.5)
     &  WRITE(LO,'(1X,A,I3,I12,I4)')
     &    'PHO_SAMPRO: IP,CALL,PROC-ID',
     &    IP,INT(CALLS(IP)+0.1D0),IPROC

C  statistics initialization
      ELSE IF(IPROC.EQ.-1) THEN
        DO 260 K=1,4
          DO 250 I=1,8
            PRO(I,K) = 0.D0
 250      CONTINUE
          CALLS(K)  = 0.D0
          SIGSUM(K) = 0.D0
          ECMSUM(K) = 0.D0
 260    CONTINUE

C  write out statistics
      ELSE IF(IPROC.EQ.-2) THEN
        KMAX = 4
        IF(ISWMDL(2).EQ.0) KMAX=1
        DO 270 K=1,KMAX
          IF(CALLS(K).GT.0.5D0) THEN
            SIGSUM(K) = SIGSUM(K)/CALLS(K)**2
            ECMSUM(K) = ECMSUM(K)/CALLS(K)
            IF(IDEB(11).GE.0) THEN
              IF (LPRI.GT.4)
     &        WRITE(LO,'(/,1X,2A,I4,1PE12.3,/,1X,A)')
     &          'PHO_SAMPRO: internal process statistics ',
     &          '(IP,<Ecm>)',K,ECMSUM(K),
     &          '---------------------------------------'
              IF (LPRI.GT.4)
     &        WRITE(LO,'(8X,A)')
     &          '        process      sampled    cross section'
              IF(ISWMDL(2).GE.1) THEN
                IF (LPRI.GT.4)
     &          WRITE(LO,'(9(/5X,A,0PF12.0,5X,1PE12.3))')
     &            '    all processes',CALLS(K),CALLS(K)*SIGSUM(K),
     &            ' nondif.inelastic',PRO(1,K),PRO(1,K)*SIGSUM(K),
     &            '          elastic',PRO(2,K),PRO(2,K)*SIGSUM(K),
     &            'vmeson production',PRO(3,K),PRO(3,K)*SIGSUM(K),
     &            '   double pomeron',PRO(4,K),PRO(4,K)*SIGSUM(K),
     &            ' single diffr.(1)',PRO(5,K),PRO(5,K)*SIGSUM(K),
     &            ' single diffr.(2)',PRO(6,K),PRO(6,K)*SIGSUM(K),
     &            ' double diffract.',PRO(7,K),PRO(7,K)*SIGSUM(K),
     &            ' direct processes',PRO(8,K),PRO(8,K)*SIGSUM(K)
              ELSE
                IF (LPRI.GT.4)
     &          WRITE(LO,'(3(/5X,A,0PF12.0,5X,1PE12.3))')
     &            '    all processes',CALLS(K),CALLS(K)*SIGSUM(K),
     &            '  double resolved',PRO(1,K),PRO(1,K)*SIGSUM(K),
     &            ' single res + dir',PRO(8,K),PRO(8,K)*SIGSUM(K)
              ENDIF
            ENDIF
          ENDIF
 270    CONTINUE
      ENDIF

      END


 
 


C*********************************************************************

CDECK  ID>, PHO_SASANO
      SUBROUTINE PHO_SASANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)

C*********************************************************************
C...Purpose: to evaluate the parton distributions of the anomalous
C...photon, inhomogeneously evolved from a scale P2 (where it vanishes)
C...to Q2.
C...KF=0 gives the sum over (up to) 5 flavours,
C...KF<0 limits to flavours up to abs(KF),
C...KF>0 is for flavour KF only.
C...ALAM is the 4-flavour Lambda, which is automatically converted
C...to 3- and 5-flavour equivalents as needed.
C*********************************************************************
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

      DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
      DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/

C...Reset output.
      DO 100 KFL=-6,6
      XPGA(KFL)=0.
      VXPGA(KFL)=0.
  100 CONTINUE
      IF(Q2.LE.P2) RETURN
      KFA=ABS(KF)

C...Calculate Lambda; protect against unphysical Q2 and P2 input.
      ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2./27.))**2
      ALAMSQ(4)=ALAM**2
      ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2./23.))**2
      P2EFF=MAX(P2,1.2*ALAMSQ(3))
      IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
      IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
      Q2EFF=MAX(Q2,P2EFF)
      XL=-LOG(X)

C...Find number of flavours at lower and upper scale.
      NFP=4
      IF(P2EFF.LT.PMC**2) NFP=3
      IF(P2EFF.GT.PMB**2) NFP=5
      NFQ=4
      IF(Q2EFF.LT.PMC**2) NFQ=3
      IF(Q2EFF.GT.PMB**2) NFQ=5

C...Define range of flavour loop.
      IF(KF.EQ.0) THEN
        KFLMN=1
        KFLMX=5
      ELSEIF(KF.LT.0) THEN
        KFLMN=1
        KFLMX=KFA
      ELSE
        KFLMN=KFA
        KFLMX=KFA
      ENDIF

C...Loop over flavours the photon can branch into.
      DO 110 KFL=KFLMN,KFLMX

C...Light flavours: calculate t range and (approximate) s range.
      IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
        TDIFF=LOG(Q2EFF/P2EFF)
        S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
     &  LOG(P2EFF/ALAMSQ(NFQ)))
        IF(NFQ.GT.NFP) THEN
          Q2DIV=PMB**2
          IF(NFQ.EQ.4) Q2DIV=PMC**2
          SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
     &    LOG(P2EFF/ALAMSQ(NFQ)))
          SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
     &    LOG(P2EFF/ALAMSQ(NFQ-1)))
          S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
        ENDIF
        IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
          Q2DIV=PMC**2
          SNF4=(6./(33.-2.*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
     &    LOG(P2EFF/ALAMSQ(4)))
          SNF3=(6./(33.-2.*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
     &    LOG(P2EFF/ALAMSQ(3)))
          S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
        ENDIF

C...u and s quark do not need a separate treatment when d has been done.
      ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN

C...Charm: as above, but only include range above c threshold.
      ELSEIF(KFL.EQ.4) THEN
        IF(Q2.LE.PMC**2) GOTO 110
        P2EFF=MAX(P2EFF,PMC**2)
        Q2EFF=MAX(Q2EFF,P2EFF)
        TDIFF=LOG(Q2EFF/P2EFF)
        S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
     &  LOG(P2EFF/ALAMSQ(NFQ)))
        IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
          Q2DIV=PMB**2
          SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
     &    LOG(P2EFF/ALAMSQ(NFQ)))
          SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
     &    LOG(P2EFF/ALAMSQ(NFQ-1)))
          S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
        ENDIF

C...Bottom: as above, but only include range above b threshold.
      ELSEIF(KFL.EQ.5) THEN
        IF(Q2.LE.PMB**2) GOTO 110
        P2EFF=MAX(P2EFF,PMB**2)
        Q2EFF=MAX(Q2,P2EFF)
        TDIFF=LOG(Q2EFF/P2EFF)
        S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
     &  LOG(P2EFF/ALAMSQ(NFQ)))
      ENDIF

C...Evaluate flavour-dependent prefactor (charge^2 etc.).
      CHSQ=1./9.
      IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4./9.
      FAC=AEM2PI*2.*CHSQ*TDIFF

C...Evaluate parton distributions (normalized to unit momentum sum).
      IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
        XVAL= ((1.5+2.49*S+26.9*S**2)/(1.+32.3*S**2)*X**2 +
     &  (1.5-0.49*S+7.83*S**2)/(1.+7.68*S**2)*(1.-X)**2 +
     &  1.5*S/(1.-3.2*S+7.*S**2)*X*(1.-X)) *
     &  X**(1./(1.+0.58*S)) * (1.-X**2)**(2.5*S/(1.+10.*S))
        XGLU= 2.*S/(1.+4.*S+7.*S**2) *
     &  X**(-1.67*S/(1.+2.*S)) * (1.-X**2)**(1.2*S) *
     &  ((4.*X**2+7.*X+4.)*(1.-X)/3. - 2.*X*(1.+X)*XL)
        XSEA= 0.333*S**2/(1.+4.90*S+4.69*S**2+21.4*S**3) *
     &  X**(-1.18*S/(1.+1.22*S)) * (1.-X)**(1.2*S) *
     &  ((8.-73.*X+62.*X**2)*(1.-X)/9. + (3.-8.*X**2/3.)*X*XL +
     &  (2.*X-1.)*X*XL**2)

C...Threshold factors for c and b sea.
        SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
        XCHM=0.
        IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
          SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
          XCHM=XSEA*(1.-(SCH/SLL)**3)
        ENDIF
        XBOT=0.
        IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
          SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
          XBOT=XSEA*(1.-(SBT/SLL)**3)
        ENDIF
      ENDIF

C...Add contribution of each valence flavour.
      XPGA(0)=XPGA(0)+FAC*XGLU
      XPGA(1)=XPGA(1)+FAC*XSEA
      XPGA(2)=XPGA(2)+FAC*XSEA
      XPGA(3)=XPGA(3)+FAC*XSEA
      XPGA(4)=XPGA(4)+FAC*XCHM
      XPGA(5)=XPGA(5)+FAC*XBOT
      XPGA(KFL)=XPGA(KFL)+FAC*XVAL
      VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
  110 CONTINUE
      DO 120 KFL=1,5
      XPGA(-KFL)=XPGA(KFL)
      VXPGA(-KFL)=VXPGA(KFL)
  120 CONTINUE

      END


 
 


C*********************************************************************

CDECK  ID>, PHO_SASBEH
      SUBROUTINE PHO_SASBEH(KF,X,Q2,P2,PM2,XPBH)

C*********************************************************************
C...Purpose: to evaluate the Bethe-Heitler cross section for
C...heavy flavour production.
C*********************************************************************
      SAVE
      DATA AEM2PI/0.0011614/

C...Reset output.
      XPBH=0.
      SIGBH=0.

C...Check kinematics limits.
      IF(X.GE.Q2/(4.*PM2+Q2+P2)) RETURN
      W2=Q2*(1.-X)/X-P2
      BETA2=1.-4.*PM2/W2
      IF(BETA2.LT.1E-10) RETURN
      BETA=SQRT(BETA2)
      RMQ=4.*PM2/Q2

C...Simple case: P2 = 0.
      IF(P2.LT.1E-4) THEN
        IF(BETA.LT.0.99) THEN
          XBL=LOG((1.+BETA)/(1.-BETA))
        ELSE
          XBL=LOG((1.+BETA)**2*W2/(4.*PM2))
        ENDIF
        SIGBH=BETA*(8.*X*(1.-X)-1.-RMQ*X*(1.-X))+
     &  XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)

C...Complicated case: P2 > 0, based on approximation of
C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
      ELSE
        RPQ=1.-4.*X**2*P2/Q2
        IF(RPQ.GT.1E-10) THEN
          RPBE=SQRT(RPQ*BETA2)
          IF(RPBE.LT.0.99) THEN
            XBL=LOG((1.+RPBE)/(1.-RPBE))
            XBI=2.*RPBE/(1.-RPBE**2)
          ELSE
            RPBESN=4.*PM2/W2+(4.*X**2*P2/Q2)*BETA2
            XBL=LOG((1.+RPBE)**2/RPBESN)
            XBI=2.*RPBE/RPBESN
          ENDIF
          SIGBH=BETA*(6.*X*(1.-X)-1.)+
     &    XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)+
     &    XBI*(2.*X/Q2)*(PM2*X*(2.-RMQ)-P2*X)
        ENDIF
      ENDIF

C...Multiply by charge-squared etc. to get parton distribution.
      CHSQ=1./9.
      IF(ABS(KF).EQ.2.OR.ABS(KF).EQ.4) CHSQ=4./9.
      XPBH=3.*CHSQ*AEM2PI*X*SIGBH

      END


 
 


C*********************************************************************

CDECK  ID>, PHO_SASDIR
      SUBROUTINE PHO_SASDIR(X,Q2,P2,Q02,XPGA)

C*********************************************************************
C...Purpose: to evaluate the direct contribution, i.e. the C^gamma term,
C...as needed in MSbar parametrizations.
C*********************************************************************
      SAVE
      DIMENSION XPGA(-6:6)
      DATA PMC/1.3/, PMB/4.6/, AEM2PI/0.0011614/

C...Reset output.
      DO 100 KFL=-6,6
      XPGA(KFL)=0.
  100 CONTINUE

C...Evaluate common x-dependent expression.
      XTMP = (X**2+(1.-X)**2) * (-LOG(X)) - 1.
      CGAM = 3.*AEM2PI*X * (XTMP*(1.+P2/(P2+Q02)) + 6.*X*(1.-X))

C...d, u, s part by simple charge factor.
      XPGA(1)=(1./9.)*CGAM
      XPGA(2)=(4./9.)*CGAM
      XPGA(3)=(1./9.)*CGAM

C...Also fill for antiquarks.
      DO 110 KF=1,5
      XPGA(-KF)=XPGA(KF)
  110 CONTINUE

      END


 
 


CDECK  ID>, PHO_SASGAM
C***********************************************************************
C...SaSgam version 2 - parton distributions of the photon
C...by Gerhard A. Schuler and Torbjorn Sjostrand
C...For further information see Z. Phys. C68 (1995) 607
C...and Phys. Lett. B376 (1996) 193.

C...18 January 1996: original code.
C...22 July 1996: calculation of BETA moved in SASBEH.

C!!!Note that one further call parameter - IP2 - has been added
C!!!to the SASGAM argument list compared with version 1.

C...The user should only need to call the SASGAM routine,
C...which in turn calls the auxiliary routines SASVMD, SASANO,
C...SASBEH and SASDIR. The package is self-contained.

C...One particular aspect of these parametrizations is that F2 for
C...the photon is not obtained just as the charge-squared-weighted
C...sum of quark distributions, but differ in the treatment of
C...heavy flavours (in F2 the DIS relation W2 = Q2*(1-x)/x restricts
C...the kinematics range of heavy-flavour production, but the same
C...kinematics is not relevant e.g. for jet production) and, for the
C...'MSbar' fits, in the addition of a Cgamma term related to the
C...separation of direct processes. Schematically:
C...PDF = VMD (rho, omega, phi) + anomalous (d, u, s, c, b).
C...F2  = VMD (rho, omega, phi) + anomalous (d, u, s) +
C...      Bethe-Heitler (c, b) (+ Cgamma (d, u, s)).
C...The J/psi and Upsilon states have not been included in the VMD sum,
C...but low c and b masses in the other components should compensate
C...for this in a duality sense.

C...The calling sequence is the following:
C     CALL SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
C...with the following declaration statement:
C     DIMENSION XPDFGM(-6:6)
C...and, optionally, further information in:
C     COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
C    &XPDIR(-6:6)
C     COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
C...Input:  ISET = 1 : SaS set 1D ('DIS',   Q0 = 0.6 GeV)
C                = 2 : SaS set 1M ('MSbar', Q0 = 0.6 GeV)
C                = 3 : SaS set 2D ('DIS',   Q0 =  2  GeV)
C                = 4 : SaS set 2M ('MSbar', Q0 =  2  GeV)
C           X : x value.
C           Q2 : Q2 value.
C           P2 : P2 value; should be = 0. for an on-shell photon.
C           IP2 : scheme used to evaluate off-shell anomalous component.
C               = 0 : recommended default, see = 7.
C               = 1 : dipole dampening by integration; very time-consuming.
C               = 2 : P_0^2 = max( Q_0^2, P^2 )
C               = 3 : P_0^2 = Q_0^2 + P^2.
C               = 4 : P_{eff} that preserves momentum sum.
C               = 5 : P_{int} that preserves momentum and average
C                     evolution range.
C               = 6 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
C               = 7 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
C...Output: F2GM : F2 value of the photon (including factors of alpha_em).
C           XPFDGM :  x times parton distribution functions of the photon,
C               with elements 0 = g, 1 = d, 2 = u, 3 = s, 4 = c, 5 = b,
C               6 = t (always empty!), - for antiquarks (result is same).
C...The breakdown by component is stored in the commonblock SASCOM,
C               with elements as above.
C           XPVMD : rho, omega, phi VMD part only of output.
C           XPANL : d, u, s anomalous part only of output.
C           XPANH : c, b anomalous part only of output.
C           XPBEH : c, b Bethe-Heitler part only of output.
C           XPDIR : Cgamma (direct contribution) part only of output.
C...The above arrays do not distinguish valence and sea contributions,
C...although this information is available internally. The additional
C...commonblock SASVAL provides the valence part only of the above
C...distributions. Array names VXPVMD, VXPANL and VXPANH correspond
C...to XPVMD, XPANL and XPANH, while XPBEH and XPDIR are valence only
C...and therefore not given doubly. VXPDGM gives the sum of valence
C...parts, and so matches XPDFGM. The difference, i.e. XPVMD-VXPVMD
C...and so on, gives the sea part only.
C***********************************************************************

      SUBROUTINE PHO_SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)

C***********************************************************************
C...Purpose: to construct the F2 and parton distributions of the photon
C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
C...For F2, c and b are included by the Bethe-Heitler formula;
C...in the 'MSbar' scheme additionally a Cgamma term is added.
C***********************************************************************
      SAVE
      DIMENSION XPDFGM(-6:6)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

      COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
     &XPDIR(-6:6)

      COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)

      SAVE /SASCOM/,/SASVAL/

C...Temporary array.
      DIMENSION XPGA(-6:6), VXPGA(-6:6)
C...Charm and bottom masses (low to compensate for J/psi etc.).
      DATA PMC/1.3/, PMB/4.6/
C...alpha_em and alpha_em/(2*pi).
      DATA AEM/0.007297/, AEM2PI/0.0011614/
C...Lambda value for 4 flavours.
      DATA ALAM/0.20/
C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
      DATA FRACU/0.8/
C...VMD couplings f_V**2/(4*pi).
      DATA FRHO/2.20/, FOMEGA/23.6/, FPHI/18.4/
C...Masses for rho (=omega) and phi.
      DATA PMRHO/0.770/, PMPHI/1.020/
C...Number of points in integration for IP2=1.
      DATA NSTEP/100/

C...Reset output.
      F2GM=0.
      DO 100 KFL=-6,6
      XPDFGM(KFL)=0.
      XPVMD(KFL)=0.
      XPANL(KFL)=0.
      XPANH(KFL)=0.
      XPBEH(KFL)=0.
      XPDIR(KFL)=0.
      VXPVMD(KFL)=0.
      VXPANL(KFL)=0.
      VXPANH(KFL)=0.
      VXPDGM(KFL)=0.
  100 CONTINUE

C...Check that input sensible.
      IF(ISET.LE.0.OR.ISET.GE.5) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,*) ' PHO_SASGAM:FATAL ERROR: called for unknown set'
        IF (LPRI.GT.4)
     &  WRITE(LO,*) ' ISET = ',ISET
        STOP
      ENDIF
      IF(X.LE.0..OR.X.GT.1.) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,*) ' PHO_SASGAM:FATAL ERROR: called for unphysical x'
        IF (LPRI.GT.4)
     &  WRITE(LO,*) ' X = ',X
        STOP
      ENDIF

C...Set Q0 cut-off parameter as function of set used.
      IF(ISET.LE.2) THEN
        Q0=0.6
      ELSE
        Q0=2.
      ENDIF
      Q02=Q0**2

C...Scale choice for off-shell photon; common factors.
      Q2A=Q2
      FACNOR=1.
      IF(IP2.EQ.1) THEN
        P2MX=P2+Q02
        Q2A=Q2+P2*Q02/MAX(Q02,Q2)
        FACNOR=LOG(Q2/Q02)/NSTEP
      ELSEIF(IP2.EQ.2) THEN
        P2MX=MAX(P2,Q02)
      ELSEIF(IP2.EQ.3) THEN
        P2MX=P2+Q02
        Q2A=Q2+P2*Q02/MAX(Q02,Q2)
      ELSEIF(IP2.EQ.4) THEN
        P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
     &  ((Q2+P2)*(Q02+P2)))
      ELSEIF(IP2.EQ.5) THEN
        P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
     &  ((Q2+P2)*(Q02+P2)))
        P2MX=Q0*SQRT(P2MXA)
        FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
      ELSEIF(IP2.EQ.6) THEN
        P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
     &  ((Q2+P2)*(Q02+P2)))
        P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
      ELSE
        P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
     &  ((Q2+P2)*(Q02+P2)))
        P2MX=Q0*SQRT(P2MXA)
        P2MXB=P2MX
        P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
        P2MXB=MAX(0.,1.-P2/Q2)*P2MXB+MIN(1.,P2/Q2)*P2MXA
        FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
      ENDIF

C...Call VMD parametrization for d quark and use to give rho, omega,
C...phi. Note dipole dampening for off-shell photon.
      CALL PHO_SASVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
      XFVAL=VXPGA(1)
      XPGA(1)=XPGA(2)
      XPGA(-1)=XPGA(-2)
      FACUD=AEM*(1./FRHO+1./FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
      FACS=AEM*(1./FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
      DO 110 KFL=-5,5
      XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
  110 CONTINUE
      XPVMD(1)=XPVMD(1)+(1.-FRACU)*FACUD*XFVAL
      XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
      XPVMD(3)=XPVMD(3)+FACS*XFVAL
      XPVMD(-1)=XPVMD(-1)+(1.-FRACU)*FACUD*XFVAL
      XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
      XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
      VXPVMD(1)=(1.-FRACU)*FACUD*XFVAL
      VXPVMD(2)=FRACU*FACUD*XFVAL
      VXPVMD(3)=FACS*XFVAL
      VXPVMD(-1)=(1.-FRACU)*FACUD*XFVAL
      VXPVMD(-2)=FRACU*FACUD*XFVAL
      VXPVMD(-3)=FACS*XFVAL

      IF(IP2.NE.1) THEN
C...Anomalous parametrizations for different strategies
C...for off-shell photons; except full integration.

C...Call anomalous parametrization for d + u + s.
        CALL PHO_SASANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
        DO 120 KFL=-5,5
        XPANL(KFL)=FACNOR*XPGA(KFL)
        VXPANL(KFL)=FACNOR*VXPGA(KFL)
  120   CONTINUE

C...Call anomalous parametrization for c and b.
        CALL PHO_SASANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
        DO 130 KFL=-5,5
        XPANH(KFL)=FACNOR*XPGA(KFL)
        VXPANH(KFL)=FACNOR*VXPGA(KFL)
  130   CONTINUE
        CALL PHO_SASANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
        DO 140 KFL=-5,5
        XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
        VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
  140   CONTINUE

      ELSE
C...Special option: loop over flavours and integrate over k2.
        DO 170 KF=1,5
        DO 160 ISTEP=1,NSTEP
        Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5)/NSTEP)
        IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
     &  (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
        CALL PHO_SASVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
        FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
        IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8./9.)
        IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2./9.)
        DO 150 KFL=-5,5
        IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
        IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
        IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
        IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
  150   CONTINUE
  160   CONTINUE
  170   CONTINUE
      ENDIF

C...Call Bethe-Heitler term expression for charm and bottom.
      CALL PHO_SASBEH(4,X,Q2,P2,PMC**2,XPBH)
      XPBEH(4)=XPBH
      XPBEH(-4)=XPBH
      CALL PHO_SASBEH(5,X,Q2,P2,PMB**2,XPBH)
      XPBEH(5)=XPBH
      XPBEH(-5)=XPBH

C...For MSbar subtraction call C^gamma term expression for d, u, s.
      IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
        CALL PHO_SASDIR(X,Q2,P2,Q02,XPGA)
        DO 180 KFL=-5,5
        XPDIR(KFL)=XPGA(KFL)
  180   CONTINUE
      ENDIF

C...Store result in output array.
      DO 190 KFL=-5,5
      CHSQ=1./9.
      IF(ABS(KFL).EQ.2.OR.ABS(KFL).EQ.4) CHSQ=4./9.
      XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
      IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
      XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
      VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
  190 CONTINUE

      RETURN
      END


 
 


C*********************************************************************

CDECK  ID>, PHO_SASVMD
      SUBROUTINE PHO_SASVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)

C*********************************************************************
C...Purpose: to evaluate the VMD parton distributions of a photon,
C...evolved homogeneously from an initial scale P2 to Q2.
C...Does not include dipole suppression factor.
C...ISET is parton distribution set, see above;
C...additionally ISET=0 is used for the evolution of an anomalous photon
C...which branched at a scale P2 and then evolved homogeneously to Q2.
C...ALAM is the 4-flavour Lambda, which is automatically converted
C...to 3- and 5-flavour equivalents as needed.
C*********************************************************************
      SAVE
      DIMENSION XPGA(-6:6), VXPGA(-6:6)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

      DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/

C...Reset output.
      DO 100 KFL=-6,6
      XPGA(KFL)=0.
      VXPGA(KFL)=0.
  100 CONTINUE
      KFA=ABS(KF)

C...Calculate Lambda; protect against unphysical Q2 and P2 input.
      ALAM3=ALAM*(PMC/ALAM)**(2./27.)
      ALAM5=ALAM*(ALAM/PMB)**(2./23.)
      P2EFF=MAX(P2,1.2*ALAM3**2)
      IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
      IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
      Q2EFF=MAX(Q2,P2EFF)

C...Find number of flavours at lower and upper scale.
      NFP=4
      IF(P2EFF.LT.PMC**2) NFP=3
      IF(P2EFF.GT.PMB**2) NFP=5
      NFQ=4
      IF(Q2EFF.LT.PMC**2) NFQ=3
      IF(Q2EFF.GT.PMB**2) NFQ=5

C...Find s as sum of 3-, 4- and 5-flavour parts.
      S=0.
      IF(NFP.EQ.3) THEN
        Q2DIV=PMC**2
        IF(NFQ.EQ.3) Q2DIV=Q2EFF
        S=S+(6./27.)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
      ENDIF
      IF(NFP.LE.4.AND.NFQ.GE.4) THEN
        P2DIV=P2EFF
        IF(NFP.EQ.3) P2DIV=PMC**2
        Q2DIV=Q2EFF
        IF(NFQ.EQ.5) Q2DIV=PMB**2
        S=S+(6./25.)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
      ENDIF
      IF(NFQ.EQ.5) THEN
        P2DIV=PMB**2
        IF(NFP.EQ.5) P2DIV=P2EFF
        S=S+(6./23.)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
      ENDIF

C...Calculate frequent combinations of x and s.
      X1=1.-X
      XL=-LOG(X)
      S2=S**2
      S3=S**3
      S4=S**4

C...Evaluate homogeneous anomalous parton distributions below or
C...above threshold.
      IF(ISET.EQ.0) THEN
      IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
     &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
        XVAL = X * 1.5 * (X**2+X1**2)
        XGLU = 0.
        XSEA = 0.
      ELSE
        XVAL = (1.5/(1.-0.197*S+4.33*S2)*X**2 + (1.5+2.10*S)/
     &  (1.+3.29*S)*X1**2 + 5.23*S/(1.+1.17*S+19.9*S3)*X*X1) *
     &  X**(1./(1.+1.5*S)) * (1.-X**2)**(2.667*S)
        XGLU = 4.*S/(1.+4.76*S+15.2*S2+29.3*S4) *
     &  X**(-2.03*S/(1.+2.44*S)) * (X1*XL)**(1.333*S) *
     &  ((4.*X**2+7.*X+4.)*X1/3. - 2.*X*(1.+X)*XL)
        XSEA = S2/(1.+4.54*S+8.19*S2+8.05*S3) *
     &  X**(-1.54*S/(1.+1.29*S)) * X1**(2.667*S) *
     &  ((8.-73.*X+62.*X**2)*X1/9. + (3.-8.*X**2/3.)*X*XL +
     &  (2.*X-1.)*X*XL**2)
      ENDIF

C...Evaluate set 1D parton distributions below or above threshold.
      ELSEIF(ISET.EQ.1) THEN
      IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
     &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
        XVAL = 1.294 * X**0.80 * X1**0.76
        XGLU = 1.273 * X**0.40 * X1**1.76
        XSEA = 0.100 * X1**3.76
      ELSE
        XVAL = 1.294/(1.+0.252*S+3.079*S2) * X**(0.80-0.13*S) *
     &  X1**(0.76+0.667*S) * XL**(2.*S)
        XGLU = 7.90*S/(1.+5.50*S) * EXP(-5.16*S) *
     &  X**(-1.90*S/(1.+3.60*S)) * X1**1.30 * XL**(0.50+3.*S) +
     &  1.273 * EXP(-10.*S) * X**0.40 * X1**(1.76+3.*S)
        XSEA = (0.1-0.397*S2+1.121*S3)/(1.+5.61*S2+5.26*S3) *
     &  X**(-7.32*S2/(1.+10.3*S2)) *
     &  X1**((3.76+15.*S+12.*S2)/(1.+4.*S))
        XSEA0 = 0.100 * X1**3.76
      ENDIF

C...Evaluate set 1M parton distributions below or above threshold.
      ELSEIF(ISET.EQ.2) THEN
      IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
     &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
        XVAL = 0.8477 * X**0.51 * X1**1.37
        XGLU = 3.42 * X**0.255 * X1**2.37
        XSEA = 0.
      ELSE
        XVAL = 0.8477/(1.+1.37*S+2.18*S2+3.73*S3) * X**(0.51+0.21*S)
     &  * X1**1.37 * XL**(2.667*S)
        XGLU = 24.*S/(1.+9.6*S+0.92*S2+14.34*S3) * EXP(-5.94*S) *
     &  X**((-0.013-1.80*S)/(1.+3.14*S)) * X1**(2.37+0.4*S) *
     &  XL**(0.32+3.6*S) + 3.42 * EXP(-12.*S) * X**0.255 *
     &  X1**(2.37+3.*S)
        XSEA = 0.842*S/(1.+21.3*S-33.2*S2+229.*S3) *
     &  X**((0.13-2.90*S)/(1.+5.44*S)) * X1**(3.45+0.5*S) *
     &  XL**(2.8*S)
        XSEA0 = 0.
      ENDIF

C...Evaluate set 2D parton distributions below or above threshold.
      ELSEIF(ISET.EQ.3) THEN
      IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
     &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
        XVAL = X**0.46 * X1**0.64 + 0.76 * X
        XGLU = 1.925 * X1**2
        XSEA = 0.242 * X1**4
      ELSE
        XVAL = (1.+0.186*S)/(1.-0.209*S+1.495*S2) * X**(0.46+0.25*S)
     &  * X1**((0.64+0.14*S+5.*S2)/(1.+S)) * XL**(1.9*S) +
     &  (0.76+0.4*S) * X * X1**(2.667*S)
        XGLU = (1.925+5.55*S+147.*S2)/(1.-3.59*S+3.32*S2) *
     &  EXP(-18.67*S) * X**((-5.81*S-5.34*S2)/(1.+29.*S-4.26*S2))
     &  * X1**((2.-5.9*S)/(1.+1.7*S)) * XL**(9.3*S/(1.+1.7*S))
        XSEA = (0.242-0.252*S+1.19*S2)/(1.-0.607*S+21.95*S2) *
     &  X**(-12.1*S2/(1.+2.62*S+16.7*S2)) * X1**4 * XL**S
        XSEA0 = 0.242 * X1**4
      ENDIF

C...Evaluate set 2M parton distributions below or above threshold.
      ELSEIF(ISET.EQ.4) THEN
      IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
     &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
        XVAL = 1.168 * X**0.50 * X1**2.60 + 0.965 * X
        XGLU = 1.808 * X1**2
        XSEA = 0.209 * X1**4
      ELSE
        XVAL = (1.168+1.771*S+29.35*S2) * EXP(-5.776*S) *
     &  X**((0.5+0.208*S)/(1.-0.794*S+1.516*S2)) *
     &  X1**((2.6+7.6*S)/(1.+5.*S)) * XL**(5.15*S/(1.+2.*S)) +
     &  (0.965+22.35*S)/(1.+18.4*S) * X * X1**(2.667*S)
        XGLU = (1.808+29.9*S)/(1.+26.4*S) * EXP(-5.28*S) *
     &  X**((-5.35*S-10.11*S2)/(1.+31.71*S)) *
     &  X1**((2.-7.3*S+4.*S2)/(1.+2.5*S)) *
     &  XL**(10.9*S/(1.+2.5*S))
        XSEA = (0.209+0.644*S2)/(1.+0.319*S+17.6*S2) *
     &  X**((-0.373*S-7.71*S2)/(1.+0.815*S+11.0*S2)) *
     &  X1**(4.+S) * XL**(0.45*S)
        XSEA0 = 0.209 * X1**4
      ENDIF
      ENDIF

C...Threshold factors for c and b sea.
      SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
      XCHM=0.
      IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
        SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
        IF(ISET.EQ.0) THEN
          XCHM=XSEA*(1.-(SCH/SLL)**2)
        ELSE
          XCHM=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SCH/SLL)
        ENDIF
      ENDIF
      XBOT=0.
      IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
        SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
        IF(ISET.EQ.0) THEN
          XBOT=XSEA*(1.-(SBT/SLL)**2)
        ELSE
          XBOT=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SBT/SLL)
        ENDIF
      ENDIF

C...Fill parton distributions.
      XPGA(0)=XGLU
      XPGA(1)=XSEA
      XPGA(2)=XSEA
      XPGA(3)=XSEA
      XPGA(4)=XCHM
      XPGA(5)=XBOT
      XPGA(KFA)=XPGA(KFA)+XVAL
      DO 110 KFL=1,5
      XPGA(-KFL)=XPGA(KFL)
  110 CONTINUE
      VXPGA(KFA)=XVAL
      VXPGA(-KFA)=XVAL

      RETURN
      END


 
 


CDECK  ID>, PHO_SCALES
      SUBROUTINE PHO_SCALES(XM1,XM2,XM3,XM4,SCG1,SCG2,SCB1,SCB2)
C**********************************************************************
C
C     calculation of scale factors
C              (mass dependent couplings and slopes)
C
C     input:   XM1..XM4     external masses
C
C     output:  SCG1,SCG2    scales of coupling constants
C              SCB1,SCB2    scales of coupling slope parameter
C
C*********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( EPS  = 1.D-3 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  Reggeon phenomenology parameters
      DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
     &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
      COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
     &                ALREG,ALREGP,GR(2),B0REG(2),
     &                GPPP,GPPR,B0PPP,B0PPR,
     &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC

C  parameters of 2x2 channel model
      DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
      COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC

C  data of c.m. system of Pomeron / Reggeon exchange
      INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
      DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
     &                 SIDP,CODP,SIFP,COFP
      COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
     &                SIDP,CODP,SIFP,COFP,NPOSP(2),
     &                IDPDG1,IDBAM1,IDPDG2,IDBAM2

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)


C  scale factors for couplings
      ECMMIN = 2.D0
*     ECMTP = 6.D0
      ECMTP = 1.D0
      IF(ABS(XM1-XM3).GT.EPS) THEN
        IF(ECMP.LT.ECMTP) THEN
          SCG1 = PHISUP(1)*LOG(ECMP**2/ECMMIN)/LOG(ECMTP**2/ECMMIN)
        ELSE
          SCG1 = PHISUP(1)
        ENDIF
      ELSE
        SCG1 = 1.D0
      ENDIF
      IF(ABS(XM2-XM4).GT.EPS) THEN
        IF(ECMP.LT.ECMTP) THEN
          SCG2 = PHISUP(2)*LOG(ECMP**2/ECMMIN)/LOG(ECMTP**2/ECMMIN)
        ELSE
          SCG2 = PHISUP(2)
        ENDIF
      ELSE
        SCG2 = 1.D0
      ENDIF
C
C  scale factors for slope parameters
      IF((ISWMDL(1).LT.2).OR.(IPAMDL(10).EQ.1)) THEN
        SCB1 = 1.D0
        SCB2 = 1.D0
      ELSE IF(ISWMDL(1).EQ.2) THEN
C  rational
        SCB1 = 2.D0*PMASSP(1)**2/(XM1**2+XM3**2)
        SCB2 = 2.D0*PMASSP(2)**2/(XM2**2+XM4**2)
      ELSE IF(ISWMDL(1).GE.3) THEN
C  symmetric gaussian
        SCB1 = VAR*(XM1-XM3)**2
        IF(SCB1.LT.25.D0) THEN
          SCB1 = EXP(-SCB1)
        ELSE
          SCB1 = 0.D0
        ENDIF
        SCB2 = VAR*(XM2-XM4)**2
        IF(SCB2.LT.25.D0) THEN
          SCB2 = EXP(-SCB2)
        ELSE
          SCB2 = 0.D0
        ENDIF
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/,1X,A,I4)') 'PHO_SCALES:ERROR:invalid ISWMDL(1)',
     &    ISWMDL(1)
        CALL PHO_ABORT
      ENDIF
C  debug output
      IF(IDEB(65).GE.10) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,4E11.3)') 'PHO_SCALES: M1..M4 ',
     &       XM1,XM2,XM3,XM4
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,4E11.3)') 'SCB1,SCB2,SCG1,SCG2',
     &       SCB1,SCB2,SCG1,SCG2
      ENDIF

      END

 
 


CDECK  ID>, PHO_SDECAY
      SUBROUTINE PHO_SDECAY(NPOS,ISP,ILEV)
C**********************************************************************
C
C     decay of single resonance of /POEVT1/:
C       decay in helicity frame according to polarization, isotropic
C       decay and decay with limited transverse phase space possible
C
C     ATTENTION:
C     reference to particle number of CPC has to exist
C
C     input:   NPOS    position in /POEVT1/
C              ISP     0  decay according to phase space
C                      1  decay according to transversal polarization
C                      2  decay according to longitudinal polarization
C                      3  decay with limited phase space
C              ILEV    decay mode to use
C                      1 strong only
C                      2 strong and ew of tau, charm, and bottom
C                      3 strong and electro-weak decays
C                      negative: remove mother resonance after decay
C
C     output:  /POEVT1/,/POEVT2/ final particles according to decay mode
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( EPS  = 1.D-15,
     &            DEPS = 1.D-10 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

C  general particle data
      DOUBLE PRECISION xm_list,tau_list,gam_list,
     &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
     &  xm_bb82_list,xm_bb102_list
      INTEGER          ich3_list,iba3_list,iq_list,
     &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
      COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
     &  xm_psm2_list(6,6),xm_vem2_list(6,6),
     &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
     &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
     &  ich3_list(300),iba3_list(300),iq_list(3,300),
     &  id_psm_list(6,6),id_vem_list(6,6),
     &  id_b8_list(6,6,6),id_b10_list(6,6,6)

C  particle decay data
      DOUBLE PRECISION wg_sec_list
      INTEGER          idec_list,isec_list
      COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
     &  isec_list(3,500)

C  auxiliary data for three particle decay
      DOUBLE PRECISION ECM,PCM,COD,COF,SIF
      COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
      DOUBLE PRECISION PHO_PMASS
      EXTERNAL         PHO_PMASS
      INTEGER  IPHO_ANTI
      EXTERNAL IPHO_ANTI

      DIMENSION WGHD(20),KCH(20),ID(3)

      IMODE = ABS(ILEV)
      IF (LPRI.GT.4 .AND. IDEB(36).GE.15)
     &WRITE(LO,'(1X,A,3I5)')
     &  'PHO_SDECAY: NPOS,ISP,ILEV',NPOS,ISP,ILEV

C  comment entry
      IF(ISTHEP(NPOS).GT.11) RETURN

C  particle stable?
      IDcpc = IMPART(NPOS)
      IF(IDcpc.EQ.0) return
      IDabs = abs(IDcpc)
      if(idec_list(1,IDabs).eq.0) return

C  different decay modi (times)
      IF(IMODE.EQ.1) THEN
        if(idec_list(1,IDabs).ne.1) return
      ELSE IF(IMODE.EQ.2) THEN
        if(idec_list(1,IDabs).gt.2) return
      ELSE IF(IMODE.EQ.3) THEN
        if(idec_list(1,IDabs).gt.3) return
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,I5)') 'PHO_SDECAY: invalid mode (ILEV)',ILEV
        CALL PHO_ABORT
      ENDIF

C  decay products, check for mass limitations
      K = 0
      WGSUM = 0.D0
      AMIST = PHEP(5,NPOS)
      DO 100 I=idec_list(2,IDabs),idec_list(3,IDabs)
        AMSUM = 0.D0
        DO 200 L=1,3
          ID(L) = isec_list(L,I)
          IF(ID(L).NE.0) AMSUM = AMSUM+PHO_PMASS(ID(L),0)
 200    CONTINUE
        IF(AMSUM.LT.AMIST) THEN
          K = K+1
          WGHD(K) = wg_sec_list(I)
          KCH(K) = I
        ENDIF
 100  CONTINUE
      IF(K.EQ.0)THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,I6,3E12.4)')
     &    'PHO_SDECAY: particle mass too small (NPOS,MA,DCYM)',
     &    NPOS,AMIST,AMSUM
        CALL PHO_PREVNT(0)
        RETURN
      ENDIF

C  sample new decay channel
      XI = (DT_RNDM(AMSUM)-EPS)*WGSUM
      K = 0
      WGSUM = 0.D0
 500  CONTINUE
        K = K+1
        WGSUM = WGSUM+WGHD(K)
      IF(XI.GT.WGSUM) GOTO 500
      IK = KCH(K)
      ID(1) = isec_list(1,IK)
      ID(2) = isec_list(2,IK)
      ID(3) = isec_list(3,IK)
      if(IDcpc.lt.0) then
        ID(1) = IPHO_ANTI(ID(1))
        ID(2) = IPHO_ANTI(ID(2))
        if(ID(3).ne.0) ID(3) = IPHO_ANTI(ID(3))
      endif

C  rotation
      PTOT = SQRT(PHEP(1,NPOS)**2+PHEP(2,NPOS)**2+PHEP(3,NPOS)**2)
      CXS = PHEP(1,NPOS)/PTOT
      CYS = PHEP(2,NPOS)/PTOT
      CZS = PHEP(3,NPOS)/PTOT
C  boost
      GBET = PTOT/AMIST
      GAM = PHEP(4,NPOS)/AMIST

      IF(ID(3).EQ.0) THEN
C  two particle decay
        CALL PHO_SDECY2(AMIST,PHO_PMASS(ID(1),0),PHO_PMASS(ID(2),0),ISP)
      ELSE
C  three particle decay
        CALL PHO_SDECY3(AMIST,PHO_PMASS(ID(1),0),PHO_PMASS(ID(2),0),
     &    PHO_PMASS(ID(3),0),ISP)
      ENDIF

      IF(ILEV.LT.0) THEN
        IF(NHEP.NE.NPOS) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,2A,2I5)') 'PHO_SDECAY:ERROR: ',
     &      'cannot remove resonance (NPOS,NHEP)',NPOS,NHEP
          CALL PHO_ABORT
        ENDIF
        IMO1 = JMOHEP(1,NPOS)
        IMO2 = JMOHEP(2,NPOS)
        NHEP = NHEP-1
      ELSE
        IMO1 = NPOS
        IMO2 = 0
      ENDIF
      IPH1 = IPHIST(1,NPOS)
      IPH2 = IPHIST(2,NPOS)

C  back transformation and registration
      DO 300 I=1,3
        IF(ID(I).NE.0) THEN
          CALL PHO_LTRANS(GAM,GBET,CXS,CYS,CZS,COD(I),COF(I),SIF(I),
     &      PCM(I),ECM(I),PTOT,CX,CY,CZ,EE)
          XX = PTOT*CX
          YY = PTOT*CY
          ZZ = PTOT*CZ
          CALL PHO_REGPAR(1,0,ID(I),IMO1,IMO2,XX,YY,ZZ,EE,
     &      IPH1,IPH2,0,0,IPOS,1)
        ENDIF
 300  CONTINUE

C400  CONTINUE
C  debug output
      IF(IDEB(36).GE.20) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(2(/1X,A))') 'PHO_SDECAY: /POEVT1/',
     &                        '--------------------'
        CALL PHO_PREVNT(0)
      ENDIF

      END


 
 


CDECK  ID>, PHO_SDECY2
      SUBROUTINE PHO_SDECY2(UMO,AM1,AM2,ISP)
C**********************************************************************
C
C     isotropic/anisotropic two particle decay in CM system,
C     (transversely/longitudinally polarized boson into two
C     pseudo-scalar mesons)
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  auxiliary data for three particle decay
      DOUBLE PRECISION ECM,PCM,COD,COF,SIF
      COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)


      UMO2=UMO*UMO
      AM11=AM1*AM1
      AM22=AM2*AM2
      ECM(1)=(UMO2+AM11-AM22)/(2.D0*UMO)
      ECM(2)=UMO-ECM(1)
      WAU=ECM(1)*ECM(1)-AM11
      IF(WAU.LT.0.D0) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,E12.4)') 'PHO_SDECY2:ERROR:too small mass',WAU
        CALL PHO_ABORT
      ENDIF
      PCM(1)=SQRT(WAU)
      PCM(2)=PCM(1)

      CALL PHO_SFECFE(SIF(1),COF(1))
      IF(ISP.EQ.0) THEN
C  no polarization
        COD(1)  = 2.D0*DT_RNDM(UMO)-1.D0
      ELSE IF(ISP.EQ.1) THEN
C  transverse polarization
 400    CONTINUE
          COD(1)  = 2.D0*DT_RNDM(AM22)-1.D0
          SID12 = 1.D0-COD(1)*COD(1)
        IF(SID12.LT.DT_RNDM(AM1)) GOTO 400
      ELSE IF(ISP.EQ.2) THEN
C  longitudinal polarization
 500    CONTINUE
          COD(1)  = 2.D0*DT_RNDM(AM2)-1.D0
          COD12 = COD(1)*COD(1)
        IF(COD12.LT.DT_RNDM(AM11)) GOTO 500
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY2:ERROR: ',
     &    'invalid polarization',ISP
        CALL PHO_ABORT
      ENDIF

      COD(2) = -COD(1)
      COF(2) = -COF(1)
      SIF(2) = -SIF(1)

      END


 
 


CDECK  ID>, PHO_SDECY3
      SUBROUTINE PHO_SDECY3(UMO,AM1,AM2,AM3,ISP)
C**********************************************************************
C
C     isotropic/anisotropic three particle decay in CM system,
C     (transversely/longitudinally polarized boson into three
C     pseudo-scalar mesons)
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( DEPS   = 1.D-30,
     &            EPS    = 1.D-15 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  auxiliary data for three particle decay
      DOUBLE PRECISION ECM,PCM,COD,COF,SIF
      COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)

      DIMENSION F(5),XX(5)

C  calculation of maximum of S2 phase space weight
      UMOO=UMO+UMO
      GU=(AM2+AM3)**2
      GO=(UMO-AM1)**2
      UFAK=1.0000000000001D0
      IF (GU.GT.GO) UFAK=0.99999999999999D0
      OFAK=2.D0-UFAK
      GU=GU*UFAK
      GO=GO*OFAK
      DS2=(GO-GU)/99.D0
      AM11=AM1*AM1
      AM22=AM2*AM2
      AM33=AM3*AM3
      UMO2=UMO*UMO
      RHO2=0.D0
      S22=GU
      DO 124 I=1,100
        S21=S22
        S22=GU+(I-1.D0)*DS2
        RHO1=RHO2
        RHO2=PHO_XLAM(S22,UMO2,AM11)*PHO_XLAM(S22,AM22,AM33)/(S22+EPS)
        IF(RHO2.LT.RHO1) GOTO 125
  124 CONTINUE

  125 CONTINUE
      S2SUP=(S22-S21)/2.D0+S21
      SUPRHO=PHO_XLAM(S2SUP,UMO2,AM11)*PHO_XLAM(S2SUP,AM22,AM33)
     &       /(S2SUP+EPS)
      SUPRHO=SUPRHO*1.05D0
      XO=S21-DS2
      IF(GU.LT.GO.AND.XO.LT.GU) XO=GU
      IF(GU.GT.GO.AND.XO.GT.GU) XO=GU
      XX(1)=XO
      XX(3)=S22
      X1=(XO+S22)*0.5D0
      XX(2)=X1
      F(3)=RHO2
      F(1)=PHO_XLAM(XO,UMO2,AM11)*PHO_XLAM(XO,AM22,AM33)/(XO+EPS)
      F(2)=PHO_XLAM(X1,UMO2,AM11)*PHO_XLAM(X1,AM22,AM33)/(X1+EPS)
      DO 126 I=1,16
        X4=(XX(1)+XX(2))*0.5D0
        X5=(XX(2)+XX(3))*0.5D0
        F(4)=PHO_XLAM(X4,UMO2,AM11)*PHO_XLAM(X4,AM22,AM33)/(X4+EPS)
        F(5)=PHO_XLAM(X5,UMO2,AM11)*PHO_XLAM(X5,AM22,AM33)/(X5+EPS)
        XX(4)=X4
        XX(5)=X5
        DO 128 II=1,5
          IA=II
          DO 131 III=IA,5
            IF(F(II).LT.F(III)) THEN
              FH=F(II)
              F(II)=F(III)
              F(III)=FH
              FH=XX(II)
              XX(II)=XX(III)
              XX(III)=FH
            ENDIF
 131      CONTINUE
 128    CONTINUE
        SUPRHO=F(1)
        S2SUP=XX(1)
        DO 129 II=1,3
          IA=II
          DO 130 III=IA,3
            IF (XX(II).LT.XX(III)) THEN
              FH=F(II)
              F(II)=F(III)
              F(III)=FH
              FH=XX(II)
              XX(II)=XX(III)
              XX(III)=FH
            ENDIF
 130      CONTINUE
 129    CONTINUE
 126  CONTINUE

      AM23=(AM2+AM3)**2

C  selection of S1
      ITH=0
 200  CONTINUE
        ITH=ITH+1
        IF(ITH.GT.200) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,I10)')
     &      'PHO_SDECY3:ERROR: too many iterations',ITH
          CALL PHO_ABORT
        ENDIF
        S2=AM23+DT_RNDM(AM2)*((UMO-AM1)**2-AM23)
        Y=DT_RNDM(AM23)*SUPRHO
        RHO=PHO_XLAM(S2,UMO2,AM11)*PHO_XLAM(S2,AM22,AM33)/S2
      IF(Y.GT.RHO) GOTO 200

C  selection of S2
      S1=DT_RNDM(AM2)*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)
     &   /(2.D0*S2)-RHO/2.D0
      S3=UMO2+AM11+AM22+AM33-S1-S2
      ECM(1)=(UMO2+AM11-S2)/UMOO
      ECM(2)=(UMO2+AM22-S3)/UMOO
      ECM(3)=(UMO2+AM33-S1)/UMOO
      PCM(1)=SQRT((ECM(1)+AM1)*(ECM(1)-AM1))
      PCM(2)=SQRT((ECM(2)+AM2)*(ECM(2)-AM2))
      PCM(3)=SQRT((ECM(3)+AM3)*(ECM(3)-AM3))

C  calculation of angles: TH between p1,p2; TH1 p3,p1; TH2 p3,p2
      IF((PCM(1).LE.EPS).OR.(PCM(2).LE.EPS)) THEN
        COSTH=(DT_RNDM(S1)-0.5D0)*2.D0
      ELSE
        COSTH=(ECM(1)*ECM(2)+0.5D0*(AM11+AM22-S1))/(PCM(1)*PCM(2))
      ENDIF
      COSTH2=(PCM(3)*PCM(3)+PCM(2)*PCM(2)-PCM(1)*PCM(1))
     &        /(2.D0*PCM(2)*PCM(3))
      SINTH2=SQRT(1.D0-COSTH2*COSTH2)
      SINTH1=COSTH2*SQRT(1.D0-COSTH*COSTH)-COSTH*SINTH2
      COSTH1=COSTH*COSTH2+SINTH2*SQRT(1.D0-COSTH*COSTH)

C  selection of the sperical coordinates of particle 3
      CALL PHO_SFECFE(SIF(3),COF(3))
      IF(ISP.EQ.0) THEN
C  no polarization
        COD(3)  = 2.D0*DT_RNDM(S2)-1.D0
      ELSE IF(ISP.EQ.1) THEN
C  transverse polarization
 400    CONTINUE
          COD(3)  = 2.D0*DT_RNDM(S1)-1.D0
          SID32 = 1.D0-COD(3)*COD(3)
        IF(SID32.LT.DT_RNDM(COSTH)) GOTO 400
      ELSE IF(ISP.EQ.2) THEN
C  longitudinal polarization
 500    CONTINUE
          COD(3)  = 2.D0*DT_RNDM(COSTH2)-1.D0
          COD32 = COD(3)*COD(3)
        IF(COD32.LT.DT_RNDM(SINTH1)) GOTO 500
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY3:ERROR: ',
     &    'invalid polarization',ISP
        CALL PHO_ABORT
      ENDIF

C  selection of the rotation angle of p1-p2 plane along p3
      IF(ISP.EQ.0) THEN
        CALL PHO_SFECFE(SFE,CFE)
      ELSE
        SFE = 0.D0
        CFE = 1.D0
      ENDIF
      CX11=-COSTH1
      CY11=SINTH1*CFE
      CZ11=SINTH1*SFE
      CX22=-COSTH2
      CY22=-SINTH2*CFE
      CZ22=-SINTH2*SFE

      SID3 = SQRT((1.D0+COD(3))*(1.D0-COD(3)))
      COD(1)=CX11*COD(3)+CZ11*SID3
      IF((1.D0-COD(1)*COD(1)).LT.DEPS) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,5E12.4)') 'PHO_SDECY3: COS(TH1) > 1',
     &    COD(1),COF(3),SID3,CX11,CZ11
        CALL PHO_PREVNT(-1)
      ENDIF

      SID1=SQRT((1.D0+COD(1))*(1.D0-COD(1)))
      COF(1)=(CX11*SID3*COF(3)-CY11*SIF(3)-CZ11*COD(3)*COF(3))/SID1
      SIF(1)=(CX11*SID3*SIF(3)+CY11*COF(3)-CZ11*COD(3)*SIF(3))/SID1
      COD(2)=CX22*COD(3)+CZ22*SID3
      SID2=SQRT((1.D0+COD(2))*(1.D0-COD(2)))
      COF(2)=(CX22*SID3*COF(3)-CY22*SIF(3)-CZ22*COD(3)*COF(3))/SID2
      SIF(2)=(CX22*SID3*SIF(3)+CY22*COF(3)-CZ22*COD(3)*SIF(3))/SID2

      END


 
 


CDECK  ID>, PHO_SEAFLA
      SUBROUTINE PHO_SEAFLA(IPAR,IFL1,IFL2,CHMASS)
C**********************************************************************
C
C     selection of sea flavour content of particle IPAR
C
C     input:    IPAR    particle index in /POEVT1/
C               CHMASS  available invariant string mass
C                       positive mass --> use BAMJET method
C                       negative mass --> SU(3) symmetric sea according
C                       to values given in PARMDL(1-6)
C               IPAR    -1 initialization
C                       -2 output of statistics
C
C     output:   sea flavours according to PDG conventions
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( EPS    =  0.1D0,
     &            DEPS   =  1.D-15)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  some hadron information, will be deleted in future versions
      INTEGER NFS
      DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
      COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS


      IF(IPAR.GT.0) THEN
        IF((ISWMDL(20).EQ.1).OR.(CHMASS.LT.0.D0)) THEN
C  constant weights for sea
 15       CONTINUE
            SUM = 0.D0
            DO 40 K=1,NFSEA
              SUM = SUM + PARMDL(K)
 40         CONTINUE
            XI = DT_RNDM(SUM)*SUM
            SUM = 0.D0
            DO 50 K=1,NFSEA
              SUM = SUM + PARMDL(K)
              IF(XI.LE.SUM) GOTO 55
 50         CONTINUE
 55         CONTINUE
          IF(K.GT.NFSEA) GOTO 15
        ELSE
C  mass dependent flavour sampling
 10       CONTINUE
            CALL PHO_FLAUX(CHMASS,K)
          IF(K.GT.NFSEA) GOTO 10
        ENDIF
        IF(DT_RNDM(CHMASS).GT.0.5D0) K = -K
        IFL1 = K
        IFL2 = -K
        IF(IDEB(46).GE.10) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,3I5,E12.4)') 'PHO_SEAFLA:IPAR,IFL1,IFL2,MASS',
     &      IPAR,IFL1,IFL2,CHMASS
        ENDIF
      ELSE IF(IPAR.EQ.-1) THEN
C  initialization
        NFSEA = NFS
      ELSE IF(IPAR.EQ.-2) THEN
C  output of statistics
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I10)') 'PHO_SEAFLA:ERROR:INVALID IPAR',IPAR
        CALL PHO_ABORT
      ENDIF

      END


 
 


CDECK  ID>, PHO_SELCOL
      SUBROUTINE PHO_SELCOL(ICO1,ICO2,ICOA1,ICOA2,ICOB1,ICOB2,IMODE)
C********************************************************************
C
C    color combinatorics
C
C    input:         ICO1,2   colors of incoming particle
C                   IMODE    -2  output of initialization status
C                            -1  initialization
C                                   ICINP(1) selection mode
C                                            0   QCD
C                                            1   large N_c expansion
C                                   ICINP(2) max. allowed color
C                            0   clear internal color counter
C                            1   hadron into two colored objects
C                            2   quark into quark gluon
C                            3   gluon into gluon gluon
C                            4   gluon into quark antiquark
C
C    output:        ICOA1,2  colors of first outgoing particle
C                   ICOB1,2  colors of second outgoing particle
C
C********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

      DATA METHOD /0/, II /0/

      ICI1 = ICO1
      ICI2 = ICO2
      IF(METHOD.EQ.0) THEN

        IF(IMODE.EQ.1) THEN
          II = II+1
          IF(II.GT.MAXCOL)
     &      II = INT(MIN(DT_RNDM(DUM)*DBLE(MAXCOL)+1.00001D+00,
     &                   DBLE(MAXCOL)))
          ICOA1 = II
          ICOA2 = 0
          ICOB1 = -II
          ICOB2 = 0
        ELSE IF(IMODE.EQ.2) THEN
          II = II+1
          IF(II.GT.MAXCOL)
     &      II = INT(MIN(DT_RNDM(DUM)*DBLE(MAXCOL)+1.00001D+00,
     &                   DBLE(MAXCOL)))
          ICOA2 = 0
          IF(ICI1.GT.0) THEN
            ICOA1 = II
            ICOB1 = ICI1
            ICOB2 = -II
          ELSE
            ICOA1 = -II
            ICOB1 = II
            ICOB2 = ICI1
          ENDIF
        ELSE IF(IMODE.EQ.3) THEN
          II = II+1
          IF(II.GT.MAXCOL)
     &      II = INT(MIN(DT_RNDM(DUM)*DBLE(MAXCOL)+1.00001D+00,
     &                   DBLE(MAXCOL)))
          IF(DT_RNDM(DUM).GT.0.5D0) THEN
            ICOA1 = ICI1
            ICOA2 = -II
            ICOB1 = II
            ICOB2 = ICI2
          ELSE
            ICOB1 = ICI1
            ICOB2 = -II
            ICOA1 = II
            ICOA2 = ICI2
          ENDIF
        ELSE IF(IMODE.EQ.4) THEN
          ICOA1 = ICI1
          ICOA2 = 0
          ICOB1 = ICI2
          ICOB2 = 0
        ELSE IF(IMODE.EQ.0) THEN
          II = 0
        ELSE IF(IMODE.EQ.-1) THEN
          METHOD = ICI1
          MAXCOL = ICI2
        ELSE IF(IMODE.EQ.-2) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,2I5)') 'PHO_SELCOL: METHOD,MAXCOL',
     &      METHOD,MAXCOL
        ELSE
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,I5)')
     &      'PHO_SELCOL:ERROR: unsupported mode',IMODE
          CALL PHO_ABORT
        ENDIF

      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I5)')
     &    'PHO_SELCOL:ERROR:unsupported method selected',METHOD
        CALL PHO_ABORT
      ENDIF

      II = ABS(II)
      IF(IDEB(75).GE.10) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I5,I12,I5)') 'PHO_SELCOL: IMODE,MAXCOL,II',
     &    IMODE,MAXCOL,II
        IF (LPRI.GT.4)
     &  WRITE(LO,'(10X,A,2I5)') 'input  colors',ICI1,ICI2
        IF (LPRI.GT.4)
     &  WRITE(LO,'(10X,A,4I5)') 'output colors',ICOA1,ICOA2,ICOB1,ICOB2
      ENDIF

      END


 
 


CDECK  ID>, PHO_SELPT
      SUBROUTINE PHO_SELPT(EE,PTLOW,PTHIGH,PTS,BETA,IMODE)
C***********************************************************************
C
C    select pt from different distributions
C
C    input:    EE            energy (for initialization only)
C                            otherwise x value of corresponding parton
C              PTLOW         lower pt limit
C              PTHIGH        upper pt limit
C                            (PTHIGH > 20 will cause DEXP underflows)
C
C              IMODE = 0     dNs/dP_t = P_t * ASS * exp(-BETA*P_t**2)
C              IMODE = 1     dNs/dP_t = P_t * ASS * exp(-BETA*P_t)
C              IMODE = 2     dNs/dP_t according photon wave function
C              IMODE = 10    no sampling
C
C              IMODE = -100+IMODE    initialization according to
C                                    given limitations
C
C    output:   PTS           sampled pt value
C    initialization:
C              BETA          soft pt slope in central region
C
C***********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( PI2    =  6.28318530718D0,
     &            AMIN   =  1.D-2,
     &            EPS    =  1.D-7,
     &            DEPS   =  1.D-30)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  data of c.m. system of Pomeron / Reggeon exchange
      INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
      DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
     &                 SIDP,CODP,SIFP,COFP
      COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
     &                SIDP,CODP,SIFP,COFP,NPOSP(2),
     &                IDPDG1,IDBAM1,IDPDG2,IDBAM2

C  average number of cut soft and hard ladders (obsolete)
      DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
      COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN

C  data needed for soft-pt calculation
      DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
      COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON

      DOUBLE PRECISION PHO_CONN0,PHO_CONN1
      EXTERNAL PHO_CONN0,PHO_CONN1

C  initialization

      IF(IMODE.LT.0) GOTO 100

      PX = PTHIGH
      PTS = 0.D0

C  initial checks

      IF(PX.LT.AMIN) RETURN

      IF((PX-PTLOW).LT.0.01) THEN
        IF (LPRI.GT.4 .AND. IDEB(5).GE.3)
     &  WRITE(LO,'(1X,A,2E12.3,I3)')
     &    'PHO_SELPT: PTLOW,PTHIGH,IMODE ',PTLOW,PTHIGH,IMODE
        RETURN
      ENDIF

C  sampling of pt values according to IMODE

      IF(IMODE.EQ.0) THEN

        FAC1 = EXP(-BETA*PX**2)
        FAC2 = (1.D0-FAC1)
 25     CONTINUE
          XI1 = DT_RNDM(PX)*FAC2 + FAC1
          PTS = SQRT(-1.D0/BETA*LOG(XI1))
        IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 25

      ELSE IF(IMODE.EQ.1) THEN

        XIMIN = EXP(-BETA*PTHIGH)
        XIDEL = 1.D0-XIMIN
 50     CONTINUE
          PTS = -LOG((XIDEL*DT_RNDM(XIDEL)+XIMIN)
     &              *(XIDEL*DT_RNDM(XIMIN)+XIMIN)+DEPS)/BETA
        IF(PTS.LT.XMT) GOTO 50
        PTS = SQRT(PTS**2-XMT2)
        IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 50

      ELSE IF(IMODE.EQ.2) THEN

        IF(EE.GE.0.D0) THEN
          P2 = PVIRTP(1)
        ELSE
          P2 = PVIRTP(2)
        ENDIF
        XV = ABS(EE)
        AA = (1.D0-XV)*XV*P2+PARMDL(25)
 75     CONTINUE
          PTS = SQRT(AA/(DT_RNDM(PX)+EPS)-AA)
        IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 75

C  something wrong

      ELSE IF(IMODE.NE.10) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,I4)') 'PHO_SELPT:ERROR: invalid IMODE',IMODE
        CALL PHO_ABORT
      ENDIF

C  debug output
      IF(IDEB(5).GE.20) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I3,4E10.3)')
     &    'PHO_SELPT: MODE,BET,PTMI,PTMA,PT',
     &    IMODE,BETA,PTLOW,PTHIGH,PTS
      ENDIF
      RETURN

C  initialization
 100  CONTINUE
        PTSMIN = PTLOW
        PTSMAX = PTHIGH
        PTCON = PTHIGH
C  calculation of parameters
        INIT = IMODE+100
        AAS = 0.D0

C  initialization for model 0 (gaussian pt distribution)

        IF(INIT.EQ.0) THEN
          BETAS(1) = PARMDL(23)+0.15D0*LOG(EE)*(PARMDL(24)-PARMDL(23))
          BETUP = BETAS(1)
          BETLO = -2.D0
          XTOL = PHO_CONN0(BETLO)*PHO_CONN0(BETUP)
          IF(XTOL.LT.0.D0) THEN
            XTOL = 1.D-4
            METHOD = 1
            MAXF = 500
            BETA = 0.D0
            BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN0,METHOD)
*           IF(BETA.LT.-1.D+10) THEN
*             WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
*    &          '(model 0: Ecm,PTcut)',EE,PTCON
*             WRITE(LO,'(1X,A,1P,3E10.3)')
*    &          'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
*             CALL PHO_PREVNT(-1)
*             BETA = 0.01
*           ELSE
              AAS = DSIGHP/PTCON*EXP(-BETA*PTCON**2)
*           ENDIF
          ELSE
            AAS = 0.D0
            BETA = BETAS(1)
          ENDIF

C  initialization for model 1 (exponential pt distribution)

        ELSE IF(INIT.EQ.1) THEN
          XMT = PARMDL(43)
          XMT2 = XMT*XMT
          BETAS(1) = PARMDL(21)+0.15D0*LOG(EE)*(PARMDL(22)-PARMDL(21))
          BETUP = BETAS(1)
          BETLO = -3.D0
          XTOL = PHO_CONN1(BETLO)*PHO_CONN1(BETUP)
          IF(XTOL.LT.0.D0) THEN
            XTOL = 1.D-4
            METHOD = 1
            MAXF = 500
            BETA = 0.D0
            BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN1,METHOD)
*           IF(BETA.LT.-1.D+10) THEN
*             WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
*    &          '(model 1: Ecm,PTcut)',EE,PTCON
*             WRITE(LO,'(1X,A,1P,3E10.3)')
*    &          'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
*             CALL PHO_PREVNT(-1)
*             BETA = 0.01
*           ELSE
              AAS = DSIGHP/PTCON*EXP(-BETA*PTCON)
*           ENDIF
          ELSE
            AAS = 0.D0
            BETA = BETAS(1)
          ENDIF
        ELSE IF(INIT.EQ.10) THEN
          IF(IDEB(5).GT.10 .AND. LPRI.GT.4)
     &      WRITE(LO,'(/1X,A)') 'PHO_SELPT: no soft pt sampling'
          RETURN
        ELSE
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,I4)') 'PHO_SELPT:ERROR: invalid distribution',
     &      INIT
          CALL PHO_ABORT
        ENDIF
        BETA = MIN(BETA,BETAS(1))

C  hard cross section is too big: neg. beta parameter
        IF(BETA.LE.0.D0) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,1P,2E12.3)')
     &      'PHO_SELPT: parameter BETA negative (BETA,AAS)',BETA,AAS
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,1P,4E11.3)') 'SIGS,DSIGHP,SIGH,PTCON:',
     &      SIGS,DSIGHP,SIGH,PTCON
          CALL PHO_PREVNT(-1)
        ENDIF

C  output of initialization parameters
        IF(IDEB(5).GE.10) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,I3)') 'PHO_SELPT: initialization for model',
     &      INIT
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,1P,2E13.3)')
     &      'BETA,AAS        ',BETA,AAS
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,1P,3E13.3)')
     &      'ECM,PTMIN,PTMAX ',EE,PTSMIN,PTSMAX
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,1P,3E13.3)')
     &      'SIGS,DSIGHP,SIGH',SIGS,DSIGHP,SIGH
        ENDIF

      END


 
 


CDECK  ID>, PHO_SELSX2
      SUBROUTINE PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
     &                  XS1,XS2,IREJ)
C***********************************************************************
C
C    select x values of soft string ends using PHO_RNDBET
C
C***********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XS1(*),XS2(*)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  data on most recent hard scattering
      INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
      DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
     &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
      COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
     &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
     &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
     &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC

C  obsolete cut-off information
      DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
      COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN


      IREJ = 0

      IF(IDEB(32).GE.10) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A)') 'PHO_SELSX2:'
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,5E11.3)') 'AS,XSUM1,2,XMAX1,2',
     &    AS,XSUM1,XSUM2,XMAX1,XMAX2
        DO 30 I=1,2
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
 30     CONTINUE
      ENDIF

      FAC1 = 1.D0-XSUM1
      FAC2 = 1.D0-XSUM2
      FAC = FAC1*FAC2
      GAM1 = XPOT1(1)+1.D0
      GAM2 = XPOT2(1)+1.D0
      BET1 = XPOT1(2)+1.D0
      BET2 = XPOT2(2)+1.D0

      ITRY0 = 0
      DO 100 I=1,IPAMDL(182)

        ITRY1 = 0
 10     CONTINUE
          X1 = PHO_RNDBET(GAM1,BET1)
          ITRY1 = ITRY1+1
          IF(ITRY1.GE.50) GOTO 1000
        IF((X1.LE.XMIN(1,1)).OR.((1.D0-X1).LE.XMIN(1,2))) GOTO 10

        ITRY2 = 0
 11     CONTINUE
          X2 = PHO_RNDBET(GAM2,BET2)
          ITRY2 = ITRY2+1
          IF(ITRY2.GE.50) GOTO 1000
        IF((X2.LE.XMIN(2,1)).OR.((1.D0-X2).LE.XMIN(2,2))) GOTO 11

        X3 = 1.D0 - X1
        X4 = 1.D0 - X2
        IF(X1*X2*FAC.GT.AS) THEN
          IF(X3*X4*FAC.GT.AS) THEN
            XS1(1) = X1*FAC1
            XS1(2) = X3*FAC1
            XS2(1) = X2*FAC2
            XS2(2) = X4*FAC2
            IF(XS1(1).GT.XMIN(1,1)) THEN
              IF(XS2(1).GT.XMIN(2,1)) THEN
                IF(XS1(2).GT.XMIN(1,2)) THEN
                  IF(XS2(2).GT.XMIN(2,2)) THEN
                    XSUM1 = XSUM1+XS1(2)
                    XSUM2 = XSUM2+XS2(2)
                    GOTO 300
                  ENDIF
                ENDIF
              ENDIF
            ENDIF
          ENDIF
        ENDIF
        ITRY0 = ITRY0+1

 100  CONTINUE

 1000 CONTINUE
      IREJ = 1
      IF(IDEB(32).GE.2) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,3I4)')
     &    'PHO_SELSX2: REJECTION(ITRY0/1/2)',ITRY0,ITRY1,ITRY2
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
      ENDIF
      RETURN
 300  CONTINUE

      END


 
 


CDECK  ID>, PHO_SELSXI
      SUBROUTINE PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
     &                  XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
C***********************************************************************
C
C    select x values of soft string ends (sea independent from valence)
C
C***********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  data on most recent hard scattering
      INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
      DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
     &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
      COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
     &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
     &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
     &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC

C  obsolete cut-off information
      DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
      COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN

      DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)

      IREJ = 0

 10   CONTINUE

      DO 50 I=1,MSOFT
        POT(1,I) = XPOT1(I)+1.D0
        POT(2,I) = XPOT2(I)+1.D0
        REVP(1,I) = 1.D0/POT(1,I)
        REVP(2,I) = 1.D0/POT(2,I)
        XLMIN(1,I) = XMIN(1,I)**POT(1,I)
        XLMAX = XMAX1**POT(1,I)
        XLDIF(1,I) = XLMAX-XLMIN(1,I)
        XLMIN(2,I) = XMIN(2,I)**POT(2,I)
        XLMAX = XMAX2**POT(2,I)
        XLDIF(2,I) = XLMAX-XLMIN(2,I)
 50   CONTINUE

C  selection of sea
      ITRY0 = 0
 5    CONTINUE

      ITRY0 = ITRY0 + 1
      IF(ITRY0.GE.IPAMDL(183)) THEN
        IF(MSOFT-MSMIN.GE.2) THEN
          MSOFT = MSMIN
          GOTO 10
        ENDIF
        GOTO 1000
      ENDIF
      XSUM1 = XS1
      XSUM2 = XS2
      DO 100 I=3,MSOFT
        ITRY1 = 0
 20     CONTINUE
        Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
        Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
        XSOFT1(I) = Z1**REVP(1,I)
        XSOFT2(I) = Z2**REVP(2,I)
        ITRY1 = ITRY1+1
        IF(ITRY1.GE.50) GOTO 1000
        IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
        XSUM1 = XSUM1+XSOFT1(I)
        XSUM2 = XSUM2+XSOFT2(I)
 100  CONTINUE

      IF(XSUM1.GT.1.D0-XMIN(1,1)-XMIN(1,2)) GOTO 5
      IF(XSUM2.GT.1.D0-XMIN(2,1)-XMIN(2,2)) GOTO 5

C  selection of valence
      CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
     &  XSOFT1,XSOFT2,IREJ)
      IF(IREJ.NE.0) THEN
        IF(MSOFT-MSMIN.GE.2) THEN
          MSOFT = MSMIN
          GOTO 10
        ENDIF
        IF (LPRI.GT.4 .AND. IDEB(31).GE.2)
     &  WRITE(LO,'(1X,A,1P,4E11.4)')
     &    'PHO_SELSXI: rejection by PHO_SELSX2 (XSUM1/2,XMAX1/2)',
     &    XSUM1,XSUM2,XMAX1,XMAX2
        RETURN
      ENDIF

      XS1 = 1.D0-XSOFT1(1)
      XS2 = 1.D0-XSOFT2(1)
      RETURN

 1000 CONTINUE
      IREJ = 1
      IF(IDEB(14).GE.2) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXI: ',
     &    'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
        DO 300 I=1,MSOFT
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
 300    CONTINUE
      ENDIF

      END


 
 


CDECK  ID>, PHO_SELSXR
      SUBROUTINE PHO_SELSXR(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
     &                  XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
C***********************************************************************
C
C    select x values of soft string ends (rejection method)
C
C***********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  data on most recent hard scattering
      INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
      DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
     &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
      COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
     &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
     &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
     &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC

C  global event kinematics and particle IDs
      INTEGER IFPAP,IFPAB
      DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
      COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)

C  obsolete cut-off information
      DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
      COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN

      DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)

      IF(IDEB(13).GE.10) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A)') 'PHO_SELSXR:'
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,I4,5E11.3)') 'MSOFT,XS1,XS2,XMAX1,2',
     &    MSOFT,XS1,XS2,XMAX1,XMAX2
        DO 40 I=1,MSOFT
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
 40     CONTINUE
      ENDIF
C
      IREJ = 0
C
      XMINK = MAX(PSOMIN/ECM*2.D0,XSOMIN)
      XMIN1 = MAX(AS/XMAX1,XMINK)
      XMIN2 = MAX(AS/XMAX2,XMINK)
C
      IF(MSOFT.EQ.1) THEN
        XSOFT1(2) = 0.D0
        XSOFT2(2) = 0.D0
        RETURN
      ENDIF
      XWMAX = MAX(XMAX1**XPOT1(1),XMIN1**XPOT1(1))
     &        *MAX(XMAX2**XPOT2(1),XMIN2**XPOT2(1))
C
 10   CONTINUE
C
      DO 50 I=2,MSOFT
        POT(1,I) = XPOT1(I)+1.D0
        POT(2,I) = XPOT2(I)+1.D0
        REVP(1,I) = 1.D0/POT(1,I)
        REVP(2,I) = 1.D0/POT(2,I)
        XLMIN(1,I) = XMIN(1,I)**POT(1,I)
        XLMAX = XMAX1**POT(1,I)
        XLDIF(1,I) = XLMAX-XLMIN(1,I)
        XLMIN(2,I) = XMIN(2,I)**POT(2,I)
        XLMAX = XMAX2**POT(2,I)
        XLDIF(2,I) = XLMAX-XLMIN(2,I)
 50   CONTINUE
C
      ITRY0 = 0
 5    CONTINUE
      ITRY0 = ITRY0 + 1
      IF(ITRY0.GE.IPAMDL(181)) THEN
        IF(MSOFT-MSMIN.GE.2) THEN
          MSOFT = MSMIN
          GOTO 10
        ENDIF
        GOTO 1000
      ENDIF
      XREST1 = 1.D0-XS1
      XREST2 = 1.D0-XS2
      DO 100 I=2,MSOFT
        ITRY1 = 0

 20     CONTINUE
        Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
        Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
        XSOFT1(I) = Z1**REVP(1,I)
        XSOFT2(I) = Z2**REVP(2,I)
        ITRY1 = ITRY1+1
        IF(ITRY1.GE.50) GOTO 1000
        IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20

        XREST1 = XREST1-XSOFT1(I)
        IF(XREST1.LT.XMIN1) GOTO 5
        IF(XREST1.LT.XMIN(1,1)) GOTO 5
        XREST2 = XREST2-XSOFT2(I)
        IF(XREST2.LT.XMIN2) GOTO 5
        IF(XREST2.LT.XMIN(2,1)) GOTO 5
        IF(XREST1*XREST2.LT.AS) GOTO 5

 100  CONTINUE
      XSOFT1(1) = XREST1
      XSOFT2(1) = XREST2
      IREJ=0
*     XX = 1.D0
*     DO 200 I=2,MSOFT
*       XX = XX*XSOFT1(I)**XPOT1(I)*XSOFT2(I)**XPOT2(I)
*200  CONTINUE
      XX = XSOFT1(1)**XPOT1(1)*XSOFT2(1)**XPOT2(1)
      IF((XX-DT_RNDM(XX)*XWMAX).LT.0.D0) GOTO 5

      XS1 = 1.D0-XREST1
      XS2 = 1.D0-XREST2
      RETURN

 1000 CONTINUE
      IREJ = 1
      IF(IDEB(13).GE.2) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,2I4)')
     &    'PHO_SELSXR: REJECTION(ITRY0/1)',ITRY0,ITRY1
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
      ENDIF

      END


 
 


CDECK  ID>, PHO_SELSXS
      SUBROUTINE PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
     &                  XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
C***********************************************************************
C
C    select x values of soft string ends (rescaling method)
C
C***********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  data on most recent hard scattering
      INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
      DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
     &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
      COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
     &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
     &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
     &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC

C  obsolete cut-off information
      DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
      COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN

      DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)

      IREJ = 0

 10   CONTINUE

      IF(MSOFT.EQ.1) THEN
        XSOFT1(1) = 1.D0-XS1
        XSOFT1(2) = 0.D0
        XSOFT2(1) = 1.D0-XS2
        XSOFT2(2) = 0.D0
        RETURN
      ENDIF

      DO 50 I=1,MSOFT
        POT(1,I) = XPOT1(I)+1.D0
        POT(2,I) = XPOT2(I)+1.D0
        REVP(1,I) = 1.D0/POT(1,I)
        REVP(2,I) = 1.D0/POT(2,I)
        XLMIN(1,I) = XMIN(1,I)**POT(1,I)
        XLMAX = XMAX1**POT(1,I)
        XLDIF(1,I) = XLMAX-XLMIN(1,I)
        XLMIN(2,I) = XMIN(2,I)**POT(2,I)
        XLMAX = XMAX2**POT(2,I)
        XLDIF(2,I) = XLMAX-XLMIN(2,I)
 50   CONTINUE

      ITRY0 = 0
 5    CONTINUE
      ITRY0 = ITRY0 + 1
      IF(ITRY0.GE.IPAMDL(180)) THEN
        IF(MSOFT-MSMIN.GE.2) THEN
          MSOFT= MSMIN
          GOTO 10
        ENDIF
        GOTO 1000
      ENDIF
      XSUM1 = 0.D0
      XSUM2 = 0.D0
      DO 100 I=1,MSOFT
        ITRY1 = 0
 20     CONTINUE
        Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
        Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
        XSOFT1(I) = Z1**REVP(1,I)
        XSOFT2(I) = Z2**REVP(2,I)
        ITRY1 = ITRY1+1
        IF(ITRY1.GE.50) GOTO 1000
        IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
        XSUM1 = XSUM1+XSOFT1(I)
        XSUM2 = XSUM2+XSOFT2(I)
 100  CONTINUE
      FAC1 = (1.D0-XS1)/XSUM1
      FAC2 = (1.D0-XS2)/XSUM2
      DO 200 I=1,MSOFT
        XSOFT1(I) = XSOFT1(I)*FAC1
        XSOFT2(I) = XSOFT2(I)*FAC2
        IF(XSOFT1(I).LT.XMIN(1,I)) GOTO 5
        IF(XSOFT2(I).LT.XMIN(2,I)) GOTO 5
        IF(XSOFT1(I)*XSOFT2(I).LT.AS) GOTO 5
 200  CONTINUE

      XS1 = 1.D0-XSOFT1(1)
      XS2 = 1.D0-XSOFT2(1)
      RETURN

 1000 CONTINUE
      IREJ = 1
      IF(IDEB(14).GE.2) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXS: ',
     &    'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
        DO 300 I=1,MSOFT
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
 300    CONTINUE
      ENDIF

      END




      SUBROUTINE PHO_SETCT14(TABLEFILE)    
c***********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE
C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

cdh   Character Tablefile*40
      CHARACTER TABLEFILE*250
      COMMON /Setchange/ Isetch, ipdsset, ipdsformat
      DATA ipdsset, ipdsformat/0,0/


      OPEN(1, FILE=TABLEFILE, STATUS='OLD', ERR=100)
c       CALL OAUXFI(Tablefile, 1,'OLD',IERR)

        IF (IERR.GT.0) GOTO 100
      
      CALL PHO_READPDS0 (1)
      Close (1)
      
      Isetch=1 
      ipdsset=1
      Return

 100  WRITE(LO,*) ' Data file ', TABLEFILE, ' cannot be opened '
     >  //'in PHO_SETCT14!!'
      STOP

      END


 
 


CDECK  ID>, PHO_SETMDL
      SUBROUTINE PHO_SETMDL(INDX,IVAL,IMODE)
C**********************************************************************
C
C     set model switches
C
C     input:  INDX       model parameter number
C                        (positive: ISWMDL, negative: IPAMDL)
C             IVAL       new value
C             IMODE      -1  print value of parameter INDX
C                        1   set new value
C                        -2  print current settings
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)


      IF(IMODE.EQ.-2) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,/1X,A,/)') 'PHO_SETMDL: current settings',
     &                             '----------------------------'
        DO 100 I=1,48,3
          IF(ISWMDL(I).EQ.-9999) GOTO 200
          IF(ISWMDL(I+1).EQ.-9999) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(5X,I3,A1,A,I6)') I,':',MDLNA(I),ISWMDL(I)
            GOTO 200
          ELSE IF(ISWMDL(I+2).EQ.-9999) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(2(5X,I3,A1,A,I6))') I,':',MDLNA(I),ISWMDL(I),
     &        I+1,':',MDLNA(I+1),ISWMDL(I+1)
            GOTO 200
          ELSE
            IF (LPRI.GT.4)
     &      WRITE(LO,'(3(5X,I3,A1,A,I6))')
     &        (I+K,':',MDLNA(I+K),ISWMDL(I+K),K=0,2)
          ENDIF
 100    CONTINUE
 200    CONTINUE
      ELSE IF(IMODE.EQ.-1) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,1X,A,I6)')
     &    'PHO_SETMDL:',MDLNA(INDX),ISWMDL(INDX)
      ELSE IF(IMODE.EQ.1) THEN
        IF(INDX.GT.0) THEN
          IF(ISWMDL(INDX).NE.IVAL) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,A,I4,1X,A,2I6)')
     &        'PHO_SETMDL:ISWMDL(OLD/NEW):',
     &        INDX,MDLNA(INDX),ISWMDL(INDX),IVAL
            ISWMDL(INDX) = IVAL
          ENDIF
        ELSE IF(INDX.LT.0) THEN
          IF(IPAMDL(-INDX).NE.IVAL) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,A,I4,1X,2I6)') 'PHO_SETMDL:IPAMDL(OLD/NEW):',
     &        -INDX,IPAMDL(-INDX),IVAL
            IPAMDL(-INDX) = IVAL
          ENDIF
        ENDIF
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,I6)')
     &    'PHO_SETMDL:ERROR: unsupported mode',IMODE
      ENDIF

      END

 
 


CDECK  ID>, PHO_SETPAR
      SUBROUTINE PHO_SETPAR(Iside,IDpdg,IDcpc,PVIR)
C**********************************************************************
C
C     assign a particle to either side 1 or 2
C     (including special treatment for remnants)
C
C     input:    Iside      1,2  side selected for the particle
C                          -2   output of current settings
C               IDpdg      PDG number
C               IDcpc      CPC number
C                          0     CPC determination in subroutine
C                          -1    special particle remnant, IDPDG
C                                is the particle number the remnant
C                                corresponds to (see /POHDFL/)
C
C**********************************************************************

      IMPLICIT NONE
      SAVE

      INTEGER Iside,IDpdg,IDcpc
      DOUBLE PRECISION PVIR

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  global event kinematics and particle IDs
      INTEGER IFPAP,IFPAB
      DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
      COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)

C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
      INTEGER IDEQP,IDEQB,IHFLD,IHFLS
      DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
      COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
     &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)

C  particle ID translation table
      INTEGER         ID_pdg_list,ID_list,ID_pdg_max
      character*12    name_list
      COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
     &                ID_pdg_max

C  general particle data
      DOUBLE PRECISION xm_list,tau_list,gam_list,
     &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
     &  xm_bb82_list,xm_bb102_list
      INTEGER          ich3_list,iba3_list,iq_list,
     &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
      COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
     &  xm_psm2_list(6,6),xm_vem2_list(6,6),
     &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
     &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
     &  ich3_list(300),iba3_list(300),iq_list(3,300),
     &  id_psm_list(6,6),id_vem_list(6,6),
     &  id_b8_list(6,6,6),id_b10_list(6,6,6)

C  particle decay data
      DOUBLE PRECISION wg_sec_list
      INTEGER          idec_list,isec_list
      COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
     &  isec_list(3,500)

C  external functions
      INTEGER  IPHO_PDG2ID,IPHO_CHR3,IPHO_BAR3
      EXTERNAL IPHO_PDG2ID,IPHO_CHR3,IPHO_BAR3
      DOUBLE PRECISION PHO_PMASS
      EXTERNAL         PHO_PMASS

C  local variables
      INTEGER i,IDcpcN,IDcpcR,IDpdgN,IDpdgR,IDB,IFL1,IFL2,IFL3

      IF (IDEB(87).GE.15) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO, '(1X,A,I2,/5X,A,2I6)') 
     &         'PHO_SETPAR: called for side', ISIDE,
     &         'IDPDG, IDCPC', IDPDG, IDCPC
      END IF

      IF((Iside.EQ.1).OR.(Iside.EQ.2)) THEN
        IDcpcN = IDcpc
C  remnant?
        IF(IDcpc.EQ.-1) THEN
          IF(Iside.EQ.1) THEN
            IDpdgR = 81
          ELSE
            IDpdgR = 82
          ENDIF
          IDcpcR = IPHO_PDG2ID(IDpdgR)
          IDEQB(Iside) = IPHO_PDG2ID(IDpdg)
          IDEQP(Iside) = IDpdg
C  copy particle properties
          IDB = abs(IDEQB(Iside))
          xm_list(IDcpcR)  = xm_list(IDB)
          tau_list(IDcpcR) = tau_list(IDB)
          gam_list(IDcpcR) = gam_list(IDB)
          IF(IHFLS(Iside).EQ.1) THEN
            ich3_list(IDcpcR) = IPHO_CHR3(IDEQB(Iside),0)
            iba3_list(IDcpcR) = IPHO_BAR3(IDEQB(Iside),0)
          ELSE
            ich3_list(IDcpcR) = 0
            iba3_list(IDcpcR) = 0
          ENDIF
C  quark content
          IFL1 = IHFLD(Iside,1)
          IFL2 = IHFLD(Iside,2)
          IFL3 = 0
          IF(IHFLS(Iside).EQ.1) THEN
            IF(ABS(IHFLD(Iside,1)).GT.1000) THEN
              IFL1 = IHFLD(Iside,1)/1000
              IFL2 = MOD(IHFLD(Iside,1)/100,10)
              IFL3 = IHFLD(Iside,2)
            ELSE IF(ABS(IHFLD(Iside,2)).GT.1000) THEN
              IFL1 = IHFLD(Iside,1)
              IFL2 = IHFLD(Iside,2)/1000
              IFL3 = MOD(IHFLD(Iside,2)/100,10)
            ENDIF
          ENDIF
          iq_list(1,IDcpcR) = IFL1
          iq_list(2,IDcpcR) = IFL2
          iq_list(3,IDcpcR) = IFL3

          IDcpcN = IDcpcR
          IDPDGN = IDPDGR

          IF(IDEB(87).GE.5) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(1X,A,I2,/5X,A,I7,4I6)')
     &        'PHO_SETPAR: remnant assignment side',Iside,
     &        'IDPDG,IFL1,2,3,IVAL',IDPDGN,IFL1,IFL2,IFL3,IHFLS(Iside)
          ENDIF
        ELSE IF(IDcpc.EQ.0) THEN
C  ordinary hadron
          IHFLS(Iside) = 1
          IHFLD(Iside,1) = 0
          IHFLD(Iside,2) = 0
          IDcpcN = IPHO_PDG2ID(IDpdg)
          IDpdgN = IDpdg
          IDEQP(Iside) = 0
        ENDIF

C initialize /POGCMS/
        IFPAP(Iside) = IDpdgN
        IFPAB(Iside) = IDcpcN
        PMASS(Iside) = PHO_PMASS(IDcpcN,0)
        IF(IFPAP(Iside).EQ.22) THEN
          PVIRT(Iside) = ABS(PVIR)
        ELSE
          PVIRT(Iside) = 0.D0
        ENDIF

      ELSE IF(Iside.EQ.-2) THEN
C  output of current settings
        DO 100 I=1,2
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,I2,1X,A,I7,I4,1X,1P2E10.3)')
     &      'PHO_SETPAR: side',
     &      I,'IDPDG,IDcpc,PMASS,PVIRT',IFPAP(I),IFPAB(I),PMASS(I),
     &      PVIRT(I)
          IF((IFPAP(I).EQ.81).OR.(IFPAP(I).EQ.82)) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(5X,A,I7,I4,I2,3I5)')
     &        'remnant:IDPDG,IDcpc,IVAL,IFLA1,2',IDEQP(I),IDEQB(I),
     &        IHFLS(I),IHFLD(I,1),IHFLD(I,2)
          ENDIF
 100    CONTINUE
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,I8)')
     &    'PHO_SETPAR: invalid argument (Iside)',Iside
      ENDIF

      END


 
 


CDECK  ID>, PHO_SETPCOMB
      SUBROUTINE PHO_SETPCOMB
c*********************************************************************
c
c     find and set or initialize current beam/target combination index
c
c     input:   ipds1   PDG particle code side 1
c              ipds2   PDG particle code side 2
c
c     output:  in /POBEAM/
c              idxmpar   currently active index
c              mpmap   PDGids of original particle in case of mapping
c              mparisinv .True. if side1/2 need swapping
c
c*********************************************************************
      IMPLICIT NONE
      SAVE

      INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR
      INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR
      DOUBLE PRECISION SQSGLOBMAX
      PARAMETER (MPARMAX=40)
      PARAMETER (MAXMAPPS=40)
      COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS),
     &           MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP

      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

      INTEGER IFPAP,IFPAB
      DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
      COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)

      INTEGER IDEQP,IDEQB,IHFLD,IHFLS
      DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
      COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
     &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)

      INTEGER  ipds1, ipds2, i, iside,iipar, ifound, k, IFAST, klim,
     &         irej, ip1, ip2, iremn1, iremn2, ipho_ismapped, 
     &         ihfldsav(2,2), ihflssav(2), ipavail, iknown
      DOUBLE PRECISION p1(4), p2(4), deps
      PARAMETER (deps=1.D-14)
C  (Anti-)Particle combination assumed to be known
      PARAMETER (IKNOWN=9)
      DIMENSION IPAVAIL(IKNOWN)
      DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/

      DATA IFAST /0/
*     DATA IFAST /4/

      INTEGER ISTART
      DATA    ISTART / 0 /

100   Continue

      iremn1 = 0
      iremn2 = 0

      ipds1 = ifpap(1)
      ipds2 = ifpap(2)

cdh
      if ( LPRI.GT.4) then
        if (istart .eq. 0 ) then
          write(LO,*) 'PHO_SETPCOMB: IFAST=',IFAST
          istart = 1
        endif
      endif
cdh

      If ((ideqp(1).NE.0).And.(ideqp(1).NE.ipds1)) Then
        iremn1 = -1
        mpar(1) = ideqp(1)
        ipds1 = ideqp(1)
      End If

      If ((ideqp(2).NE.0).And.(ideqp(2).NE.ipds2)) Then
        iremn2 = -1
        mpar(2) = ideqp(2)
        ipds2 = ideqp(2)
      End If

C       Check if side1 or side2 need mapping
      mpar(1) = ipho_ismapped(ipds1)
      mpar(2) = ipho_ismapped(ipds2)
      
      IF (LPRI.GT.4) Then
        If (ideb(90).GT.2) Write(lo,*) 'PHO_SETPCOMB: searching for ',
     &   'mpar(1)/mpar(2) combination', mpar(1),'/',mpar(2),' ', 
     &   ipds1,'/',ipds2
      End If

C       Search for index in stored pairs
      idxmpar = 0
      Do i=1,nmpar
        If (mpar(1)==mparconf(1, i) .And. mpar(2)==mparconf(2, i)) Then
          idxmpar = i
          CALL PHO_SETPAR(1, ipds1, iremn1, 0.D0)
          CALL PHO_SETPAR(2, ipds2, iremn2, 0.D0)
          CALL PHO_RREGPAR
          Exit
        End If
      End Do

C       If index not found, initialize new beam config
      If (idxmpar==0) Then
        IF (LPRI.GT.4) Then
          If (ideb(90).GT.2) Write(lo, '(/1X,A,I5,A,I5,A)')
     &   'PHO_SETPCOMB: Beam index',mpar(1),' /',mpar(2),
     &   ' not initialized.'
        End If

C         Search parameter file for combination
        ifound = 1
        Do iipar = 1,2
          k=1
          If (IFAST.NE.0) Then
             klim = IFAST
          Else
             klim = iknown
          End If
          Do i=1,klim
            If ((IFAST.NE.0).And.(ipavail(k).EQ.mpar(iipar))) Then
               Exit
            Else If ((IFAST.EQ.0).And.
     &         (ipavail(k).EQ.abs(mpar(iipar)))) Then
               Exit
            End If
            k = k + 1
          End Do
          If (k > klim) Then
             If (ideb(90).GT.-1) Then
                IF (LPRI.GT.4) Write (lo, *) 
     &           'PHO_SETPCOMB: no parameters available for ',
     &           abs(mpar(iipar)),'. Trying to map the combination.'
C     Auto-map the particle to something else
             End If
             CALL PHO_INITPMAP(1, mpar(iipar), -1, IFAST)
             ifound = 0
          End If
        End Do

        If (ifound.EQ.0) Go To 100

c   Backup the flavors in case of an initialization with a remnant
        If ((iremn1.NE.0).OR.(iremn2.NE.0)) Then
          Do iside=1,2
            ihfldsav(iside,1) = ihfld(iside,1)
            ihfldsav(iside,2) = ihfld(iside,2)
            ihflssav(iside) = ihfls(iside)
          End Do
        End If

c   Initialize phojet for new particle combination
        CALL PHO_SETPAR(1, mpar(1), 0, 0.D0)
        CALL PHO_SETPAR(2, mpar(2), 0, 0.D0)
        If (sqsglobmax.LE.1.D0) Then
           Write(lo,'(/1X,A,E10.3)')
     &     'PHO_SETPCOMB: Initialization energy too small to proceed.',
     &     ' Aborting..'
           CALL PHO_ABORT
        End If
        CALL PHO_GET4VECTORS(mpar(1), mpar(2), sqsglobmax, p1, p2)
        CALL PHO_FITPAR(1)

        nmpar = nmpar + 1
        mparconf(1, nmpar) = mpar(1)
        mparconf(2, nmpar) = mpar(2)

        IF (LPRI.GT.4) Then
          If (ideb(90).GT.2) Write(lo, *)
     &   'PHO_SETPCOMB: particle configuration ', mpar(1), '/', mpar(2),
     &   ' added to mparconf at ', nmpar
        End If

C        Set current index to new entry
        idxmpar = nmpar

C        Search parameter file for copmbination
        CALL PHO_SREGPAR
        CALL PHO_MCINI
        CALL PHO_SAMPRO(1,ifpap(1),ifpap(2),ecm,pvirt(1),pvirt(2),0.D0,
     &     -1)
        CALL PHO_PARTON(-1, 0, 0, p1, p2, irej)

        CALL PHO_EVEINI(1, p1, p2, ip1, ip2)

        IF (LPRI.GT.4) Then
          If (ideb(90).GT.1) Write(lo,*)
     &  'PHO_SETPCOMB: Initialization complete for ',mpar(1),'/',mpar(2)
        End If

        If ((ipds1.NE.mpar(1)).Or.(ipds2.NE.mpar(2)).Or.
     &      (iremn1.NE.0).Or.(iremn2.NE.0)) Then
C    Restore remnant flavors
          If ((iremn1.NE.0).Or.(iremn2.NE.0)) Then
            IF (LPRI.GT.4) Then
              If (ideb(90).GT.1) Write(lo, '(/1X,A,I5,A,I5)')
     &          'PHO_SETPCOMB: Restoring remnants.',iremn1,'/',iremn2
            End If            
            Do iside=1,2
              ihfld(iside,1) = ihfldsav(iside,1)
              ihfld(iside,2) = ihfldsav(iside,2)
              ihfls(iside) = ihflssav(iside)
            End Do
          End If
          
          CALL PHO_SETPAR(1, ipds1, iremn1, 0.D0)
          CALL PHO_SETPAR(2, ipds2, iremn2, 0.D0)
          CALL PHO_RREGPAR
        End If
      End If
      
      IF (LPRI.GT.4) Then
        If (ideb(90).GT.10)
     &    Write(lo, '(1X,A,I2)') 'PHO_SETPCOMB: Index found and set to', 
     &   idxmpar 
      End If

      END  


 
 


CDECK  ID>, PHO_SETPDF
      SUBROUTINE PHO_SETPDF(IDPDG,ITYP,IPAR,ISET,IEXT,IPAVAL,MODE)
C***************************************************************
C
C     assigns  PDF numbers to particles
C
C     input:      IDPDG    PDG number of particle
C                 ITYP     particle type
C                 IPAR     PDF paramertization
C                 ISET     number of set
C                 IEXT     library number for PDF calculation
C                 IPAVAL   (only output)
C                          1 PDF with valence quarks
C                          0 PDF without valence quarks
C                 MODE     -1   add entry to table
C                           1   read from table
C                           2   map particle IPAR to existing entry
C                           2   output of table
C
C***************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
      INTEGER IDEQP,IDEQB,IHFLD,IHFLS
      DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
      COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
     &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)

      DIMENSION IPDFS(5,50)
      DATA IENTRY / 0 /

      IF(MODE.EQ.1) THEN
        I = 1
        IF(IDPDG.EQ.81) THEN
          IDCMP = IDEQP(1)
          IPAVAL = IHFLS(1)
        ELSE IF(IDPDG.EQ.82) THEN
          IDCMP = IDEQP(2)
          IPAVAL = IHFLS(2)
        ELSE
          IDCMP = IDPDG
          IPAVAL = 1
        ENDIF
200     CONTINUE
          IF(IDCMP.EQ.IPDFS(1,I)) THEN
            ITYP = IPDFS(2,I)
            IPAR = IPDFS(3,I)
            ISET = IPDFS(4,I)
            IEXT = IPDFS(5,I)
            IF (LPRI.GT.4 .AND. IDEB(80).GE.15)
     &      WRITE(LO,'(1X,A,I7,5X,3I4)')
     &        'PHO_SETPDF: ID,IPAR,ISET,IEXT',IDCMP,IPAR,ISET,IEXT
            RETURN
          ENDIF
          I = I+1
          IF(I.GT.IENTRY) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(/1X,A,I7)')
     &        'PHO_SETPDF: no PDF assigned to ',IDCMP
            CALL PHO_ABORT
          ENDIF
        GOTO 200

      Else If (mode.EQ.2) Then
        ii = 0
        Do i=1,ientry
          ii = ii + 1 
          If (idpdg.EQ.ipdfs(1,i)) Go To 120
        End Do

120     Continue
        If (ii.LE.ientry) Then
           ientry = ientry + 1
           ipdfs(1, ientry) = ipar
           ipdfs(2, ientry) = ipdfs(2, ii)
           ipdfs(3, ientry) = ipdfs(3, ii)
           ipdfs(4, ientry) = ipdfs(4, ii)
           ipdfs(5, ientry) = ipdfs(5, ii)
           IF ((LPRI.GT.4).AND.(ideb(80).GT.0))
     &     Write (lo, '(1X,A,I7,A,I7)')
     &       'PHO_SETPDF: Particle ', ipar, ' mapped to ', idpdg
        Else
           Write (lo, '(1X,A,I7,A,I7)')
     &       'PHO_SETPDF: PDF of particle', ipar, 'unknown.'
           CALL PHO_ABORT
        End If

      ELSE IF(MODE.EQ.-1) THEN
        DO 50 I=1,IENTRY
          IF(IDPDG.EQ.IPDFS(1,I)) THEN
            IF (LPRI.GT.4)
     &      WRITE(LO,'(/1X,A,5I6)')
     &        'PHO_SETPDF: overwrite old particle PDF',
     &        IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
            GOTO 100
          ENDIF
 50     CONTINUE
        I = IENTRY+1
        IF(I.GT.50) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,/1x,6I6)')
     &      'PHO_SETPDF:ERROR: no space left in IPDFS:',
     &      I,IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
          STOP
        ENDIF
        IENTRY = I
 100    CONTINUE
        IPDFS(1,I) = IDPDG
        IF(IDPDG.EQ.990) THEN
          ITYP1 = 20
        ELSE IF(IDPDG.EQ.22) THEN
          ITYP1 = 3
        ELSE IF(ABS(IDPDG).LT.1000) THEN
          ITYP1 = 2
        ELSE
          ITYP1 = 1
        ENDIF
        IPDFS(2,I) = ITYP1
        IPDFS(3,I) = IPAR
        IPDFS(4,I) = ISET
        IPDFS(5,I) = IEXT
      ELSE IF(MODE.EQ.-2) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A)') 'PHO_SETPDF: PDFs assigned by user:'
        DO 150 I=1,IENTRY
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,I4,A,I7,A,4I5)') I,'  particle:',IPDFS(1,I),
     &      '   PDF-set  ',IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
 150    CONTINUE
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,I5)') 'PHO_SETPDF:ERROR: invalid mode ',MODE
      ENDIF

      END

 
 


CDECK  ID>, PHO_SFECFE
      SUBROUTINE PHO_SFECFE(SFE,CFE)
C**********************************************************************
C
C     fast random SIN(X) COS(X) selection
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE
C
    1 CONTINUE
        X=DT_RNDM(XX)
        Y=DT_RNDM(YY)
        XX=X*X
        YY=Y*Y
        XY=XX+YY
      IF(XY.GT.1.D0) GOTO 1
      CFE=(XX-YY)/XY
      SFE=2.D0*X*Y/XY
      IF(DT_RNDM(XY).LT.0.5D0) THEN
        SFE=-SFE
      ENDIF

      END

 
 


CDECK  ID>, PHO_SOFTPT
      SUBROUTINE PHO_SOFTPT(ISOFT,PTCUT,PTMAX,XV,IV,PTSOF)
C***********************************************************************
C
C    select pt of soft string ends
C
C    input:    ISOFT          number of soft partons
C                    -1       initialization
C                    >=0      sampling of p_t
C                    -2       output of statistics
C              PTCUT          cutoff for soft strings
C              PTMAX          maximal allowed PT
C              XV             field of x values
C              IV             0    sea quark
C                             1    valence quark
C
C    output:   /POINT3/       containing parameters AAS,BETAS
C              PTSOF          filed with soft pt values
C
C    note:     ISWMDL(3/4) = 0  dNs/dP_t = P_t ASS * exp(-BETA*P_t**2)
C              ISWMDL(3/4) = 1  dNs/dP_t = P_t ASS * exp(-BETA*P_t)
C              ISWMDL(3/4) = 2  photon wave function
C              ISWMDL(3/4) = 10 no soft P_t assignment
C
C***********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( DEPS   =  1.D-15)

      DIMENSION PTSOF(0:2,*),XV(*)
      DIMENSION IV(*)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  data of c.m. system of Pomeron / Reggeon exchange
      INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
      DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
     &                 SIDP,CODP,SIFP,COFP
      COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
     &                SIDP,CODP,SIFP,COFP,NPOSP(2),
     &                IDPDG1,IDBAM1,IDPDG2,IDBAM2

C  data on most recent hard scattering
      INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
      DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
     &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
      COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
     &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
     &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
     &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC

C  data needed for soft-pt calculation
      DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
      COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON

      DIMENSION BETAB(100)

C  selection of pt
      IF(ISOFT.GE.0) THEN
        CALLS = CALLS + 1.D0
C  sample according to model ISWMDL(3-6)
        IF(ISOFT.GT.1) THEN
 210      CONTINUE
          PTXS = 0.D0
          PTYS = 0.D0
          DO 300 I=2,ISOFT
            IMODE = ISWMDL(3)
C  valence partons
            IF(IV(I).EQ.1) THEN
              BETA = BETAS(1)
C  photon/pomeron valence part
              IF(IPAMDL(5).EQ.1) THEN
                IF(XV(I).GE.0.D0) THEN
                  IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
                    IMODE = ISWMDL(4)
                    BETA = BETAS(3)
                  ENDIF
                ELSE
                  IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
                    IMODE = ISWMDL(4)
                    BETA = BETAS(3)
                  ENDIF
                ENDIF
              ELSE IF(IPAMDL(5).EQ.2) THEN
                BETA = PARMDL(20)
              ELSE IF(IPAMDL(5).EQ.3) THEN
                BETA = BETAS(3)
              ENDIF
C  sea partons
            ELSE IF(IV(I).EQ.0) THEN
              BETA = BETAS(3)
C  hard scattering remnant
            ELSE
              IF(IPAMDL(6).EQ.0) THEN
                BETA = BETAS(1)
              ELSE IF(IPAMDL(6).EQ.1) THEN
                BETA = BETAS(3)
              ELSE
                BETA = PARMDL(20)
              ENDIF
            ENDIF
            BETA = MAX(BETA,0.01D0)
            CALL PHO_SELPT(XV(I),0.D0,PTCUT,PTS,BETA,IMODE)
            PTS = MIN(PTMAX,PTS)
            CALL PHO_SFECFE(SIG,COG)
            PTSOF(0,I) = PTS
            PTSOF(1,I) = COG*PTS
            PTSOF(2,I) = SIG*PTS
            PTXS = PTXS+PTSOF(1,I)
            PTYS = PTYS+PTSOF(2,I)
            BETAB(I) = BETA
 300      CONTINUE
C  balancing of momenta
          PTS = SQRT(PTXS**2+PTYS**2)
          IF(PTS.GE.PTMAX) GOTO 210
          PTSOF(0,1) = PTS
          PTSOF(1,1) = -PTXS
          PTSOF(2,1) = -PTYS
          BETAB(1) = 0.D0
C
*400      CONTINUE
C
C  single parton only
        ELSE
          IMODE = ISWMDL(3)
C  valence partons
          IF(IV(1).EQ.1) THEN
            BETA = BETAS(1)
C  photon/Pomeron valence part
            IF(IPAMDL(5).EQ.1) THEN
              IF(XV(1).GE.0.D0) THEN
                IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
                  IMODE = ISWMDL(4)
                  BETA = BETAS(3)
                ENDIF
              ELSE
                IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
                  IMODE = ISWMDL(4)
                  BETA = BETAS(3)
                ENDIF
              ENDIF
            ELSE IF(IPAMDL(5).EQ.2) THEN
              BETA = PARMDL(20)
            ELSE IF(IPAMDL(5).EQ.3) THEN
              BETA = BETAS(3)
            ENDIF
C  sea partons
          ELSE IF(IV(1).EQ.0) THEN
            BETA = BETAS(3)
C  hard scattering remnant
          ELSE
            IF(IPAMDL(6).EQ.1) THEN
              BETA = BETAS(3)
            ELSE
              BETA = PARMDL(20)
            ENDIF
          ENDIF
          BETA = MAX(BETA,0.01D0)
          CALL PHO_SELPT(XV(1),0.D0,PTCUT,PTS,BETA,IMODE)
          PTS = MIN(PTMAX,PTS)
          CALL PHO_SFECFE(SIG,COG)
          PTSOF(0,1) = PTS
          PTSOF(1,1) = COG*PTS
          PTSOF(2,1) = SIG*PTS
          BETAB(1) = BETA
        ENDIF

C  debug output
        IF(IDEB(29).GE.10) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,I4)') 'PHO_SOFTPT: ISOFT',ISOFT
          IF (LPRI.GT.4)
     &    WRITE(LO,'(6X,A)') 'TABLE OF  I, IV, XV, PT, PT-X, PT-Y, BETA'
          DO 105 I=1,ISOFT
            IF (LPRI.GT.4)
     &      WRITE(LO,'(10X,2I3,1P,5E12.3)') I,IV(I),XV(I),PTSOF(0,I),
     &        PTSOF(1,I),PTSOF(2,I),BETAB(I)
 105      CONTINUE
        ENDIF

C  initialization of statistics and parameters

      ELSE IF(ISOFT.EQ.-1) THEN
        PTSMIN = 0.D0
        PTSMAX = PTCUT

        IMODE = -100+ISWMDL(3)
        CALL PHO_SELPT(ECMP,PTSMIN,PTSMAX,PTS,BETAS(3),IMODE)

C  output of statistics

      ELSE IF(ISOFT.EQ.-2) THEN

      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,2A,I2)') 'PHO_SOFTPT:ERROR: ',
     &    'unsupported ISOFT ',ISOFT
        STOP
      ENDIF

      END

 
 


CDECK  ID>, PHO_SOFTXX
      SUBROUTINE PHO_SOFTXX(JM1,JM2,MSPAR1,MSPAR2,IVAL1,IVAL2,MSM1,MSM2,
     &                  XSUM1,XSUM2,XMAX1,XMAX2,XS1,XS2,IREJ)
C***********************************************************************
C
C    select soft x values
C
C    input:   JM1,JM2    mother particle index in POEVT1
C                        (0  flavour not known before)
C             MSPAR1,2   number of x values to select
C             IVAL1,2    number valence quarks involved in hard
C                        scattering (0,1,2)
C             MSM1,2     minimum number of soft x to get sampled
C             XSUM1,2    sum of all x values samples up this call
C             XMAX1,2    max. x value
C
C    output   XSUM1,2    new sum of x-values sampled
C             XS1,2      field containing sampled x values
C
C    x values of valence partons are first given
C
C***********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  internal rejection counters
      INTEGER NMXJ
      PARAMETER (NMXJ=60)
      CHARACTER*10 REJTIT
      INTEGER IFAIL
      COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  data of c.m. system of Pomeron / Reggeon exchange
      INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
      DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
     &                 SIDP,CODP,SIFP,COFP
      COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
     &                SIDP,CODP,SIFP,COFP,NPOSP(2),
     &                IDPDG1,IDBAM1,IDPDG2,IDBAM2

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
      INTEGER IDEQP,IDEQB,IHFLD,IHFLS
      DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
      COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
     &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)

C  obsolete cut-off information
      DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
      COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN

C  data on most recent hard scattering
      INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
      DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
     &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
      COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
     &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
     &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
     &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC

      DIMENSION XS1(*),XS2(*)

C** anfe increased MAXPOT = 50 -> 100
      INTEGER MAXPOT
      PARAMETER ( MAXPOT = 100 )
      DIMENSION XPOT1(MAXPOT),XPOT2(MAXPOT),XMIN(2,MAXPOT)

      IREJ = 0

      MSMAX = MAX(MSPAR1,MSPAR2)
      MSMIN = MAX(MSM1,MSM2)

      IF(MSMAX.GT.MAXPOT) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,2A,2I4)') 'PHO_SOFTXX: no space left in ',
     &    'local fields XPOT1/2 (MSMAX,MAXPOT):',MSMAX,MAXPOT
        IREJ = 1
        RETURN
      ENDIF

C  determine exponents
      IBAR1 = IPHO_BAR3(JM1,2)
      IBAR2 = IPHO_BAR3(JM2,2)
      ISWAP = 0
      IF((IBAR1*IBAR2).LT.0) ISWAP = 1
C  meson-baryon scattering (asymmetric sea)
      IF((ABS(IBAR1)+ABS(IBAR2)).EQ.1) THEN
        PSBAR = PARMDL(53)
        PSMES = PARMDL(57)
      ELSE
        PSBAR = PARMDL(52)
        PSMES = PARMDL(56)
      ENDIF

C  lower limits for x sampling
      XMMINA = 2.D0*PARMDL(157)/ECMP
      XBMINA = 2.D0*PARMDL(158)/ECMP
      XSMINA = 2.D0*PARMDL(159)/ECMP
      XMIN1 = MAX(XSOMIN,AS/XMAX2)
      XMIN2 = MAX(XSOMIN,AS/XMAX1)
      XMAXP1 = MIN(1.D0-XMIN1*MSMAX,XMAX1)
      XMAXP2 = MIN(1.D0-XMIN2*MSMAX,XMAX2)
      XMIN1 = MAX(AS/XMAX2,XMIN1)
      XMIN2 = MAX(AS/XMAX1,XMIN2)

C  particle 1
      XMMIN1 = MAX(XMIN1,XMMINA)
      XBMIN1 = MAX(XMIN1,XBMINA)
      XSMIN1 = MAX(XMIN1,XSMINA)
C  mesonic particle
      IF(IBAR1.EQ.0) THEN
        IF(IHFLS(1).EQ.0) THEN
          XPOT1(1) = PARMDL(62)
          XMIN(1,1)  = XSMIN1
          XPOT1(2) = PARMDL(63)
          XMIN(1,2)  = XSMIN1
        ELSE
          XPOT1(1) = PARMDL(54)
          XMIN(1,1)  = XMMIN1
          XPOT1(2) = PARMDL(55)
          XMIN(1,2)  = XMMIN1
        ENDIF
        DO 100 I=3-IVAL1,MSMAX
          XPOT1(I) = PSMES
          XMIN(1,I)  = XSMIN1
 100    CONTINUE
C  baryonic particle
      ELSE
        IF(IHFLS(1).EQ.0) THEN
          XPOT1(1) = PARMDL(62)
          XMIN(1,1)  = XSMIN1
          XPOT1(2) = PARMDL(63)
          XMIN(1,2)  = XSMIN1
        ELSE
          XPOT1(1) = PARMDL(50)
          XMIN(1,1)  = XBMIN1
          XPOT1(2) = PARMDL(51)
          XMIN(1,2)  = XMMIN1
        ENDIF
        DO 200 I=3-IVAL1,MSMAX
          XPOT1(I) = PSBAR
          XMIN(1,I)  = XSMIN1
 200    CONTINUE
      ENDIF

C  particle 2
      XMMIN2 = MAX(XMIN2,XMMINA)
      XBMIN2 = MAX(XMIN2,XBMINA)
      XSMIN2 = MAX(XMIN2,XSMINA)
C  mesonic particle
      IF(IBAR2.EQ.0) THEN
        IF(IHFLS(2).EQ.0) THEN
          XPOT2(1) = PARMDL(62)
          XMIN(2,1)  = XSMIN2
          XPOT2(2) = PARMDL(63)
          XMIN(2,2)  = XSMIN2
        ELSE
          XPOT2(1) = PARMDL(54)
          XMIN(2,1)  = XMMIN2
          XPOT2(2) = PARMDL(55)
          XMIN(2,2)  = XMMIN2
        ENDIF
        DO 300 I=3-IVAL2,MSMAX
          XPOT2(I) = PSMES
          XMIN(2,I)  = XSMIN2
 300    CONTINUE
C  baryonic particle
      ELSE
        IF(IHFLS(2).EQ.0) THEN
          XPOT2(1) = PARMDL(62)
          XMIN(2,1)  = XSMIN2
          XPOT2(2) = PARMDL(63)
          XMIN(2,2)  = XSMIN2
        ELSE
          XPOT2(1) = PARMDL(50)
          XMIN(2,1)  = XBMIN2
          XPOT2(2) = PARMDL(51)
          XMIN(2,2)  = XMMIN2
        ENDIF
        DO 400 I=3-IVAL2,MSMAX
          XPOT2(I) = PSBAR
          XMIN(2,I)  = XSMIN2
 400    CONTINUE
      ENDIF

      XSS1 = XSUM1
      XSS2 = XSUM2
      MSOFT = MSMAX

C  check limits (important for valences)
      IF((XMIN(1,1).GE.XMAXP1).OR.(XMIN(1,2).GE.XMAXP1)) GOTO 1000
      IF((XMIN(2,1).GE.XMAXP2).OR.(XMIN(2,2).GE.XMAXP2)) GOTO 1000

      XMINS1 = XSS1
      IF(IHFLS(1).NE.0) XMINS1 = XMINS1+(PARMDL(166)/ECMP)**2
      XMINS2 = XSS2
      IF(IHFLS(2).NE.0) XMINS2 = XMINS2+(PARMDL(166)/ECMP)**2
      DO 10 I=1,MSOFT
        XMINS1 = XMINS1+XMIN(1,I)
        XMINS2 = XMINS2+XMIN(2,I)
 10   CONTINUE
      IF((XMINS1.GE.1.D0).OR.(XMINS2.GE.1.D0)) GOTO 1000

C  try to sample x values
      IF(IPAMDL(14).EQ.0) THEN
        IF(MSOFT.EQ.2) THEN
          CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
     &                XS1,XS2,IREJ)
        ELSE IF(MSOFT.LT.5) THEN
          CALL PHO_SELSXR(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
     &                XMAXP1,XMAXP2,XS1,XS2,IREJ)
        ELSE
          CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
     &                XMAXP1,XMAXP2,XS1,XS2,IREJ)
        ENDIF
      ELSE IF(IPAMDL(14).EQ.1) THEN
        IF(MSOFT.EQ.2) THEN
          CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
     &                XS1,XS2,IREJ)
        ELSE
          CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
     &                XMAXP1,XMAXP2,XS1,XS2,IREJ)
        ENDIF
      ELSE IF(IPAMDL(14).EQ.2) THEN
        CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
     &              XMAXP1,XMAXP2,XS1,XS2,IREJ)
      ELSE IF(IPAMDL(14).EQ.3) THEN
        IF(MSOFT.EQ.2) THEN
          CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
     &                XS1,XS2,IREJ)
        ELSE IF(IVAL1+IVAL2.EQ.0) THEN
          CALL PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
     &                XMAXP1,XMAXP2,XS1,XS2,IREJ)
        ELSE
          CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
     &                XMAXP1,XMAXP2,XS1,XS2,IREJ)
        ENDIF
      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/,1X,A,I3)')
     &    'PHO_SOFTXX:ERROR: unsupported IPAMDL(14)',IPAMDL(14)
        STOP
      ENDIF
      IF(IREJ.NE.0) THEN
        IFAIL(41) = IFAIL(41)+1
        IF(IDEB(60).GE.2) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,I12,4I3)')
     &      'PHO_SOFTXX: rejection: EVE,MSP1/2,MSM1/2',
     &      KEVENT,MSPAR1,MSPAR2,MSM1,MSM2
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,1P4E11.3)') 'XSUM1/2,XMAX1/2',
     &      XSUM1,XSUM2,XMAX1,XMAX2
        ENDIF
        RETURN
      ENDIF
      IF(MSOFT.NE.MSMAX) THEN
        MSDIFF = MSMAX-MSOFT
        MSPAR1 = MSPAR1-MSDIFF
        MSPAR2 = MSPAR2-MSDIFF
      ENDIF

C  correct for different MSPAR numbers
      IF(MSOFT.NE.MSPAR1) THEN
        IF(MSPAR1.GT.1) THEN
          XDEL = 0.D0
          DO 500 I=MSPAR1+1,MSOFT
            XDEL = XDEL+XS1(I)
 500      CONTINUE
          XFAC = (1.D0-XSUM1)/(1.D0-XDEL-XSUM1)
          DO 550 I=2,MSPAR1
            XS1(I) = XS1(I)*XFAC
 550      CONTINUE
          XSS1 = (XSS1-XDEL-XSUM1)*XFAC+XSUM1
        ELSE
          XSS1 = XSUM1
        ENDIF
      ENDIF
      IF(MSOFT.NE.MSPAR2) THEN
        IF(MSPAR2.GT.1) THEN
          XDEL = 0.D0
          DO 600 I=MSPAR2+1,MSOFT
            XDEL = XDEL+XS2(I)
 600      CONTINUE
          XFAC = (1.D0-XSUM2)/(1.D0-XDEL-XSUM2)
          DO 650 I=2,MSPAR2
            XS2(I) = XS2(I)*XFAC
 650      CONTINUE
          XSS2 = (XSS2-XDEL-XSUM2)*XFAC+XSUM2
        ELSE
          XSS2 = XSUM2
        ENDIF
      ENDIF

C  first x entry
      XS1(1) = 1.D0 - XSS1
      XS2(1) = 1.D0 - XSS2
      XSUM1 = XSS1
      XSUM2 = XSS2

C  debug output
      IF(IDEB(60).GE.10) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I8,2I4,2E12.4)')
     &    'PHO_SOFTXX: EVE,MSPAR1/2,XSUM1/2:',
     &    KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I  XS1/2   XPOT1/2  XMIN1/2'
        DO 30 I=1,MSOFT
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,I3,6E12.4)') I,XS1(I),XS2(I),XPOT1(I),XPOT2(I),
     &      XMIN(1,I),XMIN(2,I)
 30     CONTINUE
      ENDIF

      RETURN

C  not enough phase space
 1000 CONTINUE

      IFAIL(42) = IFAIL(42)+1
      IREJ = 1

C  warning message
      IF(IDEB(60).GE.1) THEN
        WRITE (6,'(1X,A,1P,2E11.3,/1X,A,/5X,6E11.3)')
     &    'PHO_SOFTXX: Xmin>Xmax or sum(Xmin)>1 (ECM,AS)',
     &    ECMP,AS,'PHO_SOFTXX: Xmin1/2,Xmaxp1/2,sum(Xmin1/2)',
     &    XMIN1,XMIN2,XMAXP1,XMAXP2,XMINS1,XMINS2
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,1P,3E11.3)')
     &    'PHO_SOFTXX: Xmmina,Xbmina,Xsmina:',XMMINA,XBMINA,XSMINA
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,1P,3E11.3)')
     &    'PHO_SOFTXX: Xmmin1,Xbmin1,Xsmin1:',XMMIN1,XBMIN1,XSMIN1
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,1P,3E11.3)')
     &    'PHO_SOFTXX: Xmmin2,Xbmin2,Xsmin2:',XMMIN2,XBMIN2,XSMIN2
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A)')
     &    'PHO_SOFTXX: Table of lower x limits (I,Xmin(1,I),Xmin(2,I))'
        DO 27 I=1,MSOFT
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,I3,1P,2E11.3)') I,XMIN(1,I),XMIN(2,I)
 27     CONTINUE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I10,2I4,2E11.3)')
     &    'PHO_SOFTXX: KEVENT,MSPAR1/2,XSUM1/2:',
     &    KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I   XPOT1/2   XMIN1/2'
        DO 25 I=1,MSOFT
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,I3,4E12.4)') I,XPOT1(I),XPOT2(I),
     &    XMIN(1,I),XMIN(2,I)
 25     CONTINUE
      ENDIF

      END


 
 


CDECK  ID>, PHO_SREGPAR
      SUBROUTINE PHO_SREGPAR
c*********************************************************************
c
c     Save reggeon and pomeron parameter common block according
c     to current multiparticle index
c
c     input:   in /popreg/
c
c     output:  in /pospre/
c
c*********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      SAVE

      INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN
      INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL
      DOUBLE PRECISION SQSGLOBMAX
      PARAMETER (MPARMAX=40)
      PARAMETER (MAXMAPPS=40)
      PARAMETER (IKNOWN=9)
      DIMENSION IPAVAIL(IKNOWN)
      DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/
      COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS),
     &           MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP

      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

      DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
     &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
      COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
     &                ALREG,ALREGP,GR(2),B0REG(2),
     &                GPPP,GPPR,B0PPP,B0PPR,
     &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC

      DOUBLE PRECISION SALPOM,SALPOMP,SGP,SB0POM,SALREG,SALREGP,SGR,
     &  SB0REG,SGPPP,SGPPR,SB0PPP,SB0PPR,SVDMFAC,SVDMQ2F,SB0HAR,SAKFAC,
     &  SPHISUP, SRMASS
      COMMON /POSPRE/ SALPOM(MPARMAX),SALPOMP(MPARMAX),SGP(2,MPARMAX),
     &  SB0POM(2,MPARMAX),SALREG(MPARMAX),SALREGP(MPARMAX),
     &  SGR(2,MPARMAX),SB0REG(2,MPARMAX),SGPPP(MPARMAX),SGPPR(MPARMAX),
     &  SB0PPP(MPARMAX),SB0PPR(MPARMAX),SVDMFAC(4,MPARMAX),
     &  SVDMQ2F(4,MPARMAX),SB0HAR(MPARMAX),SAKFAC(MPARMAX),
     &  SPHISUP(2,MPARMAX),SRMASS(2,MPARMAX)

      DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
      COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC

      
      IF (LPRI.GT.4) Then
        If (ideb(90) > 10)
     &  Write(lo,'(1X,A,I2)') 'PHO_SREGPAR: Saving reggeon parameters.',
     &     idxmpar 
      End If
      salpom(idxmpar) = alpom
      salpomp(idxmpar) = alpomp
      salreg(idxmpar) = alreg
      salregp(idxmpar) = alregp
      sgppp(idxmpar) = gppp
      sgppr(idxmpar) = gppr
      sb0ppp(idxmpar) = b0ppp
      sb0ppr(idxmpar) = b0ppr
      sb0har(idxmpar) = b0har
      sakfac(idxmpar) = akfac
      Do i=1,2
        sgp(i,idxmpar) = gp(i)
        sgr(i,idxmpar) = gr(i)
        sb0pom(i,idxmpar) = b0pom(i)
        sb0reg(i,idxmpar) = b0reg(i)
      End Do
      Do i=1,4
        svdmfac(i,idxmpar) = vdmfac(i)
        svdmq2f(i,idxmpar) = vdmq2f(i)
      End Do
      Do i=1,2
        sphisup(i,idxmpar) = phisup(i)
        srmass(i,idxmpar) = rmass(i)
      End Do
      
      END 


 
 


CDECK  ID>, PHO_STDPAR
      SUBROUTINE PHO_STDPAR(IJM1,IJM2,IGEN,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
C***********************************************************************
C
C     select the initial parton x-fractions and flavors and
C     the final parton momenta and flavours
C     for standard Pomeron/Reggeon cuts
C
C     input:   IJM1   index of mother particle 1 in /POEVT1/
C              IJM2   index of mother particle 2 in /POEVT1/
C              IGEN   production process of mother particles
C              MSPOM  soft cut Pomerons
C              MHPOM  hard or semihard cut Pomerons
C              MSREG  soft cut Reggeons
C              MHDIR  direct hard processes
C
C              IJM1   -1    initialization of statistics
C                     -2    output of statistics
C
C     output:  partons are directly written to /POEVT1/,/POEVT2/
C
C          structure of /POSOFT/
C               XS1(I),XS2(I):     x-values of initial partons
C               IJSI1(I),IJSI2(I): flavor of initial parton
C                                  0            gluon
C                                  1,2,3,4      quarks
C                                  negative     antiquarks
C               IJSF1(I),IJSF2(I): flavor of final state partons
C               PSOFT1(I,J),PSOFT2(I,J): final part. momentum and energy
C                                J=1   PX
C                                 =2   PY
C                                 =3   PZ
C                                 =4   ENERGY
C
C***********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER (RHOMAS =  0.766D0,
     &           DEPS   =  1.D-10,
     &           TINY   =  1.D-10)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  current beam selection
      INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN
      INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL
      DOUBLE PRECISION SQSGLOBMAX
      PARAMETER (MPARMAX=40)
      PARAMETER (MAXMAPPS=40)
      PARAMETER (IKNOWN=9)
      DIMENSION IPAVAIL(IKNOWN)
      DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/
      COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS),
     &           MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

C  general process information
      INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
      COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)

C  global event kinematics and particle IDs
      INTEGER IFPAP,IFPAB
      DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
      COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)

C  data of c.m. system of Pomeron / Reggeon exchange
      INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
      DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
     &                 SIDP,CODP,SIFP,COFP
      COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
     &                SIDP,CODP,SIFP,COFP,NPOSP(2),
     &                IDPDG1,IDBAM1,IDPDG2,IDBAM2

C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
      INTEGER IDEQP,IDEQB,IHFLD,IHFLS
      DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
      COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
     &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)

C  obsolete cut-off information
      DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
      COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN

C  currently activated parton density parametrizations
      CHARACTER*8 PDFNAM
      INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
      DOUBLE PRECISION PDFLAM,PDFQ2M
      COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
     &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD

C  hard scattering parameters used for most recent hard interaction
      INTEGER NFbeta,NF
      DOUBLE PRECISION ALQCD2,BQCD
      COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF

C  particles created by initial state evolution
      INTEGER MXISR1,MXISR2
      PARAMETER ( MXISR1 = 150, MXISR2 = 1000 )
      INTEGER IFLISR,IPOISR,IMXISR
      DOUBLE PRECISION PHISR
      COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
     &                IPOISR(2,2,MXISR2),IMXISR(2)

C  light-cone x fractions and c.m. momenta of soft cut string ends
      INTEGER MAXSOF
      PARAMETER ( MAXSOF = 2000 )
      INTEGER IJSI2,IJSI1
      DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
      COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
     &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
     &                IJSI1(MAXSOF),IJSI2(MAXSOF)

C  table of particle indices for recursive PHOJET calls
      INTEGER MAXIPX
      PARAMETER ( MAXIPX = 500 )
      INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
      COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
     &                IPOIX1,IPOIX2,IPOIX3

C  hard scattering data
      INTEGER MSCAHD
      PARAMETER ( MSCAHD = 1000 )
      INTEGER LSCAHD,LSC1HD,LSIDX,
     &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
      DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
      COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
     &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
     &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
     &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
     &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
     &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
     &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

C  internal rejection counters
      INTEGER NMXJ
      PARAMETER (NMXJ=60)
      CHARACTER*10 REJTIT
      INTEGER IFAIL
      COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)

C  internal cross check information on hard scattering limits
      DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
      COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)

C  hard cross sections and MC selection weights
      INTEGER Max_pro_2
      PARAMETER ( Max_pro_2 = 16 )
      INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
     &  MH_acc_1,MH_acc_2
      DOUBLE PRECISION HFAC, HWGX, HSIG, HDPT, HECM_LAST, 
     &   HQ2A_LAST, HQ2B_LAST
      COMMON /POHRCS/HFAC(-1:MAX_PRO_2, MPARMAX), 
     &   HWGX(-1:MAX_PRO_2, MPARMAX),
     &   HSIG(-1:MAX_PRO_2, MPARMAX), HDPT(-1:MAX_PRO_2, MPARMAX), 
     &   HECM_LAST, HQ2A_LAST, HQ2B_LAST, IHA_LAST, IHB_LAST, 
     &   MH_PRO_ON(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_TRIED(-1:MAX_PRO_2, 0:4, MPARMAX), 
     &   MH_ACC_1(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_ACC_2(-1:MAX_PRO_2, 0:4, MPARMAX) 

      DOUBLE PRECISION PHO_ALPHAS
      EXTERNAL         PHO_ALPHAS
      DOUBLE PRECISION PHO_PMASS
      EXTERNAL         PHO_PMASS
      DIMENSION PC(4),IFLA(2),ICI(2,2)

      IF(IJM1.EQ.-1) THEN
        DO 116 I=1,15
          ETAMI(1,I) = 1.D10
          ETAMA(1,I) = -1.D10
          ETAMI(2,I) = 1.D10
          ETAMA(2,I) = -1.D10
          XXMI(1,I) = 1.D0
          XXMA(1,I) = 0.D0
          XXMI(2,I) = 1.D0
          XXMA(2,I) = 0.D0
 116    CONTINUE
        CALL PHO_HARSCA(IJM1,1)
        CALL PHO_HARCOL(IJM1,0.D0,0,0,0,0,0,0,0,0,0,0,0,0)

        RETURN

      ELSE IF(IJM1.EQ.-2) THEN

C  output internal statistics
        IF(IDEB(23).GE.1) THEN
          IF (LPRI.GT.4)
     $    WRITE(LO,'(/1X,A)') 'PHO_STDPAR'
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A)')
     &      'kinematic limits particle c (ETAMIN,ETAMAX,XMIN,XMAX)'
          DO 117 I=1,15
            IF (LPRI.GT.4)
     &      WRITE(LO,'(5X,I3,4E13.5)')
     &        I,ETAMI(1,I),ETAMA(1,I),XXMI(1,I),XXMA(1,I)
 117      CONTINUE
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A)')
     &      'kinematic limits particle d (ETAMIN,ETAMAX,XMIN,XMAX)'
          DO 118 I=1,15
            IF (LPRI.GT.4)
     &      WRITE(LO,'(5X,I3,4E13.5)')
     &        I,ETAMI(2,I),ETAMA(2,I),XXMI(2,I),XXMA(2,I)
 118      CONTINUE
        ENDIF
        CALL PHO_HARSCA(IJM1,1)
        CALL PHO_HARCOL(IJM1,0.D0,0,0,0,0,0,0,0,0,0,0,0,0)

        RETURN
      ENDIF

      IREJ   = 0
C  debug output
      IF (LPRI.GT.4 .AND. IDEB(23).GT.5)
     &WRITE(LO,221) IJM1,IJM2,MSPOM,MHPOM,MSREG,MHDIR
  221 FORMAT (' PHO_STDPAR: JM1/2,MSPOM,MHPOM,MSREG,MHDIR ',6I5)

C  get mother data (exchange if first particle is a pomeron)
      IF((IDHEP(IJM1).EQ.990).AND.(IFPAP(1).NE.990)) THEN
        JM1 = IJM2
        JM2 = IJM1
      ELSE
        JM1 = IJM1
        JM2 = IJM2
      ENDIF

      NPOSP(1) = JM1
      NPOSP(2) = JM2
      IDPDG1 = IDHEP(JM1)
      IDBAM1 = IMPART(JM1)
      IDPDG2 = IDHEP(JM2)
      IDBAM2 = IMPART(JM2)

C  store current status of /POEVT1/
      KHPOMS = KHPOM
      KSPOMS = KSPOM
      KSREGS = KSREG
      KHDIRS = KHDIR
      NHEPS  = NHEP
      IPOIS1 = IPOIX1
      IPOIS2 = IPOIX2

C  get nominal masses (photons: VDM assumption)
      DELMAS = 0.D0
      IF(IDHEP(JM1).EQ.22) THEN
        PMASSP(1) = RHOMAS+DELMAS
        PVIRTP(1) = PHEP(5,JM1)**2
      ELSE
        PMASSP(1) = PHO_PMASS(IDBAM1,0)+DELMAS
        PVIRTP(1) = 0.D0
      ENDIF
      IF(IDHEP(JM2).EQ.22) THEN
        PMASSP(2) = RHOMAS+DELMAS
        PVIRTP(2) = PHEP(5,JM2)**2
      ELSE
        PMASSP(2) = PHO_PMASS(IDBAM2,0)+DELMAS
        PVIRTP(2) = 0.D0
      ENDIF

C  calculate c.m. energy and check kinematics
      PC(1) = PHEP(1,JM1)+PHEP(1,JM2)
      PC(2) = PHEP(2,JM1)+PHEP(2,JM2)
      PC(3) = PHEP(3,JM1)+PHEP(3,JM2)
      PC(4) = PHEP(4,JM1)+PHEP(4,JM2)
      SS = (PC(4)+PC(3))*(PC(4)-PC(3))-PC(1)**2-PC(2)**2

      IF(SS.LE.(PMASSP(1)+PMASSP(2)+DEPS)**2) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/,1X,2A)') 'PHO_STDPAR: ',
     &    'energy smaller than two-particle threshold (event rejected)'
        CALL PHO_PREVNT(1)
        IREJ = 5
        GOTO 150
      ENDIF
      ECMP = SQRT(SS)

      IF(IDEB(23).GE.5) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,2A,2I7,E12.4)') 'PHO_STDPAR: ',
     &    'particles, available energy:',IDHEP(JM1),IDHEP(JM2),ECMP
        IF(IDEB(23).GE.25) CALL PHO_PREVNT(0)
      ENDIF

C  Lorentz transformation into c.m. system
      DO 10 I=1,4
        GAMBEP(I) = PC(I)/ECMP
 10   CONTINUE
      CALL PHO_ALTRA(GAMBEP(4),-GAMBEP(1),-GAMBEP(2),-GAMBEP(3),
     &           PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
     &           PHEP(4,JM1),PTOT1,PC(1),PC(2),PC(3),PC(4))
C  rotation angle: particle 1 moves along +z
      CODP = PC(3)/PTOT1
      SIDP = SQRT(PC(1)**2+PC(2)**2)/PTOT1
      COFP = 1.D0
      SIFP = 0.D0
      IF(PTOT1*SIDP.GT.1.D-5) THEN
        COFP = PC(1)/(SIDP*PTOT1)
        SIFP = PC(2)/(SIDP*PTOT1)
        ANORF = SQRT(COFP*COFP+SIFP*SIFP)
        COFP = COFP/ANORF
        SIFP = SIFP/ANORF
      ENDIF
C  get CM momentum
      XM12 = PMASSP(1)**2
      XM22 = PMASSP(2)**2
      PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*ECMP)

C  find particle combination
      II = 0
      IF(IDPDG2.EQ.IFPAP(2)) THEN
        IF(IDPDG1.EQ.IFPAP(1)) II = 1
      ELSE IF(IDPDG2.EQ.990) THEN
        IF(IDPDG1.EQ.IFPAP(1)) THEN
          II = 2
        ELSE IF(IDPDG1.EQ.IFPAP(2)) THEN
          II = 3
        ELSE IF(IDPDG1.EQ.990) THEN
          II = 4
        ENDIF
      ENDIF
      IF(II.EQ.0) THEN
        IF(ISWMDL(14).GT.0) THEN
          II = 1
        ELSE
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,2A,2I8)') 'PHO_STDPAR:ERROR: ',
     &      'invalid particle combination:',IDPDG1,IDPDG2
          CALL PHO_ABORT
        ENDIF
      ENDIF

C  select parton distribution functions from tables
      IF((MHPOM+MHDIR).GT.0) THEN
        CALL PHO_ACTPDF(IDPDG1,1)
        CALL PHO_ACTPDF(IDPDG2,2)
C  initialize alpha_s calculation
        DUMMY = PHO_ALPHAS(0.D0,-4)
      ENDIF

C  interpolate hard cross sections and rejection weights
      CALL PHO_HARINT(II,ECMP,PVIRTP(1),PVIRTP(2),
     &            -1,Max_pro_2,1,4,MSPOM+MHPOM+MHDIR)

      NTRY   = 10

C  position of first particle added to /POEVT2/
      NLOR1 = NHEP+1

C  ---------------- direct processes -----------------

      IF(MHDIR.EQ.1) THEN
        CALL PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
        IF(IREJ.EQ.50) RETURN
        IF(IREJ.NE.0) GOTO 150

C  soft spectator partons
        ICA1  = 0
        ICA2  = 0
        ICB1  = 0
        ICB2  = 0
        IPDF1 = 0
        IPDF2 = 0

C  write comments to /POEVT1/
        CALL PHO_REGPAR(25,II,NPROHD(1),IDPDG1,IDPDG2,X0HD(1,1),
     &    X0HD(1,2),PTHD(1),VHD(1),N0INHD(1,1),N0INHD(1,2),
     &    IPHO_CNV1(NOUTHD(1,1)),IPHO_CNV1(NOUTHD(1,2)),IPOS,1)
        CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,1)),IPDF1,JM1,JM2,
     &    PPH(1,1),PPH(2,1),PPH(3,1),Q2SCA(1,1),100,NBRAHD(1,1),
     &    ICA1,ICA2,IPOS,1)
        CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,2)),IPDF2,JM2,JM1,
     &    PPH(1,2),PPH(2,2),PPH(3,2),Q2SCA(1,2),100,NBRAHD(1,2),
     &    ICA1,ICA2,IPOS,1)
        CALL PHO_REGPAR(21,NOUTHD(1,1),IPDF1,JM1,JM2,PPH(5,1),
     &    PPH(6,1),PPH(7,1),PPH(8,1),100,NBRAHD(1,1),ICA1,ICA2,
     &    IPOS1,1)
        CALL PHO_REGPAR(21,NOUTHD(1,2),IPDF2,JM2,JM1,PPH(5,2),
     &    PPH(6,2),PPH(7,2),PPH(8,2),100,NBRAHD(1,2),ICA1,ICA2,
     &    IPOS2,1)


C  single resolved: QCD compton scattering
C ------------------------------
        IF(NPROHD(1).EQ.10) THEN
C  register hadron remnant
          CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
          IPDF2 = 1000*IGRP(2)+ISET(2)
        ELSE IF(NPROHD(1).EQ.12) THEN
C  register hadron remnant
          CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
          IPDF1 = 1000*IGRP(1)+ISET(1)

C  single resolved: photon gluon fusion
C ---------------------------
        ELSE IF(NPROHD(1).EQ.11) THEN
C  register hadron remnant
          CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
          IPDF2 = 1000*IGRP(2)+ISET(2)
        ELSE IF(NPROHD(1).EQ.13) THEN
C  register hadron remnant
          CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
          IPDF1 = 1000*IGRP(1)+ISET(1)

C  direct process (no remnant)
C ----------------------------
        ELSE IF(NPROHD(1).EQ.14) THEN

        ENDIF

C  write final high-pt partons to POEVT1
        IF((ISWMDL(8).GE.2).AND.(NPROHD(1).NE.14)) THEN
          ICI(1,1) = ICA1
          ICI(1,2) = ICA2
          ICI(2,1) = ICB1
          ICI(2,2) = ICB2
          I = 1
          IFLA(1) = NINHD(I,1)
          IFLA(2) = NINHD(I,2)
C  initial state radiation
          DO 130 K=1,2
            DO 135 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
              KK = 1
 137          CONTINUE
              IFLB = IFLISR(K,IPA)
              IF(ABS(IFLB).LE.6) THEN
C  partons
                IF(ICI(K,1)*ICI(K,2).NE.0) THEN
                  IF(IFLB.EQ.0) THEN
                    CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
     &                ICI(K,1),ICI(K,2),3)
                  ELSE IF(IFLB.GT.0) THEN
                    CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
     &                ICI(K,1),ICI(K,2),4)
                  ELSE
                    CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
     &                IC1,IC2,4)
                  ENDIF
                ELSE
                  IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
                    IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
                      CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
                      KK = KK+1
                      GOTO 137
                    ENDIF
                  ENDIF
                  IF(IFLB.EQ.0) THEN
                    CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
     &                IC1,IC2,2)
                  ELSE
                    CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
     &                ICI(K,1),ICI(K,2),2)
                  ENDIF
                ENDIF
                IIFL = IPHO_CNV1(IFLB)

                IFLA(K) = IFLA(K)-IFLB
                IST = -1
              ELSE
C  other particle
                IIFL = IFLB
                IC1 = 0
                IC2 = 0
                IST = 1
              ENDIF
              CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
     &          PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),I*100+K,
     &          IGEN,IC1,IC2,IPOS,1)
 135        CONTINUE
 130      CONTINUE
          ICOLOR(1,IPOS1-2) = ICI(1,1)
          ICOLOR(2,IPOS1-2) = ICI(1,2)
          ICOLOR(1,IPOS1-1) = ICI(2,1)
          ICOLOR(2,IPOS1-1) = ICI(2,2)
          CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
     &      IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
     &      NOUTHD(I,2),ICI(2,1),ICI(2,2))
          ICOLOR(1,IPOS1) = ICI(1,1)
          ICOLOR(2,IPOS1) = ICI(1,2)
          ICOLOR(1,IPOS2) = ICI(2,1)
          ICOLOR(2,IPOS2) = ICI(2,2)
          DO 140 K=1,2
            IPA = IPOISR(K,1,I)
            CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
     &        PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
     &        PHISR(K,4,IPA),-I*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
 140      CONTINUE
        ELSE
          ICOLOR(1,IPOS1-2) = ICA1
          ICOLOR(2,IPOS1-2) = ICA2
          ICOLOR(1,IPOS1-1) = ICB1
          ICOLOR(2,IPOS1-1) = ICB2
          CALL PHO_HARCOL(NPROHD(1),VHD(1),NINHD(1,1),ICA1,ICA2,
     &      NINHD(1,2),ICB1,ICB2,NOUTHD(1,1),ICA1,ICA2,
     &      NOUTHD(1,2),ICB1,ICB2)
          ICOLOR(1,IPOS1) = ICA1
          ICOLOR(2,IPOS1) = ICA2
          ICOLOR(1,IPOS2) = ICB1
          ICOLOR(2,IPOS2) = ICB2
          I = -1
          IF(ABS(NOUTHD(1,1)).GT.12) I = 1
          CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,1)),0,JM1,JM2,PPH(5,1),
     &      PPH(6,1),PPH(7,1),PPH(8,1),-100,IGEN,ICA1,ICA2,IPOS,1)
          CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,2)),0,JM1,JM2,PPH(5,2),
     &      PPH(6,2),PPH(7,2),PPH(8,2),-100,IGEN,ICB1,ICB2,IPOS,1)
        ENDIF

C  assign soft pt to spectators
        IF(ISWMDL(18).EQ.0) THEN
          IPOS2 = IPOS2-1
          CALL PHO_PARTPT(0,NLOR1,IPOS2,PTCUT(II),IREJ)
          IF(IREJ.NE.0) THEN
            IFAIL(26) = IFAIL(26) + 1
            GOTO 150
          ENDIF

        ENDIF

C  ----------------- resolved processes -------------------

C  single Reggeon exchange
C ----------------------------
      ELSE IF((MSREG.EQ.1).AND.(MHPOM+MSPOM.EQ.0)) THEN
C  flavours
        CALL PHO_REGFLA(JM1,JM2,IFL1,IFL2,IREJ)
        IF(IREJ.NE.0) THEN
          IFAIL(24) = IFAIL(24)+1
          GOTO 150
        ENDIF

C  colors
        CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
        IF(((ABS(IFL1).GT.6).AND.(IFL1.GT.0))
     &     .OR.((ABS(IFL1).LE.6).AND.(IFL1.LT.0))) THEN
          CALL PHO_SWAPI(ICA1,ICB1)
        ENDIF
        ECMH = ECMP/2.D0

C  registration

C  DPMJET call with special projectile / target
        IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
          CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH*XPSUB,
     &               ECMH*XPSUB,-1,IGEN,ICA1,0,IPOS1,1)
          CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH*XTSUB,
     &               ECMH*XTSUB,-1,IGEN,ICB1,0,IPOS2,1)
C  default treatment
        ELSE
          CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH,ECMH,
     &      -1,IGEN,ICA1,0,IPOS1,1)
          CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH,ECMH,
     &      -1,IGEN,ICB1,0,IPOS2,1)
        ENDIF

C  soft pt assignment
        IF(ISWMDL(18).EQ.0) THEN
          CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
          IF(IREJ.NE.0) THEN
            IFAIL(25) = IFAIL(25) + 1
            GOTO 150
          ENDIF
        ENDIF
C
C  multi Reggeon / Pomeron exchange
C----------------------------------------
      ELSE
C  parton configuration

        CALL PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,MSPAR1,MSPAR2,
     &              MHPAR1,MHPAR2,IREJ)

        IF(IREJ.EQ.50) RETURN
        IF(IREJ.NE.0) GOTO 150

C  register particles
        IF (LPRI.GT.4 .AND. IDEB(23).GE.15)
     &  WRITE(LO,'(1X,A,/15X,7I5)')
     &    'PHO_STDPAR: MSPOM,MHPOM,MSREG,MSPAR1/2,IVAL1/2',
     &    MSPOM,MHPOM,MSREG,MSPAR1,MSPAR2,IVAL1,IVAL2

C  register soft partons
        IF(IVAL1.NE.0) THEN
          IF(IVAL1.LT.0) THEN
            IND1 = 3
            IVAL1=-IVAL1
          ELSE
            IND1 = 2
          ENDIF
        ELSE IF(MSPOM.EQ.0) THEN
          IND1 = 4
        ELSE
          IND1 = 1
        ENDIF
        IF(IVAL2.NE.0) THEN
          IF(IVAL2.LT.0) THEN
            IND2 = 3
            IVAL2=-IVAL2
          ELSE
            IND2 = 2
          ENDIF
        ELSE IF(MSPOM.EQ.0) THEN
          IND2 = 4
        ELSE
          IND2 = 1
        ENDIF

        IF (LPRI.GT.4 .AND. IDEB(23).GE.20)
     &  WRITE(LO,'(1X,A,2I3,2X,2I3)')
     &    'PHO_STDPAR: IND1/2,IVAL1/2',IND1,IND2,IVAL1,IVAL2

C  soft Pomeron final states
C -----------------------------------
        K = MSPOM+MHPOM+MSREG
        DO 50 I=1,MSPOM

          CALL PHO_POSPOM(II,IND1,IND2,IGEN,I,K,ISWAP,IREJ)
          IF(IREJ.NE.0) THEN
            IFAIL(8) = IFAIL(8) + 1
            GOTO 150
          ENDIF
C
 50     CONTINUE

C  soft Reggeon final states
C -----------------------------------------
        DO 75 I=1,MSREG
C  flavours
          CMASS1 = MIN(PSOFT1(4,IND1),PSOFT2(4,IND2))
          IF(DT_RNDM(CMASS1).LT.0.5D0) THEN
            CALL PHO_SEAFLA(JM1,IFLA1,IFLB1,CMASS1)
          ELSE
            CALL PHO_SEAFLA(JM2,IFLA1,IFLB1,CMASS1)
          ENDIF

C  colors
          CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
          IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
     &      .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
     &      CALL PHO_SWAPI(ICA1,ICB1)
C  registration
          CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
     &      PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),
     &      I,IGEN,ICA1,ICA2,IPOS1,1)
          IND1 = IND1+1
          CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
     &      PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),
     &      I,IGEN,ICB1,ICB2,IPOS2,1)
          IND2 = IND2+1

          IF (LPRI.GT.4 .AND. IDEB(23).GE.20)
     &    WRITE(LO,'(1X,A,/15X,6I4)')
     &      'PHO_STDPAR: reg.cut: IND1,IND2,IFLA,IFLB,IPOS1,IPOS2',
     &      IND1-1,IND2-1,IFLA1,IFLB1,IPOS1,IPOS2

C  soft pt assignment
          IF(ISWMDL(18).EQ.0) THEN
            CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
            IF(IREJ.NE.0) THEN
              IFAIL(25) = IFAIL(25) + 1
              GOTO 150
            ENDIF
          ENDIF

 75     CONTINUE

C  hard Pomeron final states
C ------------------------------------
        IND1 = MSPAR1
        IND2 = MSPAR2
        ICA1  = 0
        ICA2  = 0
        ICB1  = 0
        ICB2  = 0
        
        DO 100 L=1,MHPOM
          I = LSIDX(L)

          IFLI1 = IPHO_CNV1(N0INHD(I,1))
          IFLI2 = IPHO_CNV1(N0INHD(I,2))
          IFLO1 = IPHO_CNV1(NOUTHD(I,1))
          IFLO2 = IPHO_CNV1(NOUTHD(I,2))

C  write comments to /POEVT1/
          CALL PHO_REGPAR(25,II,NPROHD(I),IDPDG1,IDPDG2,X0HD(I,1),
     &      X0HD(I,2),PTHD(I),VHD(I),N0INHD(I,1),N0INHD(I,2),
     &      IFLO1,IFLO2,IPOS,1)
          I1 = 8*I-7
          IPDF = 1000*IGRP(1)+ISET(1)
          CALL PHO_REGPAR(20,IFLI1,IPDF,JM1,JM2,PPH(I1,1),
     &      PPH(I1+1,1),PPH(I1+2,1),Q2SCA(I,1),L*100,NBRAHD(I,1),
     &      ICA1,ICA2,IPOS,1)
          IPDF = 1000*IGRP(2)+ISET(2)
          CALL PHO_REGPAR(20,IFLI2,IPDF,JM2,JM1,PPH(I1,2),
     &      PPH(I1+1,2),PPH(I1+2,2),Q2SCA(I,2),L*100,NBRAHD(I,2),
     &      ICB1,ICB2,IPOS,1)
          I1 = 8*I-3
          IPDF = 1000*IGRP(1)+ISET(1)
          CALL PHO_REGPAR(21,IFLO1,IPDF,JM1,JM2,PPH(I1,1),
     &      PPH(I1+1,1),PPH(I1+2,1),PPH(I,1),L*100,NBRAHD(I,1),
     &      ICA1,ICA2,IPOS1,1)
          IPDF = 1000*IGRP(2)+ISET(2)
          CALL PHO_REGPAR(21,IFLO2,IPDF,JM2,JM1,PPH(I1,2),
     &      PPH(I1+1,2),PPH(I1+2,2),PPH(I,2),L*100,NBRAHD(I,2),
     &      ICB1,ICB2,IPOS2,1)

C  spectator partons belonging to hard interaction
          IF(IVAL1.EQ.I) THEN
            IVQ = 1
            IND = 1
          ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL1.EQ.0)) THEN
            IVQ = 0
            IND = 1
          ELSE
            IVQ = -1
            IND = IND1
          ENDIF
          CALL PHO_HARREM(JM1,JM2,IGEN,L,IVQ,IND,ICA1,ICA2,IUSED,IREJ)
          IF(IVQ.LT.0) IND1 = IND1-IUSED
          IF(IVAL2.EQ.I) THEN
            IVQ = 1
            IND = 1
          ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL2.EQ.0)) THEN
            IVQ = 0
            IND = 1
          ELSE
            IVQ = -1
            IND = IND2
          ENDIF
          CALL PHO_HARREM(JM2,JM1,IGEN,-L,IVQ,IND,ICB1,ICB2,IUSED,IREJ)
          IF(IVQ.LT.0) IND2 = IND2-IUSED
C
C  register hard scattered partons
          IF((ISWMDL(8).GE.2)
     &       .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
            ICI(1,1) = ICA1
            ICI(1,2) = ICA2
            ICI(2,1) = ICB1
            ICI(2,2) = ICB2
            IFLA(1) = NINHD(I,1)
            IFLA(2) = NINHD(I,2)
C  initial state radiation
            DO 230 K=1,2
              DO 235 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
                KK = 1
 237            CONTINUE
                IFLB = IFLISR(K,IPA)
                IF(ABS(IFLB).LE.6) THEN
C  partons
                  IF(ICI(K,1)*ICI(K,2).NE.0) THEN
                    IF(IFLB.EQ.0) THEN
                      CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
     &                  ICI(K,1),ICI(K,2),3)
                    ELSE IF(IFLB.GT.0) THEN
                      CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
     &                  ICI(K,1),ICI(K,2),4)
                    ELSE
                      CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
     &                  ICI(K,2),IC1,IC2,4)
                    ENDIF
                  ELSE
                    IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
                      IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
                        CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
                        KK = KK+1
                        GOTO 237
                      ENDIF
                    ENDIF
                    IF(IFLB.EQ.0) THEN
                      CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
     &                  ICI(K,2),IC1,IC2,2)
                    ELSE
                      CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
     &                  ICI(K,1),ICI(K,2),2)
                    ENDIF
                  ENDIF
                  IIFL = IPHO_CNV1(IFLB)

                  IFLA(K)  = IFLA(K)-IFLB
                  IST = -1
                ELSE
C  other particles
                  IIFL = IFLB
                  IC1 = 0
                  IC2 = 0
                  IST = 1
                ENDIF
                CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
     &            PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),
     &            L*100+K,IGEN,IC1,IC2,IPOS,1)
 235          CONTINUE
 230        CONTINUE
            ICOLOR(1,IPOS1-2) = ICI(1,1)
            ICOLOR(2,IPOS1-2) = ICI(1,2)
            ICOLOR(1,IPOS1-1) = ICI(2,1)
            ICOLOR(2,IPOS1-1) = ICI(2,2)
            CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
     &        IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
     &        NOUTHD(I,2),ICI(2,1),ICI(2,2))
            ICOLOR(1,IPOS1) = ICI(1,1)
            ICOLOR(2,IPOS1) = ICI(1,2)
            ICOLOR(1,IPOS2) = ICI(2,1)
            ICOLOR(2,IPOS2) = ICI(2,2)
            DO 240 K=1,2
              IPA = IPOISR(K,1,I)
              CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
     &          PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
     &          PHISR(K,4,IPA),-L*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
 240        CONTINUE
          ELSE
            ICOLOR(1,IPOS1-2) = ICA1
            ICOLOR(2,IPOS1-2) = ICA2
            ICOLOR(1,IPOS1-1) = ICB1
            ICOLOR(2,IPOS1-1) = ICB2
            CALL PHO_HARCOL(NPROHD(I),VHD(I),NINHD(I,1),ICA1,ICA2,
     &        NINHD(I,2),ICB1,ICB2,NOUTHD(I,1),ICA1,ICA2,
     &        NOUTHD(I,2),ICB1,ICB2)
            ICOLOR(1,IPOS1) = ICA1
            ICOLOR(2,IPOS1) = ICA2
            ICOLOR(1,IPOS2) = ICB1
            ICOLOR(2,IPOS2) = ICB2
            I1 = 8*I-3
            CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,1)),0,JM1,JM2,
     &        PPH(I1,1),PPH(I1+1,1),PPH(I1+2,1),PPH(I1+3,1),-L*100,IGEN,
     &        ICA1,ICA2,IPOS,1)
            CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,2)),0,JM1,JM2,
     &        PPH(I1,2),PPH(I1+1,2),PPH(I1+2,2),PPH(I1+3,2),-L*100,IGEN,
     &        ICB1,ICB2,IPOS,1)
          ENDIF
 100    CONTINUE
C  end of resolved parton registration
      ENDIF

      IF(MHDIR+MHPOM.GT.0) THEN

        IF(ISWMDL(29).GE.1) THEN
C  primordial kt of hard scattering
          CALL PHO_PRIMKT(1,NLOR1,NHEP,PTCUT(II),IREJ)
          IF(IREJ.NE.0) THEN
            IFAIL(27) = IFAIL(27)+1
            GOTO 150
          ENDIF
        ELSE IF(ISWMDL(24).GE.0) THEN
C  give "soft" pt only to soft (spectator) partons in hard processes
          CALL PHO_PARTPT(1,NLOR1,NHEP,PTCUT(II),IREJ)
          IF(IREJ.NE.0) THEN
            IFAIL(26) = IFAIL(26)+1
            GOTO 150
          ENDIF
        ENDIF

      ENDIF

C  give "soft" pt to partons in soft Pomerons
      IF((MHDIR.EQ.0).AND.(ISWMDL(18).EQ.1)) THEN
        CALL PHO_PARTPT(0,NLOR1,NHEP,PTCUT(II),IREJ)
        IF(IREJ.NE.0) THEN
          IFAIL(25) = IFAIL(25) + 1
          GOTO 150
        ENDIF
      ENDIF

C  boost back to lab frame
      CALL PHO_LTRHEP(NLOR1,NHEP,CODP,SIDP,COFP,SIFP,GAMBEP(4),
     &  GAMBEP(1),GAMBEP(2),GAMBEP(3))
      RETURN

C  rejection treatment
 150  CONTINUE
      IFAIL(2) = IFAIL(2)+1
C  reset counters
      KSPOM = KSPOMS
      KHPOM = KHPOMS
      KHDIR = KHDIRS
      KSREG = KSREGS
C  reset mother-daugther relations
      JDAHEP(1,JM1) = 0
      JDAHEP(2,JM1) = 0
      JDAHEP(1,JM2) = 0
      JDAHEP(2,JM2) = 0
      ISTHEP(JM1) = 1
      ISTHEP(JM2) = 1
      IPOIX1 = IPOIS1
      IPOIX2 = IPOIS2
      NHEP   = NHEPS
C  debug
      IF (LPRI.GT.4 .AND. IDEB(23).GT.2)
     .WRITE(LO,'(/1X,A,4I6)')
     &  'PHO_STDPAR: rejection (MSPOM,MHPOM,MSREG,MHDIR)',
     &  MSPOM,MHPOM,MSREG,MHDIR
      RETURN

      END


 
 


CDECK  ID>, PHO_STRFRA
      SUBROUTINE PHO_STRFRA(IREJ)
C********************************************************************
C
C     do all fragmentation of strings
C
C     output:  IREJ    0   successful
C                      1   rejection
C                     50   rejection due to user cutoffs
C
C********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  general process information
      INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
      COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  global event kinematics and particle IDs
      INTEGER IFPAP,IFPAB
      DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
      COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)

C  hard scattering data
      INTEGER MSCAHD
      PARAMETER ( MSCAHD = 1000 )
      INTEGER LSCAHD,LSC1HD,LSIDX,
     &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
      DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
      COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
     &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
     &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
     &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
     &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
     &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
     &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

C  color string configurations including collapsed strings and hadrons
      INTEGER MSTR
      PARAMETER (MSTR=2000)
      INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
      COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
     &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
     &                NNCH(MSTR),IBHAD(MSTR),ISTR

      INTEGER IREJ

      DOUBLE PRECISION PX,PY,PZ,HE,XMB,PT1,PT2

      INTEGER I,II,IJ,IFOUND,IP,IP_old,IPMOTH,IPOS,IBAM,IJOIN,
     &        IGEN,IS,ISH,ISTR,J,K1,K2,NHEP1,NLINES
      INTEGER indx(500),indx_max

      INTEGER  IPHO_PDG2ID
      DOUBLE PRECISION DT_RNDM
      EXTERNAL DT_RNDM,IPHO_PDG2ID

      DOUBLE PRECISION PYP,RQLUN
      INTEGER PYK

      INTEGER MSTU,MSTJ
      DOUBLE PRECISION PARU,PARJ
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      SAVE /PYDAT1/

      COMMON/PYINT1/MINT(400),VINT(400)
      SAVE /PYINT1/

      INTEGER MAXLND, N,NPAD,K
      DOUBLE PRECISION P,V
      PARAMETER (MAXLND=12000)
      COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
      SAVE /PYJETS/

      DIMENSION IJOIN(MSCAHD)

      IREJ = 0
      IF(ABS(ISWMDL(6)).GT.3) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,2A,I3)') 'PHO_STRFRA:ERROR: ',
     &    'invalid value of ISWMDL(6)',ISWMDL(6)
        CALL PHO_ABORT
      ENDIF

cdh 23.1.2017
cc*anfe Reset internal popcorn flags before fragmentation
      DO I = 1,5
        MSTU(120 + I) = 0
      ENDDO

C  popcorn suppression
C        IF(PARMDL(134).GT.0.D0) THEN
C          IF(DT_RNDM(DUM).LT.PARMDL(134)) THEN
C            MSTJ(12) = 2
C          ELSE
C            MSTJ(12) = 1
C          ENDIF
C        ENDIF

C  copy partons to fragmentation code JETSET
        IP = 0
        IP_old = 1

        DO 300 J=1,ISTR

C  select partons with common production process
          IGEN = NPOS(4,J)
          if(IGEN.lt.0) goto 299

          indx_max = 0
          DO 400 I=J,ISTR
            if((IGEN.eq.NPOS(4,I)).or.(IPAMDL(17).eq.0)) then

C  write final particles/resonances to JETSET
              IF(NCODE(I).EQ.-99) THEN
                II = NPOS(1,I)
                IP = IP+1
                P(IP,1) = PHEP(1,II)
                P(IP,2) = PHEP(2,II)
                P(IP,3) = PHEP(3,II)
                P(IP,4) = PHEP(4,II)
                P(IP,5) = PHEP(5,II)
                K(IP,1) = 1
                K(IP,2) = IDHEP(II)
                K(IP,3) = 0
                K(IP,4) = 0
                K(IP,5) = 0
                IPHIST(2,II) = IP

                if(indx_max.eq.500) then
                  IF (LPRI.GT.4)
     &            WRITE(LO,'(1x,2a,i8,I12)') 'PHO_STRFRA: ',
     &              'no space left in index vector (indx,Kevent)',
     &              indx_max,KEVENT
                  IREJ = 1
                  return
                endif

                indx_max = indx_max+1
                indx(indx_max) = II
C  write partons to JETSET
              ELSE IF(NCODE(I).GE.0) THEN
                K1 = JMOHEP(1,NPOS(1,I))
                K2 = MAX(JMOHEP(1,NPOS(1,I)),-JMOHEP(2,NPOS(1,I)))
                IJ = 0
                DO II=K1,K2
                  IP = IP+1
                  P(IP,1) = PHEP(1,II)
                  P(IP,2) = PHEP(2,II)
                  P(IP,3) = PHEP(3,II)
                  P(IP,4) = PHEP(4,II)
                  P(IP,5) = PHEP(5,II)
                  K(IP,1) = 1
                  K(IP,2) = IDHEP(II)
                  K(IP,3) = 0
                  K(IP,4) = 0
                  K(IP,5) = 0
                  IPHIST(2,II) = IP
                  IJ = IJ+1
                  IJOIN(IJ) = IP
                  indx_max = indx_max+1
                  indx(indx_max) = II

                ENDDO
                II = JMOHEP(2,NPOS(1,I))
                IF((II.GT.0).AND.(II.NE.K1)) THEN
                  IP = IP+1
                  P(IP,1) = PHEP(1,II)
                  P(IP,2) = PHEP(2,II)
                  P(IP,3) = PHEP(3,II)
                  P(IP,4) = PHEP(4,II)
                  P(IP,5) = PHEP(5,II)
                  K(IP,1) = 1
                  K(IP,2) = IDHEP(II)
                  K(IP,3) = 0
                  K(IP,4) = 0
                  K(IP,5) = 0
                  IPHIST(2,II) = IP
                  IJ = IJ+1
                  IJOIN(IJ) = IP
                  indx_max = indx_max+1
                  indx(indx_max) = II

                ENDIF
                N = IP
C  connect partons to strings

                CALL PYJOIN(IJ,IJOIN)

              ENDIF

              NPOS(4,I) = -NPOS(4,I)
            endif
 400      continue

C  set Lund counter
          N = IP
          if(IP.eq.0) goto 299

C  hard final state evolution
          IF((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
            ISH = 0
            do 125 k1=1,indx_max
              I = indx(k1)
              IF(IPHIST(1,I).LE.-100) THEN
C**anfe  Added bounds check for IJOIN
                IF(ISH.LE.MSCAHD) THEN
                  ISH = ISH+1
                  IJOIN(ISH) = I
                ELSE
                  IF (LPRI.GT.4)
     &            WRITE(LO,'(1x,2A,2I5)') 'PHO_STRFRA:ERROR: ',
     &              'no space left in IJOIN (ISH,MSCAHD)',ISH,MSCAHD
                  CALL PHO_ABORT
                ENDIF
              ENDIF 
 125        continue
            IF(ISH.GE.2) THEN
              DO 130 K1=1,ISH
                IF(IJOIN(K1).EQ.0) GOTO 130
                I = IJOIN(K1)
                IF((IPAMDL(102).EQ.1)
     &             .AND.(IPHIST(1,I).NE.-100)) GOTO 130
                DO 135 K2=K1+1,ISH
                  IF(IJOIN(K2).EQ.0) GOTO 135
                  II = IJOIN(K2)
                  IF(IPHIST(1,I).EQ.IPHIST(1,II)) THEN
                    PT1 = SQRT(PHEP(1,II)**2+PHEP(2,II)**2)
                    PT2 = SQRT(PHEP(1,I)**2+PHEP(2,I)**2)
                    RQLUN = MIN(PT1,PT2)

                    IF (LPRI.GT.4 .AND. IDEB(22).GE.10)
     &              WRITE(LO,'(1X,A,2I5,E12.4)')
     &                'PHO_STRFRA: PYSHOW called',I,II,RQLUN
                    CALL PYSHOW(IPHIST(2,I),IPHIST(2,II),RQLUN)

                    IJOIN(K1) = 0
                    IJOIN(K2) = 0
                    GOTO 130
                  ENDIF
 135            CONTINUE
 130          CONTINUE
            ENDIF
          ENDIF

C  fragment parton / hadron configuration (hadronization & decay)

          IF(ISWMDL(6).NE.0) THEN
            II = MSTU(21)
            MSTU(21) = 1

            CALL PYEXEC

            MSTU(21) = II
C  Lund warning?
            if(MSTU(28).ne.0) then
              IF(IDEB(22).GE.10) THEN
                IF (LPRI.GT.4)
     &          WRITE(LO,'(1X,A,I12,I3)')
     &            'PHO_STRFRA:(1) Lund code warning (EV/code)',
     &            KEVENT,MSTU(28)
                CALL PHO_PREVNT(2)
              ENDIF
            endif
C  event accepted?
            IF(MSTU(24).NE.0) THEN
              IF(IDEB(22).GE.2) THEN
                IF (LPRI.GT.4)
     &          WRITE(LO,'(1X,A,I12,I3)')
     &            'PHO_STRFRA:(1) rejection by Lund code (EV/code)',
     &            KEVENT,MSTU(24)
                CALL PHO_PREVNT(2)
              ENDIF
              IREJ = 1
              RETURN
            ENDIF
          ENDIF

          IP = N
C  change particle status in JETSET to avoid internal adjustments
          do k1=IP_old,IP
            K(k1,1) = K(k1,1)+1000
          enddo
          IP_old = IP+1

 299      continue
 300    CONTINUE

C  restore original JETSET particle status codes
        do i=1,N
          K(i,1) = K(i,1)-1000
        enddo

*       IF(IDEB(22).GE.25) THEN
*         WRITE(LO,'(//1X,2A)') 'PHO_STRFRA: ',
*    &      'particle/string system before fragmentation'
*         CALL PHO_PREVNT(2)
*       ENDIF

C  copy hadrons back to POEVT1 / POEVT2

        IF(IP.GT.0) THEN
          NHEP1 = NHEP+1

          NLINES = PYK(0,1)

C  copy hadrons back with full history information
          IF(IPAMDL(178).EQ.1) THEN
            DO 155 II=1,ISTR
              IF(NCODE(II).GE.0) THEN
                K1 = IPHIST(2,NPOS(2,II))
                K2 = IPHIST(2,-NPOS(3,II))
              ELSE IF(NCODE(II).EQ.-99) THEN
                K1 = IPHIST(2,NPOS(1,II))
                K2 = K1
              ELSE
                GOTO 149
              ENDIF
              IFOUND = 0
              DO 160 J=1,NLINES

                IF(PYK(J,7).EQ.1) THEN
                  IPMOTH = PYK(J,15)

                  IF((IPMOTH.GE.K1).AND.(IPMOTH.LE.K2)) THEN

                    IBAM = IPHO_PDG2ID(PYK(J,8))

                    IF((IBAM.EQ.0).AND.(ISWMDL(6).NE.0)) THEN
                      IF(IDEB(22).GE.2) THEN
                        IF (LPRI.GT.4)
     &                  WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
     &                    'LUND interface (1) rejection'
                        CALL PHO_PREVNT(2)
                      ENDIF
                      IREJ = 1
                      RETURN
                    ENDIF
                    IFOUND = IFOUND+1

                    PX = PYP(J,1)
                    PY = PYP(J,2)
                    PZ = PYP(J,3)
                    HE = PYP(J,4)
                    XMB = PYP(J,5)**2

C  register parton/hadron
                    IS = 1
                    IF(IBAM.EQ.0) THEN
                      IF(ISWMDL(6).EQ.0) THEN
                        IS = -1
                      ELSE
                        IF(IDEB(22).GE.2) THEN
                          IF (LPRI.GT.4)
     &                    WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
     &                      'LUND interface (2) rejection'
                          CALL PHO_PREVNT(2)
                        ENDIF
                        IREJ = 1
                        RETURN
                      ENDIF
                    ENDIF

                    CALL PHO_REGPAR(IS,PYK(J,8),IBAM,NPOS(1,II),0,
     &                PX,PY,PZ,HE,J,0,0,0,IPOS,1)

                    ISTHEP(IPOS) = 1
                  ENDIF
                ENDIF
 160          CONTINUE
              IF(IFOUND.EQ.0) THEN
                IF(IDEB(2).GE.2) THEN
                  IF (LPRI.GT.4)
     &            WRITE(LO,'(2A,I12,I3)') 'PHO_STRFRA: ',
     &            'no particles found for string (EVE,ISTR):',KEVENT,II
                ENDIF
                ISTHEP(NPOS(1,II)) = 2
              ENDIF
 149          CONTINUE
 155        CONTINUE
          ELSE
C  copy hadrons back without history information
            JDAHEP(1,1) = NHEP1
            JDAHEP(1,2) = NHEP1
            DO 170 J=1,NLINES

              IF(PYK(J,7).EQ.1) THEN
                IBAM = IPHO_PDG2ID(PYK(J,8))

                IF((IBAM.EQ.99999).AND.(ISWMDL(6).NE.0)) THEN
                  IF(IDEB(22).GE.2) THEN
                    IF (LPRI.GT.4)
     &              WRITE(LO,'(/1X,A)')
     &                'PHO_STRFRA: LUND interface (3) rejection'
                    CALL PHO_PREVNT(2)
                  ENDIF
                  IREJ = 1
                  RETURN
                ENDIF

                PX = PYP(J,1)
                PY = PYP(J,2)
                PZ = PYP(J,3)
                HE = PYP(J,4)
                XMB = PYP(J,5)**2

C  register parton/hadron
                IS = 1
                IF(IBAM.EQ.0) THEN
                  IF(ISWMDL(6).EQ.0) THEN
                    IS = -1
                  ELSE
                    IF(IDEB(22).GE.2) THEN
                      IF (LPRI.GT.4)
     &                WRITE(LO,'(/1X,A)')
     &                  'PHO_STRFRA: LUND interface (4) rejection'
                      CALL PHO_PREVNT(2)
                    ENDIF
                    IREJ = 1
                    RETURN
                  ENDIF
                ENDIF

                CALL PHO_REGPAR(IS,PYK(J,8),IBAM,1,2,PX,PY,PZ,
     &            HE,J,0,0,0,IPOS,1)

                ISTHEP(IPOS) = 1
              ENDIF
 170        CONTINUE
            DO 180 II=1,ISTR
              IF((NCODE(II).GE.0).OR.(NCODE(II).EQ.-99))
     &          ISTHEP(NPOS(1,II)) = 2
 180        CONTINUE
          ENDIF
        ENDIF

C  debug event status
      IF(IDEB(22).GE.15) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(//1X,A)')
     &    'PHO_STRFRA: particle system after fragmentation'
        CALL PHO_PREVNT(2)
      ENDIF

      END


 
 


CDECK  ID>, PHO_STRING
      SUBROUTINE PHO_STRING(IMODE,IREJ)
C********************************************************************
C
C    calculation of string combinatorics, Lorentz boosts and
C                   particle codes
C
C                - splitting of gluons
C                - strings will be built up from pairs of partons
C                  according to their color labels
C                  with IDHEP(..) = -1
C                - there can be other particles between to string partons
C                  (these will be unchanged by string construction)
C                - string mass fine correction
C
C    input:      IMODE    1  complete string processing
C                        -1 initialization
C                        -2 output of statistics
C
C    output:     /POSTRG/
C                IREJ    1 combination of strings impossible
C                        0 successful combination
C                       50 rejection due to user cutoffs
C
C********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( DEPS   =  1.D-15,
     &            EPS    =  1.D-5 )

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  general process information
      INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
      COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)

C  current beam selection
      INTEGER IDXMPAR, MPARMAX, MPARCONF, NMPAR, IKNOWN
      INTEGER MPMAPP, MAXMAPPS, NMAPP, MPAR, IPAVAIL
      DOUBLE PRECISION SQSGLOBMAX
      PARAMETER (MPARMAX=40)
      PARAMETER (MAXMAPPS=40)
      PARAMETER (IKNOWN=9)
      DIMENSION IPAVAIL(IKNOWN)
      DATA IPAVAIL /2212, 211, 111, 22, 2112, 3122, 3112, 321, 311/
      COMMON /POBEAM/ MPARCONF(2, MPARMAX), MPMAPP(2,MAXMAPPS),
     &           MPAR(2), SQSGLOBMAX, NMPAR, IDXMPAR, NMAPP

C  internal rejection counters
      INTEGER NMXJ
      PARAMETER (NMXJ=60)
      CHARACTER*10 REJTIT
      INTEGER IFAIL
      COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  hard cross sections and MC selection weights
      INTEGER Max_pro_2
      PARAMETER ( Max_pro_2 = 16 )
      INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
     &  MH_acc_1,MH_acc_2
      DOUBLE PRECISION HFAC, HWGX, HSIG, HDPT, HECM_LAST, 
     &   HQ2A_LAST, HQ2B_LAST
      COMMON /POHRCS/HFAC(-1:MAX_PRO_2, MPARMAX), 
     &   HWGX(-1:MAX_PRO_2, MPARMAX),
     &   HSIG(-1:MAX_PRO_2, MPARMAX), HDPT(-1:MAX_PRO_2, MPARMAX), 
     &   HECM_LAST, HQ2A_LAST, HQ2B_LAST, IHA_LAST, IHB_LAST, 
     &   MH_PRO_ON(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_TRIED(-1:MAX_PRO_2, 0:4, MPARMAX), 
     &   MH_ACC_1(-1:MAX_PRO_2, 0:4, MPARMAX),
     &   MH_ACC_2(-1:MAX_PRO_2, 0:4, MPARMAX) 

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

C  color string configurations including collapsed strings and hadrons
      INTEGER MSTR
      PARAMETER (MSTR=2000)
      INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
      COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
     &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
     &                NNCH(MSTR),IBHAD(MSTR),ISTR

C  table of particle indices for recursive PHOJET calls
      INTEGER MAXIPX
      PARAMETER ( MAXIPX = 500 )
      INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
      COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
     &                IPOIX1,IPOIX2,IPOIX3

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)


      IREJ = 0
      IF(IMODE.EQ.-1) THEN
        CALL PHO_POMCOR(-1)
        CALL PHO_MASCOR(-1)
        CALL PHO_PARCOR(-1,IREJ)

        RETURN
      ELSE IF(IMODE.EQ.-2) THEN
        CALL PHO_POMCOR(-2)
        CALL PHO_MASCOR(-2)
        CALL PHO_PARCOR(-2,IREJ)

        RETURN
      ENDIF

C  generate enhanced graphs
      IF(IPOIX2.GT.0) THEN
 200    CONTINUE
        I1 = MAX(1,IPOIX1)
        I2 = IPOIX2
        IF(ISWMDL(14).EQ.1) IPOIX1 = 0
        KSPOMS = KSPOM-1
        KSREGS = KSREG
        KHPOMS = KHPOM
        KHDIRS = KHDIR
        IDDFS1 = IDIFR1
        IDDFS2 = IDIFR2
        IDDPOS = IDDPOM
        DO 110 I=I1,I2
          IPOIX3 = I
          KSPOM = 0
          KSREG = 0
          KHPOM = 0
          KHDIR = 0
          IF(IPORES(I).EQ.8) THEN
            KSPOM = 2
            LSPOM = 2
            LHPOM = 0
            LSREG = 0
            LHDIR = 0
            IGEN = abs(IPHIST(2,IPOPOS(1,I)))
            CALL PHO_STDPAR(IPOPOS(1,I),IPOPOS(2,I),IGEN,
     &                      LSPOM,LSREG,LHPOM,LHDIR,IREJ)
            IF(IREJ.NE.0) THEN
              IF(IDEB(4).GE.2) THEN
                IF (LPRI.GT.4)
     &          WRITE(LO,'(/1X,A,I5)')
     &            'PHO_STRING: sec.rejection by PHO_STDPAR',IREJ
                CALL PHO_PREVNT(-1)
              ENDIF
              RETURN
            ENDIF
            KSPOM = KSPOMS+LSPOM
            KSREG = KSREGS+LSREG
            KHPOM = KHPOMS+LHPOM
            KHDIR = KHDIRS+LHDIR
          ELSE IF(IPORES(I).EQ.4) THEN
            ITEMP = ISWMDL(17)
            ISWMDL(17) = 0
            CALL PHO_CDIFF(IPOPOS(1,I),IPOPOS(2,I),MSOFT,MHARD,1,IREJ)
            ISWMDL(17) = ITEMP
            IF(IREJ.NE.0) THEN
              IF(IDEB(4).GE.2) THEN
                IF (LPRI.GT.4)
     &          WRITE(LO,'(/1X,A,I5)')
     &            'PHO_STRING: sec.rejection by PHO_CDIFF',IREJ
                CALL PHO_PREVNT(-1)
              ENDIF
              RETURN
            ENDIF
            KSDPO = KSDPO+1
            KSPOM = KSPOMS+KSPOM
            KSREG = KSREGS+KSREG
            KHPOM = KHPOMS+KHPOM
            KHDIR = KHDIRS+KHDIR
          ELSE
            IDIF1 = 1
            IDIF2 = 1
            IF(IPORES(I).EQ.5) THEN
              IDIF2 = 0
              KSTRG = KSTRG+1
            ELSE IF(IPORES(I).EQ.6) THEN
              IDIF1 = 0
              KSTRG = KSTRG+1
            ELSE
              KSLOO = KSLOO+1
            ENDIF
            ITEMP = ISWMDL(16)
            ISWMDL(16) = 0
            SPROB = 1.D0
            CALL PHO_DIFDIS(IDIF1,IDIF2,IPOPOS(1,I),IPOPOS(2,I),SPROB,
     &        0,MSOFT,MHARD,IREJ)
            ISWMDL(16) = ITEMP
            IF(IREJ.NE.0) THEN
              IF(IDEB(4).GE.2) THEN
                IF (LPRI.GT.4)
     &          WRITE(LO,'(/1X,A,I5)')
     &            'PHO_STRING: sec.rejection by PHO_DIFDIS',IREJ
                CALL PHO_PREVNT(-1)
              ENDIF
              RETURN
            ENDIF
            KSPOM = KSPOMS+KSPOM
            KSREG = KSREGS+KSREG
            KHPOM = KHPOMS+KHPOM
            KHDIR = KHDIRS+KHDIR
          ENDIF
          IDIFR1 = IDDFS1
          IDIFR2 = IDDFS2
          IDDPOM = IDDPOS
 110    CONTINUE
        IF(IPOIX2.GT.I2) THEN
          IPOIX1 = I2+1
          GOTO 200
        ENDIF
      ENDIF

C  optional: split gluons to q-qbar pairs
      IF(ISWMDL(9).GT.0) THEN
        NHEPO = NHEP
        DO 30 I=3,NHEPO
          IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).EQ.21)) THEN
            ICG1=ICOLOR(1,I)
            ICG2=ICOLOR(2,I)
            IQ1 = 0
            IQ2 = 0
            DO 40 K=3,NHEPO
              IF(ICOLOR(1,K).EQ.-ICG1) THEN
                IQ1 = K
                IF(IQ1*IQ2.NE.0) GOTO 45
              ELSE IF(ICOLOR(1,K).EQ.-ICG2) THEN
                IQ2 = K
                IF(IQ1*IQ2.NE.0) GOTO 45
              ENDIF
 40         CONTINUE
            IF (LPRI.GT.4)
     &      WRITE(LO,'(/1X,2A,3I6)') 'PHO_STRING:ERROR:(1) ',
     &        'no matching color found (IG,ICG1,ICG2)',I,ICG1,ICG2
            CALL PHO_ABORT
 45         CONTINUE
            CALL PHO_GLU2QU(I,IQ1,IQ2,IREJ)
            IF(IREJ.NE.0) THEN
              IF(IDEB(19).GE.5) THEN
                IF (LPRI.GT.4)
     &          WRITE(LO,'(/,1X,A)')
     &            'PHO_STRING: no gluon splitting possible'
                CALL PHO_PREVNT(0)
              ENDIF
              RETURN
            ENDIF
          ENDIF
 30     CONTINUE
      ENDIF

C  construct strings and write entries sorted by strings

      ISTR = ISTR+1
      NHEPO = NHEP
      DO 50 I=3,NHEPO

        IF(ISTR.GT.MSTR) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
     &      'event has too many strings (ISTR,MSTR):',ISTR,MSTR
          CALL PHO_PREVNT(0)
          IREJ = 1
          RETURN
        ENDIF

        IF(ISTHEP(I).EQ.1) THEN
C  hadrons / resonances / clusters
          NPOS(1,ISTR) = I
          NPOS(2,ISTR) = 0
          NPOS(3,ISTR) = 0
          NPOS(4,ISTR) = abs(IPHIST(2,I))
          NCODE(ISTR) = -99
          IPHIST(1,I) = ISTR
C**anfe For (semi-) stable particles set IDs to 0 to keep 
C       printouts consistent
          IPAR1(ISTR) = 0
          IPAR2(ISTR) = 0
          IPAR3(ISTR) = 0
          IPAR4(ISTR) = 0
          ISTR = ISTR+1
        ELSE IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).NE.21)) THEN
C  quark /diquark terminated strings
          ICOL1 = -ICOLOR(1,I)
          P1 = PHEP(1,I)
          P2 = PHEP(2,I)
          P3 = PHEP(3,I)
          P4 = PHEP(4,I)
          ICH1 = IPHO_CHR3(I,2)
          IBA1 = IPHO_BAR3(I,2)
          CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
     &                P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
     &                ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
          JM1 = IPOS

          NRPOM = 0
 65       CONTINUE
          DO 55 K=3,NHEPO
            IF(ISTHEP(K).EQ.-1)THEN
              IF(IDHEP(K).EQ.21) THEN
                IF(ICOLOR(1,K).EQ.ICOL1) THEN
                  ICOL1 = -ICOLOR(2,K)
                  GOTO 60
                ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
                  ICOL1 = -ICOLOR(1,K)
                  GOTO 60
                ENDIF
              ELSE IF(ICOLOR(1,K).EQ.ICOL1) THEN
                ICOL1 = 0
                GOTO 60
              ENDIF
            ENDIF
 55       CONTINUE
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,I5)')
     &      'PHO_STRING:ERROR:(2) no matching color found for',-ICOL1
          CALL PHO_ABORT
 60       CONTINUE
          P1 = P1+PHEP(1,K)
          P2 = P2+PHEP(2,K)
          P3 = P3+PHEP(3,K)
          P4 = P4+PHEP(4,K)
          NRPOM = MAX(NRPOM,IPHIST(1,K))
          ICH1 = ICH1+IPHO_CHR3(K,2)
          IBA1 = IBA1+IPHO_BAR3(K,2)
          CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
     &      PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
     &      IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
C  further parton involved?
          IF(ICOL1.NE.0) GOTO 65
          JM2 = IPOS
C  register string
          IGEN = IPHIST(2,K)
          CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
     &                ISTR,IGEN,ICH1,IBA1,IPOS,1)
C  store additional string information
          NPOS(1,ISTR) = IPOS
          NPOS(2,ISTR) = JM1
          NPOS(3,ISTR) = -JM2
          NPOS(4,ISTR) = abs(IPHIST(2,K))
C  calculate CPC string codes
          CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
     &                IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
          ISTR = ISTR+1
        ENDIF
 50   CONTINUE

      DO 150 I=3,NHEPO

        IF(ISTR.GT.MSTR) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
     &      'event has too many strings (ISTR,MSTR):',ISTR,MSTR
          CALL PHO_PREVNT(0)
          IREJ = 1
          RETURN
        ENDIF

        IF(ISTHEP(I).EQ.-1) THEN
C  gluon loop-strings
          ICOL1 = -ICOLOR(1,I)
          P1 = PHEP(1,I)
          P2 = PHEP(2,I)
          P3 = PHEP(3,I)
          P4 = PHEP(4,I)
          IBA1 = 0
          ICH1 = 0
          CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
     &                P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
     &                ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
          JM1 = IPOS
C
          NRPOM = 0
 165      CONTINUE
          IF(ICOLOR(2,I).EQ.ICOL1) GOTO 170
          DO 155 K=I,NHEPO
            IF(ISTHEP(K).EQ.-1)THEN
              IF(ICOLOR(1,K).EQ.ICOL1) THEN
                ICOL1 = -ICOLOR(2,K)
                GOTO 160
              ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
                ICOL1 = -ICOLOR(1,K)
                GOTO 160
              ENDIF
            ENDIF
 155      CONTINUE
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,I5)')
     &      'PHO_STRING:ERROR:(3) no matching color found for',-ICOL1
          CALL PHO_ABORT
 160      CONTINUE
          P1 = P1+PHEP(1,K)
          P2 = P2+PHEP(2,K)
          P3 = P3+PHEP(3,K)
          P4 = P4+PHEP(4,K)
          NRPOM = MAX(NRPOM,IPHIST(1,K))
          CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
     &      PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
     &      IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
C  further parton involved?
          IF(ICOL1.NE.0) GOTO 165
 170      CONTINUE
          JM2 = IPOS
C  register string
          IGEN = IPHIST(2,K)
          CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
     &                ISTR,IGEN,ICH1,IBA1,IPOS,1)
C  store additional string information
          NPOS(1,ISTR) = IPOS
          NPOS(2,ISTR) = JM1
          NPOS(3,ISTR) = -JM2
          NPOS(4,ISTR) = abs(IPHIST(2,K))
C  calculate CPC string codes
          CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
     &                IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
          ISTR = ISTR+1
        ENDIF
 150  CONTINUE

      ISTR = ISTR-1

      IF(IDEB(19).GE.17) THEN
        IF (LPRI.GT.4)
     .  WRITE(LO,'(1X,A)') 'PHO_STRING: after string construction'
        CALL PHO_PREVNT(0)
      ENDIF

C  pomeron corrections
      CALL PHO_POMCOR(IREJ)
      IF(IREJ.NE.0) THEN
        IFAIL(38) = IFAIL(38)+1
        IF(IDEB(19).GE.3) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,I6)')
     &      'PHO_STRING: rejection by PHO_POMCOR (IREJ)',IREJ
          CALL PHO_PREVNT(-1)
        ENDIF
        RETURN
      ENDIF

C  string mass corrections
      CALL PHO_MASCOR(IREJ)
      IF(IREJ.NE.0) THEN
        IFAIL(34) = IFAIL(34)+1
        IF(IDEB(19).GE.3) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,I6)')
     &      'PHO_STRING: rejection by PHO_MASCOR (IREJ)',IREJ
          CALL PHO_PREVNT(-1)
        ENDIF
        RETURN
      ENDIF

C  parton mass corrections
      DO 100 I=1,ISTR
        IF(NCODE(I).GE.0) THEN
          CALL PHO_PARCOR(NPOS(1,I),IREJ)
          IF(IREJ.NE.0) THEN
            IFAIL(35) = IFAIL(35)+1
            IF(IDEB(19).GE.3) THEN
              IF (LPRI.GT.4)
     &        WRITE(LO,'(1X,A,I6)')
     &          'PHO_STRING: rejection by PHO_PARCOR (IREJ)',IREJ
              CALL PHO_PREVNT(-1)
            ENDIF
            RETURN
          ENDIF
        ENDIF
 100  CONTINUE

C  statistics of hard processes
      DO 550 I=3,NHEP
        IF(ISTHEP(I).EQ.25) THEN
          K  = IMPART(I)
          II = IDHEP(I)
          MH_acc_2(K,II,idxmpar) = MH_acc_2(K,II,idxmpar)+1
        ENDIF
 550  CONTINUE

C  debug: write out strings
      IF(IDEB(19).GE.5) THEN
        IF(IDEB(19).GE.10)
     &    CALL PHO_CHECK(1,IDEV)
        IF(IDEB(19).GE.15) THEN
          CALL PHO_PREVNT(0)
        ELSE
          CALL PHO_PRSTRG
        ENDIF
      ENDIF

      END


 
 


CDECK  ID>, PHO_SWAPD
      SUBROUTINE PHO_SWAPD(D1,D2)
C********************************************************************
C
C     exchange of argument values (double precision)
C
C********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE
      D = D1
      D1 = D2
      D2 = D

      END


      SUBROUTINE PHO_SWAPFLAV(PD, IOLDFL, INEWFL)
c*********************************************************************
c
c     Change exchange densities of 2 flavors incl. anti-flavor
c
c     input:    pd(-6:6) parton density array 
c               ioldfl   old flavor index
c               inewfl   new flavor index
c
c     output:   pd(-6,6) with swapped flavors
c
c*********************************************************************
      IMPLICIT NONE
      SAVE

      DOUBLE PRECISION PD(-6:6), FL, ANTIFL
      INTEGER IOLDFL, INEWFL

      FL = PD(IOLDFL)
      ANTIFL = PD(-IOLDFL)
      PD(IOLDFL) = PD(INEWFL)
      PD(-IOLDFL) = PD(-INEWFL)
      PD(INEWFL) = FL
      PD(-INEWFL) = ANTIFL

      END 


 
 


CDECK  ID>, PHO_SWAPI
      SUBROUTINE PHO_SWAPI(I1,I2)
C********************************************************************
C
C     exchange of argument values (integer)
C
C********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      K = I1
      I1 = I2
      I2 = K

      END


 
 


CDECK  ID>, PHO_TRACE
      SUBROUTINE PHO_TRACE(ISTART,ISWI,LEVEL)
C**********************************************************************
C
C     trace program subroutines according to level,
C                          original output levels will be saved
C
C     input:   ISTART      first event to trace
C              ISWI        number of events to trace
C                                0   loop call, use old values
C                               -1   restore original output levels
C                                1   store level and wait for event
C              LEVEL       desired output level
C                                0   standard output
C                                3   internal rejections
C                                5   cross sections, slopes etc.
C                               10   parameter of subroutines and
C                                    results
C                               20   huge amount of debug output
C                               30   maximal possible output
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

      DIMENSION IMEM(NMAXD)

C  protect ISWI
      ISW = ISWI
 10   CONTINUE
      IF(ISW.EQ.0) THEN
        IF(KEVENT.LT.ION) THEN
          RETURN
        ELSE IF(KEVENT.EQ.ION) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(///,1X,A,///)')
     &      'PHO_TRACE: trace mode switched on'
          DO 100 I=1,NMAXD
            IMEM(I) = IDEB(I)
            IDEB(I) = MAX(ILEVEL,IMEM(I))
 100      CONTINUE
        ELSE IF(KEVENT.EQ.IOFF) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(//,1X,A,///)')
     &      'PHO_TRACE: trace mode switched off'
          DO 200 I=1,NMAXD
            IDEB(I) = IMEM(I)
 200      CONTINUE
        ENDIF
      ELSE IF(ISW.EQ.-1) THEN
        DO 300 I=1,NMAXD
          IDEB(I) = IMEM(I)
 300    CONTINUE
      ELSE
C  save information
        ION = ISTART
        IOFF = ISTART+ISW
        ILEVEL = LEVEL
      ENDIF
C  check coincidence
      IF(ISW.GT.0) THEN
        ISW=0
        ILEVEL = LEVEL
        GOTO 10
      ENDIF

      END


 
 


CDECK  ID>, PHO_TRANI
      SUBROUTINE PHO_TRANI(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
C**********************************************************************
C
C  rotation of coordinate frame (1) -fe rotation around z axis
C                               (2) -de rotation around y axis
C  (inverse rotation to PHO_TRANS)
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
      Y=-SFE    *XO+CFE*    YO
      Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO

      END


 
 


CDECK  ID>, PHO_TRANS
      SUBROUTINE PHO_TRANS(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
C**********************************************************************
C
C  rotation of coordinate frame (1) de rotation around y axis
C                               (2) fe rotation around z axis
C  (inverse rotation to PHO_TRANI)
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
      Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
      Z=-SDE    *XO       +CDE    *ZO

      END


 
 


CDECK  ID>, PHO_TRIREG
      SUBROUTINE PHO_TRIREG(S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP,VIR2A,
     &                     SIGTR,BTR)
C**********************************************************************
C
C     calculation of triple-Pomeron total cross section
C     according to Gribov's Regge theory
C
C     input:        S        squared cms energy
C                   GA       coupling constant to diffractive line
C                   AA       slope related to GA (GeV**-2)
C                   GB       coupling constant to elastic line
C                   BB       slope related to GB (GeV**-2)
C                   DELTA    effective pomeron delta (intercept-1)
C                   ALPHAP   slope of pomeron trajectory (GeV**-2)
C                   GPPP     triple-Pomeron coupling
C                   BPPP     slope related to B0PPP (GeV**-2)
C                   VIR2A    virtuality of particle a (GeV**2)
C                   note: units of all coupling constants are mb**1/2
C
C     output:       SIGTR    total triple-Pomeron cross section
C                   BTR      effective triple-Pomeron slope
C                            (differs from diffractive slope!)
C
C     uses E_i (Exponential-Integral function)
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER (EPS =0.0001D0)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)


C  integration cut-off Sigma_U ( see Nucl.Phys.B97(1975)493 )
      SIGU = 2.5
C  integration cut-off Sigma_L (min. squared mass of diff. blob)
      SIGL = 5.+VIR2A
C  debug output
      IF (LPRI.GT.4 .AND. IDEB(50).GE.10)
     &WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
     &       'PHO_TRIREG: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP ',
     &       S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
C
      IF(S.LT.5.D0) THEN
        SIGTR = 0.D0
        BTR = BPPP+BB
        RETURN
      ENDIF
C  change units of ALPHAP to mb
      ALSCA  = ALPHAP*GEV2MB
C
C  cross section
      PART1=GA*GB**2*GPPP/(16.*PI*2.*ALSCA)*S**DELTA*
     &        EXP(-(BB+BPPP)/(2.*ALPHAP)*DELTA)
      PART2=PHO_EXPINT(((BB+BPPP)/(2.*ALPHAP)+LOG(S/SIGL))*DELTA)
      PART3=PHO_EXPINT(((BB+BPPP)/(2.*ALPHAP)+LOG(SIGU))*DELTA)
C
      SIGTR=PART1*(PART2-PART3)
C
C  slope
      PART1 = (BB+BPPP+2.*ALPHAP*LOG(S/SIGL))/
     &        (BB+BPPP+2.*ALPHAP*LOG(SIGU))
      PART2 = LOG(PART1)
      PART1 = 0.5D0*ALPHAP*LOG(1.D0+S/(SIGU*SIGL))/PART2
      BTR = (AA+BB/2.D0)/2.D0+BPPP+ALPHAP*LOG(S/4.D0)
      BTR = BTR-PART1
C
      IF(SIGTR.LT.EPS) SIGTR = 0.D0
      IF(BTR.LT.BB)  BTR = BB
C
      IF (LPRI.GT.4 .AND. IDEB(50).GE.7)
     &WRITE(LO,'(1X,A,1P,3E12.3)')
     &  'PHO_TRIREG: ENERGY,SIGTR,BTR ',SQRT(S),SIGTR,BTR

      END

 
 


CDECK  ID>, PHO_TRXPOM
      SUBROUTINE PHO_TRXPOM(S,GA,AA,GB,BB,DELTA,ALPHAP,
     &                     GPPP,BPPP,SIGDP,BDP)
C**********************************************************************
C
C     calculation of total cross section of two tripe-Pomeron
C     graphs in X configuration according to Gribov's Reggeon field
C     theory
C
C     input:        S        squared cms energy
C                   GA       coupling constant to elastic line 1
C                   AA       slope related to GA (GeV**-2)
C                   GB       coupling constant to elastic line 2
C                   BB       slope related to GB (GeV**-2)
C                   DELTA    effective pomeron delta (intercept-1)
C                   ALPHAP   slope of pomeron trajectory (GeV**-2)
C                   BPPP     triple-Pomeron coupling
C                   BTR      slope related to B0PPP (GeV**-2)
C                   note: units of all coupling constants are mb**1/2
C
C     output:       SIGDP    total cross section for double-Pomeron
C                            scattering
C                   BDP      effective double-Pomeron slope
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER (EPS =0.0001D0)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

      DIMENSION XWGH1(96),XPOS1(96)

C  lower integration cut-off Sigma_L
      SIGL = PARMDL(71)**2
C  upper integration cut-off Sigma_U
      C = 1.D0-1.D0/PARMDL(70)**2
      C = MAX(PARMDL(72),C)
      SIGU = (1.D0-C)**2*S
C  integration precision
      NGAUS1=16
C
C  debug output
      IF (LPRI.GT.4 .AND. IDEB(52).GE.10)
     &WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
     &       'PHO_TRXPOM: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP',
     &       S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
C
      IF(SIGU.LE.SIGL) THEN
        SIGDP = 0.D0
        BDP = AA+BB
        RETURN
      ENDIF
C
C  cross section
C
      XIL = LOG(SIGL)
      XIU = LOG(SIGU)
      XI = LOG(S)
      FAC = (GPPP*GA*GB)**2/(256.D0*PI2)/ALPHAP/GEV2MB**2
      ALPHA2 = 2.D0*ALPHAP
      ALOC = LOG(1.D0/(1.D0-C))
      CALL PHO_GAUSET(XIL,XIU,NGAUS1,XPOS1,XWGH1)
      XSUM = 0.D0
      DO 100 I1=1,NGAUS1
        AMXSQ  = EXP(XPOS1(I1))
        ALOSMX = LOG(S/AMXSQ)
        ALCSMX = LOG((1.D0-C)*S/AMXSQ)
        W = LOG((AA+BPPP+ALPHA2*ALCSMX)/(BB+BPPP+ALPHA2*ALOC))
        W = MAX(0.D0,W)
        WN=(AA+BB+2.D0*BPPP+ALPHA2*ALOSMX)
C  supercritical part
        WSC = AMXSQ**DELTA*(S/AMXSQ)**(2.D0*DELTA)
        XSUM = XSUM + W*XWGH1(I1)/WN*WSC
 100  CONTINUE
      SIGDP = XSUM*FAC
C
C  slope
      BDP = 0.5*(AA+BB+BPPP+ALPHAP*XI)
C
      IF (LPRI.GT.4 .AND. IDEB(52).GE.7)
     &WRITE(LO,'(1X,A,1P,3E12.3)')
     &  'PHO_TRXPOM: ENERGY,SIGDP,BDP',SQRT(S),SIGDP,BDP

      END

 
 


CDECK  ID>, PHO_VALFLA
      SUBROUTINE PHO_VALFLA(IPAR,IFL1,IFL2,E1,E2)
C***********************************************************************
C
C     selection of valence flavour decomposition of particle IPAR
C
C     input:    IPAR   particle index in /POEVT1/
C                      -1   initialization
C                      -2   output of statistics
C               XMASS  mass of particle
C                      (important for pomeron:
C                       mass dependent flavour sampling)
C
C     output:   IFL1,IFL2
C               baryon: IFL1  diquark flavour
C               (valence flavours according to PDG conventions)
C
C***********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER ( EPS    =  0.1D0,
     &            DEPS   =  1.D-15)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

C  general particle data
      DOUBLE PRECISION xm_list,tau_list,gam_list,
     &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
     &  xm_bb82_list,xm_bb102_list
      INTEGER          ich3_list,iba3_list,iq_list,
     &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
      COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
     &  xm_psm2_list(6,6),xm_vem2_list(6,6),
     &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
     &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
     &  ich3_list(300),iba3_list(300),iq_list(3,300),
     &  id_psm_list(6,6),id_vem_list(6,6),
     &  id_b8_list(6,6,6),id_b10_list(6,6,6)

      DATA ITMX / 5 /

      IF(IPAR.GT.0) THEN
        K = IPAR
C  select particle code
        ID1 = IDHEP(K)
        ID  = abs(IMPART(K))
        IBAR = IPHO_BAR3(K,2)
        ITER = 0

C10     CONTINUE

        ifl1 = 0
        ifl2 = 0
        ITER = ITER+1
        if(ITER.GT.ITMX) then
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1x,2a,i10,1p,2e11.3)') 'PHO_VALFLA: ',
     &      'no valences found for (IPAR,E1,E2)',IPAR,E1,E2
          return
        endif

C  not baryon
        IF(IBAR.EQ.0) THEN

C  photon
          IF(ID1.EQ.22) THEN
C  charge dependent flavour sampling
 15         CONTINUE
            K = INT(DT_RNDM(E1)*6.D0)+1
            IF(K.LE.4) THEN
              IFL1 = 2
              IFL2 = -2
            ELSE IF(K.EQ.5) THEN
              IFL1 = 1
              IFL2 = -1
            ELSE
              IFL1 = 3
              IFL2 = -3
            ENDIF
C  optional strangeness suppression
            IF((IFL1.EQ.3).AND.(DT_RNDM(E2).GT.PARMDL(160))) GOTO 15
            IF(DT_RNDM(DUM).LT.0.5D0) THEN
              K = IFL1
              IFL1 = IFL2
              IFL2 = K
            ENDIF

C  pomeron, reggeon
          ELSE IF((ID1.EQ.990).or.(ID1.eq.110)) THEN
            IF(ISWMDL(19).EQ.0) THEN
C  SU(3) symmetric valences
              K = INT(DT_RNDM(E1)*3.D0)+1
              IF(DT_RNDM(DUM).LT.0.5D0) THEN
                IFL1 = K
              ELSE
                IFL1 = -K
              ENDIF
              IFL2 = -IFL1
            ELSE IF(ISWMDL(19).EQ.1) THEN
C  mass dependent flavour sampling
              EMIN = MIN(E1,E2)
              CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
            ELSE
              IF (LPRI.GT.4)
     &        WRITE(LO,'(/1X,2A,I5)') 'PHO_VALFLA: ',
     &          'invalid flavour selection mode ISWMDL(19)',ISWMDL(19)
              CALL PHO_ABORT
            ENDIF

C  meson with flavour mixing
          ELSE if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
            K = INT(2.D0*DT_RNDM(E1))+1
            IFL1 = K
            IFL2 = -K
C  meson (standard)
          ELSE
            K = INT(2.D0*DT_RNDM(E1))+1
            IFL1 = iq_list(K,ID)
            K = MOD(K,2) + 1
            IFL2 = iq_list(K,ID)
            if(IFL1.EQ.0) then
              EMIN = MIN(E1,E2)
              CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
            endif
          ENDIF

C  baryon
        ELSE
          K = INT(2.999999D0*DT_RNDM(E2))+1
          K1 = MOD(K,3)+1
          K2 = MOD(K1,3)+1
          IFL1 = IPHO_DIQU(iq_list(K1,ID),iq_list(K2,ID))
          IFL2 = iq_list(K,ID)
        ENDIF

C  change sign for antiparticles
        if(ID1.lt.0) then
          IFL1 = -IFL1
          IFL2 = -IFL2
        endif

************************************************************************
C  check kinematic constraints
*       IF((PHO_PMASS(IFL1,3).GT.E1)
*    &     .OR.(PHO_PMASS(IFL2,3).GT.E2)) GOTO 10
************************************************************************

C  debug output
        IF (LPRI.GT.4 .AND. IDEB(46).GE.10)
     &  WRITE(LO,'(1X,A,I5,2E12.4,2I7)')
     &    'PHO_VALFLA: IPAR,MASS1/2,FL1/2',IPAR,E1,E2,IFL1,IFL2

      ELSE IF(IPAR.EQ.-1) THEN
C  initialization

      ELSE IF(IPAR.EQ.-2) THEN
C  output of final statistics

      ELSE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,I10)')
     &    'PHO_VALFLA:ERROR: invalid input particle (IPAR)',IPAR
        CALL PHO_ABORT
      ENDIF

      END


 
 


CDECK  ID>, PHO_VECRES
      SUBROUTINE PHO_VECRES(IVEC,RMASS,IDPDG,IDBAM)
C**********************************************************************
C
C     sampling of vector meson resonance in diffractive processes
C     (nothing done for hadrons)
C
C     input:   /POSVDM/     VDMFAC factors
C
C     output:  IVEC         0   incoming hadron
C                           1   rho 0
C                           2   omega
C                           3   phi
C                           4   pi+/pi- background
C              RMASS        mass of vector meson (GeV)
C              IDPDG        particle ID according to PDG
C              IDBAM        particle ID according to CPC
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER(EPS  = 1.D-10)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
      INTEGER IDEQP,IDEQB,IHFLD,IHFLS
      DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
      COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
     &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)

C  parameters of the "simple" Vector Dominance Model
      DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
      COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

      DOUBLE PRECISION PHO_PMASS
      EXTERNAL         PHO_PMASS
      INTEGER  IPHO_PDG2ID
      EXTERNAL IPHO_PDG2ID
C  particle code translation
      DIMENSION ITRANS(4)
C                  rho0,omega,phi,pi+/pi-
      DATA ITRANS /113, 223, 333, 92 /

      IDPDO = IDPDG
C
C  vector meson production
      IF(IDPDG.EQ.22) THEN
        XI = DT_RNDM(RMASS)*(VMFA(1)+VMFA(2)+VMFA(3)+VMFA(4))
        SUM = 0.D0
        DO 55 K=1,4
          SUM = SUM + VMFA(K)
          IF(XI.LE.SUM) GOTO 65
 55     CONTINUE
 65     CONTINUE
C
        IDPDG = ITRANS(K)
        IDBAM = IPHO_PDG2ID(IDPDG)
        IVEC  = K
C  sample mass of vector meson
        CALL PHO_SAMASS(IDPDG,RMASS)

C  hadronic resonance of multi-pomeron coupling
      ELSE IF(IDPDG.EQ.990) THEN
        K = 4
        IDPDG = 91
        IDBAM = IPHO_PDG2ID(IDPDG)
        IVEC  = 4
C  sample mass of two-pion system
        CALL PHO_SAMASS(IDPDG,RMASS)

C  hadron remnants in inucleus interactions
      ELSE IF(IDPDG.EQ.81) THEN
        IF(IHFLD(1,1).EQ.0) THEN
          CALL PHO_SEAFLA(1,IFL1,IFL2,RMASS)
          CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
        ELSE
          CALL PHO_HACODE(IHFLD(1,1),IHFLD(1,2),IDBA1,IDBA2)
        ENDIF
        RMAS1 = PHO_PMASS(IDBA1,0)
        RMAS2 = PHO_PMASS(IDBA2,0)
        IF((IDBA2.NE.0).AND.
     &    (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
          IDBAM = IDBA2
          RMASS = RMAS2
        ELSE
          IDBAM = IDBA1
          RMASS = RMAS1
        ENDIF
        IDPDG = IPHO_ID2PDG(IDBAM)
        IVEC = 0
      ELSE IF(IDPDG.EQ.82) THEN
        IF(IHFLD(2,1).EQ.0) THEN
          CALL PHO_SEAFLA(2,IFL1,IFL2,RMASS)
          CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
        ELSE
          CALL PHO_HACODE(IHFLD(2,1),IHFLD(2,2),IDBA1,IDBA2)
        ENDIF
        RMAS1 = PHO_PMASS(IDBA1,0)
        RMAS2 = PHO_PMASS(IDBA2,0)
        IF((IDBA2.NE.0).AND.
     &    (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
          IDBAM = IDBA2
          RMASS = RMAS2
        ELSE
          IDBAM = IDBA1
          RMASS = RMAS1
        ENDIF
        IDPDG = IPHO_ID2PDG(IDBAM)
        IVEC = 0
      ENDIF
C  debug output
      IF(IDEB(47).GE.5) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(1X,A,/10X,3I7,E12.4)')
     &    'PHO_VECRES: IDPDG-OLD,IDPDG,IDBAM,MASS',
     &    IDPDO,IDPDG,IDBAM,RMASS
      ENDIF

      END


 
 


CDECK  ID>, PHO_WGEPEM
      SUBROUTINE PHO_WGEPEM(WGHAPP,WGHQPM,IMODE)
C**********************************************************************
C
C     calculate cross section weights for
C      fully differential equivalent (improved) photon approximation
C     and/or
C      fully differential QPM model with exact one-photon exchange graphs
C
C     (unpolarized lepton beams)
C
C     input:     IMODE     0   flux calculation only
C                          1   flux folded with QPM cross section
C                /POFSRC/  photon and electron momenta
C                /POPRCS/  process type
C                /POCKIN/  kinematics of hard scattering
C
C     output:    WGHAPP  weight of event according to approximation
C                WGHQPM  weight of event according to one-photon exchange
C
C**********************************************************************

      IMPLICIT NONE
      SAVE

      DOUBLE PRECISION WGHAPP,WGHQPM
      INTEGER IMODE

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

C  gamma-lepton or gamma-hadron vertex information
      INTEGER IGHEL,IDPSRC,IDBSRC
      DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
     &                 RADSRC,AMSRC,GAMSRC
      COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
     &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
     &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)

C  general process information
      INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
      COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)

C  data on most recent hard scattering
      INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
      DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
     &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
      COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
     &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
     &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
     &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
     &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC

C  hard scattering parameters used for most recent hard interaction
      INTEGER NFbeta,NF
      DOUBLE PRECISION ALQCD2,BQCD
      COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF

C  currently activated parton density parametrizations
      CHARACTER*8 PDFNAM
      INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
      DOUBLE PRECISION PDFLAM,PDFQ2M
      COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
     &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD

C  standard particle data interface
      INTEGER NMXHEP
      PARAMETER (NMXHEP=8000)
      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)

C  extension to standard particle data interface (PHOJET specific)
      INTEGER IMPART,IPHIST,ICOLOR
      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)

      DOUBLE PRECISION AA,ALPHA1,ALPHA2,BB,CC,CCAP,DD,FAC,HELFLX,
     &  P1,P1P2,P1Q2,P2,P2Q1,Q1KK,Q1Q2,Q2,Q2KK,QC2,RHO100,RHO1PP,
     &  RHO200,RHO2PP,RHOP08,RHOPM2,RR,SH,SIGQPM,SP,SS,SW0000,SW0P0M,
     &  SW0P0P,SW0PM0,SWP00P,SWP0M0,SWP0P0,SWPMPM,SWPP00,SWPPMM,SWPPPP,
     &  TH,TP,UH,W2,WGHEQ,WGHQQ,XCAP,XK1,XK2,XKAM,XKAP,
     &  XM2,XQ2,XTM1,XTM2,XTM3,YCAP
      DOUBLE PRECISION PHO_ALPHAS,PHO_ALPHAE
      EXTERNAL         PHO_ALPHAS,PHO_ALPHAE

      INTEGER I,I1,I2,IDIR,IPFL1,IPFL2,IPOS,K

      DIMENSION WGHEQ(2),XM2(2),P1(4),P2(4),XK1(4),XK2(4)
      DIMENSION HELFLX(6),SIGQPM(6)

      WGHAPP = 1.D0
      WGHQPM = 0.D0

C  strict pt cutoff after putting partons on mass shell,
C  calculated in gamma-gamma CMS
      if((Imode.eq.1).and.(ipamdl(121).gt.0)) then
        if(PTfin.lt.PTwant) then
          if(ipamdl(121).gt.1) return
          if((ipamdl(121).eq.1).and.(MSPR.eq.14)) return
        endif
      endif

C  cross section of sampled event (approximate treatment)

C  photon flux
      DO 50 K=1,2
        XM2(K) = AMSRC(K)**2
        IF(abs(IGHEL(K)).EQ.1) THEN
          WGHEQ(K) = ((1.D0+(1.D0-GYY(K))**2)/GYY(K)
     &              -2.D0*XM2(K)*GYY(K)/GQ2(K))/(137.D0*2.D0*PI*GQ2(K))
        ELSE
          WGHEQ(K) = (1.D0-GYY(K))/GYY(K)/(137.D0*PI*GQ2(K))
        ENDIF
 50   CONTINUE

      W2 = GGECM*GGECM
      IDIR   = 0
      WGHQQ  = 1.D0

C  direct or single-resolved gam-gam interaction
      IF((IMODE.GE.1).AND.
     &   (IPROCE.EQ.8).AND.(MSPR.GE.10)) THEN
        IDIR   = 1
        WGHQQ = 0.D0
C  determine final state partons
        DO 100 I=3,NHEP
          IF(ISTHEP(I).EQ.25) GOTO 110
 100    CONTINUE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,2A,I5)') 'PHO_WGEPEM:ERROR: ',
     &    'inconsistent process information (MSPR)',MSPR
        CALL PHO_ABORT
 110    CONTINUE
        IPOS = I
C  final state flavors
        IPFL1 = ABS(IDHEP(IPOS+3))
        IPFL2 = ABS(IDHEP(IPOS+4))
        SH = X1*X2*W2
C  calculate alpha-em
        ALPHA1 = PHO_ALPHAE(QQAL)
C  calculate alpha-s
        IF(MSPR.LT.14) THEN
          ALPHA2 = PHO_ALPHAS(QQAL,3)
        ENDIF
C  LO matrix element (8 pi s dsig/dt)
*       QC2 = 4.D0/9.D0 - DBLE(MOD(IPFL2,2))*3.D0/9.D0
        QC2 = Q_ch2(IPFL2)
        IF(IPFL2.EQ.0) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,2A,/,5X,A,I12,I3,4I4)') 'PHO_WGEPEM:ERROR: ',
     &      'invalid hard process - flavor combination',
     &      'EVENT,MSPR,IA,IB,IC,ID:',KEVENT,MSPR,IA,IB,IC,ID
        ENDIF
        IF(MSPR.EQ.10) THEN
          WGHQQ  = -8.D0*PI/(3.D0*SH**2)*ALPHA1*QC2*ALPHA2*(U**2+1.D0)/U
     &            *8.D0*PI*SH
        ELSE IF(MSPR.EQ.11) THEN
          WGHQQ  = PI/SH**2*ALPHA1*QC2*ALPHA2*(V**2+U**2)/(U*V)
     &            *8.D0*PI*SH
        ELSE IF(MSPR.EQ.12) THEN
          WGHQQ  = -8.D0*PI/(3.D0*SH**2)*ALPHA1*QC2*ALPHA2*(V**2+1.D0)/V
     &            *8.D0*PI*SH
        ELSE IF(MSPR.EQ.13) THEN
          WGHQQ  = PI/SH**2*ALPHA1*QC2*ALPHA2*(V**2+U**2)/(U*V)
     &            *8.D0*PI*SH
        ELSE IF(MSPR.EQ.14) THEN
          WGHQQ  = 6.D0*PI/SH**2*(ALPHA1*QC2)**2*(V**2+U**2)/(U*V)
     &            *8.D0*PI*SH
        ENDIF
      ENDIF

C  fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
      WGHAPP = WGHEQ(1)*WGHEQ(2)*WGHQQ/(2.D0*PI)

C  full leading-order QPM prediction (Budnev et al.)

C  full two-gamma flux

      P1Q2 = PINI(4,1)*PGAM(4,2)-PINI(1,1)*PGAM(1,2)
     &      -PINI(2,1)*PGAM(2,2)-PINI(3,1)*PGAM(3,2)
      P2Q1 = PINI(4,2)*PGAM(4,1)-PINI(1,2)*PGAM(1,1)
     &      -PINI(2,2)*PGAM(2,1)-PINI(3,2)*PGAM(3,1)
      Q1Q2 = PGAM(4,1)*PGAM(4,2)-PGAM(1,1)*PGAM(1,2)
     &      -PGAM(2,1)*PGAM(2,2)-PGAM(3,1)*PGAM(3,2)
      P1P2 = PINI(4,1)*PINI(4,2)-PINI(1,1)*PINI(1,2)
     &      -PINI(2,1)*PINI(2,2)-PINI(3,1)*PINI(3,2)
      DO 120 I=1,4
        P1(I) = 2.D0*PINI(I,1)-PGAM(I,1)
        P2(I) = 2.D0*PINI(I,2)-PGAM(I,2)
 120  CONTINUE
      XTM1 = 2.D0*P1Q2-Q1Q2
      XTM2 = 2.D0*P2Q1-Q1Q2
      XTM3 = P1(4)*P2(4)-P1(1)*P2(1)-P1(2)*P2(2)-P1(3)*P2(3)
      XCAP = Q1Q2**2-GQ2(1)*GQ2(2)
      YCAP = P1P2**2-XM2(1)*XM2(2)
      CCAP = -XTM3 + Q1Q2*XTM1*XTM2/XCAP

      RHO1PP = (XTM1**2/XCAP+1.D0-4.D0*XM2(1)/GQ2(1))/2.D0
      RHO2PP = (XTM2**2/XCAP+1.D0-4.D0*XM2(2)/GQ2(2))/2.D0
      RHO100 = XTM1**2/XCAP-1.D0
      RHO200 = XTM2**2/XCAP-1.D0
      RHOPM2 = CCAP**2/(GQ2(1)*GQ2(2))-2.D0*(RHO1PP-1.D0)*(RHO2PP-1.D0)
      RHOP08 = 4.D0*XTM1*XTM2*CCAP/XCAP/SQRT(GQ2(1)*GQ2(2))
      SS     = 2.D0*P1P2+XM2(1)+XM2(2)

      HELFLX(1) = 4.D0*RHO1PP*RHO2PP
      HELFLX(2) = RHOPM2
      HELFLX(3) = 2.D0*RHO1PP*RHO200
      HELFLX(4) = 2.D0*RHO100*RHO2PP
      HELFLX(5) = RHO100*RHO200
      HELFLX(6) = -RHOP08

C  only flux calculation

      IF(IDIR.EQ.0) THEN
        IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.1)) THEN
          WEIGHT = HELFLX(1)
        ELSE IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.0)) THEN
          WEIGHT = HELFLX(3)
        ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.1)) THEN
          WEIGHT = HELFLX(4)
        ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.0)) THEN
          WEIGHT = HELFLX(5)
        ELSE IF((IGHEL(1).EQ.-1).AND.(IGHEL(2).EQ.-1)) THEN
          WEIGHT = HELFLX(1)
        ELSE
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,2I3)')
     &      'PHO_WGEPEM:ERROR: invalid photon helicities: ',IGHEL
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,I12)')
     &      'PHO_WGEPEM: event rejected (KEVENT)',KEVENT
          WEIGHT = 0.D0
        ENDIF

C  fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
        WGHQPM = WEIGHT/(137.D0**2*16.D0*PI**4*GQ2(1)*GQ2(2))
     &          *SQRT(XCAP/YCAP)*PI*SS/(2.D0*YCAP)*PINI(4,1)*PINI(4,2)

      ELSE

C  flux folded with cross section
C  polarized, leading order gam gam --> q qbar cross sections

        DO 125 I=1,6
          SIGQPM(I) = 0.D0
 125    CONTINUE
C  momenta of produced parton pair
        I1 = IPOS+3
        I2 = IPOS+4
        DO 150 K=1,4
          XK1(K) = PHEP(K,I1)
          XK2(K) = PHEP(K,I2)
 150    CONTINUE
        XQ2 = PHEP(5,I2)**2

        IF(MSPR.EQ.14) THEN
C  direct photon-photon interaction
          XKAP = XQ2-(PGAM(4,1)-XK1(4))**2
     &          +(PGAM(1,1)-XK1(1))**2+(PGAM(2,1)-XK1(2))**2
     &          +(PGAM(3,1)-XK1(3))**2
          XKAM = XQ2-(PGAM(4,1)-XK2(4))**2
     &          +(PGAM(1,1)-XK2(1))**2+(PGAM(2,1)-XK2(2))**2
     &          +(PGAM(3,1)-XK2(3))**2
          CC = Q1Q2
          AA = XKAP*XKAM-GQ2(1)*GQ2(2)
          BB = CC**2-XKAP*XKAM
          DD = CC**2-GQ2(1)*GQ2(2)
          RR = -XQ2+W2*AA/(4.D0*DD)
          Q1KK = Q1Q2-GQ2(1)
          Q2KK = Q1Q2-GQ2(2)
          FAC = 192.D0*(PI*ALPHA1*QC2/(XKAP*XKAM))**2/(4.D0*SQRT(XCAP))

        ELSE
C  single-resolved photon-hadron interactions
C  Mandelstam variables
          IF(MSPR.LE.11) THEN
            TH = (PGAM(4,1)-XK1(4))**2-(PGAM(1,1)-XK1(1))**2
     &          -(PGAM(2,1)-XK1(2))**2-(PGAM(3,1)-XK1(3))**2
            UH = (PGAM(4,1)-XK2(4))**2-(PGAM(1,1)-XK2(1))**2
     &          -(PGAM(2,1)-XK2(2))**2-(PGAM(3,1)-XK2(3))**2
          ELSE
            TH = (PGAM(4,2)-XK2(4))**2-(PGAM(1,2)-XK2(1))**2
     &          -(PGAM(2,2)-XK2(2))**2-(PGAM(3,2)-XK2(3))**2
            UH = (PGAM(4,2)-XK1(4))**2-(PGAM(1,2)-XK1(1))**2
     &          -(PGAM(2,2)-XK1(2))**2-(PGAM(3,2)-XK1(3))**2
          ENDIF
          V = TH/SH
          U = UH/SH
        ENDIF

        WEIGHT = 0.D0
        IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.1)) THEN
          IF((MSPR.EQ.10).OR.(MSPR.EQ.12)) THEN
            IF(MSPR.EQ.10) THEN
              Q2 = -GQ2(1)
              SP = SH-XQ2
              TP = UH-XQ2
            ELSE
              Q2 = -GQ2(2)
              SP = SH-XQ2
              TP = TH-XQ2
            ENDIF
            SIGQPM(1)= -32.D0*PI**2*4.D0/3.D0*ALPHA1*QC2*ALPHA2
     &        *(SP*TP*(2.D0*Q2**4-4.D0*Q2*SP**3-2.D0*Q2**3*(3*SP+TP)
     &        +SP**2*(SP**2+TP**2)+Q2**2*(7.D0*SP**2+2.D0*SP*TP+TP**2))
     &       -2.D0*(2.D0*SP**3*TP*(SP+TP)+Q2**3*(SP**2+6.D0*SP*TP+TP**2)
     &        -2.D0*Q2**2*SP*(SP**2+4.D0*SP*TP+3.D0*TP**2)+Q2*SP*
     &        (SP**3+SP**2*TP-SP*TP**2+TP**3))*XQ2 +
     &        4.D0*(2.D0*Q2**2-SP**2)*(SP+TP)**2*XQ2**2)/
     &        (SP**2*TP**2*((Q2-SP)**2-4.D0*Q2*XQ2))
            WEIGHT = HELFLX(1)*SIGQPM(1)/(2.D0*(SH+GQ2(1)+GQ2(2)))
          ELSE IF((MSPR.EQ.11).OR.(MSPR.EQ.13)) THEN
            IF(MSPR.EQ.11) THEN
              Q2 = -GQ2(1)
            ELSE
              Q2 = -GQ2(2)
            ENDIF
            SP = SH
            TP = UH
            SIGQPM(1) = -32.D0*PI**2/2.D0*ALPHA1*QC2*ALPHA2
     &        *(-((Q2**2+SP**2)*TP*(Q2**3-SP**3-3.D0*SP**2*TP
     &        - 4.D0*SP*TP**2 - 2.D0*TP**3 - 3.D0*Q2**2*(SP + TP) + Q2*
     &            (3.D0*SP**2 + 6.D0*SP*TP + 4.D0*TP**2))) +
     &        (3.D0*Q2**5 - Q2**4*(11.D0*SP + 10.D0*TP) +
     &         4.D0*Q2**3*(4.D0*SP**2 + 5.D0*SP*TP + 4.D0*TP**2)
     &        +Q2*SP**2*(5.D0*SP**2+4.D0*SP*TP+8.D0*TP**2)-4.D0*Q2**2
     &        *(3.D0*SP**3+3.D0*SP**2*TP+4.D0*SP*TP**2+2.D0*TP**3)-
     &        SP**2*(SP**3+2.D0*SP**2*TP+8.D0*SP*TP**2+8.D0*TP**3))*XQ2+
     &        (11.D0*Q2**4-10.D0*Q2**3*(3.D0*SP+2.D0*TP)-2.D0*Q2*SP**2
     &        *(7.D0*SP+2.D0*TP)+2.D0*Q2**2*(15.D0*SP**2+10.D0*SP*TP
     &        +6.D0*TP**2)+SP**2*(3.D0*SP**2+4.D0*SP*TP+12.D0*TP**2))
     &        *XQ2**2+8.D0*(Q2**3-SP**2*TP-Q2**2*(SP+TP))*XQ2**3+
     &        2.D0*(Q2**2+SP**2)*XQ2**4)/((Q2-SP)**2*(-TP+XQ2)**2*
     &        (Q2-SP-TP+XQ2)**2)
            WEIGHT = HELFLX(1)*SIGQPM(1)/(2.D0*(SH+GQ2(1)+GQ2(2)))
          ELSE IF(MSPR.EQ.14) THEN
            SWPMPM = 4.D0*CC**2*RR*(W2-2.D0*RR)
            SWPPPP = SWPMPM +2.D0*(CC**2+BB)*(AA-4.D0*RR*CC)
            SWPPMM = 8.D0*RR*CC*(XKAP*XKAM-RR*CC)
     &              -2.D0*XKAP*XKAM*AA
            SIGQPM(1) = (SWPPPP+SWPMPM)/2.D0*FAC
            SIGQPM(2) = SWPPMM*FAC
            WEIGHT = HELFLX(1)*SIGQPM(1)
     &              +HELFLX(2)*SIGQPM(2)
          ENDIF
        ELSE IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.0)) THEN
          IF(MSPR.EQ.12) THEN
            Q2 = -GQ2(2)
            SP = SH-XQ2
            TP = TH-XQ2
            SIGQPM(3) = 32.D0*PI**2*8.D0/3.D0*ALPHA1*QC2*ALPHA2
     &               *Q2*(-(SP**2*TP**2*(-Q2 + SP + TP)) +
     &               SP*TP*(2.D0*Q2**2 + 3.D0*SP**2 + 2.D0*SP*TP -
     &               TP**2 - 2.D0*Q2*(3*SP + TP))*XQ2 -
     &               2.D0*(Q2*(SP**2 + 6.D0*SP*TP + TP**2) -
     &               2.D0*SP*(SP**2 + 4.D0*SP*TP + 3.D0*TP**2))*
     &               XQ2**2 + 8.D0*(SP + TP)**2*XQ2**3)/
     &               (SP**2*TP**2*((Q2 - SP)**2 - 4.D0*Q2*XQ2))
            WEIGHT = HELFLX(3)*SIGQPM(3)/(2.D0*(SH+GQ2(2)))
          ELSE IF(MSPR.EQ.13) THEN
            Q2 = -GQ2(2)
            SP = SH
            TP = TH
            SIGQPM(3) = 32.D0*PI**2*2.D0*ALPHA1*QC2*ALPHA2
     &        *(-Q2*(SP*TP*(-Q2+SP+TP)+(Q2**2-Q2*SP-2*SP*TP)*XQ2 +
     &        SP*XQ2**2))/((Q2-SP)**2*(-TP+XQ2)*(Q2-SP-TP+XQ2))
            WEIGHT = HELFLX(3)*SIGQPM(3)/(2.D0*(SH+GQ2(2)))
          ELSE IF(MSPR.EQ.14) THEN
            SWP0M0 = 4.D0*RR*GQ2(2)*(-CC**2*GQ2(1)*W2
     &              -XKAP*XKAM*Q1KK**2)/DD
            SWP0P0 = - SWP0M0+2.D0*GQ2(2)*GQ2(1)**2*W2*BB/DD
            SWPP00 = 2.D0*W2*BB*(AA-2.D0*CC*RR)
     &              *SQRT(GQ2(1)*GQ2(2))/DD
            SWP00P = 4.D0*RR*(CC**2*(GQ2(1)*Q2KK+GQ2(2)*Q1KK)
     &              +XKAP*XKAM*Q1KK*Q2KK)*SQRT(GQ2(1)*GQ2(2))/DD
            SW0PM0 = -SWP00P-2.D0*GQ2(1)*GQ2(2)*W2*BB
     &              *SQRT(GQ2(1)*GQ2(2))/DD
            SIGQPM(3) = SWP0P0*FAC
            SIGQPM(6) = (SWPP00+SW0PM0)/2.D0*FAC
            WEIGHT = HELFLX(3)*SIGQPM(3)
     &              +HELFLX(6)*SIGQPM(6)/2.D0
          ENDIF
        ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.1)) THEN
          IF(MSPR.EQ.10) THEN
            Q2 = -GQ2(1)
            SP = SH-XQ2
            TP = UH-XQ2
            SIGQPM(4) = 32.D0*PI**2*8.D0/3.D0*ALPHA1*QC2*ALPHA2
     &               *Q2*(-(SP**2*TP**2*(-Q2 + SP + TP)) +
     &               SP*TP*(2.D0*Q2**2 + 3.D0*SP**2 + 2.D0*SP*TP -
     &               TP**2 - 2.D0*Q2*(3*SP + TP))*XQ2 -
     &               2.D0*(Q2*(SP**2 + 6.D0*SP*TP + TP**2) -
     &               2.D0*SP*(SP**2 + 4.D0*SP*TP + 3.D0*TP**2))*
     &               XQ2**2 + 8.D0*(SP + TP)**2*XQ2**3)/
     &               (SP**2*TP**2*((Q2 - SP)**2 - 4.D0*Q2*XQ2))
            WEIGHT = HELFLX(4)*SIGQPM(4)/(2.D0*(SH+GQ2(1)))
          ELSE IF(MSPR.EQ.11) THEN
            Q2 = -GQ2(1)
            SP = SH
            TP = TH
            SIGQPM(4) = 32.D0*PI**2*2.D0*ALPHA1*QC2*ALPHA2
     &        *(-Q2*(SP*TP*(-Q2+SP+TP)+(Q2**2-Q2*SP-2*SP*TP)*XQ2 +
     &        SP*XQ2**2))/((Q2-SP)**2*(-TP+XQ2)*(Q2-SP-TP+XQ2))
            WEIGHT = HELFLX(4)*SIGQPM(4)/(2.D0*(SH+GQ2(2)))
          ELSE IF(MSPR.EQ.14) THEN
            SW0P0M = 4.D0*RR*GQ2(1)*(-CC**2*GQ2(2)*W2
     &                               -XKAP*XKAM*Q2KK**2)/DD
            SW0P0P = - SW0P0M+2.D0*GQ2(1)*GQ2(2)**2*W2*BB/DD
            SWPP00 = 2.D0*W2*BB*(AA-2.D0*CC*RR)
     &              *SQRT(GQ2(1)*GQ2(2))/DD
            SWP00P = 4.D0*RR*(CC**2*(GQ2(1)*Q2KK+GQ2(2)*Q1KK)
     &              +XKAP*XKAM*Q1KK*Q2KK)*SQRT(GQ2(1)*GQ2(2))/DD
            SW0PM0 = -SWP00P-2.D0*GQ2(1)*GQ2(2)*W2*BB
     &              *SQRT(GQ2(1)*GQ2(2))/DD
            SIGQPM(4) = SW0P0P*FAC
            SIGQPM(6) = (SWPP00+SW0PM0)/2.D0*FAC
            WEIGHT = HELFLX(4)*SIGQPM(4)
     &              +HELFLX(6)*SIGQPM(6)/2.D0
          ENDIF
        ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.0)) THEN
          IF(MSPR.EQ.14) THEN
            SW0000 = 2.D0*GQ2(1)*GQ2(2)*W2*W2*AA*BB/DD**2
            SIGQPM(5) = SW0000*FAC
            WEIGHT = HELFLX(5)*SIGQPM(5)
          ENDIF
        ELSE
          IF (LPRI.GT.4)
     &    WRITE(LO,'(/1X,A,2I3)')
     &      'PHO_WGEPEM:ERROR: invalid photon helicities: ',IGHEL
          IF (LPRI.GT.4)
     &    WRITE(LO,'(1X,A,I12)')
     &      'PHO_WGEPEM: event rejected (KEVENT)',KEVENT
          WEIGHT = 0.D0
        ENDIF

C  fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)

        WGHQPM = WEIGHT/(137.D0**2*16.D0*PI**4*GQ2(1)*GQ2(2))
     &          *SQRT(XCAP/YCAP)*PI*SS/(2.D0*YCAP)*PINI(4,1)*PINI(4,2)

      ENDIF

      END


 
 


CDECK  ID>, PHO_XLAM
      DOUBLE PRECISION FUNCTION PHO_XLAM(X,Y,Z)
C**********************************************************************
C
C     auxiliary function for two/three particle decay mode
C     (standard LAMBDA**(1/2) function)
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE
C
      YZ=Y-Z
      XLAM=X*X-2.D0*X*(Y+Z)+YZ*YZ
      IF(XLAM.LT.0.D0) XLAM=-XLAM
      PHO_XLAM=SQRT(XLAM)

      END

 
 


CDECK  ID>, PHO_XSECT
      SUBROUTINE PHO_XSECT(IP,IFHARD,EE)
C*********************************************************************
C
C     calculation of physical cross sections
C
C     input:   IP      particle combination
C              IFHARD  -1 reset Born graph cross section tables
C                      0  calculate hard cross sections or take them
C                         from interpolation table (if available)
C                      1  assume that hard cross sections are already
C                         calculated and stored in /POSBRN/
C              EE      cms energy (GeV)
C
C     output:  /POSBRN/  input cross sections
C              /POZBRN/  scaled input cross values
C              /POCSEC/  physical cross sections and slopes
C
C              slopes in GeV**-2, cross sections in mb
C
C*********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE

      PARAMETER(ONEM=-1.D0,
     &         THOUS=1.D3,
     &          DEPS=1.D-20)

C  input/output channels
      INTEGER LI,LO ,LPRI
      COMMON /POINOU/ LI,LO ,LPRI

C  some constants
      DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
      COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
     &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)

C  event debugging information
      INTEGER NMAXD
      PARAMETER (NMAXD=100)
      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD

C  integration precision for hard cross sections (obsolete)
      INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
      COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO

C  model switches and parameters
      CHARACTER*8 MDLNA
      INTEGER ISWMDL,IPAMDL
      DOUBLE PRECISION PARMDL
      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)

C  Born graph cross sections and slopes
      INTEGER Max_pro_3
      PARAMETER ( Max_pro_3 = 16 )
      COMPLEX*16      SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
     &                SIGD1,SIGD2,DSIGH
      COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
     &                SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)

C  cross sections
      INTEGER IPFIL,IFAFIL,IFBFIL
      DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
     &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
     &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
     &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
     &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
      COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
     &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
     &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
     &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
     &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
     &                IPFIL,IFAFIL,IFBFIL

C  global event kinematics and particle IDs
      INTEGER IFPAP,IFPAB
      DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
      COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)

      CHARACTER*15    PHO_PNAME

C  complex Born graph amplitudes used for unitarization
      COMPLEX*16      AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
     &                AMHMDD,AMPDP
      COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
     &                AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)

      DIMENSION XPNT(96),WGHT(96),SLVM1(4,4),SLVM2(4,4)
      CHARACTER*8 VMESA(0:4),VMESB(0:4)
      DATA VMESA / 'vmeson  ','rho     ','omega   ','phi     ',
     &             'pi+pi-  ' /
      DATA VMESB / 'vmeson  ','rho     ','omega   ','phi     ',
     &             'pi+pi-  ' /

      CDABS(AMPEL) = ABS(AMPEL)

      ETMP = ECM
      IF(EE.LT.0.D0) GOTO 500
      ECM = EE

C  impact parameter integration
C     BMAX=12.D0*SQRT(MAX(BPOM,BREG))
      BMAX=10.D0
      CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
      SIGTOT    = 0.D0
      SIGINE    = 0.D0
      SIGELA    = 0.D0
      SIGNDF    = 0.D0
      SIGLSD(1) = 0.D0
      SIGLSD(2) = 0.D0
      SIGLDD    = 0.D0
      SIGHSD(1) = 0.D0
      SIGHSD(2) = 0.D0
      SIGHDD    = 0.D0
      SIGCDF(0) = 0.D0
      SIG1SO    = 0.D0
      SIG1HA    = 0.D0
      SLEL1 = 0.D0
      SLEL2 = 0.D0
      DO 50 I=1,4
        SIGCDF(I) = 0.D0
        DO 55 K=1,4
          SIGVM(I,K) = 0.D0
          SLVM1(I,K) = 0.D0
          SLVM2(I,K) = 0.D0
 55     CONTINUE
 50   CONTINUE

      DO 100 I=1,NGAUSO
        B2  = XPNT(I)**2
        WG  = WGHT(I)*XPNT(I)
        WGB = B2*WG

C  calculate impact parameter amplitude, results in /POINT4/
        IF(I.EQ.1) THEN
          CALL PHO_EIKON(IP,IFHARD,XPNT(I))
        ELSE
          CALL PHO_EIKON(IP,1,XPNT(I))
        ENDIF

        SIGTOT    = SIGTOT + DREAL(AMPEL)*WG
        SIGELA    = SIGELA + CDABS(AMPEL)**2*WG
        SLEL1     = SLEL1  + AMPEL*WGB
        SLEL2     = SLEL2  + AMPEL*WG

        DO 110 J=1,4
          DO 120 K=1,4
            SIGVM(J,K) = SIGVM(J,K) + CDABS(AMPVM(J,K))**2*WG
            SLVM1(J,K) = SLVM1(J,K) + AMPVM(J,K)*WGB
            SLVM2(J,K) = SLVM2(J,K) + AMPVM(J,K)*WG
 120      CONTINUE
          SIGCDF(J)   = SIGCDF(J)   + DREAL(AMPDP(J))*WG
 110    CONTINUE

        SIGLSD(1) = SIGLSD(1) + CDABS(AMLMSD(1))**2*WG
        SIGLSD(2) = SIGLSD(2) + CDABS(AMLMSD(2))**2*WG
        SIGLDD    = SIGLDD    + CDABS(AMLMDD)**2*WG
        SIG1SO    = SIG1SO    + DREAL(AMPSOF)*WG
        SIG1HA    = SIG1HA    + DREAL(AMPHAR)*WG
        SIGHSD(1) = SIGHSD(1) + DREAL(AMHMSD(1))*WG
        SIGHSD(2) = SIGHSD(2) + DREAL(AMHMSD(2))*WG
        SIGHDD    = SIGHDD    + DREAL(AMHMDD)*WG

 100  CONTINUE

      SIGDIR = DREAL(SIGHD)
      FAC    = 4.D0*PI2
      SIGTOT = SIGTOT*FAC
      SIGELA = SIGELA*FAC
      FACSL  = 0.5D0/GEV2MB
      SLOEL  = SLEL1/MAX(DEPS,SLEL2)*FACSL

      IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22)) THEN
        DO 130 I=1,4
          DO 140 J=1,4
            SIGVM(I,J) = SIGVM(I,J)*FAC
            SLOVM(I,J) = SLVM1(I,J)/MAX(DEPS,SLVM2(I,J))*FACSL
 140      CONTINUE
 130    CONTINUE
        SIGVM(0,0) = 0.D0
        DO 150 I=1,4
          SIGVM(0,I) = 0.D0
          SIGVM(I,0) = 0.D0
          DO 160 J=1,4
            SIGVM(0,I) = SIGVM(0,I) + SIGVM(J,I)
            SIGVM(I,0) = SIGVM(I,0) + SIGVM(I,J)
 160      CONTINUE
          SIGVM(0,0) = SIGVM(0,0) + SIGVM(I,0)
 150    CONTINUE
      ENDIF

C  diffractive cross sections

      SIGLSD(1) = SIGLSD(1)*FAC*PARMDL(40)
      SIGLSD(2) = SIGLSD(2)*FAC*PARMDL(41)
      SIGLDD    = SIGLDD   *FAC*PARMDL(42)
      SIGHSD(1) = (SIGHSD(1)-2.D0*(SIGCDF(1)+SIGCDF(2)))*FAC*PARMDL(40)
      SIGHSD(2) = (SIGHSD(2)-2.D0*(SIGCDF(1)+SIGCDF(3)))*FAC*PARMDL(41)
      SIGHDD    = (SIGHDD-2.D0*(SIGCDF(2)+SIGCDF(3)+2.D0*SIGCDF(4)))
     &            *FAC*PARMDL(42)

C  double pomeron scattering

      SIGCDF(0) = 0.D0
      DO 170 I=1,4
        SIGCDF(I) = SIGCDF(I)*FAC
        SIGCDF(0) = SIGCDF(0)+SIGCDF(I)
 170  CONTINUE

      SIG1SO    = SIG1SO   *FAC
      SIG1HA    = SIG1HA   *FAC

      SIGINE    = SIGTOT - SIGELA

C  user-forced change of diffractive cross section

      IF((IP.EQ.1).AND.(ISWMDL(30).GE.1)) THEN

C  use optional explicit parametrization for single-diffraction

        SIGSD1 = SIGLSD(1)+SIGHSD(1)
        SIGSD2 = SIGLSD(2)+SIGHSD(2)
        SS = EE*EE
        XI_MIN = 1.5D0/SS
        XI_MAX = PARMDL(45)**2
        CALL PHO_CSDIFF(IFPAP(1),IFPAP(2),SS,XI_MIN,XI_MAX,
     &    SIG_SD1,SIG_SD2,SIG_DD)
        SIG_SD1 = SIG_SD1*PARMDL(40)
        SIG_SD2 = SIG_SD2*PARMDL(41)

**sr
C       DEL_SD1 = SIG_SD1-SIGSD1
        DEL_SD1 = PARMDL(200)*(SIG_SD1-SIGSD1)
**

        FAC = SIGLSD(1)/SIGSD1
        SIGLSD(1) = SIGLSD(1)+FAC*DEL_SD1
        SIGHSD(1) = SIGHSD(1)+(1.D0-FAC)*DEL_SD1

C       DEL_SD2 = SIG_SD2-SIGSD2
        DEL_SD2 = PARMDL(200)*(SIG_SD2-SIGSD2)

        FAC = SIGLSD(2)/SIGSD2
        SIGLSD(2) = SIGLSD(2)+FAC*DEL_SD2
        SIGHSD(2) = SIGHSD(2)+(1.D0-FAC)*DEL_SD2

        IF(ISWMDL(30).GE.2) THEN

C  use explicit parametrization also for double diffraction diss.
          SIGDD  = SIGLDD+SIGHDD
          SIG_DD = SIG_DD*PARMDL(42)
          DEL_DD = SIG_DD-SIGDD
          FAC = SIGLDD/SIGDD
          SIGLDD = SIGLDD+FAC*DEL_DD
          SIGHDD = SIGHDD+(1.D0-FAC)*DEL_DD
          SIGCOR = DEL_SD1 + DEL_SD2 + DEL_DD

        ELSE

C  rescale double diffraction cross sections
          SIGLDD    = SIGLDD   *PARMDL(42)
          SIGHDD    = SIGHDD   *PARMDL(42)
          SIGCOR = DEL_SD1 + DEL_SD2
     &      +(SIGLDD+SIGHDD)*(PARMDL(42)-1.D0)

        ENDIF

      ELSE

C  rescale unitarized cross sections for diffraction dissociation

        SIGLSD(1) = SIGLSD(1)*PARMDL(40)
        SIGHSD(1) = SIGHSD(1)*PARMDL(40)
        SIGLSD(2) = SIGLSD(2)*PARMDL(41)
        SIGHSD(2) = SIGHSD(2)*PARMDL(41)
        SIGLDD    = SIGLDD   *PARMDL(42)
        SIGHDD    = SIGHDD   *PARMDL(42)
        SIGCOR = (SIGLSD(1)+SIGHSD(1))*(PARMDL(40)-1.D0)
     &          +(SIGLSD(2)+SIGHSD(2))*(PARMDL(41)-1.D0)
     &          +(SIGLDD+SIGHDD)*(PARMDL(42)-1.D0)

      ENDIF

C  non-diffractive inelastic cross section

      SIGNDF    = SIGTOT-SIGELA-SIGVM(0,0)-SIGCDF(0)-SIGDIR
     &            -SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
     &            -SIGLDD-SIGHDD

C  specify elastic scattering channel

 500  CONTINUE
      IF(IFPAP(1).NE.22) THEN
        VMESA(1) = PHO_PNAME(IFPAB(1),0)
      ELSE
        VMESA(1) = 'rho           '
      ENDIF
      IF(IFPAP(2).NE.22) THEN
        VMESB(1) = PHO_PNAME(IFPAB(2),0)
      ELSE
        VMESB(1) = 'rho           '
      ENDIF

C  write out physical cross sections

      IF(IDEB(57).GE.5) THEN
        IF (LPRI.GT.4)
     &  WRITE(LO,'(/1X,A,I3,/1X,A)')
     &    'PHO_XSECT: cross sections (mb) for combination',IP,
     &    '----------------------------------------------'
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,E12.3,2E11.3)')'energy,virtualities',ECM,PVIRT
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,E12.3)') '             total ',SIGTOT
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,E12.3)') '    purely elastic ',SIGELA
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,E12.3)') '         inelastic ',SIGINE
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,E12.3)') ' s-diff.particle 1 ',
     &    SIGLSD(1)+SIGHSD(1)
        IF(IDEB(57).GE.7) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,E12.3)') '     low-mass part ',SIGLSD(1)
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,E12.3)') '    high-mass part ',SIGHSD(1)
        ENDIF
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,E12.3)') ' s-diff.particle 2 ',
     &    SIGLSD(2)+SIGHSD(2)
        IF(IDEB(57).GE.7) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,E12.3)') '     low-mass part ',SIGLSD(2)
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,E12.3)') '    high-mass part ',SIGHSD(2)
        ENDIF
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,E12.3)') '       double diff ',SIGLDD+SIGHDD
        IF(IDEB(57).GE.7) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,E12.3)') '     low-mass part ',SIGLDD
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,E12.3)') '    high-mass part ',SIGHDD
        ENDIF
        IF (LPRI.GT.4)
     &  WRITE(LO,'(5X,A,E12.3)') '    double pomeron ',SIGCDF(0)
        IF(IDEB(57).GE.7) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,E12.3)') '    purely elastic ',SIGCDF(1)
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,E12.3)') ' excitation part.1 ',SIGCDF(2)
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,E12.3)') ' excitation part.2 ',SIGCDF(3)
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,E12.3)') '   excitation both ',SIGCDF(4)
        ENDIF
        IF (LPRI.GT.4)
     .  WRITE(LO,'(5X,A,E12.3)') '     elastic slope ',SLOEL
        DO 200 I=1,4
          DO 210 J=1,4
            IF(SIGVM(I,J).GT.DEPS) THEN
              IF (LPRI.GT.4)
     &        WRITE(LO,'(1X,3A)') 'q-elastic production of ',
     &          VMESA(I),VMESB(J)
              IF (LPRI.GT.4)
     &        WRITE(LO,'(10X,A,E12.3)') 'cross section ',SIGVM(I,J)
              IF((I.NE.0).AND.(J.NE.0) .AND. LPRI.GT.4)
     &          WRITE(LO,'(18X,A,E12.3)') 'slope ',SLOVM(I,J)
            ENDIF
 210      CONTINUE
 200    CONTINUE
        IF(IDEB(57).GE.7) THEN
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,E12.3)') ' vmeson production ',SIGVM(0,0)
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,E12.3)') '  one-pomeron soft ',SIG1SO
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,E12.3)') '  one-pomeron hard ',SIG1HA
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,E12.3)') '  pomeron exchange ',SIGPOM
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,E12.3)') '  reggeon exchange ',SIGREG
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,E12.3)') ' hard resolved QCD ',DREAL(DSIGH(9))
          IF (LPRI.GT.4)
     &    WRITE(LO,'(5X,A,E12.3/)')'   hard direct QCD ',
     &      DREAL(DSIGH(15))
        ENDIF
      ENDIF

      ECM = ETMP

      END


 
 


CDECK  ID>, PHVAL
      SUBROUTINE PHVAL(IGRP,ISET,XI,SCALE2,PD,IRET)
C**********************************************************************
C
C   dummy subroutine, remove to link PHOLIB
C
C**********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE
      DIMENSION PD(-6:6)

      END

