DPMJET/phojet1.12-35c3.f

   1 C***********************************************************************
   2 C
   3 C
   4 C
   5 C                       PHOJET version 1.12
   6 C                       -------------------
   7 C
   8 C
   9 C    ($Revision: 1.12.1.35 $, $Date: 2000/06/25 21:59:19 $)
  10 C
  11 C
  12 C    Authors: Ralph Engel
  13 C             (ralph.engel@fzk.de)
  14 C
  15 C             Johannes Ranft
  16 C             (johannes.ranft@cern.ch)
  17 C
  18 C             Stefan Roesler
  19 C             (Stefan.Roesler@cern.ch)
  20 C
  21 C
  22 C    For the latest version and documentation check
  23 C       http://www-ik.fzk.de/~engel/phojet.html
  24 C
  25 C
  26 C    Bug reports, questions, complaints are welcome
  27 C    (please send a mail to ralph.engel@fzk.de).
  28 C
  29 C
  30 C    Note that the code is available with several interfaces to
  31 C    Lund fragmentation programs (JETSET7.x, 1.x and a double
  32 C    precision JETSET version). This file is the code with
  33 C
  34 C                interface to PYTHIA 6.1 (or higher)
  35 C     for usage in DPMJET 3.x (Lund common block dimensions increased)
  36 C
  37 C***********************************************************************
  38 C
  39 C
  40 C             List of subroutines and functions
  41 C             ---------------------------------
  42 C
  43 C
  44 C  main event simulation routines
  45 C
  46 C      PHO_EVENT
  47 C      PHO_PARTON
  48 C      PHO_POSPOM
  49 C
  50 C      PHO_STDPAR
  51 C      PHO_POMSCA
  52 C
  53 C
  54 C  user steering interface
  55 C
  56 C      PHO_SETMDL
  57 C      PHO_PRESEL
  58 C
  59 C
  60 C  experimental setup / photon flux calculation
  61 C
  62 C      PHO_FIXLAB
  63 C      PHO_FIXCOL
  64 C      PHO_GPHERA
  65 C      PHO_GGEPEM
  66 C      PHO_WGEPEM
  67 C      PHO_GGBLSR
  68 C      PHO_GGBEAM
  69 C      PHO_GGHIOF
  70 C      PHO_GGHIOG
  71 C      PHO_GGFLCL
  72 C      PHO_GGFLCR
  73 C      PHO_GGFAUX
  74 C      PHO_GGFNUC
  75 C      PHO_GHHIOF
  76 C      PHO_GHHIAS
  77 C
  78 C
  79 C  initialization
  80 C
  81 C      PHO_INIT
  82 C      PHO_DATINI
  83 C      PHO_PARDAT
  84 C      PHO_MCINI
  85 C
  86 C      PHO_EVEINI
  87 C
  88 C      PHO_HARINI
  89 C      PHO_FRAINI
  90 C
  91 C      PHO_FITPAR
  92 C
  93 C
  94 C  cross section calculation
  95 C
  96 C      PHO_CSINT
  97 C
  98 C      PHO_XSECT
  99 C      PHO_BORNCS
 100 C      PHO_HARXTO
 101 C
 102 C      PHO_DSIGDT
 103 C
 104 C      PHO_TRIREG
 105 C      PHO_LOOREG
 106 C      PHO_TRXPOM
 107 C
 108 C      PHO_EIKON
 109 C      PHO_CHAN2A
 110 C
 111 C      PHO_SCALES
 112 C
 113 C
 114 C  multiple interaction structure
 115 C
 116 C      PHO_IMPAMP
 117 C      PHO_PRBDIS
 118 C      PHO_SAMPRO
 119 C      PHO_SAMPRB
 120 C
 121 C
 122 C  hadron / photon remnant treatment, soft x selection
 123 C
 124 C      PHO_HARREM
 125 C      PHO_PARREM
 126 C
 127 C      PHO_HADSP2
 128 C      PHO_HADSP3
 129 C      PHO_SOFTXX
 130 C      PHO_SELSXR
 131 C      PHO_SELSX2
 132 C      PHO_SELSXS
 133 C      PHO_SELSXI
 134 C
 135 C      PHO_VALFLA
 136 C      PHO_REGFLA
 137 C      PHO_SEAFLA
 138 C      PHO_FLAUX
 139 C      PHO_BETAF
 140 C      IPHO_DIQU
 141 C
 142 C
 143 C  primordial kt and soft parton pt
 144 C
 145 C      PHO_PRIMKT
 146 C      PHO_PARTPT
 147 C      PHO_SOFTPT
 148 C      PHO_SELPT
 149 C
 150 C      PHO_CONN0
 151 C      PHO_CONN1
 152 C
 153 C
 154 C  simulation of hard scattering, initial state radiation
 155 C
 156 C      PHO_HARCOL
 157 C      PHO_SELCOL
 158 C      PHO_HARCOR
 159 C
 160 C      PHO_HARDIR
 161 C      PHO_HARX12
 162 C      PHO_HARDX1
 163 C      PHO_HARKIN
 164 C      PHO_HARWGH
 165 C      PHO_HARSCA
 166 C      PHO_HARFAC
 167 C      PHO_HARWGX
 168 C      PHO_HARWGI
 169 C      PHO_HARINT
 170 C      PHO_HARMCI
 171 C
 172 C      PHO_HARXR3
 173 C      PHO_HARXR2
 174 C      PHO_HARXD2
 175 C      PHO_HARXPT
 176 C      PHO_HARISR
 177 C      PHO_HARZSP
 178 C
 179 C      PHO_PTCUT
 180 C      PHO_ALPHAE
 181 C      PHO_ALPHAS
 182 C
 183 C
 184 C  diffraction dissociation
 185 C
 186 C      PHO_DIFDIS
 187 C      PHO_DIFPRO
 188 C      PHO_DIFPAR
 189 C      PHO_QELAST
 190 C      PHO_CDIFF
 191 C      PHO_DFWRAP
 192 C
 193 C      PHO_SAMASS
 194 C      PHO_DSIGDM
 195 C      PHO_DFMASS
 196 C
 197 C      PHO_SDECAY
 198 C      PHO_SDECY2
 199 C      PHO_SDECY3
 200 C
 201 C      PHO_DIFSLP
 202 C      PHO_DIFKIN
 203 C      PHO_VECRES
 204 C      PHO_DIFRES
 205 C
 206 C      PHO_REGPAR
 207 C
 208 C      PHO_PECMS
 209 C      PHO_SETPAR
 210 C
 211 C
 212 C  fragmentation, treatment of low-mass strings
 213 C
 214 C      PHO_STRING
 215 C      PHO_STRFRA
 216 C
 217 C      PHO_ID2STR
 218 C      PHO_MCHECK
 219 C      PHO_POMCOR
 220 C      PHO_MASCOR
 221 C      PHO_PARCOR
 222 C
 223 C      PHO_GLU2QU
 224 C      PHO_GLUSPL
 225 C
 226 C      PHO_DQMASS
 227 C      PHO_BAMASS
 228 C      PHO_MEMASS
 229 C
 230 C
 231 C  particle code tables, particle numbering conversion
 232 C
 233 C      PHO_PNAME
 234 C      PHO_PMASS
 235 C      IPHO_CHR3
 236 C      IPHO_BAR3
 237 C
 238 C      IPHO_ANTI
 239 C
 240 C      IPHO_PDG2ID
 241 C      IPHO_ID2PDG
 242 C      IPHO_LU2PDG
 243 C      IPHO_PDG2LU
 244 C
 245 C      IPHO_CNV1
 246 C      PHO_HACODE
 247 C
 248 C
 249 C
 250 C  Lorentz transformations, rotations and mass adjustment
 251 C
 252 C      PHO_ALTRA
 253 C      PHO_LTRANS
 254 C      PHO_TRANS
 255 C      PHO_TRANI
 256 C
 257 C      PHO_MKSLTR
 258 C      PHO_GETLTR
 259 C
 260 C      PHO_LTRHEP
 261 C
 262 C      PHO_MSHELL
 263 C      PHO_MASSAD
 264 C
 265 C
 266 C  program debugging and internal cross-checks
 267 C
 268 C      PHO_PREVNT
 269 C      PHO_PRSTRG
 270 C      PHO_CHECK
 271 C
 272 C      PHO_TRACE
 273 C
 274 C      PHO_REJSTA
 275 C
 276 C      PHO_ABORT
 277 C
 278 C
 279 C  cross section fitting
 280 C
 281 C      PHO_FITMAI
 282 C      PHO_FITINP
 283 C      PHO_FITDAT
 284 C      PHO_FITOUT
 285 C      PHO_FITAMP
 286 C      PHO_FITTST
 287 C      PHO_FITMSQ
 288 C      PHO_FITVD1
 289 C      PHO_FITCN1
 290 C      PHO_FITINI
 291 C
 292 C
 293 C  cross section parametrizations
 294 C
 295 C      PHO_HADCSL
 296 C      PHO_ALLM97
 297 C      PHO_CSDIFF
 298 C
 299 C
 300 C  random numbers
 301 C
 302 C      DPMJET random number generator DT_RNDM used
 303 C
 304 C      PHO_SFECFE
 305 C      PHO_RNDBET
 306 C      PHO_RNDGAM
 307 C
 308 C
 309 C  auxiliary routines / numerical methods
 310 C
 311 C      PHO_GAUSET
 312 C      PHO_GAUDAT
 313 C
 314 C      pho_samp1d
 315 C
 316 C      PHO_DZEROX
 317 C      PHO_EXPINT
 318 C      PHO_BESSJ0
 319 C      PHO_BESSI0
 320 C      pho_ExpBessI0
 321 C      PHO_BESSI1
 322 C      PHO_BESSK0
 323 C      PHO_BESSK1
 324 C
 325 C      PHO_XLAM
 326 C
 327 C      PHO_SWAPD
 328 C      PHO_SWAPI
 329 C
 330 C
 331 C  parton density parametrization management / interface
 332 C
 333 C      PHO_PDF
 334 C
 335 C      PHO_SETPDF
 336 C      PHO_GETPDF
 337 C      PHO_ACTPDF
 338 C
 339 C      PHO_QPMPDF
 340 C
 341 C      PHO_PDFTST
 342 C
 343 C
 344 C  parton density parametrizations from other authors
 345 C
 346 C      PHO_DOR98LO
 347 C      PHO_DOR98SC
 348 C      PHO_DOR94LO
 349 C      PHO_DOR94HO
 350 C      PHO_DOR94DI
 351 C      PHO_DOR92LO
 352 C      PHO_DOR92HO
 353 C      PHO_DORPLO
 354 C      PHO_DORPHO
 355 C      PHO_DORGLO
 356 C      PHO_DORGHO
 357 C      PHO_DORGH0
 358 C      PHO_DOR94FV
 359 C      PHO_DOR94FW
 360 C      PHO_DOR94FS
 361 C      PHO_DOR92FV
 362 C      PHO_DOR92FW
 363 C      PHO_DOR92FS
 364 C      PHO_DORFVP
 365 C      PHO_DORFGP
 366 C      PHO_DORFQP
 367 C      PHO_DORGF
 368 C      PHO_DORGFS
 369 C      PHO_grsf1
 370 C      PHO_grsf2
 371 C
 372 C      PHO_CKMTPA
 373 C      PHO_CKMTPD
 374 C      PHO_CKMTPO
 375 C      PHO_CKMTFV
 376 C
 377 C      PHO_DBFINT
 378 C
 379 C      PHO_SASGAM
 380 C      PHO_SASVMD
 381 C      PHO_SASANO
 382 C      PHO_SASBEH
 383 C      PHO_SASDIR
 384 C
 385 C      PHO_PHGAL
 386 C      PHVAL
 387 C
 388 C
 389 C***********************************************************************
 390
 391 *$ CREATE PHO_INIT.FOR
 392 *COPY PHO_INIT
 393 CDECK  ID>, PHO_INIT
 394       SUBROUTINE PHO_INIT(LINP,LOUT,IREJ)
 395 C***********************************************************************
 396 C
 397 C     main subroutine to configure and manage PHOJET calculations
 398 C
 399 C     input:  LINP       input unit to read from
 400 C                        -1 to skip reading of input file
 401 C             LOUT       output unit to write to
 402 C
 403 C     output: IREJ       0  success
 404 C                        1  failure
 405 C
 406 C***********************************************************************
 407       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
 408       SAVE
 409
 410 C  input/output channels
 411       INTEGER LI,LO
 412       COMMON /POINOU/ LI,LO
 413 C  event debugging information
 414       INTEGER NMAXD
 415       PARAMETER (NMAXD=100)
 416       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
 417      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
 418       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
 419      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
 420 C  model switches and parameters
 421       CHARACTER*8 MDLNA
 422       INTEGER ISWMDL,IPAMDL
 423       DOUBLE PRECISION PARMDL
 424       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
 425 C  general process information
 426       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
 427       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
 428
 429 C  global event kinematics and particle IDs
 430       INTEGER IFPAP,IFPAB
 431       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
 432       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
 433 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
 434       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
 435       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
 436       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
 437      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
 438 C  integration precision for hard cross sections (obsolete)
 439       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
 440       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
 441 C  some hadron information, will be deleted in future versions
 442       INTEGER NFS
 443       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
 444       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
 445 C  obsolete cut-off information
 446       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
 447       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
 448 C  photon flux kinematics and cuts
 449       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
 450      &                 YMIN1,YMAX1,YMIN2,YMAX2,
 451      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
 452      &                 THMIN1,THMAX1,THMIN2,THMAX2
 453       INTEGER          ITAG1,ITAG2
 454       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
 455      &                YMIN1,YMAX1,YMIN2,YMAX2,
 456      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
 457      &                THMIN1,THMAX1,THMIN2,THMAX2,
 458      &                ITAG1,ITAG2
 459 C  cut probability distribution
 460       INTEGER IEETA1,IIMAX,KKMAX
 461       PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
 462       INTEGER IEEMAX,IMAX,KMAX
 463       REAL PROB
 464       DOUBLE PRECISION EPTAB
 465       COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
 466      &                IEEMAX,IMAX,KMAX
 467 C  event weights and generated cross section
 468       INTEGER IPOWGC,ISWCUT,IVWGHT
 469       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
 470       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
 471      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
 472 C  names of hard scattering processes
 473       INTEGER Max_pro_1
 474       PARAMETER ( Max_pro_1 = 16 )
 475       CHARACTER*18 PROC
 476       COMMON /POHPRO/ PROC(0:Max_pro_1)
 477 C  hard cross sections and MC selection weights
 478       INTEGER Max_pro_2
 479       PARAMETER ( Max_pro_2 = 16 )
 480       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
 481      &  MH_acc_1,MH_acc_2
 482       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
 483       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
 484      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
 485      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
 486      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
 487      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
 488
 489       INTEGER MSTU,MSTJ
 490       DOUBLE PRECISION PARU,PARJ
 491       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
 492       INTEGER KCHG
 493       DOUBLE PRECISION  PMAS,PARF,VCKM
 494       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
 495       INTEGER MDCY,MDME,KFDP
 496       DOUBLE PRECISION  BRAT
 497       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
 498
 499       INTEGER PYCOMP
 500
 501       DIMENSION ITMP(0:11)
 502       CHARACTER*10 CNAME
 503       CHARACTER*70 NUMBER,FILENA
 504
 505  14   FORMAT(A10,A69)
 506  15   FORMAT(A12)
 507
 508 C  define input/output units
 509       IF(LINP.GE.0) THEN
 510         LI = LINP
 511       ELSE
 512         LI = 5
 513       ENDIF
 514       LO = LOUT
 515
 516       IREJ = 0
 517
 518       WRITE(LO,*)
 519       WRITE(LO,*) ' ==================================================='
 520       WRITE(LO,*) '                                                    '
 521       WRITE(LO,*) '      ----      PHOJET version 1.12      ----      '
 522       WRITE(LO,*) '                                                    '
 523       WRITE(LO,*) ' ==================================================='
 524       WRITE(LO,*) '     Authors: Ralph Engel      (FZ Karlsruhe)'
 525       WRITE(LO,*) '              Johannes Ranft   (Siegen Univ.)'
 526       WRITE(LO,*) '              Stefan Roesler   (CERN)'
 527       WRITE(LO,*) ' ---------------------------------------------------'
 528       WRITE(LO,*) '   Manual, updates, and further information:'
 529       WRITE(LO,*) '    http://www-ik.fzk.de/~engel/phojet.html'
 530       WRITE(LO,*) ' ---------------------------------------------------'
 531       WRITE(LO,*) '    please send suggestions / bug reports etc. to:'
 532       WRITE(LO,*) '             ralph.engel@fzk.de'
 533       WRITE(LO,*) ' ==================================================='
 534       WRITE(LO,*) '   $Date: 2000/06/25 21:59:19 $'
 535       WRITE(LO,*) '   $Revision: 1.12.1.35 $'
 536       WRITE(LO,*) '   (code version with interface to PYTHIA 6.x)'
 537       WRITE(LO,*) '   (code version for usage in DPMJET 3.x)'
 538       WRITE(LO,*) ' ==================================================='
 539       WRITE(LO,*)
 540
 541 C  standard initializations
 542       CALL PHO_DATINI
 543       CALL PHO_PARDAT
 544       DUM = PHO_PMASS(0,-1)
 545
 546 C  initialize standard PDFs
 547 C  proton
 548       CALL PHO_SETPDF(2212,IDUM,5,6,0,0,-1)
 549       CALL PHO_SETPDF(-2212,IDUM,5,6,0,0,-1)
 550 C  neutron
 551       CALL PHO_SETPDF(2112,IDUM,5,6,0,0,-1)
 552       CALL PHO_SETPDF(-2112,IDUM,5,6,0,0,-1)
 553 C  photon
 554       CALL PHO_SETPDF(22,IDUM,5,3,0,0,-1)
 555 C  pomeron
 556       CALL PHO_SETPDF(990,IDUM,4,0,0,0,-1)
 557 C  pions
 558       CALL PHO_SETPDF(211,IDUM,5,2,0,0,-1)
 559       CALL PHO_SETPDF(-211,IDUM,5,2,0,0,-1)
 560       CALL PHO_SETPDF(111,IDUM,5,2,0,0,-1)
 561 C  kaons
 562       CALL PHO_SETPDF(321,IDUM,5,2,0,0,-1)
 563       CALL PHO_SETPDF(-321,IDUM,5,2,0,0,-1)
 564       CALL PHO_SETPDF(130,IDUM,5,2,0,0,-1)
 565       CALL PHO_SETPDF(310,IDUM,5,2,0,0,-1)
 566
 567 C  nothing to be done
 568       IF(LINP.LT.0) RETURN
 569
 570 C  main loop to read input cards
 571  1200 CONTINUE
 572         READ(LINP,14,END=1300) CNAME,NUMBER
 573         IF(CNAME.EQ.'ENDINPUT  ') THEN
 574           GOTO 1300
 575         ELSE IF(CNAME.EQ.'STOP      ') THEN
 576           WRITE(LO,*) 'STOP'
 577           STOP
 578         ELSE IF(CNAME.EQ.'COMMENT   ') THEN
 579           WRITE(LO,'(1X,A10,A69)') 'COMMENT   ',NUMBER
 580         ELSE IF(CNAME(1:1).EQ.'*') THEN
 581           WRITE(LO,'(1X,A10,A69)') CNAME,NUMBER
 582         ELSE IF(CNAME.EQ.'PTCUT     ') THEN
 583           READ(NUMBER,*) PARMDL(36),PARMDL(37),PARMDL(38),PARMDL(39)
 584           WRITE(LO,*) 'PTCUT     ',PARMDL(36),PARMDL(37),
 585      &      PARMDL(38),PARMDL(39)
 586         ELSE IF(CNAME.EQ.'PROCESS   ') THEN
 587           READ(NUMBER,*) (IPRON(KK,1),KK=1,8)
 588           WRITE(LO,*) 'PROCESS   ',(IPRON(KK,1),KK=1,8)
 589         ELSE IF(CNAME.EQ.'DIFF-PROC ') THEN
 590           READ(NUMBER,*) (ITMP(KK),KK=0,11)
 591           WRITE(LO,*) 'DIFF-PROC ',(ITMP(KK),KK=0,8)
 592           DO 112 KK=1,8
 593             IPRON(KK,ITMP(0)) = ITMP(KK)
 594  112      CONTINUE
 595         ELSE IF(CNAME.EQ.'SUBPROCESS') THEN
 596           READ(NUMBER,*) IMPRO,IP,ION
 597           WRITE(LO,*) 'SUBPROCESS',IMPRO,IP,ION
 598           MH_pro_on(IMPRO,IP) = ION
 599         ELSE IF(CNAME.EQ.'PARTICLE1 ') THEN
 600           READ(NUMBER,*) IDPDG,PVIR
 601           IHFLS(1) = 1
 602           XPSUB = 1.D0
 603           CALL PHO_SETPAR(1,IDPDG,0,PVIR)
 604           WRITE(LO,*) 'PARTICLE1  ',IDPDG,PVIR
 605         ELSE IF(CNAME.EQ.'PARTICLE2 ') THEN
 606           READ(NUMBER,*) IDPDG,PVIR
 607           IHFLS(2) = 1
 608           XTSUB = 1.D0
 609           CALL PHO_SETPAR(2,IDPDG,0,PVIR)
 610           WRITE(LO,*) 'PARTICLE2  ',IDPDG,PVIR
 611         ELSE IF(CNAME.EQ.'REMNANT1  ') THEN
 612           READ(NUMBER,*) IDPDG,IFL1,IFL2,IVAL,XSUB
 613           IHFLS(1) = IVAL
 614           IHFLD(1,1) = IFL1
 615           IHFLD(1,2) = IFL2
 616           XPSUB = XSUB
 617           PVIR = 0.D0
 618           CALL PHO_SETPAR(1,IDPDG,-1,PVIR)
 619           WRITE(LO,*) 'REMNANT1   ',IDPDG,IFL1,IFL2,IVAL,XSUB
 620         ELSE IF(CNAME.EQ.'REMNANT2  ') THEN
 621           READ(NUMBER,*) IDPDG,IFL1,IFL2,IVAL,XSUB
 622           IHFLS(2) = IVAL
 623           IHFLD(2,1) = IFL1
 624           IHFLD(2,2) = IFL2
 625           XTSUB = XSUB
 626           PVIR = 0.D0
 627           CALL PHO_SETPAR(2,IDPDG,-1,PVIR)
 628           WRITE(LO,*) 'REMNANT2   ',IDPDG,IFL1,IFL2,IVAL,XSUB
 629         ELSE IF(CNAME.EQ.'PDF       ') THEN
 630           READ(NUMBER,*) IDPDG,IPAR,ISET,IEXT
 631           WRITE(LO,*) 'PDF        ',IDPDG,IPAR,ISET,IEXT
 632           CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,IEXT,0,-1)
 633         ELSE IF(CNAME.EQ.'SETMODEL  ') THEN
 634           READ(NUMBER,*) I,IVAL
 635           WRITE(LO,*) 'SETMODEL   ',I,IVAL
 636           CALL PHO_SETMDL(I,IVAL,1)
 637         ELSE IF(CNAME.EQ.'SETPARAM  ') THEN
 638           READ(NUMBER,*) I,PARNEW
 639           WRITE(LO,*) 'SETPARAM   ',I,PARNEW
 640           PARMDL(I) = PARNEW
 641         ELSE IF(CNAME.EQ.'DEBUG     ') THEN
 642           READ(NUMBER,*) IDEBF,IDEBN,IDLEV
 643           WRITE(LO,*) 'DEBUG      ',IDEBF,IDEBN,IDLEV
 644           CALL PHO_TRACE(IDEBF,IDEBN,IDLEV)
 645         ELSE IF(CNAME.EQ.'TRACE     ') THEN
 646           READ(NUMBER,*) IDEBF,IDLEV
 647           WRITE(LO,*) 'TRACE      ',IDEBF,IDLEV
 648           IDEB(IDEBF) = IDLEV
 649         ELSE IF(CNAME.EQ.'SETICUT   ') THEN
 650           READ(NUMBER,*) I,ICUT
 651           WRITE(LO,*) 'SETICUT    ',I,ICUT
 652           ISWCUT(I) = ICUT
 653         ELSE IF(CNAME.EQ.'SETFCUT   ') THEN
 654           READ(NUMBER,*) I,PARNEW
 655           WRITE(LO,*) 'SETFCUT    ',I,PARNEW
 656           HSWCUT(I) = PARNEW
 657         ELSE IF(CNAME.EQ.'LUND-MSTU ') THEN
 658           READ(NUMBER,*) I,IVAL
 659           WRITE(LO,*) 'LUND-MSTU  ',I,IVAL
 660           MSTU(I) = IVAL
 661         ELSE IF(CNAME.EQ.'LUND-MSTJ ') THEN
 662           READ(NUMBER,*) I,IVAL
 663           WRITE(LO,*) 'LUND-MSTJ  ',I,IVAL
 664           MSTJ(I) = IVAL
 665         ELSE IF(CNAME.EQ.'LUND-PARJ ') THEN
 666           READ(NUMBER,*) I,EE
 667           WRITE(LO,*) 'LUND-PARJ  ',I,EE
 668           PARJ(I) = REAL(EE)
 669         ELSE IF(CNAME.EQ.'LUND-PARU ') THEN
 670           READ(NUMBER,*) I,EE
 671           WRITE(LO,*) 'LUND-PARU  ',I,EE
 672           PARU(I) = REAL(EE)
 673         ELSE IF(CNAME.EQ.'LUND-DECAY') THEN
 674           READ(NUMBER,*) ID,ION
 675           WRITE(LO,*) 'LUND-DECAY ',ID,ION
 676           KC=PYCOMP(ID)
 677           MDCY(KC,1) = ION
 678         ELSE IF(CNAME.EQ.'PSOFTMIN  ') THEN
 679           READ(NUMBER,*) PSOMIN
 680           WRITE(LO,*) 'PSOFTMIN   ',PSOMIN
 681         ELSE IF(CNAME.EQ.'INTPREC   ') THEN
 682           READ(NUMBER,*) NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
 683           WRITE(LO,*) 'INTPREC    ',NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
 684
 685 C  PDF test utility
 686         ELSE IF(CNAME.EQ.'PDFTEST   ') THEN
 687           READ(NUMBER,*) IDPDG,SCALE2,PVIRT2
 688           PVIRT2 = ABS(PVIRT2)
 689           WRITE(LO,*) 'PDFTEST   ',IDPDG,' ',SCALE2,' ',PVIRT2
 690           CALL PHO_PDFTST(IDPDG,SCALE2,PVIRT2)
 691
 692 C  mass cut on gamma-gamma or gamma-hadron system
 693         ELSE IF(CNAME.EQ.'ECMS-CUT  ') THEN
 694           READ(NUMBER,*) ECMIN,ECMAX
 695           WRITE(LO,*) 'ECMS-CUT  ',ECMIN,ECMAX
 696
 697 C  beam lepton (anti-)tagging system
 698         ELSE IF(CNAME.EQ.'TAG-METHOD') THEN
 699           READ(NUMBER,*) ITAG1,ITAG2
 700           WRITE(LO,*) 'TAG-METHOD',ITAG1,ITAG2
 701         ELSE IF(CNAME.EQ.'E-TAG1    ') THEN
 702           READ(NUMBER,*)
 703      &      EEMIN1,YMIN1,YMAX1,Q2MIN1,Q2MAX1,THMIN1,THMAX1
 704           WRITE(LO,*) 'E-TAG1    ',EEMIN1,YMIN1,YMAX1,
 705      &      Q2MIN1,Q2MAX1,THMIN1,THMAX1
 706         ELSE IF(CNAME.EQ.'E-TAG2    ') THEN
 707           READ(NUMBER,*)
 708      &      EEMIN2,YMIN2,YMAX2,Q2MIN2,Q2MAX2,THMIN2,THMAX2
 709           WRITE(LO,*) 'E-TAG2    ',EEMIN2,YMIN2,YMAX2,
 710      &      Q2MIN2,Q2MAX2,THMIN2,THMAX2
 711
 712 C  sampling of gamma-p events in ep (HERA)
 713         ELSE IF(    (CNAME.EQ.'WW-HERA   ')
 714      &          .OR.(CNAME.EQ.'GP-HERA   ')) THEN
 715           READ(NUMBER,*) EE1,EE2,NEV
 716           WRITE(LO,*) 'GP-HERA   ',EE1,EE2,NEV
 717           IF(YMAX2.LT.0.D0) THEN
 718             WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGER NOT SET'
 719           ELSE
 720             CALL PHO_GPHERA(NEV,EE1,EE2)
 721             KEVENT = 0
 722           ENDIF
 723
 724 C  sampling of gamma-gamma events in e+e- (LEP)
 725         ELSE IF(    (CNAME.EQ.'GG-EPEM   ')
 726      &          .OR.(CNAME.EQ.'WW-EPEM   ')) THEN
 727           READ(NUMBER,*) EE1,EE2,NEV
 728           WRITE(LO,*) 'GG-EPEM   ',EE1,EE2,NEV
 729           IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
 730             WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGERS NOT SET'
 731           ELSE
 732             CALL PHO_GGEPEM(-1,EE1,EE2)
 733             CALL PHO_GGEPEM(NEV,EE1,EE2)
 734             CALL PHO_GGEPEM(-2,sig_tot,sig_gg)
 735             KEVENT = 0
 736           ENDIF
 737
 738 C  sampling of gamma-gamma in heavy-ion collisions
 739         ELSE IF(CNAME.EQ.'GG-HION-F ') THEN
 740           READ(NUMBER,*) EE,NA,NZ,NEV
 741           WRITE(LO,*) 'GG-HION-F ',EE,NA,NZ,NEV
 742           IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
 743             WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
 744           ELSE
 745             CALL PHO_GGHIOF(NEV,EE,NA,NZ)
 746             KEVENT = 0
 747           ENDIF
 748         ELSE IF(CNAME.EQ.'GG-HION-G ') THEN
 749           READ(NUMBER,*) EE,NA,NZ,NEV
 750           WRITE(LO,*) 'GG-HION-G ',EE,NA,NZ,NEV
 751           IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
 752             WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
 753           ELSE
 754             CALL PHO_GGHIOG(NEV,EE,NA,NZ)
 755             KEVENT = 0
 756           ENDIF
 757
 758 C  sampling of gamma-hadron events in heavy ion collisions
 759         ELSE IF(CNAME.EQ.'GH-HION-F ') THEN
 760           READ(NUMBER,*) EE,NA,NZ,NEV
 761           WRITE(LO,*) 'GH-HION-F ',EE,NA,NZ,NEV
 762           IF((YMAX1.LT.0.D0).OR.(YMAX2.LT.0.D0)) THEN
 763             WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
 764           ELSE
 765             CALL PHO_GHHIOF(NEV,EE,NA,NZ)
 766             KEVENT = 0
 767           ENDIF
 768
 769 C  sampling of hadron-gamma events in hadron - heavy ion collisions
 770         ELSE IF(CNAME.EQ.'HG-HIAS-F ') THEN
 771           READ(NUMBER,*) EP,EE,NA,NZ,NEV
 772           WRITE(LO,*) 'HG-HIAS-F ',EP,EE,NA,NZ,NEV
 773           IF(YMAX2.LT.0.D0) THEN
 774             WRITE(LO,*) ' PHO_INIT:ERROR:Y RANGE FOR PHOTONS NOT SET'
 775           ELSE
 776             CALL PHO_GHHIAS(NEV,EP,EE,NA,NZ)
 777             KEVENT = 0
 778           ENDIF
 779
 780 C  sampling of photoproduction events e+e-, backscattered laser
 781         ELSE IF(CNAME.EQ.'BLASER    ') THEN
 782           READ(NUMBER,*) EE1,EE2,Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A,NEV
 783           WRITE(LO,*) 'BLASER    ',EE1,EE2,
 784      &      Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A,NEV
 785           CALL PHO_GGBLSR(NEV,EE1,EE2,Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A)
 786           KEVENT = 0
 787
 788 C  sampling of photoproduction events beamstrahlung
 789         ELSE IF(CNAME.EQ.'BEAMST    ') THEN
 790           READ(NUMBER,*) EE1,YPSI,SIGX,SIGY,SIGZ,AEB,NEV
 791           WRITE(LO,*) 'BEAMST    ',EE1,YPSI,SIGX,SIGY,SIGZ,AEB,NEV
 792           IF(YMAX1.LT.0.D0) THEN
 793             WRITE(LO,*) ' PHO_INIT:ERROR:ELECTRON TAGGER 1 NOT SET'
 794           ELSE
 795             CALL PHO_GGBEAM(NEV,EE1,YPSI,SIGX,SIGY,SIGZ,AEB)
 796             KEVENT = 0
 797           ENDIF
 798
 799 C  fixed-energy events in LAB system of particle 2
 800         ELSE IF(CNAME.EQ.'EVENT-LAB ') THEN
 801           READ(NUMBER,*) PLAB,NEV
 802           WRITE(LO,*) 'EVENT-LAB ',PLAB,NEV
 803           CALL PHO_FIXLAB(PLAB,NEV)
 804           KEVENT = 0
 805
 806 C  fixed-energy events in CM system
 807         ELSE IF(CNAME.EQ.'EVENT-CMS ') THEN
 808           READ(NUMBER,*) ECM,NEV
 809           WRITE(LO,*) 'EVENT-CMS ',ECM,NEV
 810           PMASS1 = PHO_PMASS(IFPAB(1),0)-SQRT(PVIRT(1))
 811           PMASS2 = PHO_PMASS(IFPAB(2),0)-SQRT(PVIRT(2))
 812           CALL PHO_PECMS(1,PMASS1,PMASS2,ECM,PCM,EE)
 813           E1 = EE
 814           E2 = ECM-EE
 815           THETA = 0.D0
 816           PHI   = 0.D0
 817           CALL PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
 818           KEVENT = 0
 819
 820 C  fixed-energy events for collider setup with crossing angle
 821         ELSE IF(CNAME.EQ.'EVENT-COLL') THEN
 822           READ(NUMBER,*) E1,E2,THETA,PHI,NEV
 823           WRITE(LO,*) 'EVENT-COLL',E1,E2,THETA,PHI,NEV
 824           CALL PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
 825           KEVENT = 0
 826
 827 C  unknown data card
 828         ELSE
 829           WRITE(LO,*) 'PHO_INIT: unknown data card: ',CNAME,NUMBER
 830         ENDIF
 831
 832       GOTO 1200
 833  1300 CONTINUE
 834       WRITE(LO,*) ' RETURN'
 835
 836       END
 837
 838 *$ CREATE PHO_SETMDL.FOR
 839 *COPY PHO_SETMDL
 840 CDECK  ID>, PHO_SETMDL
 841       SUBROUTINE PHO_SETMDL(INDX,IVAL,IMODE)
 842 C**********************************************************************
 843 C
 844 C     set model switches
 845 C
 846 C     input:  INDX       model parameter number
 847 C                        (positive: ISWMDL, negative: IPAMDL)
 848 C             IVAL       new value
 849 C             IMODE      -1  print value of parameter INDX
 850 C                        1   set new value
 851 C                        -2  print current settings
 852 C
 853 C**********************************************************************
 854       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
 855       SAVE
 856
 857 C  input/output channels
 858       INTEGER LI,LO
 859       COMMON /POINOU/ LI,LO
 860 C  model switches and parameters
 861       CHARACTER*8 MDLNA
 862       INTEGER ISWMDL,IPAMDL
 863       DOUBLE PRECISION PARMDL
 864       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
 865
 866       IF(IMODE.EQ.-2) THEN
 867         WRITE(LO,'(/1X,A,/1X,A,/)') 'PHO_SETMDL: current settings',
 868      &                             '----------------------------'
 869         DO 100 I=1,48,3
 870           IF(ISWMDL(I).EQ.-9999) GOTO 200
 871           IF(ISWMDL(I+1).EQ.-9999) THEN
 872             WRITE(LO,'(5X,I3,A1,A,I6)') I,':',MDLNA(I),ISWMDL(I)
 873             GOTO 200
 874           ELSE IF(ISWMDL(I+2).EQ.-9999) THEN
 875             WRITE(LO,'(2(5X,I3,A1,A,I6))') I,':',MDLNA(I),ISWMDL(I),
 876      &        I+1,':',MDLNA(I+1),ISWMDL(I+1)
 877             GOTO 200
 878           ELSE
 879             WRITE(LO,'(3(5X,I3,A1,A,I6))')
 880      &        (I+K,':',MDLNA(I+K),ISWMDL(I+K),K=0,2)
 881           ENDIF
 882  100    CONTINUE
 883  200    CONTINUE
 884       ELSE IF(IMODE.EQ.-1) THEN
 885         WRITE(LO,'(1X,A,1X,A,I6)')
 886      &    'PHO_SETMDL:',MDLNA(INDX),ISWMDL(INDX)
 887       ELSE IF(IMODE.EQ.1) THEN
 888         IF(INDX.GT.0) THEN
 889           IF(ISWMDL(INDX).NE.IVAL) THEN
 890             WRITE(LO,'(1X,A,I4,1X,A,2I6)')
 891      &        'PHO_SETMDL:ISWMDL(OLD/NEW):',
 892      &        INDX,MDLNA(INDX),ISWMDL(INDX),IVAL
 893             ISWMDL(INDX) = IVAL
 894           ENDIF
 895         ELSE IF(INDX.LT.0) THEN
 896           IF(IPAMDL(-INDX).NE.IVAL) THEN
 897             WRITE(LO,'(1X,A,I4,1X,2I6)') 'PHO_SETMDL:IPAMDL(OLD/NEW):',
 898      &        -INDX,IPAMDL(-INDX),IVAL
 899             IPAMDL(-INDX) = IVAL
 900           ENDIF
 901         ENDIF
 902       ELSE
 903         WRITE(LO,'(/1X,A,I6)')
 904      &    'PHO_SETMDL:ERROR: unsupported mode',IMODE
 905       ENDIF
 906       END
 907
 908 *$ CREATE PHO_DATINI.FOR
 909 *COPY PHO_DATINI
 910 CDECK  ID>, PHO_DATINI
 911       SUBROUTINE PHO_DATINI
 912 C*********************************************************************
 913 C
 914 C     initialization of variables and switches
 915 C
 916 C*********************************************************************
 917       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
 918       SAVE
 919
 920 C  input/output channels
 921       INTEGER LI,LO
 922       COMMON /POINOU/ LI,LO
 923 C  some constants
 924       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
 925       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
 926      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
 927 C  event debugging information
 928       INTEGER NMAXD
 929       PARAMETER (NMAXD=100)
 930       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
 931      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
 932       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
 933      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
 934 C  event weights and generated cross section
 935       INTEGER IPOWGC,ISWCUT,IVWGHT
 936       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
 937       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
 938      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
 939 C  scale parameters for parton model calculations
 940       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
 941       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
 942       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
 943      &                NQQAL,NQQALI,NQQALF,NQQPD
 944 C  integration precision for hard cross sections (obsolete)
 945       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
 946       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
 947 C  hard scattering parameters used for most recent hard interaction
 948       INTEGER NFbeta,NF
 949       DOUBLE PRECISION ALQCD2,BQCD
 950       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
 951 C  cut probability distribution
 952       INTEGER IEETA1,IIMAX,KKMAX
 953       PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
 954       INTEGER IEEMAX,IMAX,KMAX
 955       REAL PROB
 956       DOUBLE PRECISION EPTAB
 957       COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
 958      &                IEEMAX,IMAX,KMAX
 959 C  gamma-lepton or gamma-hadron vertex information
 960       INTEGER IGHEL,IDPSRC,IDBSRC
 961       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
 962      &                 RADSRC,AMSRC,GAMSRC
 963       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
 964      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
 965      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
 966 C  photon flux kinematics and cuts
 967       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
 968      &                 YMIN1,YMAX1,YMIN2,YMAX2,
 969      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
 970      &                 THMIN1,THMAX1,THMIN2,THMAX2
 971       INTEGER          ITAG1,ITAG2
 972       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
 973      &                YMIN1,YMAX1,YMIN2,YMAX2,
 974      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
 975      &                THMIN1,THMAX1,THMIN2,THMAX2,
 976      &                ITAG1,ITAG2
 977 C  obsolete cut-off information
 978       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
 979       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
 980 C  global event kinematics and particle IDs
 981       INTEGER IFPAP,IFPAB
 982       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
 983       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
 984 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
 985       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
 986       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
 987       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
 988      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
 989 C  some hadron information, will be deleted in future versions
 990       INTEGER NFS
 991       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
 992       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
 993 C  model switches and parameters
 994       CHARACTER*8 MDLNA
 995       INTEGER ISWMDL,IPAMDL
 996       DOUBLE PRECISION PARMDL
 997       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
 998 C  general process information
 999       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
1000       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
1001 C  parameters of the "simple" Vector Dominance Model
1002       DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
1003       COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
1004 C  parameters for DGLAP backward evolution in ISR
1005       INTEGER NFSISR
1006       DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
1007       COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
1008 C  particles created by initial state evolution
1009       INTEGER MXISR1,MXISR2
1010       PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
1011       INTEGER IFLISR,IPOISR,IMXISR
1012       DOUBLE PRECISION PHISR
1013       COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
1014      &                IPOISR(2,2,MXISR2),IMXISR(2)
1015 C  names of hard scattering processes
1016       INTEGER Max_pro_1
1017       PARAMETER ( Max_pro_1 = 16 )
1018       CHARACTER*18 PROC
1019       COMMON /POHPRO/ PROC(0:Max_pro_1)
1020 C  hard cross sections and MC selection weights
1021       INTEGER Max_pro_2
1022       PARAMETER ( Max_pro_2 = 16 )
1023       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
1024      &  MH_acc_1,MH_acc_2
1025       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
1026       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
1027      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
1028      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
1029      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
1030      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
1031 C  interpolation tables for hard cross section and MC selection weights
1032       INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
1033       PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
1034       INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
1035       DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
1036      &  HQ2a_tab,HQ2b_tab,HEcm_tab
1037       COMMON /POHTAB/
1038      &  Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1039      &  HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1040      &  HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1041      &  Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
1042      &  HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
1043      &  HEcm_tab(1:Max_tab_E,0:4),
1044      &  IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
1045
1046 C  initialize /POCONS/
1047       PI   = ATAN(1.D0)*4.D0
1048       PI2  = 2.D0*PI
1049       PI4  = 2.D0*PI2
1050 C  GeV**-2 --> millibarn (multiply by GEV2MB to get mb as units)
1051       GEV2MB = 0.389365D0
1052 C  precalculate quark charges
1053       do i=1,6
1054         Q_ch(i) = dble(2-3*mod(i,2))/3.D0
1055         Q_ch(-i) = -Q_ch(i)
1056
1057         Q_ch2(i) = Q_ch(i)**2
1058         Q_ch2(-i) = Q_ch2(i)
1059
1060         Q_ch4(i) = Q_ch2(i)**2
1061         Q_ch4(-i) = Q_ch4(i)
1062       enddo
1063       Q_ch(0)  = 0.D0
1064       Q_ch2(0) = 0.D0
1065       Q_ch4(0) = 0.D0
1066
1067 C  initialize /GLOCMS/
1068       ECM    = 50.D0
1069       PMASS(1) = 0.D0
1070       PVIRT(1) = 0.D0
1071       PMASS(2) = 0.D0
1072       PVIRT(2) = 0.D0
1073       IFPAP(1) = 22
1074       IFPAP(2) = 22
1075 C  initialize /HADVAL/
1076       IHFLD(1,1) = 0
1077       IHFLD(1,2) = 0
1078       IHFLD(2,1) = 0
1079       IHFLD(2,2) = 0
1080       IHFLS(1) = 1
1081       IHFLS(2) = 1
1082 C  initialize /MODELS/
1083       ISWMDL(1)  = 3
1084       MDLNA(1)  = 'AMPL MOD'
1085       ISWMDL(2)  = 1
1086       MDLNA(2)  = 'MIN-BIAS'
1087       ISWMDL(3)  = 1
1088       MDLNA(3)  = 'PTS DISH'
1089       ISWMDL(4)  = 1
1090       MDLNA(4)  = 'PTS DISP'
1091       ISWMDL(5)  = 2
1092       MDLNA(5)  = 'PTS ASSI'
1093       ISWMDL(6)  = 3
1094       MDLNA(6)  = 'HADRONIZ'
1095       ISWMDL(7)  = 2
1096       MDLNA(7)  = 'MASS COR'
1097       ISWMDL(8)  = 3
1098       MDLNA(8)  = 'PAR SHOW'
1099       ISWMDL(9)  = 0
1100       MDLNA(9)  = 'GLU SPLI'
1101       ISWMDL(10) = 2
1102       MDLNA(10) = 'VIRT PHO'
1103       ISWMDL(11) = 0
1104       MDLNA(11) = 'LARGE NC'
1105       ISWMDL(12) = 0
1106       MDLNA(12) = 'LIPA POM'
1107       ISWMDL(13) = 1
1108       MDLNA(13) = 'QELAS VM'
1109       ISWMDL(14) = 2
1110       MDLNA(14) = 'ENHA GRA'
1111       ISWMDL(15) = 4
1112       MDLNA(15) = 'MULT SCA'
1113       ISWMDL(16) = 4
1114       MDLNA(16) = 'MULT DIF'
1115       ISWMDL(17) = 4
1116       MDLNA(17) = 'MULT CDF'
1117       ISWMDL(18) = 0
1118       MDLNA(18) = 'BALAN PT'
1119       ISWMDL(19) = 1
1120       MDLNA(19) = 'POMV FLA'
1121       ISWMDL(20) = 0
1122       MDLNA(20) = 'SEA  FLA'
1123       ISWMDL(21) = 2
1124       MDLNA(21) = 'SPIN DEC'
1125       ISWMDL(22) = 1
1126       MDLNA(22) = 'DIF.MASS'
1127       ISWMDL(23) = 1
1128       MDLNA(23) = 'DIFF RES'
1129       ISWMDL(24) = 0
1130       MDLNA(24) = 'PTS HPOM'
1131       ISWMDL(25) = 0
1132       MDLNA(25) = 'POM CORR'
1133       ISWMDL(26) = 1
1134       MDLNA(26) = 'OVERLAP '
1135       ISWMDL(27) = 0
1136       MDLNA(27) = 'MUL R/AN'
1137       ISWMDL(28) = 1
1138       MDLNA(28) = 'SUR PROB'
1139       ISWMDL(29) = 1
1140       MDLNA(29) = 'PRIMO KT'
1141       ISWMDL(30) = 0
1142       MDLNA(30) = 'DIFF. CS'
1143       ISWMDL(31) = -9999
1144 C  mass-independent sea flavour ratios (for low-mass strings)
1145       PARMDL(1)  = 0.425D0
1146       PARMDL(2)  = 0.425D0
1147       PARMDL(3)  = 0.15D0
1148       PARMDL(4)  = 0.D0
1149       PARMDL(5)  = 0.D0
1150       PARMDL(6)  = 0.D0
1151 C  suppression by energy momentum conservation
1152       PARMDL(8)  = 9.D0
1153       PARMDL(9)  = 7.D0
1154 C  VDM factors
1155       PARMDL(10) = 0.866D0
1156       PARMDL(11) = 0.288D0
1157       PARMDL(12) = 0.288D0
1158       PARMDL(13) = 0.288D0
1159       PARMDL(14) = 0.866D0
1160       PARMDL(15) = 0.288D0
1161       PARMDL(16) = 0.288D0
1162       PARMDL(17) = 0.288D0
1163       PARMDL(18) = 0.D0
1164 C  lower energy limit for initialization
1165       PARMDL(19) = 5.D0
1166 C  soft pt for hard scattering remnants
1167       PARMDL(20) = 5.D0
1168 C  low energy beta of soft pt distribution 1
1169       PARMDL(21) = 4.5D0
1170 C  high energy beta of soft pt distribution 1
1171       PARMDL(22) = 3.0D0
1172 C  low energy beta of soft pt distribution 0
1173       PARMDL(23) = 2.5D0
1174 C  high energy beta of soft pt distribution 0
1175       PARMDL(24) = 0.4D0
1176 C  effective quark mass in photon wave function
1177       PARMDL(25) = 0.2D0
1178 C  normalization of unevolved Pomeron PDFs
1179       PARMDL(26) = 0.3D0
1180 C  effective VDM parameters for Q**2 dependence of cross section
1181       PARMDL(27) = 0.65D0
1182       PARMDL(28) = 0.08D0
1183       PARMDL(29) = 0.05D0
1184       PARMDL(30) = 0.22D0
1185       PARMDL(31) = 0.589824D0
1186       PARMDL(32) = 0.609961D0
1187       PARMDL(33) = 1.038361D0
1188       PARMDL(34) = 1.96D0
1189 C  Q**2 suppression of multiple interactions
1190       PARMDL(35) = 0.59D0
1191 C  pt cutoff defaults
1192       PARMDL(36) = 2.5D0
1193       PARMDL(37) = 2.5D0
1194       PARMDL(38) = 2.5D0
1195       PARMDL(39) = 2.5D0
1196 C  enhancement factor for diffractive cross sections
1197       PARMDL(40) = 1.D0
1198       PARMDL(41) = 1.D0
1199       PARMDL(42) = 1.D0
1200 C  mass in soft pt distribution
1201       PARMDL(43) = 0.D0
1202 C  maximum of x allowed for leading particle
1203       PARMDL(44) = 0.9D0
1204 C  max. mass sampled in diffraction
1205       PARMDL(45) = sqrt(0.4D0)
1206 C  mass threshold in diffraction (2pi mass)
1207       PARMDL(46) = 0.3D0
1208 C  regularization of slope parameter in diffraction
1209       PARMDL(47) = 4.D0
1210 C  renormalized intercept for enhanced graphs
1211       PARMDL(48) = 1.08D0
1212 C  coherence constraint for diff. cross sections
1213       PARMDL(49) = sqrt(0.05D0)
1214 C  exponents of x distributions
1215 C  baryon
1216       PARMDL(50) = 1.5D0
1217       PARMDL(51) = -0.5D0
1218       PARMDL(52) = -0.99D0
1219       PARMDL(53) = -0.99D0
1220 C  meson (non-strangeness part)
1221       PARMDL(54) = -0.5D0
1222       PARMDL(55) = -0.5D0
1223       PARMDL(56) = -0.99D0
1224       PARMDL(57) = -0.99D0
1225 C  meson (strangeness part)
1226       PARMDL(58) = -0.2D0
1227       PARMDL(59) = -0.2D0
1228       PARMDL(60) = -0.99D0
1229       PARMDL(61) = -0.99D0
1230 C  particle remnant (no valence quarks)
1231       PARMDL(62) = -0.5D0
1232       PARMDL(63) = -0.5D0
1233       PARMDL(64) = -0.99D0
1234       PARMDL(65) = -0.99D0
1235 C  ratio beetween triple-pomeron/reggeon couplings grrp/gppp
1236       PARMDL(66) = 10.D0
1237 C  ratio beetween triple-pomeron/reggeon couplings gppr/gppp
1238       PARMDL(67) = 10.D0
1239 C  min. abs(t) in diffraction
1240       PARMDL(68) = 0.D0
1241 C  max. abs(t) in diffraction
1242       PARMDL(69) = 10.D0
1243 C  min. mass for elastic pomerons in central diffraction
1244       PARMDL(70) = 2.D0
1245 C  min. mass of diffractive blob in central diffraction
1246       PARMDL(71) = 2.D0
1247 C  min. Feynman x cut in central diffraction
1248       PARMDL(72) = 0.D0
1249 C  direct pomeron coupling
1250       PARMDL(74) = 0.D0
1251 C  relative deviation allowed for energy-momentum conservation
1252 C  energy-momentum relative deviation
1253       PARMDL(75) = 0.01D0
1254 C  transverse momentum deviation
1255       PARMDL(76) = 0.01D0
1256 C  couplings for unitarization in diffraction
1257 C  non-unitarized pomeron coupling (sqrt(mb))
1258       PARMDL(77)  = 3.D0
1259 C  rescaling factor for pomeron PDF
1260       PARMDL(78)  = 3.D0
1261 C  coupling probabilities
1262       PARMDL(79)  = 1.D0
1263       PARMDL(80)  = 0.D0
1264 C  scales to calculate alpha-s of matrix element
1265       PARMDL(81) = 1.D0
1266       PARMDL(82) = 1.D0
1267       PARMDL(83) = 1.D0
1268 C  scales to calculate alpha-s of initial state radiation
1269       PARMDL(84) = 1.D0
1270       PARMDL(85) = 1.D0
1271       PARMDL(86) = 1.D0
1272 C  scales to calculate alpha-s of final state radiation
1273       PARMDL(87) = 1.D0
1274       PARMDL(88) = 1.D0
1275       PARMDL(89) = 1.D0
1276 C  scales to calculate PDFs
1277       PARMDL(90) = 1.D0
1278       PARMDL(91) = 1.D0
1279       PARMDL(92) = 1.D0
1280 C  scale for ISR starting virtuality
1281       PARMDL(93) = 1.D0
1282 C  min. virtuality to generate time-like showers in ISR
1283       PARMDL(94) = 2.D0
1284 C  factor to scale the max. allowed time-like parton shower virtuality
1285       PARMDL(95) = 4.D0
1286 C  max. transverse momentum for primordial kt
1287       PARMDL(100) = 2.D0
1288 C  weight factors for pt-distribution
1289       PARMDL(101) = 2.D0
1290       PARMDL(102) = 2.D0
1291       PARMDL(103) = 4.D0
1292       PARMDL(104) = 2.D0
1293       PARMDL(105) = 6.D0
1294       PARMDL(106) = 4.D0
1295 C
1296 *     PARMDL(110-125)  reserved for hard scattering
1297 C  currently chosen scales for hard scattering
1298       DO 10 I=1,16
1299         PARMDL(109+I) = 0.D0
1300  10   CONTINUE
1301 C  virtuality cutoff in initial state evolution
1302       PARMDL(126) = PARMDL(36)**2
1303       PARMDL(127) = PARMDL(37)**2
1304       PARMDL(128) = PARMDL(38)**2
1305       PARMDL(129) = PARMDL(39)**2
1306 C  virtuality cutoff for direct contribution to photon PDF
1307       PARMDL(130) = 1.D30
1308       PARMDL(131) = 1.D30
1309       PARMDL(132) = 1.D30
1310       PARMDL(133) = 1.D30
1311 C  fraction of events without popcorn
1312       PARMDL(134) = -1.D0
1313 C  fraction of diquarks with spin 1 (relative to sum of spin 1 and 0)
1314       PARMDL(135) = 0.5D0
1315 C  soft color re-connection (fraction)
1316 C  g g final state
1317       PARMDL(140) = 1.D0/64.D0
1318 C  g q final state
1319       PARMDL(141) = 1.D0/24.D0
1320 C  q q final state
1321       PARMDL(142) = 1.D0/9.D0
1322 C  effective scale in Drees-Godbole like suppresion in photon PDF
1323       PARMDL(144) = 0.766D0**2
1324 C  QCD scales (if PDF scales are not used, 4 active flavours)
1325       PARMDL(145) = 0.2D0**2
1326       PARMDL(146) = 0.2D0**2
1327       PARMDL(147) = 0.2D0**2
1328 C  threshold scales for variable flavour calculation (GeV**2)
1329       PARMDL(148) = 1.5D0**2
1330       PARMDL(149) = 4.5D0**2
1331       PARMDL(150) = 175.D0**2
1332 C  constituent quark masses
1333       PARMDL(151) = 0.3D0
1334       PARMDL(152) = 0.3D0
1335       PARMDL(153) = 0.5D0
1336       PARMDL(154) = 1.6D0
1337       PARMDL(155) = 5.D0
1338       PARMDL(156) = 174.D0
1339 C  min. masses of valence quark
1340       PARMDL(157) = 0.3D0
1341 C  min. masses of valence diquark
1342       PARMDL(158) = 0.8D0
1343 C  min. mass of sea quark
1344       PARMDL(159) = 0.D0
1345 C  suppression of strange quarks as photon valences
1346       PARMDL(160) = 0.2D0
1347 C  min. masses for strings (used in PHO_SOFTXX)
1348       PARMDL(161) = 1.D0
1349       PARMDL(162) = 1.D0
1350       PARMDL(163) = 1.D0
1351       PARMDL(164) = 1.D0
1352 C  min. momentum fraction for soft processes
1353       PARMDL(165) = 0.3D0
1354 C  min. phase space for x-sampling
1355       PARMDL(166) = 0.135D0
1356 C  Ross-Stodolsky exponent
1357       PARMDL(170) = 4.2D0
1358 C  cutoff on photon-pomeron invariant mass in hadron-hadron collisions
1359       PARMDL(175) = 2.D0
1360 **sr
1361 *  extra factor multiplying difference between Goulianos and PHOJET-
1362 *  diff. cross sections
1363       PARMDL(200) = 0.6D0
1364 **
1365 C  complex amplitudes, eikonal functions
1366       IPAMDL(1)  = 0
1367 C  allow for Reggeon cuts
1368       IPAMDL(2)  = 1
1369 C  decay of hadron resonances in diffraction (0 iso, 1 trans, 2 long)
1370       IPAMDL(3)  = 0
1371 C  polarization of photon resonances (0 none, 1 trans, 2 long)
1372       IPAMDL(4)  = 1
1373 C  pt of valence partons
1374       IPAMDL(5)  = 1
1375 C  pt of hard scattering remnant
1376       IPAMDL(6)  = 2
1377 C  running cutoff for hard scattering
1378       IPAMDL(7)  = 1
1379 C  intercept used for the calculation of enhanced graphs
1380       IPAMDL(8)  = 1
1381 C  effective slope of hard scattering amplitde
1382       IPAMDL(9)  = 1
1383 C  mass dependence of slope parameters
1384       IPAMDL(10) = 0
1385 C  lepton-photon vertex 1
1386       IPAMDL(11) = 0
1387 C  lepton-photon vertex 2
1388       IPAMDL(12) = 0
1389 C  call by DPMJET
1390       IPAMDL(13) = 0
1391 C  method to sample x distributions
1392       IPAMDL(14) = 3
1393 C  energy-momentum check
1394       IPAMDL(15) = 1
1395 C  phase space correction for DPMJET interface
1396       IPAMDL(16) = 1
1397 C  fragment strings from projectile/target/central diff. separately
1398       IPAMDL(17) = 1
1399 C  method to construct strings for hard interactions
1400       IPAMDL(18) = 1
1401 C  method to construct strings for soft sea (pomeron cuts)
1402       IPAMDL(19) = 0
1403 C  method to construct strings in pomeron interactions
1404       IPAMDL(20) = 0
1405 C  soft color re-connection
1406       IPAMDL(21) = 0
1407 C  resummation of triple- and loop-Pomeron
1408       IPAMDL(24) = 1
1409 C  resummation of X iterated triple-Pomeron
1410       IPAMDL(25) = 1
1411 C  dimension of interpolation table for weights in hard scattering
1412       IPAMDL(30) = Max_tab_E
1413 C  dimension of interpolation table for pomeron cut distribution
1414       IPAMDL(31) = IEETA1
1415 C  number of cut soft pomerons (restriction by field dimension)
1416       IPAMDL(32) = IIMAX
1417 C  number of cut hard pomerons (restriction by field dimension)
1418       IPAMDL(33) = KKMAX
1419 C  tau pair production in direct photon-photon collisions
1420       IPAMDL(64) = 0
1421 C  currently chosen scales for hard scattering
1422 C  ATTENTION:   IPAMDL(65-80)  reserved for hard scattering!
1423       DO 15 I=1,16
1424         IPAMDL(64+I) = -99999
1425  15   CONTINUE
1426 C  scales to calculate alpha-s of matrix element
1427       IPAMDL(81) = 1
1428       IPAMDL(82) = 1
1429       IPAMDL(83) = 1
1430 C  scales to calculate alpha-s of initial state radiation
1431       IPAMDL(84) = 1
1432       IPAMDL(85) = 1
1433       IPAMDL(86) = 1
1434 C  scales to calculate alpha-s of final state radiation
1435       IPAMDL(87) = 1
1436       IPAMDL(88) = 1
1437       IPAMDL(89) = 1
1438 C  scales to calculate PDFs
1439       IPAMDL(90) = 1
1440       IPAMDL(91) = 1
1441       IPAMDL(92) = 1
1442 C  where to get the parameter sets from
1443       IPAMDL(99) = 1
1444 C  program PHO_ABORT for fatal errors (simulation of division by zero)
1445       IPAMDL(100) = 0
1446 C  initial state parton showers for all / hardest interaction(s)
1447       IPAMDL(101) = 1
1448 C  final state parton showers for all / hardest interaction(s)
1449       IPAMDL(102) = 1
1450 C  initial virtuality for ISR generation
1451       IPAMDL(109) = 1
1452 C  qqbar-gamma coupling in initial state showers
1453       IPAMDL(110) = 1
1454 C  generation of time-like showers during ISR
1455       IPAMDL(111) = 1
1456 C  reweighting of multiple soft contributions for virtual photons
1457       IPAMDL(114) = 1
1458 C  reweighting / use photon virtuality in photon PDF calculations
1459       IPAMDL(115) = 0
1460 C  use full QPM model incl. interference terms (direct part in gam-gam)
1461       IPAMDL(116) = 0
1462 C  matching sigma_tot to F2 as given by parton density at high Q2
1463       IPAMDL(117) = 1
1464 C  use virtuality of target in F2 calculations (two-gamma only)
1465       IPAMDL(118) = 1
1466 C  calculation of alpha_em
1467       IPAMDL(120) = 1
1468 C  strict pt cutoff for gamma-gamma events
1469       IPAMDL(121) = 0
1470 C  photon virtuality sampled in photon flux approximations
1471       IPAMDL(174) = 1
1472 C  photon-pomeron: 0,1,2: both,left,right photon emission
1473       IPAMDL(175) = 0
1474 C  keep full history information in PHOJET-JETSET interface
1475       IPAMDL(178) = 1
1476 C  max. number of conservation law violations allowed in one run
1477       IPAMDL(179) = 20
1478 C  selection of soft X values
1479 C  max. iteration number in PHO_SELSXS
1480       IPAMDL(180) = 50
1481 C  max. iteration number in PHO_SELSXR
1482       IPAMDL(181) = 200
1483 C  max. iteration number in PHO_SELSX2
1484       IPAMDL(182) = 100
1485 C  max. iteration number in PHO_SELSXI
1486       IPAMDL(183) = 50
1487
1488 C  initialize /PROBAB/
1489       IEEMAX = IEETA1
1490       IMAX   = IIMAX
1491       KMAX   = KKMAX
1492
1493       DO 20 I=1,30
1494         PARMDL(300+I) = -100000.D0
1495  20   CONTINUE
1496 C  initialize /POHDRN/
1497       QMASS(1) =  PARMDL(151)
1498       QMASS(2) =  PARMDL(152)
1499       QMASS(3) =  PARMDL(153)
1500       QMASS(4) =  PARMDL(154)
1501       QMASS(5) =  PARMDL(155)
1502       QMASS(6) =  PARMDL(156)
1503       BET      = 8.D0
1504       PCOUDI   = 0.D0
1505       VALPRG(1) = 1.D0
1506       VALPRG(2) = 1.D0
1507 C  number of light flavours (quarks treated as massless)
1508       NFS      = 4
1509 C  initialize /POCUT1/
1510       PTCUT(1) = PARMDL(36)
1511       PTCUT(2) = PARMDL(37)
1512       PTCUT(3) = PARMDL(38)
1513       PTCUT(4) = PARMDL(39)
1514       PSOMIN = 0.D0
1515       XSOMIN = 0.D0
1516 C  initialize /POHAPA/
1517       NFbeta  = 4
1518       NF      = 4
1519       BQCD(1) = PI4/(11.D0-(2.D0/3.D0)*3)
1520       BQCD(2) = PI4/(11.D0-(2.D0/3.D0)*4)
1521       BQCD(3) = PI4/(11.D0-(2.D0/3.D0)*5)
1522       BQCD(4) = PI4/(11.D0-(2.D0/3.D0)*6)
1523 C  initialize /POGAUP/
1524       NGAUP1 = 12
1525       NGAUP2 = 12
1526       NGAUET = 16
1527       NGAUIN = 12
1528       NGAUSO = 96
1529 C  initialize //
1530       DO 30 I=1,100
1531         IDEB(I) = 0
1532  30   CONTINUE
1533 C  initialize /PROCES/
1534       DO 35 I=1,11
1535         IPRON(I,1) = 1
1536  35   CONTINUE
1537 C  DPMJET default: no elastic scattering
1538       IPRON(2,1) = 0
1539       DO 36 K=2,4
1540         DO 37 I=2,11
1541           IPRON(I,K) = 0
1542  37     CONTINUE
1543         IPRON(1,K) = 1
1544         IPRON(8,K) = 1
1545  36   CONTINUE
1546 C  initialize /POSVDM/
1547       TWOPIM = 0.28D0
1548       RMIN(1) = 0.285D0
1549       RMIN(2) = 0.45D0
1550       RMIN(3) = 1.D0
1551       RMIN(4) = TWOPIM
1552       VMAS(1) = 0.770D0
1553       VMAS(2) = 0.787D0
1554       VMAS(3) = 1.02D0
1555       VMAS(4) = TWOPIM
1556       GAMM(1) = 0.155D0
1557       GAMM(2) = 0.01D0
1558       GAMM(3) = 0.0045D0
1559       GAMM(4) = 1.D0
1560       RMAX(1) = VMAS(1)+TWOPIM
1561       RMAX(2) = VMAS(2)+TWOPIM
1562       RMAX(3) = VMAS(3)+TWOPIM
1563       RMAX(4) = VMAS(1)+TWOPIM
1564       VMSL(1) = 11.D0
1565       VMSL(2) = 10.D0
1566       VMSL(3) = 6.D0
1567       VMSL(4) = 4.D0
1568       VMFA(1) = 0.0033D0
1569       VMFA(2) = 0.00036D0
1570       VMFA(3) = 0.0002D0
1571       VMFA(4) = 0.0002D0
1572 C  initialize /PODGL1/
1573       Q2MISR(1) = PARMDL(36)**2
1574       Q2MISR(2) = PARMDL(36)**2
1575       PMISR(1) = 1.D0
1576       PMISR(2) = 1.D0
1577       ZMISR(1) = 0.001D0
1578       ZMISR(2) = 0.001D0
1579       AL2ISR(1) = 0.046D0
1580       AL2ISR(2) = 0.046D0
1581       NFSISR  = 4
1582 C  initialize /POPISR/
1583       DO 40 I=1,50
1584         IPOISR(1,2,I) = 0
1585         IPOISR(2,2,I) = 0
1586  40   CONTINUE
1587 C  initialize /POHPRO/
1588       PROC(0) = 'sum over processes'
1589       PROC(1) = 'G  +G  --> G  +G  '
1590       PROC(2) = 'Q  +QB --> G  +G  '
1591       PROC(3) = 'G  +Q  --> G  +Q  '
1592       PROC(4) = 'G  +G  --> Q  +QB '
1593       PROC(5) = 'Q  +QB --> Q  +QB '
1594       PROC(6) = 'Q  +QB --> QP +QBP'
1595       PROC(7) = 'Q  +Q  --> Q  +Q  '
1596       PROC(8) = 'Q  +QP --> Q  +QP '
1597       PROC(9) = 'resolved processes'
1598       PROC(10) = 'gam+Q  --> G  +Q  '
1599       PROC(11) = 'gam+G  --> Q  +QB '
1600       PROC(12) = 'Q  +gam--> G  +Q  '
1601       PROC(13) = 'G  +gam--> Q  +QB '
1602       PROC(14) = 'gam+gam--> Q  +QB '
1603       PROC(15) = 'direct processes  '
1604       PROC(16) = 'gam+gam--> l+ +l- '
1605
1606 C  initialize /POHRCS/
1607       do M=1,Max_pro_2
1608         HWgx(M) = 0.D0
1609         HSig(M) = 0.D0
1610         Hdpt(M) = 0.D0
1611       enddo
1612       DO I=0,4
1613         DO M=-1,Max_pro_2
1614 C  switch all hard subprocesses on
1615           MH_pro_on(M,I) = 1
1616 C  reset all counters
1617           MH_tried(M,I) = 0
1618           MH_acc_1(M,I) = 0
1619           MH_acc_2(M,I) = 0
1620         ENDDO
1621         MH_pro_on(16,I) = 0
1622       ENDDO
1623
1624 C  initialize /POHTAB/
1625       do I=0,4
1626         IH_Ecm_up(I) = 0
1627         IH_Q2a_up(I) = 0
1628         IH_Q2b_up(I) = 0
1629         HEcm_tab(1,I) = 0.D0
1630       enddo
1631       HEcm_last = 0.D0
1632       IHa_last = 0.D0
1633       IHb_last = 0.D0
1634
1635 C  initialize /POFSRC/
1636       IGHEL(1) = -1
1637       IGHEL(2) = -1
1638 C  initialize /LEPCUT/
1639       ECMIN = 5.D0
1640       ECMAX = 1.D+30
1641       EEMIN1 = 1.D0
1642       EEMIN2 = 1.D0
1643       YMAX1 = -1.D0
1644       YMAX2 = -1.D0
1645       THMIN1 = 0.D0
1646       THMAX1 = PI
1647       THMIN2 = 0.D0
1648       THMAX2 = PI
1649       ITAG1 = 1
1650       ITAG2 = 1
1651 C  initialize /POWGHT/
1652       DO 70 I=1,20
1653         HSWCUT(I) = 0.D0
1654         ISWCUT(I) = 0
1655  70   CONTINUE
1656       EVWGHT(1) = 1.D0
1657       IVWGHT(1) = 0
1658       SIGGEN(1) = 0.D0
1659       SIGGEN(2) = 0.D0
1660       SIGGEN(3) = 0.D0
1661       SIGGEN(4) = 0.D0
1662
1663       END
1664
1665 *$ CREATE PHO_PARDAT.FOR
1666 *COPY PHO_PARDAT
1667 CDECK  ID>, PHO_PARDAT
1668       SUBROUTINE PHO_PARDAT
1669 C***********************************************************************
1670 C
1671 C     particle data (based on 1996 PDG naming scheme and data tables)
1672 C
1673 C***********************************************************************
1674       IMPLICIT NONE
1675       SAVE
1676
1677 C  input/output channels
1678       INTEGER LI,LO
1679       COMMON /POINOU/ LI,LO
1680 C  event debugging information
1681       INTEGER NMAXD
1682       PARAMETER (NMAXD=100)
1683       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
1684      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
1685       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
1686      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
1687 C  particle ID translation table
1688       integer         ID_pdg_list,ID_list,ID_pdg_max
1689       character*12    name_list
1690       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
1691      &                ID_pdg_max
1692 C  general particle data
1693       double precision xm_list,tau_list,gam_list,
1694      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
1695      &  xm_bb82_list,xm_bb102_list
1696       integer          ich3_list,iba3_list,iq_list,
1697      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
1698       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
1699      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
1700      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
1701      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
1702      &  ich3_list(300),iba3_list(300),iq_list(3,300),
1703      &  id_psm_list(6,6),id_vem_list(6,6),
1704      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
1705 C  particle decay data
1706       double precision wg_sec_list
1707       integer          idec_list,isec_list
1708       COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
1709      &  isec_list(3,500)
1710
1711 C  external functions
1712
1713       integer ipho_pdg2id
1714       double precision pho_pmass
1715
1716 C  local variables for storing data tables
1717
1718       integer number,ich3,iba3,iq_linear,idec_linear,isec_linear,
1719      &  id_psm_linear,id_vem_linear,id_b8_linear,id_b10_linear
1720
1721       dimension number(300),ich3(300),iba3(300),iq_linear(900),
1722      &  idec_linear(900),isec_linear(900),id_psm_linear(36),
1723      &  id_vem_linear(36),id_b8_linear(216),id_b10_linear(216)
1724
1725       double precision xmass,gamma,wg_chan
1726       dimension xmass(300),gamma(300),wg_chan(300)
1727
1728       character*12 name
1729       dimension name(300)
1730
1731       integer i,i1,i2,ii,j,jj,k,l,ichan,i_tab_max,K8,K10,L8,L10
1732       double precision AM1,AM2,AM2P,AM2V,AM82,AM102,AMM
1733       integer itmp
1734
1735       DATA i_tab_max /260/
1736
1737       DATA (number(K),K=    1,  171) /
1738      &     1,     2,     3,     4,     5,     6,  1103,  2101,  2103,
1739      &  2203,  3101,  3103,  3201,  3203,  3303,  4101,  4103,  4201,
1740      &  4203,  4301,  4303,  4403,    81,    82,    90,    91,    92,
1741      &   110,   990,    21,    22,    24,    23,    11,    13,    15,
1742      &    12,    14,    16,   211,   111,   221,   113,   213,   223,
1743      &   331, 10221, 10111, 10211,   333, 10223, 10113, 10213, 20113,
1744      & 20213,   225, 20223, 20221, 20111, 20211,   115,   215, 30223,
1745      & 50223, 40113, 40213, 50221,   335, 60223,   227, 10115, 10215,
1746      & 10333,   117,   217, 30113, 30213, 60221,   337, 20225,   229,
1747      & 30225, 40225,   321,   311,   310,   130,   323,   313, 10313,
1748      & 10323, 20313, 20323, 30313, 30323, 10311, 10321,   325,   315,
1749      & 40313, 40323, 10315, 10325,   317,   327, 20315, 20325,   319,
1750      &   329,   411,   421,   423,   413, 10423,   425,   415,   431,
1751      &   433, 10433,   521,   511,   513,   523,   531,   441,   443,
1752      & 10441, 10443,   445, 20443, 30443, 40443, 50443, 60443,   553,
1753      &   551, 10553,   555, 20553, 10551, 70553, 10555, 30553, 40553,
1754      & 50553, 60553,  2212,  2112, 12112, 12212,  1214,  2124, 22112,
1755      & 22212, 32112, 32212,  2116,  2216, 12116, 12216, 21214, 22124,
1756      & 42112, 42212, 31214, 32124,  1218,  2128,  1114,  2114,  2214/
1757       DATA (number(K),K=  172,  260) /
1758      &  2224, 31114, 32114, 32214, 32224,  1112,  1212,  2122,  2222,
1759      & 11114, 12114, 12214, 12224,  1116,  1216,  2126,  2226, 21112,
1760      & 21212, 22122, 22222, 21114, 22114, 22214, 22224, 11116, 11216,
1761      & 12126, 12226,  1118,  2118,  2218,  2228,  3122, 13122,  3124,
1762      & 23122, 33122, 13124, 43122, 53122,  3126, 13126, 23124,  3128,
1763      & 23126,  3222,  3212,  3112,  3224,  3214,  3114, 13112, 13212,
1764      & 13222, 13114, 13214, 13224, 23112, 23212, 23222,  3116,  3216,
1765      &  3226, 13116, 13216, 13226, 23114, 23214, 23224,  3118,  3218,
1766      &  3228,  3322,  3312,  3324,  3314, 13314, 13324,  3334,  4122,
1767      & 14122,  4222,  4212,  4112,  4232,  4132,  4332,  5122/
1768       DATA (name(K),K=    1,   76) /
1769      &'d           ','u           ','s           ','c           ',
1770      &'b           ','t           ','(dd)_1      ','(ud)_0      ',
1771      &'(ud)_1      ','(uu)_1      ','(sd)_0      ','(sd)_1      ',
1772      &'(su)_0      ','(su)_1      ','(ss)_1      ','(cd)_0      ',
1773      &'(cd)_1      ','(cu)_0      ','(cu)_1      ','(cs)_0      ',
1774      &'(cs)_1      ','(cc)_1      ','remnant 1   ','remnant 2   ',
1775      &'string      ','mod. string ','coll. string','reggeon     ',
1776      &'pomeron     ','gluon       ','gamma       ','W           ',
1777      &'Z           ','e           ','mu          ','tau         ',
1778      &'nu(e)       ','nu(mu)      ','nu(tau)     ','pi          ',
1779      &'pi          ','eta         ','rho(770)    ','rho(770)    ',
1780      &'ome(782)    ','etap(958)   ','f(0)(980)   ','a(0)(980)   ',
1781      &'a(0)(980)   ','phi(1020)   ','h(1)(1170)  ','b(1)(1235)  ',
1782      &'b(1)(1235)  ','a(1)(1260)  ','a(1)(1260)  ','f(2)(1270)  ',
1783      &'f(1)(1285)  ','eta(1295)   ','pi(1300)    ','pi(1300)    ',
1784      &'a(2)(1320)  ','a(2)(1320)  ','f(1)(1420)  ','ome(1420)   ',
1785      &'rho(1450)   ','rho(1450)   ','f(0)(1500)  ','f(2)p(1525) ',
1786      &'ome(1600)   ','ome(3)(1670)','pi(2)(1670) ','pi(2)(1670) ',
1787      &'phi(1680)   ','rho(3)(1690)','rho(3)(1690)','rho(1700)   '/
1788       DATA (name(K),K=   77,  152) /
1789      &'rho(1700)   ','f(J)(1710)  ','phi(3)(1850)','f(2)(2010)  ',
1790      &'f(4)(2050)  ','f(2)(2300)  ','f(2)(2340)  ','K           ',
1791      &'K           ','K(S)        ','K(L)        ','K*(892)     ',
1792      &'K*(892)     ','K(1)(1270)  ','K(1)(1270)  ','K(1)(1400)  ',
1793      &'K(1)(1400)  ','K*(1410)    ','K*(1410)    ','K(0)*(1430) ',
1794      &'K(0)*(1430) ','K(2)*(1430) ','K(2)*(1430) ','K*(1680)    ',
1795      &'K*(1680)    ','K(2)(1770)  ','K(2)(1770)  ','K(3)*(1780) ',
1796      &'K(3)*(1780) ','K(2)(1820)  ','K(2)(1820)  ','K(4)*(2045) ',
1797      &'K(4)*(2045) ','D           ','D           ','D*(2007)    ',
1798      &'D*(2010)    ','D(1)(2420)  ','D(2)*(2460) ','D(2)*(2460) ',
1799      &'D(s)        ','D(s)*       ','D(s1)(2536) ','B           ',
1800      &'B           ','B*          ','B*          ','B(s)        ',
1801      &'eta(c)(1S)  ','J/psi(1S)   ','chi(c0)(1P) ','chi(c1)(1P) ',
1802      &'chi(c2)(1P) ','psi(2S)     ','psi(3770)   ','psi(4040)   ',
1803      &'psi(4160)   ','psi(4415)   ','Ups(1S)     ','chi(b0)(1P) ',
1804      &'chi(b1)(1P) ','chi(b2)(1P) ','Ups(2S)     ','chi(b0)(2P) ',
1805      &'chi(b1)(2P) ','chi(b2)(2P) ','Ups(3S)     ','Ups(4S)     ',
1806      &'Ups(10860)  ','Ups(11020)  ','p           ','n           ',
1807      &'N(1440)     ','N(1440)     ','N(1520)     ','N(1520)     '/
1808       DATA (name(K),K=  153,  228) /
1809      &'N(1535)     ','N(1535)     ','N(1650)     ','N(1650)     ',
1810      &'N(1675)     ','N(1675)     ','N(1680)     ','N(1680)     ',
1811      &'N(1700)     ','N(1700)     ','N(1710)     ','N(1710)     ',
1812      &'N(1720)     ','N(1720)     ','N(2190)     ','N(2190)     ',
1813      &'Del(1232)   ','Del(1232)   ','Del(1232)   ','Del(1232)   ',
1814      &'Del(1600)   ','Del(1600)   ','Del(1600)   ','Del(1600)   ',
1815      &'Del(1620)   ','Del(1620)   ','Del(1620)   ','Del(1620)   ',
1816      &'Del(1700)   ','Del(1700)   ','Del(1700)   ','Del(1700)   ',
1817      &'Del(1905)   ','Del(1905)   ','Del(1905)   ','Del(1905)   ',
1818      &'Del(1910)   ','Del(1910)   ','Del(1910)   ','Del(1910)   ',
1819      &'Del(1920)   ','Del(1920)   ','Del(1920)   ','Del(1920)   ',
1820      &'Del(1930)   ','Del(1930)   ','Del(1930)   ','Del(1930)   ',
1821      &'Del(1950)   ','Del(1950)   ','Del(1950)   ','Del(1950)   ',
1822      &'Lambda      ','Lam(1405)   ','Lam(1520)   ','Lam(1600)   ',
1823      &'Lam(1670)   ','Lam(1690)   ','Lam(1800)   ','Lam(1810)   ',
1824      &'Lam(1820)   ','Lam(1830)   ','Lam(1890)   ','Lam(2100)   ',
1825      &'Lam(2110)   ','Sigma       ','Sigma       ','Sigma       ',
1826      &'Sig(1385)   ','Sig(1385)   ','Sig(1385)   ','Sig(1660)   ',
1827      &'Sig(1660)   ','Sig(1660)   ','Sig(1670)   ','Sig(1670)   '/
1828       DATA (name(K),K=  229,  260) /
1829      &'Sig(1670)   ','Sig(1750)   ','Sig(1750)   ','Sig(1750)   ',
1830      &'Sig(1775)   ','Sig(1775)   ','Sig(1775)   ','Sig(1915)   ',
1831      &'Sig(1915)   ','Sig(1915)   ','Sig(1940)   ','Sig(1940)   ',
1832      &'Sig(1940)   ','Sig(2030)   ','Sig(2030)   ','Sig(2030)   ',
1833      &'Xi          ','Xi          ','Xi(1530)    ','Xi(1530)    ',
1834      &'Xi(1820)    ','Xi(1820)    ','Omega       ','Lam(c)      ',
1835      &'Lam(c)(2593)','Sig(c)(2455)','Sig(c)(2455)','Sig(c)(2455)',
1836      &'Xi(c)       ','Xi(c)       ','Ome(c)      ','Lam(b)      '/
1837       DATA (ich3(K),K=    1,  260) /
1838      &-1, 2,-1, 2,-1, 2,-2, 1, 1, 4,-2,-2, 1, 1,-2, 1, 1, 4, 4, 1, 1, 4,
1839      & 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0,-3,-3,-3, 0, 0, 0, 3, 0, 0, 0, 3,
1840      & 0, 0, 0, 0, 3, 0, 0, 0, 3, 0, 3, 0, 0, 0, 0, 3, 0, 3, 0, 0, 0, 3,
1841      & 0, 0, 0, 0, 0, 3, 0, 0, 3, 0, 3, 0, 0, 0, 0, 0, 0, 3, 0, 0, 0, 3,
1842      & 0, 0, 3, 0, 3, 0, 3, 0, 3, 3, 0, 0, 3, 0, 3, 0, 3, 0, 3, 0, 3, 3,
1843      & 0, 0, 3, 0, 0, 3, 3, 3, 3, 3, 0, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1844      & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 0, 3, 0, 3, 0, 3,
1845      & 0, 3, 0, 3, 0, 3, 0, 3, 0, 3, 0, 3, 0, 3,-3, 0, 3, 6,-3, 0, 3, 6,
1846      &-3, 0, 3, 6,-3, 0, 3, 6,-3, 0, 3, 6,-3, 0, 3, 6,-3, 0, 3, 6,-3, 0,
1847      & 3, 6,-3, 0, 3, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0,-3,
1848      & 3, 0,-3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3, 0, 3,-3,
1849      & 0, 3, 0,-3, 0,-3,-3, 0,-3, 3, 3, 6, 3, 0, 3, 0, 0, 0/
1850       DATA (iba3(K),K=    1,  260) /
1851      &1,1,1,1,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,0,0,0,0,0,0,0,0,0,0,0,
1852      &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
1853      &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
1854      &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
1855      &0,0,0,0,0,0,0,0,0,0,0,0,0,0,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
1856      &3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
1857      &3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
1858      &3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3/
1859       DATA (iq_linear(K),K=    1,  418) /
1860      & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 2,
1861      & 1, 0, 2, 1, 0, 2, 2, 0, 3, 1, 0, 3, 1, 0, 3, 2, 0, 3, 2, 0, 3, 3,
1862      & 0, 4, 1, 0, 4, 1, 0, 4, 2, 0, 4, 2, 0, 4, 3, 0, 4, 3, 0, 4, 4, 0,
1863      & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1864      & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1865      & 0, 0, 0, 0, 0, 0, 0, 2,-1, 0, 1,-1, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0,
1866      & 2,-2, 0, 3,-3, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0, 3,-3, 0, 2,-2, 0, 1,
1867      &-1, 0, 2,-1, 0, 1,-1, 0, 2, 1, 0, 2,-2, 0, 2,-2, 0, 2,-2, 0, 1,-1,
1868      & 0, 2,-1, 0, 1,-1, 0, 2,-1, 0, 2,-2, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0,
1869      & 2,-2, 0, 3,-3, 0, 2,-2, 0, 2,-2, 0, 1,-1, 0, 2,-1, 0, 3,-3, 0, 1,
1870      &-1, 0, 2,-1, 0, 1,-1, 0, 2,-1, 0, 2,-2, 0, 3,-3, 0, 2,-2, 0, 2,-2,
1871      & 0, 2,-2, 0, 2,-2, 0, 2,-3, 0, 1,-3, 0, 1,-3, 0, 3,-1, 0, 2,-3, 0,
1872      & 1,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 1,
1873      &-3, 0, 2,-3, 0, 2,-3, 0, 1,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3,
1874      & 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 1,-3, 0, 2,-3, 0, 4,-1, 0,
1875      & 4,-2, 0, 4,-2, 0, 4,-1, 0, 4,-2, 0, 4,-2, 0, 4,-1, 0, 4,-3, 0, 4,
1876      &-3, 0, 4,-3, 0, 2,-5, 0, 1,-5, 0, 1,-5, 0, 2,-5, 0, 3,-5, 0, 4,-4,
1877      & 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0, 4,-4, 0,
1878      & 4,-4, 0, 4,-4, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5/
1879       DATA (iq_linear(K),K=  419,  780) /
1880      &-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 5,-5, 0, 2, 2,
1881      & 1, 2, 1, 1, 2, 1, 1, 2, 2, 1, 1, 2, 1, 2, 1, 2, 2, 1, 1, 2, 2, 1,
1882      & 2, 1, 1, 2, 2, 1, 2, 2, 2, 2, 2, 1, 2, 1, 1, 2, 2, 1, 1, 2, 1, 2,
1883      & 1, 2, 2, 1, 1, 2, 2, 1, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 1,
1884      & 1, 2, 1, 1, 2, 2, 1, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 2, 1, 2, 2, 2,
1885      & 1, 1, 1, 1, 2, 1, 2, 1, 2, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 2, 1, 2,
1886      & 2, 2, 1, 1, 1, 1, 2, 1, 2, 1, 2, 2, 2, 2, 1, 1, 1, 1, 2, 1, 2, 1,
1887      & 2, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 1, 1, 2, 2, 2, 1, 1, 1, 1, 2, 1,
1888      & 2, 1, 2, 2, 2, 2, 1, 1, 1, 2, 1, 1, 2, 2, 1, 2, 2, 2, 3, 1, 2, 3,
1889      & 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1,
1890      & 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 2, 2, 3, 2, 1, 3, 1, 1, 3,
1891      & 3, 2, 2, 3, 2, 1, 3, 1, 1, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1, 3,
1892      & 2, 1, 3, 2, 2, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1, 3, 2, 1, 3, 2,
1893      & 2, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1, 3, 2, 1, 3, 2, 2, 3, 1, 1,
1894      & 3, 2, 1, 3, 2, 2, 2, 3, 3, 1, 3, 3, 2, 3, 3, 1, 3, 3, 3, 3, 1, 3,
1895      & 3, 2, 3, 3, 3, 2, 1, 4, 4, 1, 2, 2, 2, 4, 2, 1, 2, 1, 1, 4, 3, 2,
1896      & 2, 3, 1, 2, 3, 3, 4, 5, 1, 2/
1897       DATA (xmass(K),K=    1,  114) /
1898      &3.0000E-01,3.0000E-01,3.5000E-01,1.4500E+00,4.5000E+00,1.7400E+02,
1899      &7.7133E-01,5.7933E-01,7.7133E-01,7.7133E-01,8.0473E-01,9.2953E-01,
1900      &8.0473E-01,9.2953E-01,1.0936E+00,1.9691E+00,2.0081E+00,1.9691E+00,
1901      &2.0081E+00,2.1543E+00,2.1797E+00,3.2753E+00,0.0000E+00,0.0000E+00,
1902      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
1903      &0.0000E+00,8.0410E+01,9.1187E+01,5.1100E-04,1.0566E-01,1.7771E+00,
1904      &0.0000E+00,0.0000E+00,0.0000E+00,1.3957E-01,1.3498E-01,5.4730E-01,
1905      &7.7000E-01,7.7000E-01,7.8194E-01,9.5778E-01,9.8000E-01,9.8340E-01,
1906      &9.8340E-01,1.0194E+00,1.1700E+00,1.2295E+00,1.2295E+00,1.2300E+00,
1907      &1.2300E+00,1.2750E+00,1.2819E+00,1.2970E+00,1.3000E+00,1.3000E+00,
1908      &1.3181E+00,1.3181E+00,1.4262E+00,1.4190E+00,1.4650E+00,1.4650E+00,
1909      &1.5000E+00,1.5250E+00,1.6490E+00,1.6670E+00,1.6700E+00,1.6700E+00,
1910      &1.6800E+00,1.6910E+00,1.6910E+00,1.7000E+00,1.7000E+00,1.7120E+00,
1911      &1.8540E+00,2.0100E+00,2.0440E+00,2.2970E+00,2.3400E+00,4.9368E-01,
1912      &4.9767E-01,4.9767E-01,4.9767E-01,8.9166E-01,8.9610E-01,1.2720E+00,
1913      &1.2720E+00,1.4020E+00,1.4020E+00,1.4140E+00,1.4140E+00,1.4290E+00,
1914      &1.4290E+00,1.4256E+00,1.4324E+00,1.7170E+00,1.7170E+00,1.7730E+00,
1915      &1.7730E+00,1.7760E+00,1.7760E+00,1.8160E+00,1.8160E+00,2.0450E+00,
1916      &2.0450E+00,1.8693E+00,1.8646E+00,2.0067E+00,2.0100E+00,2.4222E+00/
1917       DATA (xmass(K),K=  115,  228) /
1918      &2.4589E+00,2.4590E+00,1.9685E+00,2.1124E+00,2.5353E+00,5.2789E+00,
1919      &5.2792E+00,5.3249E+00,5.3249E+00,5.3693E+00,2.9798E+00,3.0969E+00,
1920      &3.4173E+00,3.5105E+00,3.5562E+00,3.6860E+00,3.7699E+00,4.0400E+00,
1921      &4.1590E+00,4.4150E+00,9.4604E+00,9.8598E+00,9.8919E+00,9.9132E+00,
1922      &1.0023E+01,1.0232E+01,1.0255E+01,1.0268E+01,1.0355E+01,1.0580E+01,
1923      &1.0865E+01,1.1019E+01,9.3827E-01,9.3957E-01,1.4400E+00,1.4400E+00,
1924      &1.5200E+00,1.5200E+00,1.5350E+00,1.5350E+00,1.6500E+00,1.6500E+00,
1925      &1.6750E+00,1.6750E+00,1.6800E+00,1.6800E+00,1.7000E+00,1.7000E+00,
1926      &1.7100E+00,1.7100E+00,1.7200E+00,1.7200E+00,2.1900E+00,2.1900E+00,
1927      &1.2320E+00,1.2320E+00,1.2320E+00,1.2320E+00,1.6000E+00,1.6000E+00,
1928      &1.6000E+00,1.6000E+00,1.6200E+00,1.6200E+00,1.6200E+00,1.6200E+00,
1929      &1.7000E+00,1.7000E+00,1.7000E+00,1.7000E+00,1.9050E+00,1.9050E+00,
1930      &1.9050E+00,1.9050E+00,1.9100E+00,1.9100E+00,1.9100E+00,1.9100E+00,
1931      &1.9200E+00,1.9200E+00,1.9200E+00,1.9200E+00,1.9300E+00,1.9300E+00,
1932      &1.9300E+00,1.9300E+00,1.9500E+00,1.9500E+00,1.9500E+00,1.9500E+00,
1933      &1.1157E+00,1.4070E+00,1.5195E+00,1.6000E+00,1.6700E+00,1.6900E+00,
1934      &1.8000E+00,1.8100E+00,1.8200E+00,1.8300E+00,1.8900E+00,2.1000E+00,
1935      &2.1100E+00,1.1894E+00,1.1926E+00,1.1974E+00,1.3828E+00,1.3837E+00,
1936      &1.3872E+00,1.6600E+00,1.6600E+00,1.6600E+00,1.6700E+00,1.6700E+00/
1937       DATA (xmass(K),K=  229,  260) /
1938      &1.6700E+00,1.7500E+00,1.7500E+00,1.7500E+00,1.7750E+00,1.7750E+00,
1939      &1.7750E+00,1.9150E+00,1.9150E+00,1.9150E+00,1.9400E+00,1.9400E+00,
1940      &1.9400E+00,2.0300E+00,2.0300E+00,2.0300E+00,1.3149E+00,1.3213E+00,
1941      &1.5318E+00,1.5350E+00,1.8230E+00,1.8230E+00,1.6724E+00,2.2849E+00,
1942      &2.5939E+00,2.4528E+00,2.4536E+00,2.4522E+00,2.4656E+00,2.4703E+00,
1943      &2.7040E+00,5.6240E+00/
1944       DATA (gamma(K),K=    1,  114) /
1945      &8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,
1946      &8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,8.0000E-01,
1947      &8.0000E-01,8.0000E-01,8.0000E-01,0.0000E+00,0.0000E+00,0.0000E+00,
1948      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
1949      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
1950      &0.0000E+00,2.0600E+00,2.4900E+00,0.0000E+00,2.9959E-19,2.2700E-12,
1951      &0.0000E+00,0.0000E+00,0.0000E+00,2.5284E-17,7.8000E-09,1.1800E-06,
1952      &1.5070E-01,1.5070E-01,8.4100E-03,2.0300E-04,0.0000E+00,0.0000E+00,
1953      &0.0000E+00,4.4300E-03,3.6000E-01,1.4200E-01,1.4200E-01,0.0000E+00,
1954      &0.0000E+00,1.8550E-01,2.4000E-02,5.3000E-02,0.0000E+00,0.0000E+00,
1955      &1.0700E-01,1.0700E-01,5.5000E-02,1.7000E-01,3.1000E-01,3.1000E-01,
1956      &1.1200E-01,7.6000E-02,2.2000E-01,1.6800E-01,2.5800E-01,2.5800E-01,
1957      &1.5000E-01,1.6000E-01,1.6000E-01,2.4000E-01,2.4000E-01,1.3300E-01,
1958      &8.7000E-02,2.0000E-01,2.0800E-01,1.5000E-01,3.2000E-01,5.3140E-17,
1959      &0.0000E+00,7.3730E-15,1.2730E-17,5.0800E-02,5.0500E-02,9.0000E-02,
1960      &9.0000E-02,1.7400E-01,1.7400E-01,2.3200E-01,2.3200E-01,2.8700E-01,
1961      &2.8700E-01,9.8500E-02,1.0900E-01,3.2000E-01,3.2000E-01,1.8600E-01,
1962      &1.8600E-01,1.5900E-01,1.5900E-01,2.7600E-01,2.7600E-01,1.9800E-01,
1963      &1.9800E-01,6.2300E-13,1.5860E-12,5.0000E-03,2.0000E-03,1.8900E-02/
1964       DATA (gamma(K),K=  115,  228) /
1965      &2.3000E-02,2.5000E-02,1.4100E-12,2.0000E-03,0.0000E+00,3.9900E-13,
1966      &4.2200E-13,0.0000E+00,0.0000E+00,4.2700E-13,1.3200E-02,8.7000E-05,
1967      &1.4000E-02,8.8000E-04,2.0000E-03,2.7700E-04,2.3600E-02,5.2000E-02,
1968      &7.8000E-02,4.3000E-02,5.2500E-05,0.0000E+00,0.0000E+00,0.0000E+00,
1969      &4.4000E-05,0.0000E+00,0.0000E+00,0.0000E+00,2.6300E-05,1.0000E-02,
1970      &1.1000E-01,7.9000E-02,0.0000E+00,7.4240E-28,3.5000E-01,3.5000E-01,
1971      &1.2000E-01,1.2000E-01,1.5000E-01,1.5000E-01,1.5000E-01,1.5000E-01,
1972      &1.5000E-01,1.5000E-01,1.3000E-01,1.3000E-01,1.0000E-01,1.0000E-01,
1973      &1.0000E-01,1.0000E-01,1.5000E-01,1.5000E-01,4.5000E-01,4.5000E-01,
1974      &1.2000E-01,1.2000E-01,1.2000E-01,1.2000E-01,3.5000E-01,3.5000E-01,
1975      &3.5000E-01,3.5000E-01,1.5000E-01,1.5000E-01,1.5000E-01,1.5000E-01,
1976      &3.0000E-01,3.0000E-01,3.0000E-01,3.0000E-01,3.5000E-01,3.5000E-01,
1977      &3.5000E-01,3.5000E-01,2.5000E-01,2.5000E-01,2.5000E-01,2.5000E-01,
1978      &2.0000E-01,2.0000E-01,2.0000E-01,2.0000E-01,3.5000E-01,3.5000E-01,
1979      &3.5000E-01,3.5000E-01,3.0000E-01,3.0000E-01,3.0000E-01,3.0000E-01,
1980      &2.5010E-15,5.0000E-02,1.5600E-02,1.5000E-01,3.5000E-02,6.0000E-02,
1981      &3.0000E-01,1.5000E-01,8.0000E-02,9.5000E-02,1.0000E-01,2.0000E-01,
1982      &2.0000E-01,8.2400E-15,8.9000E-06,4.4500E-15,3.5800E-02,3.6000E-02,
1983      &3.9400E-02,1.0000E-01,1.0000E-01,1.0000E-01,6.0000E-02,6.0000E-02/
1984       DATA (gamma(K),K=  229,  260) /
1985      &6.0000E-02,9.0000E-02,9.0000E-02,9.0000E-02,1.2000E-01,1.2000E-01,
1986      &1.2000E-01,1.2000E-01,1.2000E-01,1.2000E-01,2.2000E-01,2.2000E-01,
1987      &2.2000E-01,1.8000E-01,1.8000E-01,1.8000E-01,2.2700E-15,4.0200E-15,
1988      &9.1000E-03,9.9000E-03,2.4000E-02,2.4000E-02,8.0100E-15,3.1900E-12,
1989      &3.6000E-03,0.0000E+00,0.0000E+00,0.0000E+00,1.8600E-12,6.7000E-12,
1990      &1.0200E-11,5.3100E-13/
1991       DATA (idec_linear(K),K=    1,  304) /
1992      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
1993      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
1994      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
1995      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
1996      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
1997      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
1998      &  0,  0,  0,  0,  0,  0,  3,  1,  1,  2,  2,  6,  0,  0,  0,  0,
1999      &  0,  0,  0,  0,  0,  3,  7,  7,  3,  8,  9,  1, 10, 14,  1, 15,
2000      & 16,  1, 17, 17,  1, 18, 20,  1, 21, 24,  0,  0,  0,  0,  0,  0,
2001      &  0,  0,  0,  1, 25, 29,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2002      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2003      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  1, 30, 32,
2004      &  1, 33, 34,  0,  0,  0,  0,  0,  0,  0,  0,  0,  1, 35, 37,  0,
2005      &  0,  0,  0,  0,  0,  0,  0,  0,  1, 38, 39,  0,  0,  0,  0,  0,
2006      &  0,  1, 40, 40,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2007      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  3, 41, 46,  0,  0,  0,  3,
2008      & 47, 48,  3, 49, 52,  1, 53, 54,  1, 55, 56,  1, 57, 58,  1, 59,
2009      & 60,  0,  0,  0,  0,  0,  0,  1, 61, 68,  1, 69, 76,  0,  0,  0,
2010      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0/
2011       DATA (idec_linear(K),K=  305,  608) /
2012      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2013      &  0,  0,  0,  0,  0,  0,  0,  2, 77, 78,  2, 79, 82,  1, 83, 84,
2014      &  1, 85, 87,  0,  0,  0,  0,  0,  0,  0,  0,  0,  2, 88, 90,  1,
2015      & 91, 92,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2016      &  0,  0,  0,  0,  2, 93, 95,  1, 96, 98,  0,  0,  0,  0,  0,  0,
2017      &  0,  0,  0,  1, 99,101,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2018      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2019      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2020      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  3,102,102,  1,103,112,  1,
2021      &113,122,  0,  0,  0,  0,  0,  0,  1,123,129,  1,130,136,  0,  0,
2022      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2023      &  0,  0,  0,  0,  0,  0,  1,137,144,  1,145,152,  0,  0,  0,  0,
2024      &  0,  0,  0,  0,  0,  0,  0,  0,  1,153,153,  1,154,155,  1,156,
2025      &157,  1,158,158,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2026      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  1,159,162,  1,
2027      &163,169,  1,170,176,  1,177,180,  0,  0,  0,  0,  0,  0,  0,  0,
2028      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2029      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2030      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0/
2031       DATA (idec_linear(K),K=  609,  780) /
2032      &  0,  0,  0,  0,  3,181,182,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2033      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2034      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  3,183,184,  3,185,
2035      &185,  3,186,186,  1,187,189,  1,190,192,  1,193,194,  0,  0,  0,
2036      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2037      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  1,195,203,  0,  0,
2038      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
2039      &  0,  0,  0,  0,  0,  0,  1,204,216,  0,  0,  0,  3,217,217,  3,
2040      &218,218,  1,219,220,  1,221,222,  0,  0,  0,  0,  0,  0,  2,223,
2041      &225,  2,226,239,  0,  0,  0,  2,240,240,  2,241,241,  2,242,242,
2042      &  2,243,246,  2,247,251,  2,252,255,  0,  0,  0/
2043       DATA (isec_linear(K),K=    1,  152) /
2044      &     11,     12,    -12,     13,    -14,     16,     11,    -12,
2045      &     16,   -213,     16,      0,   -211,     16,      0,   -323,
2046      &     16,      0,    -13,     12,      0,     22,     22,      0,
2047      &     22,    -11,     11,     22,     22,      0,    111,     22,
2048      &     22,    111,    111,    111,    211,   -211,    111,    211,
2049      &   -211,     22,    211,   -211,      0,    111,    111,      0,
2050      &    211,    111,      0,    211,   -211,    111,    211,   -211,
2051      &      0,    111,     22,      0,    221,    211,   -211,    221,
2052      &    111,    111,    211,   -211,     22,     22,     22,      0,
2053      &    321,   -321,      0,    130,    310,      0,    113,    111,
2054      &      0,    211,   -211,    111,    221,     22,      0,    113,
2055      &    111,      0,   -213,    211,      0,    213,   -211,      0,
2056      &    211,   -211,      0,    111,    111,      0,    113,    111,
2057      &      0,   -213,    211,      0,    213,   -211,      0,    311,
2058      &   -313,      0,   -311,    313,      0,    113,    211,   -211,
2059      &    -13,     12,      0,    211,    111,      0,    211,    211,
2060      &   -211,    211,    111,    111,    -13,    111,     12,    -11,
2061      &    111,     12,    211,   -211,      0,    111,    111,      0,
2062      &    111,    111,    111,    211,   -211,    111,    211,     13/
2063       DATA (isec_linear(K),K=  153,  304) /
2064      &     12,    211,     11,     12,    321,    111,      0,    311,
2065      &    211,      0,    311,    111,      0,    321,   -211,      0,
2066      &    311,    111,      0,    321,   -211,      0,    321,    111,
2067      &      0,    311,    211,      0,    311,    111,      0,    321,
2068      &   -211,      0,    313,    111,      0,    323,   -211,      0,
2069      &    311,    113,      0,    321,   -213,      0,    311,    223,
2070      &      0,    311,    221,      0,    321,    111,      0,    311,
2071      &    211,      0,    323,    111,      0,    313,    211,      0,
2072      &    321,    113,      0,    311,    213,      0,    321,    223,
2073      &      0,    321,    221,      0,   -321,    211,    211,   -311,
2074      &    211,      0,   -321,    211,      0,   -321,    211,    111,
2075      &    311,    211,   -211,    311,    111,      0,    421,    111,
2076      &      0,    421,     22,      0,    421,    211,      0,    411,
2077      &    111,      0,    411,     22,      0,    221,    211,      0,
2078      &    321,   -321,    321,    321,   -311,      0,    431,     22,
2079      &      0,    431,     22,      0,    111,    111,      0,    211,
2080      &   -211,      0,     22,     22,      0,    -11,     11,      0,
2081      &    -13,     13,      0,    211,   -211,    111,    443,    211,
2082      &   -211,    443,    111,    111,    443,    221,      0,   2212/
2083       DATA (isec_linear(K),K=  305,  456) /
2084      &     11,     12,   2112,    111,      0,   2212,   -211,      0,
2085      &   2112,    111,    111,   2112,    211,   -211,   1114,    211,
2086      &      0,   2114,    111,      0,   2214,   -211,      0,   2112,
2087      &    113,      0,   2212,   -213,      0,   2112,    221,      0,
2088      &   2212,    111,      0,   2112,    211,      0,   2212,    111,
2089      &    111,   2212,    211,   -211,   2224,   -211,      0,   2214,
2090      &    111,      0,   2114,    211,      0,   2212,    113,      0,
2091      &   2112,    213,      0,   2212,    221,      0,   2212,   -211,
2092      &      0,   2112,    111,      0,   2214,   -211,      0,   2114,
2093      &    111,      0,   1114,    211,      0,   2212,   -213,      0,
2094      &   2112,    113,      0,   2212,    111,      0,   2112,    211,
2095      &      0,   2224,   -211,      0,   2214,    111,      0,   2114,
2096      &    211,      0,   2212,    113,      0,   2112,    213,      0,
2097      &   2212,   -211,      0,   2112,    111,      0,   2212,   -213,
2098      &      0,   2112,    113,      0,   3122,    311,      0,   3212,
2099      &    311,      0,   3112,    321,      0,   2112,    221,      0,
2100      &   2212,    111,      0,   2112,    211,      0,   2212,    113,
2101      &      0,   2112,    213,      0,   3122,    321,      0,   3222,
2102      &    311,      0,   3212,    321,      0,   2212,    221,      0/
2103       DATA (isec_linear(K),K=  457,  608) /
2104      &   2112,   -211,      0,   2212,   -211,      0,   2112,    111,
2105      &      0,   2212,    111,      0,   2112,    211,      0,   2212,
2106      &    211,      0,   2112,   -211,      0,   2114,   -211,      0,
2107      &   1114,    111,      0,   2112,   -213,      0,   2212,   -211,
2108      &      0,   2112,    111,      0,   2214,   -211,      0,   2114,
2109      &    111,      0,   1114,    211,      0,   2212,   -213,      0,
2110      &   2112,    113,      0,   2212,    111,      0,   2112,    211,
2111      &      0,   2224,   -211,      0,   2214,    111,      0,   2114,
2112      &    211,      0,   2212,    113,      0,   2112,    213,      0,
2113      &   2212,    211,      0,   2224,    111,      0,   2214,    211,
2114      &      0,   2212,    213,      0,   2212,   -211,      0,   2112,
2115      &    111,      0,   2212,    111,      0,   2112,    211,      0,
2116      &   3122,     22,      0,   2112,   -211,      0,   3122,    211,
2117      &      0,   3212,    211,      0,   3222,    111,      0,   3122,
2118      &    111,      0,   3222,   -211,      0,   3112,    211,      0,
2119      &   3122,   -211,      0,   3212,   -211,      0,   2112,   -311,
2120      &      0,   2212,   -321,      0,   3222,   -211,      0,   3212,
2121      &    111,      0,   3112,    211,      0,   3122,    221,      0,
2122      &   3224,   -211,      0,   3114,    211,      0,   3214,    111/
2123       DATA (isec_linear(K),K=  609,  760) /
2124      &      0,   2112,   -311,      0,   2212,   -321,      0,   3122,
2125      &    111,      0,   3122,    223,      0,   3122,    113,      0,
2126      &   3222,   -213,      0,   3112,    213,      0,   3212,    113,
2127      &      0,   3122,    221,      0,   3212,    221,      0,   3222,
2128      &   -211,      0,   3112,    211,      0,   3212,    111,      0,
2129      &   3122,    111,      0,   3122,   -211,      0,   3322,    111,
2130      &      0,   3312,    211,      0,   3322,   -211,      0,   3312,
2131      &    111,      0,   3322,   -211,      0,   3312,    111,      0,
2132      &   3122,   -321,      0,   3222,    221,      0,   3222,    331,
2133      &      0,   2212,   -311,      0,   3322,    321,      0,   3224,
2134      &    221,      0,   2214,    331,      0,   2224,   -321,      0,
2135      &   3122,    213,      0,   3212,    213,      0,   3222,    113,
2136      &      0,   3222,    223,      0,   2212,   -313,      0,   2214,
2137      &   -313,      0,   2224,   -323,      0,   4122,    211,      0,
2138      &   4122,    111,      0,   4122,   -211,      0,   3222,   -311,
2139      &      0,   3322,    211,      0,   3222,   -313,      0,   3322,
2140      &    213,      0,   3212,   -313,      0,   3222,   -323,      0,
2141      &   3322,    223,      0,   3312,    213,      0,   3214,   -313,
2142      &      0,   3322,   -311,      0,   3322,    313,      0,   3334/
2143       DATA (isec_linear(K),K=  761,  765) /
2144      &    213,      0,   3334,    211,      0/
2145       DATA (wg_chan(K),K=    1,  114) /
2146      &1.0000E+00,2.8000E-01,2.8000E-01,3.5000E-01,7.0000E-02,2.0000E-02,
2147      &1.0000E+00,9.9000E-01,1.0000E-02,3.8000E-01,3.0000E-02,3.0000E-01,
2148      &2.4000E-01,5.0000E-02,1.0000E+00,0.0000E+00,1.0000E+00,8.8800E-01,
2149      &2.5000E-02,8.7000E-02,4.8000E-01,2.4000E-01,2.6000E-01,2.0000E-02,
2150      &4.9100E-01,3.4400E-01,1.2900E-01,2.4000E-02,1.2000E-02,4.0000E-01,
2151      &3.0000E-01,3.0000E-01,6.0000E-01,4.0000E-01,4.0000E-01,3.0000E-01,
2152      &3.0000E-01,5.0000E-01,5.0000E-01,1.0000E+00,6.4000E-01,2.1000E-01,
2153      &6.0000E-02,2.0000E-02,3.0000E-02,4.0000E-02,6.9000E-01,3.1000E-01,
2154      &2.1000E-01,1.2000E-01,2.7000E-01,4.0000E-01,3.3000E-01,6.7000E-01,
2155      &3.3000E-01,6.7000E-01,3.3000E-01,6.7000E-01,3.3000E-01,6.7000E-01,
2156      &1.9000E-01,3.8000E-01,9.0000E-02,2.0000E-01,3.0000E-02,4.0000E-02,
2157      &5.0000E-02,2.0000E-02,1.9000E-01,3.8000E-01,9.0000E-02,2.0000E-01,
2158      &3.0000E-02,4.0000E-02,5.0000E-02,2.0000E-02,7.0000E-01,3.0000E-01,
2159      &1.0000E-01,5.0000E-01,1.6000E-01,2.4000E-01,5.5000E-01,4.5000E-01,
2160      &6.8000E-01,3.0000E-01,2.0000E-02,3.0000E-01,4.0000E-01,3.0000E-01,
2161      &9.0000E-01,1.0000E-01,4.9000E-01,4.9000E-01,2.0000E-02,1.0000E-01,
2162      &1.0000E-01,8.0000E-01,6.0000E-01,3.0000E-01,1.0000E-01,1.0000E+00,
2163      &1.5000E-01,3.5000E-01,7.0000E-02,1.8000E-01,1.1000E-01,6.0000E-02,
2164      &3.0000E-02,1.0000E-02,3.0000E-02,1.0000E-02,1.5000E-01,3.5000E-01/
2165       DATA (wg_chan(K),K=  115,  228) /
2166      &7.0000E-02,1.8000E-01,1.1000E-01,6.0000E-02,3.0000E-02,1.0000E-02,
2167      &3.0000E-02,1.0000E-02,3.7000E-01,1.8000E-01,4.0000E-02,8.0000E-02,
2168      &1.3000E-01,1.3000E-01,7.0000E-02,1.8000E-01,3.7000E-01,1.3000E-01,
2169      &8.0000E-02,4.0000E-02,7.0000E-02,1.3000E-01,1.3000E-01,7.0000E-02,
2170      &4.7000E-01,2.3000E-01,5.0000E-02,1.0000E-02,2.0000E-02,2.0000E-02,
2171      &7.0000E-02,1.3000E-01,2.3000E-01,4.7000E-01,5.0000E-02,2.0000E-02,
2172      &1.0000E-02,2.0000E-02,1.0000E+00,3.3000E-01,6.7000E-01,6.7000E-01,
2173      &3.3000E-01,1.0000E+00,2.5000E-01,1.8000E-01,2.7000E-01,3.0000E-01,
2174      &8.0000E-02,1.7000E-01,2.4000E-01,3.0000E-02,1.8000E-01,1.0000E-01,
2175      &2.0000E-01,1.7000E-01,8.0000E-02,1.8000E-01,3.0000E-02,2.4000E-01,
2176      &2.0000E-01,1.0000E-01,2.5000E-01,2.7000E-01,1.8000E-01,3.0000E-01,
2177      &6.4000E-01,3.6000E-01,5.2000E-01,4.8000E-01,1.0000E+00,1.0000E+00,
2178      &8.8000E-01,6.0000E-02,6.0000E-02,8.8000E-01,6.0000E-02,6.0000E-02,
2179      &8.8000E-01,1.2000E-01,1.9000E-01,1.9000E-01,1.6000E-01,1.6000E-01,
2180      &1.7000E-01,3.0000E-02,3.0000E-02,3.0000E-02,4.0000E-02,1.0000E-01,
2181      &1.0000E-01,2.0000E-01,1.2000E-01,1.0000E-01,4.0000E-02,4.0000E-02,
2182      &5.0000E-02,7.5000E-02,7.5000E-02,3.0000E-02,3.0000E-02,4.0000E-02,
2183      &1.0000E+00,1.0000E+00,3.3000E-01,6.7000E-01,6.7000E-01,3.3000E-01,
2184      &2.5000E-01,2.5000E-01,5.0000E-01,2.0000E-02,3.0000E-02,7.0000E-02/
2185       DATA (wg_chan(K),K=  229,  255) /
2186      &2.0000E-02,2.0000E-02,4.0000E-02,1.3000E-01,7.0000E-02,6.0000E-02,
2187      &6.0000E-02,2.0000E-01,1.4000E-01,4.0000E-02,1.0000E-01,1.0000E+00,
2188      &1.0000E+00,1.0000E+00,2.5000E-01,3.0000E-02,3.0000E-01,4.2000E-01,
2189      &2.2000E-01,3.5000E-01,1.9000E-01,1.6000E-01,8.0000E-02,3.7000E-01,
2190      &2.0000E-01,3.6000E-01,7.0000E-02/
2191       DATA (id_psm_linear(K),K=    1,   36) /
2192      &    111,    211,   -311,    411,      0,      0,   -211,    111,
2193      &   -321,    421,      0,      0,    311,    321,    221,    431,
2194      &      0,      0,   -411,   -421,   -431,    441,      0,      0,
2195      &      0,      0,      0,      0,      0,      0,      0,      0,
2196      &      0,      0,      0,      0/
2197       DATA (id_vem_linear(K),K=    1,   36) /
2198      &    113,    213,   -313,    413,      0,      0,   -213,    113,
2199      &   -323,    423,      0,      0,    313,    323,    333,    433,
2200      &      0,      0,   -413,   -423,   -433,  20443,      0,      0,
2201      &      0,      0,      0,      0,      0,      0,      0,      0,
2202      &      0,      0,      0,      0/
2203       DATA (id_b8_linear(K),K=    1,  171) /
2204      &  1114,  2112,  3112,  4112,     0,     0,  2112,  2212,  3212,
2205      &  4122,     0,     0,  3112,  3212,  3312,  4132,     0,     0,
2206      &  4112,  4122,  4132,  4412,     0,     0,     0,     0,     0,
2207      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2208      &  2112,  2212,  3212,  4122,     0,     0,  2212,  2224,  3222,
2209      &  4222,     0,     0,  3212,  3222,  3322,  4232,     0,     0,
2210      &  4122,  4222,  4232,  4422,     0,     0,     0,     0,     0,
2211      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2212      &  3112,  3212,  3312,  4132,     0,     0,  3212,  3222,  3322,
2213      &  4232,     0,     0,  3312,  3322,  3334,  4332,     0,     0,
2214      &  4132,  4232,  4332,  4432,     0,     0,     0,     0,     0,
2215      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2216      &  4112,  4122,  4132,  4412,     0,     0,  4122,  4222,  4232,
2217      &  4422,     0,     0,  4132,  4232,  4332,  4432,     0,     0,
2218      &  4412,  4422,  4432,  4444,     0,     0,     0,     0,     0,
2219      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2220      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2221      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2222      &     0,     0,     0,     0,     0,     0,     0,     0,     0/
2223       DATA (id_b8_linear(K),K=  172,  216) /
2224      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2225      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2226      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2227      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2228      &     0,     0,     0,     0,     0,     0,     0,     0,     0/
2229       DATA (id_b10_linear(K),K=    1,  171) /
2230      &  1114,  2114,  3114,  4114,     0,     0,  2114,  2214,  3214,
2231      &  4214,     0,     0,  3114,  3214,  3314,  4314,     0,     0,
2232      &  4114,  4214,  4314,  4414,     0,     0,     0,     0,     0,
2233      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2234      &  2114,  2214,  3214,  4214,     0,     0,  2214,  2224,  3224,
2235      &  4224,     0,     0,  3214,  3224,  3324,  4324,     0,     0,
2236      &  4214,  4224,  4324,  4424,     0,     0,     0,     0,     0,
2237      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2238      &  3114,  3214,  3314,  4314,     0,     0,  3214,  3224,  3324,
2239      &  4324,     0,     0,  3314,  3324,  3334,  4334,     0,     0,
2240      &  4314,  4324,  4334,  4434,     0,     0,     0,     0,     0,
2241      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2242      &  4114,  4214,  4314,  4414,     0,     0,  4214,  4224,  4324,
2243      &  4424,     0,     0,  4314,  4324,  4334,  4434,     0,     0,
2244      &  4414,  4424,  4434,  4444,     0,     0,     0,     0,     0,
2245      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2246      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2247      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2248      &     0,     0,     0,     0,     0,     0,     0,     0,     0/
2249       DATA (id_b10_linear(K),K=  172,  216) /
2250      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2251      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2252      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2253      &     0,     0,     0,     0,     0,     0,     0,     0,     0,
2254      &     0,     0,     0,     0,     0,     0,     0,     0,     0/
2255
2256       ID_pdg_max = i_tab_max
2257
2258 C  copy from local to global variables
2259       do i=1,i_tab_max
2260         ID_pdg_list(i) = number(i)
2261         name_list(i)   = name(i)
2262         xm_list(i)     = xmass(i)
2263         gam_list(i)    = gamma(i)
2264         ich3_list(i)   = ich3(i)
2265         iba3_list(i)   = iba3(i)
2266         do j=1,3
2267           iq_list(j,i)   = iq_linear(3*(i-1)+j)
2268           idec_list(j,i) = idec_linear(3*(i-1)+j)
2269         enddo
2270       enddo
2271
2272 C  initialize hash table
2273       call pho_cpcini(ID_pdg_max,ID_pdg_list,ID_list)
2274
2275       itmp = IDEB(71)
2276       IDEB(71) = -1
2277
2278 C  quark index table for mesons
2279       do i=1,6
2280         do j=1,6
2281           id_psm_list(i,j) = ipho_pdg2id(id_psm_linear(6*(j-1)+i))
2282           id_vem_list(i,j) = ipho_pdg2id(id_vem_linear(6*(j-1)+i))
2283         enddo
2284       enddo
2285
2286 C  quark index table for baryons
2287       do i=1,6
2288         do j=1,6
2289           do k=1,6
2290             id_b8_list(i,j,k)  =
2291      &        ipho_pdg2id(id_b8_linear(36*(k-1)+6*(j-1)+i))
2292             id_b10_list(i,j,k) =
2293      &        ipho_pdg2id(id_b10_linear(36*(k-1)+6*(j-1)+i))
2294           enddo
2295         enddo
2296       enddo
2297
2298       IDEB(71) = itmp
2299
2300 C  copy secondary particles
2301 C  (translate PDG-ID to CPC and sort according to CPC)
2302       ichan = 0
2303       do i=1,i_tab_max
2304         if(idec_list(1,i).ne.0) then
2305           do j=idec_list(2,i),idec_list(3,i)
2306             ichan = ichan+1
2307             wg_sec_list(ichan) = wg_chan(j)
2308             do k=1,3
2309               if(isec_linear(3*(j-1)+k).ne.0) then
2310                 isec_list(k,ichan) = ipho_pdg2id(isec_linear(3*(j-1)+k))
2311               else
2312                 isec_list(k,ichan) = 0
2313               endif
2314             enddo
2315           enddo
2316         endif
2317       enddo
2318
2319 C  add two-pion background (low-mass photon dissociation)
2320       i = ipho_pdg2id(92)
2321       ichan = ichan+1
2322       idec_list(1,i) = 1
2323       idec_list(2,i) = ichan
2324       idec_list(3,i) = ichan
2325       wg_sec_list(ichan) = 1.D0
2326       isec_list(1,ichan) = ipho_pdg2id(211)
2327       isec_list(2,ichan) = ipho_pdg2id(-211)
2328       isec_list(3,ichan) = 0
2329
2330 C  min. mass limits for strings: q-qbar
2331       do i=1,6
2332         do j=1,6
2333           AM2P = 1000.D0
2334           AM2V = 1000.D0
2335           do k=1,3
2336 C  pseudo-scalar mesons
2337             i1 = iabs(id_psm_list(i,k))
2338             if(i1.ne.0) then
2339               AM1 = xm_list(i1)
2340             else
2341               AM1 = pho_pmass(i,3)+pho_pmass(k,3)
2342             endif
2343             i2 = iabs(id_psm_list(k,j))
2344             if(i2.ne.0) then
2345               AM2 = xm_list(i2)
2346             else
2347               AM2 = pho_pmass(k,3)+pho_pmass(j,3)
2348             endif
2349             AM2P = MIN(AM2P,AM1+AM2)
2350 C  vector mesons
2351             i1 = iabs(id_vem_list(i,k))
2352             if(i1.ne.0) then
2353               AM1 = xm_list(i1)
2354             else
2355               AM1 = pho_pmass(i,3)+pho_pmass(k,3)
2356             endif
2357             i2 = iabs(id_vem_list(k,j))
2358             if(i2.ne.0) then
2359               AM2 = xm_list(i2)
2360             else
2361               AM2 = pho_pmass(k,3)+pho_pmass(j,3)
2362             endif
2363             AM2V = MIN(AM2V,AM1+AM2)
2364           enddo
2365           xm_psm2_list(i,j) = AM2P
2366           xm_vem2_list(i,j) = AM2V
2367         enddo
2368       enddo
2369
2370 C  min. mass limits for strings: qq-q
2371       do i=1,6
2372         do j=1,6
2373           do k=1,6
2374             AM82  = 1000.D0
2375             AM102 = 1000.D0
2376             do l=1,3
2377 C  pseudo-scalar meson
2378               i1 = iabs(id_psm_list(k,l))
2379               if(i1.ne.0) then
2380                 AM1 = xm_list(i1)
2381               else
2382                 AM1 = pho_pmass(i,3)+pho_pmass(k,3)
2383               endif
2384 C  vector meson
2385               i2 = iabs(id_vem_list(k,l))
2386               if(i2.ne.0) then
2387                 AM2 = xm_list(i2)
2388               else
2389                 AM2 = pho_pmass(i,3)+pho_pmass(k,3)
2390               endif
2391 C  octet baryon
2392               AMM = min(AM1,AM2)
2393               K8  = id_b8_list(i,j,l)
2394               if(K8.ne.0) then
2395                 AM1 = xm_list(K8)
2396               else
2397                 AM1 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
2398               endif
2399               AM82  = MIN(AM82, AM1 + AMM)
2400 C  decuplet baryon
2401               K10 = id_b10_list(i,j,l)
2402               if(K10.ne.0) then
2403                 AM2 = xm_list(K10)
2404               else
2405                 AM2 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
2406               endif
2407               AM102 = MIN(AM102, AM2 + AMM)
2408             enddo
2409             xm_b82_list(i,j,k)  = AM82
2410             xm_b102_list(i,j,k) = AM102
2411           enddo
2412         enddo
2413       enddo
2414
2415 C  min. mass limits for strings: qq-qbarqbar
2416       do i=1,6
2417         do j=1,6
2418           do ii=1,6
2419             do jj=1,6
2420               AM82  = 1000.D0
2421               AM102 = 1000.D0
2422               do l=1,3
2423 C  octet baryons
2424                 K8  = id_b8_list(i,j,l)
2425                 if(K8.ne.0) then
2426                   AM1 = xm_list(K8)
2427                 else
2428                   AM1 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
2429                 endif
2430                 L8  = id_b8_list(ii,jj,l)
2431                 if(L8.ne.0) then
2432                   AM2 = xm_list(L8)
2433                 else
2434                   AM2 = pho_pmass(ii,3)+pho_pmass(jj,3)+pho_pmass(l,3)
2435                 endif
2436                 AM82  = MIN(AM82, AM1+AM2)
2437 C  decuplet baryons
2438                 K10 = id_b10_list(i,j,l)
2439                 if(K10.ne.0) then
2440                   AM1 = xm_list(K10)
2441                 else
2442                   AM1 = pho_pmass(i,3)+pho_pmass(j,3)+pho_pmass(l,3)
2443                 endif
2444                 L10 = id_b10_list(ii,jj,l)
2445                 if(L10.ne.0) then
2446                   AM2 = xm_list(L10)
2447                 else
2448                   AM2 = pho_pmass(ii,3)+pho_pmass(jj,3)+pho_pmass(l,3)
2449                 endif
2450                 AM102 = MIN(AM102, AM1+AM2)
2451               enddo
2452               xm_bb82_list(i,j,ii,jj)  = AM82
2453               xm_bb102_list(i,j,ii,jj) = AM102
2454             enddo
2455           enddo
2456         enddo
2457       enddo
2458
2459       END
2460
2461 *$ CREATE PHO_PRESEL.FOR
2462 *COPY PHO_PRESEL
2463 CDECK  ID>, PHO_PRESEL
2464       SUBROUTINE PHO_PRESEL(MODE,IREJ)
2465 C**********************************************************************
2466 C
2467 C     user specific function to pre-select events during generation
2468 C
2469 C     input:   MODE  5  electron and photon kinematics
2470 C                   10  process and number of cut Pomerons
2471 C                   15  partons without construction of strings
2472 C                   20  partons assigned to strings
2473 C                   25  after fragmentation, complete final state
2474 C
2475 C     output:  IREJ  0  event accepted
2476 C                   50  event rejected
2477 C
2478 C**********************************************************************
2479       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2480       SAVE
2481
2482 C  input/output channels
2483       INTEGER LI,LO
2484       COMMON /POINOU/ LI,LO
2485 C  event debugging information
2486       INTEGER NMAXD
2487       PARAMETER (NMAXD=100)
2488       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2489      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2490       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2491      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2492 C  standard particle data interface
2493       INTEGER NMXHEP
2494       PARAMETER (NMXHEP=4000)
2495       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
2496       DOUBLE PRECISION PHEP,VHEP
2497       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2498      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
2499      &                VHEP(4,NMXHEP)
2500 C  extension to standard particle data interface (PHOJET specific)
2501       INTEGER IMPART,IPHIST,ICOLOR
2502       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
2503 C  global event kinematics and particle IDs
2504       INTEGER IFPAP,IFPAB
2505       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
2506       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
2507 C  gamma-lepton or gamma-hadron vertex information
2508       INTEGER IGHEL,IDPSRC,IDBSRC
2509       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
2510      &                 RADSRC,AMSRC,GAMSRC
2511       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
2512      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
2513      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
2514 C  hard scattering data
2515       INTEGER MSCAHD
2516       PARAMETER ( MSCAHD = 50 )
2517       INTEGER LSCAHD,LSC1HD,LSIDX,
2518      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
2519       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
2520       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
2521      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
2522      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
2523      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
2524      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
2525      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
2526      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
2527 C  event weights and generated cross section
2528       INTEGER IPOWGC,ISWCUT,IVWGHT
2529       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2530       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2531      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2532
2533       IREJ = 0
2534
2535 *     XBJ = GQ2(2)/(GGECM**2+GQ2(2))
2536 *     IF(XBJ.LT.0.002D0) IREJ = 1
2537
2538       END
2539
2540 *$ CREATE PHO_FIXCOL.FOR
2541 *COPY PHO_FIXCOL
2542 CDECK  ID>, PHO_FIXCOL
2543       SUBROUTINE PHO_FIXCOL(E1,E2,THETA,PHI,NEV)
2544 C**********************************************************************
2545 C
2546 C     interface to call PHOJET (fixed energy run) with
2547 C     collider kinematics
2548 C
2549 C     equivalen photon approximation to get photon flux
2550 C
2551 C     input:     NEV     number of events to generate
2552 C                THETA   azimuthal angle (micro radians)
2553 C                PHI     beam crossing angle
2554 C                        (with respect to x, in degrees)
2555 C                E1      energy of particle 1 (+z direction, GeV)
2556 C                E2      energy of particle 2 (-z direction, GeV)
2557 C
2558 C     note: particle types have to be specified before
2559 C           with PHO_SETPAR
2560 C
2561 C**********************************************************************
2562       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2563       SAVE
2564
2565       PARAMETER(TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
2566
2567 C  input/output channels
2568       INTEGER LI,LO
2569       COMMON /POINOU/ LI,LO
2570 C  event debugging information
2571       INTEGER NMAXD
2572       PARAMETER (NMAXD=100)
2573       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2574      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2575       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2576      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2577 C  general process information
2578       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
2579       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
2580 C  global event kinematics and particle IDs
2581       INTEGER IFPAP,IFPAB
2582       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
2583       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
2584 C  model switches and parameters
2585       CHARACTER*8 MDLNA
2586       INTEGER ISWMDL,IPAMDL
2587       DOUBLE PRECISION PARMDL
2588       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
2589 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
2590       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
2591       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
2592       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
2593      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
2594 C  integration precision for hard cross sections (obsolete)
2595       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2596       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2597 C  event weights and generated cross section
2598       INTEGER IPOWGC,ISWCUT,IVWGHT
2599       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2600       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2601      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2602
2603       DIMENSION P1(4),P2(4)
2604
2605 C  remnant initialization (only needed for DPMJET)
2606       ISAVP1 = IFPAP(1)
2607       ISAVB1 = IFPAB(1)
2608       IF(IFPAP(1).EQ.81) THEN
2609         IFPAP(1) = IDEQP(1)
2610         IFPAB(1) = IDEQB(1)
2611       ENDIF
2612       ISAVP2 = IFPAP(2)
2613       ISAVB2 = IFPAB(2)
2614       IF(IFPAP(2).EQ.82) THEN
2615         IFPAP(2) = IDEQP(2)
2616         IFPAB(2) = IDEQB(2)
2617       ENDIF
2618       PMASS1 = PHO_PMASS(IFPAB(1),0)-SQRT(PVIRT(1))
2619       PMASS2 = PHO_PMASS(IFPAB(2),0)-SQRT(PVIRT(2))
2620       PP1 = SQRT(E1**2-PMASS1**2)
2621       PP2 = SQRT(E2**2-PMASS2**2)
2622 C  beam crossing angle
2623       TH = 1.D-6*THETA/2.D0
2624       PH = PHI*BOG
2625       P1(1) = PP1*SIN(TH)*COS(PH)
2626       P1(2) = PP1*SIN(TH)*SIN(PH)
2627       P1(3) = PP1*COS(TH)
2628       P1(4) = E1
2629       P2(1) = PP2*SIN(TH)*COS(PH)
2630       P2(2) = PP2*SIN(TH)*SIN(PH)
2631       P2(3) = -PP2*COS(TH)
2632       P2(4) = E2
2633       CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
2634       IFPAP(1) = ISAVP1
2635       IFPAB(1) = ISAVB1
2636       IFPAP(2) = ISAVP2
2637       IFPAB(2) = ISAVB2
2638       ITRY = 0
2639       CALL PHO_PHIST(-1,SIGMAX)
2640       CALL PHO_LHIST(-1,SIGMAX)
2641 C  test of DPMJET interface (default is IPAMDL(13)=0)
2642       if(IPAMDL(13).gt.0) then
2643         MODE = IPAMDL(13)
2644         IPAMDL(13) = 0
2645       else
2646         MODE = 1
2647       endif
2648 C  main generation loop
2649       DO 50 I=1,NEV
2650  55     CONTINUE
2651         ITRY = ITRY+1
2652         CALL PHO_EVENT(MODE,P1,P2,SIGCUR,IREJ)
2653         IF(IREJ.NE.0) GOTO 55
2654         CALL PHO_PHIST(1,HSWGHT(0))
2655         CALL PHO_LHIST(1,HSWGHT(0))
2656  50   CONTINUE
2657
2658       IF(NEV.GT.0) THEN
2659         SIGMAX = SIGMAX*DBLE(NEV)/DBLE(ITRY)
2660         WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
2661      &  '=========================================================',
2662      &  ' *****   simulated cross section: ',SIGMAX,' mb  *****',
2663      &  '========================================================='
2664         CALL PHO_EVENT(-2,P1,P2,SIGCUR,IREJ)
2665         CALL PHO_PHIST(-2,SIGMAX)
2666         CALL PHO_LHIST(-2,SIGMAX)
2667       ELSE
2668         WRITE(LO,'(1X,A,I5)') 'POFCOL: no events simulated',NEV
2669       ENDIF
2670
2671       END
2672
2673 *$ CREATE PHO_FIXLAB.FOR
2674 *COPY PHO_FIXLAB
2675 CDECK  ID>, PHO_FIXLAB
2676       SUBROUTINE PHO_FIXLAB(PLAB,NEV)
2677 C**********************************************************************
2678 C
2679 C     interface to call PHOJET (fixed energy run) with
2680 C     LAB kinematics (second particle as target)
2681 C
2682 C     equivalent photon approximation to get photon flux
2683 C
2684 C     input:     NEV     number of events to generate
2685 C                PLAB    LAB momentum of particle 1
2686 C
2687 C     note: particle types have to be specified before
2688 C           with PHO_SETPAR
2689 C
2690 C**********************************************************************
2691       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2692       SAVE
2693
2694 C  input/output channels
2695       INTEGER LI,LO
2696       COMMON /POINOU/ LI,LO
2697 C  event debugging information
2698       INTEGER NMAXD
2699       PARAMETER (NMAXD=100)
2700       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2701      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2702       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2703      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2704 C  general process information
2705       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
2706       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
2707 C  global event kinematics and particle IDs
2708       INTEGER IFPAP,IFPAB
2709       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
2710       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
2711 C  model switches and parameters
2712       CHARACTER*8 MDLNA
2713       INTEGER ISWMDL,IPAMDL
2714       DOUBLE PRECISION PARMDL
2715       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
2716 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
2717       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
2718       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
2719       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
2720      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
2721 C  integration precision for hard cross sections (obsolete)
2722       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2723       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
2724 C  event weights and generated cross section
2725       INTEGER IPOWGC,ISWCUT,IVWGHT
2726       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2727       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2728      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2729
2730       DIMENSION P1(4),P2(4)
2731
2732 C  remnant initialization (only needed for DPMJET)
2733       SPCM = PLAB
2734       ISAVP1 = IFPAP(1)
2735       ISAVB1 = IFPAB(1)
2736       IF(IFPAP(1).EQ.81) THEN
2737         IFPAP(1) = IDEQP(1)
2738         IFPAB(1) = IDEQB(1)
2739       ENDIF
2740       ISAVP2 = IFPAP(2)
2741       ISAVB2 = IFPAB(2)
2742       IF(IFPAP(2).EQ.82) THEN
2743         IFPAP(2) = IDEQP(2)
2744         IFPAB(2) = IDEQB(2)
2745       ENDIF
2746 C  get momenta in LAB system
2747       PMASS1 = PHO_PMASS(IFPAB(1),0)**2-PVIRT(1)
2748       PMASS2 = PHO_PMASS(IFPAB(2),0)**2-PVIRT(2)
2749       IF(PMASS2.LT.0.1D0) THEN
2750         WRITE(LO,'(/1X,2A,2I7)') 'PHO_FIXLAB:ERROR: ',
2751      &    'no LAB system possible',IFPAB(1),IFPAB(2)
2752       ELSE
2753         P1(1) = 0.D0
2754         P1(2) = 0.D0
2755         P1(3) = PLAB
2756         P1(4) = SQRT(PMASS1+PLAB**2)
2757         P2(1) = 0.D0
2758         P2(2) = 0.D0
2759         P2(3) = 0.D0
2760         P2(4) = SQRT(PMASS2)
2761         CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
2762         IFPAP(1) = ISAVP1
2763         IFPAB(1) = ISAVB1
2764         IFPAP(2) = ISAVP2
2765         IFPAB(2) = ISAVB2
2766         ITRY = 0
2767         CALL PHO_PHIST(-1,SIGMAX)
2768         CALL PHO_LHIST(-1,SIGMAX)
2769 C  event generation loop
2770         DO 40 I=1,NEV
2771  45       CONTINUE
2772           ITRY = ITRY+1
2773           CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
2774           IF(IREJ.NE.0) GOTO 45
2775           CALL PHO_LHIST(1,HSWGHT(0))
2776           CALL PHO_PHIST(10,HSWGHT(0))
2777  40     CONTINUE
2778         IF(NEV.GT.0) THEN
2779           SIGMAX = SIGMAX*DBLE(NEV)/DBLE(ITRY)
2780           WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
2781      &    '=========================================================',
2782      &    ' *****   simulated cross section: ',SIGMAX,' mb  *****',
2783      &    '========================================================='
2784           CALL PHO_EVENT(-2,P1,P2,SIGCUR,IREJ)
2785           CALL PHO_PHIST(-2,SIGMAX)
2786           CALL PHO_LHIST(-2,SIGMAX)
2787         ELSE
2788           WRITE(LO,'(1X,A,I5)')
2789      &      'PHO_FIXLAB: no events simulated',NEV
2790         ENDIF
2791       ENDIF
2792
2793       END
2794
2795 *$ CREATE PHO_GPHERA.FOR
2796 *COPY PHO_GPHERA
2797 CDECK  ID>, PHO_GPHERA
2798       SUBROUTINE PHO_GPHERA(NEVENT,EE1,EE2)
2799 C**********************************************************************
2800 C
2801 C     interface to call PHOJET (variable energy run) with
2802 C     HERA kinematics, photon as particle 2
2803 C
2804 C     equivalent photon approximation to get photon flux
2805 C
2806 C     input:     NEVENT  number of events to generate
2807 C                EE1     proton energy (LAB system)
2808 C                EE2     electron energy (LAB system)
2809 C             from /POFCUT/:
2810 C                YMIN2    lower limit of Y
2811 C                        (energy fraction taken by photon from electron)
2812 C                YMAX2    upper limit of Y
2813 C                Q2MIN2   lower limit of photon virtuality
2814 C                Q2MAX2   upper limit of photon virtuality
2815 C
2816 C**********************************************************************
2817       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2818       SAVE
2819
2820       PARAMETER ( DEPS = 1.D-10,
2821      &            PI   = 3.14159265359D0 )
2822
2823 C  input/output channels
2824       INTEGER LI,LO
2825       COMMON /POINOU/ LI,LO
2826 C  event debugging information
2827       INTEGER NMAXD
2828       PARAMETER (NMAXD=100)
2829       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
2830      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2831       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
2832      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
2833 C  model switches and parameters
2834       CHARACTER*8 MDLNA
2835       INTEGER ISWMDL,IPAMDL
2836       DOUBLE PRECISION PARMDL
2837       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
2838 C  photon flux kinematics and cuts
2839       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
2840      &                 YMIN1,YMAX1,YMIN2,YMAX2,
2841      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
2842      &                 THMIN1,THMAX1,THMIN2,THMAX2
2843       INTEGER          ITAG1,ITAG2
2844       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
2845      &                YMIN1,YMAX1,YMIN2,YMAX2,
2846      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
2847      &                THMIN1,THMAX1,THMIN2,THMAX2,
2848      &                ITAG1,ITAG2
2849 C  gamma-lepton or gamma-hadron vertex information
2850       INTEGER IGHEL,IDPSRC,IDBSRC
2851       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
2852      &                 RADSRC,AMSRC,GAMSRC
2853       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
2854      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
2855      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
2856 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
2857       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
2858       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
2859       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
2860      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
2861 C  event weights and generated cross section
2862       INTEGER IPOWGC,ISWCUT,IVWGHT
2863       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
2864       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
2865      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
2866
2867       DIMENSION P1(4),P2(4)
2868
2869       WRITE(LO,'(//1X,A,I10)') 'PHO_GPHERA: events to process',NEVENT
2870 C  assign particle momenta according to HERA kinematics
2871 C  proton data
2872       PROM = PHO_PMASS(2212,1)
2873       PROM2 = PROM**2
2874       IDPSRC(1) = 0
2875       IDBSRC(1) = 0
2876 C  electron data
2877       ELEM = 0.512D-03
2878       ELEM2 = ELEM**2
2879       AMSRC(2) = ELEM
2880       IDPSRC(2) = 11
2881       IDBSRC(2) = ipho_pdg2id(11)
2882 C
2883       Q2MIN = Q2MIN2
2884       Q2MAX = Q2MAX2
2885 C
2886       XIMAX = LOG(YMAX2)
2887       XIMIN = LOG(YMIN2)
2888       XIDEL = XIMAX-XIMIN
2889 C
2890       IF(Q2MIN.GT.ELEM2*YMIN2**2/(1.D0-YMIN2))
2891      &  WRITE(LO,'(/1X,A,1P2E11.4)')
2892      &  'PHO_GPHERA: lower Q2 cutoff larger than kin. limit:',
2893      &  Q2MIN,ELEM2*YMIN2**2/(1.D0-YMIN2)
2894 C
2895       Max_tab = 50
2896       DELLY = LOG(YMAX2/YMIN2)/DBLE(Max_tab-1)
2897       FLUXT = 0.D0
2898       FLUXL = 0.D0
2899       IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
2900      &  'PHO_GPHERA: table of photon flux (trans/long)',Max_tab
2901       DO 100 I=1,Max_tab
2902         Y = EXP(XIMIN+DELLY*DBLE(I-1))
2903         Q2LOW = MAX(Q2MIN,ELEM2*Y**2/(1.D0-Y))
2904         FFT = ((1.D0+(1.D0-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2905      &         -2.D0*ELEM2*Y*(1.D0/Q2LOW-1.D0/Q2MAX))/(2.D0*PI*137.D0)
2906         FFL = 2.D0*(1.D0-Y)/Y*LOG(Q2MAX/Q2LOW)/(2.D0*PI*137.D0)
2907         FLUXT = FLUXT + Y*FFT
2908         FLUXL = FLUXL + Y*FFL
2909         IF(IDEB(30).GE.1) WRITE(LO,'(5X,1P3E14.4)') Y,FFT,FFL
2910  100  CONTINUE
2911       FLUXT = FLUXT*DELLY
2912       FLUXL = FLUXL*DELLY
2913       IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,1P2E12.4)')
2914      &  'PHO_GPHERA: integrated flux (trans./long.):',FLUXT,FLUXL
2915 C
2916       AY = 0.D0
2917       AY2 = 0.D0
2918       YY = YMIN2
2919       Q2LOW = MAX(Q2MIN,ELEM2*YY**2/(1.D0-YY))
2920       WGMAX = (1.D0+(1.D0-YY)**2)*LOG(Q2MAX/Q2LOW)
2921      &        -2.D0*ELEM2*YY*(1.D0/Q2LOW-1.D0/Q2MAX)*YY
2922       IF(ISWMDL(10).GE.2) WGMAX = WGMAX+2.D0*(1.D0-YY)*LOG(Q2MAX/Q2LOW)
2923 C
2924 C  initialization of PHOJET at upper energy limit
2925 C  proton momentum
2926       P1(1) = 0.D0
2927       P1(2) = 0.D0
2928       P1(3) = SQRT(EE1**2-PROM2+DEPS)
2929       P1(4) = EE1
2930 C  photon momentum
2931       EGAM = YMAX2*EE2
2932       P2(1) = 0.D0
2933       P2(2) = 0.D0
2934       P2(3) = -EGAM
2935       P2(4) = EGAM
2936 C  sum of both photon polarizations
2937       IGHEL(2) = -1
2938 C
2939       CALL PHO_SETPAR(1,2212,0,0.D0)
2940       CALL PHO_SETPAR(2,22,0,0.D0)
2941       CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
2942       CALL PHO_PHIST(-1,SIGMAX)
2943       CALL PHO_LHIST(-1,SIGMAX)
2944 C
2945 C  generation of events, flux calculation
2946       ECMIN2 = ECMIN**2
2947       ECMAX2 = ECMAX**2
2948       AY = 0.D0
2949       AY2 = 0.D0
2950       Q22MIN = 1.D30
2951       Q22AVE = 0.D0
2952       Q22AV2 = 0.D0
2953       Q22MAX = 0.D0
2954       AN2MIN = 1.D30
2955       AN2MAX = 0.D0
2956       YY2MIN = 1.D30
2957       YY2MAX = 0.D0
2958       NITER = NEVENT
2959       ITRY = 0
2960       ITRW = 0
2961       DO 200 I=1,NITER
2962  150    CONTINUE
2963 C  sample y
2964         ITRY = ITRY+1
2965  175    CONTINUE
2966           ITRW = ITRW+1
2967           YY = EXP(XIDEL*DT_RNDM(AY)+XIMIN)
2968           IF(ISWMDL(10).GE.2) THEN
2969             YEFF = 1.D0+(1.D0-YY)**2+2.D0*(1.D0-YY)
2970           ELSE
2971             YEFF = 1.D0+(1.D0-YY)**2
2972           ENDIF
2973           Q2LOW = MAX(Q2MIN,ELEM2*YY**2/(1.D0-YY))
2974           Q2LOG = LOG(Q2MAX/Q2LOW)
2975           WGH = YEFF*Q2LOG-2.D0*ELEM2*YY**2*(1.D0/Q2LOW-1.D0/Q2MAX)
2976           IF(WGMAX.LT.WGH) THEN
2977             WRITE(LO,'(1X,A,3E12.5)')
2978      &        'PHO_GPHERA: inconsistent weight:',YY,WGMAX,WGH
2979           ENDIF
2980         IF(DT_RNDM(AY2)*WGMAX.GT.WGH) GOTO 175
2981 C  sample Q2
2982         IF(IPAMDL(174).EQ.1) THEN
2983  185      CONTINUE
2984             Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
2985             WEIGHT = (YEFF-2.D0*ELEM2*YY**2/Q2)/YEFF
2986           IF(WEIGHT.LT.DT_RNDM(Q2)) GOTO 185
2987         ELSE
2988           Q2 = Q2LOW
2989         ENDIF
2990 C
2991 C  incoming electron
2992         PINI(1,2) = 0.D0
2993         PINI(2,2) = 0.D0
2994         PINI(3,2) = -EE2
2995         PINI(4,2) = EE2
2996         PINI(5,2) = 0.D0
2997 C  outgoing electron
2998         YQ2 = SQRT((1.D0-YY)*Q2)
2999         Q2E = Q2/(4.D0*EE2)
3000         E1Y = EE2*(1.D0-YY)
3001         CALL PHO_SFECFE(SIF,COF)
3002         PFIN(1,2) = YQ2*COF
3003         PFIN(2,2) = YQ2*SIF
3004         PFIN(3,2) = -E1Y+Q2E
3005         PFIN(4,2) = E1Y+Q2E
3006         PFIN(5,2) = 0.D0
3007 C  set /POFSRC/
3008         GYY(2) = YY
3009         GQ2(2) = Q2
3010 C  polar angle
3011         PFTHE(2) = ACOS(PFIN(3,2)/PFIN(4,2))
3012 C  electron tagger
3013         IF(PFIN(4,2).GT.EEMIN2) THEN
3014           IF((PFTHE(2).LT.THMIN2).OR.(PFTHE(2).GT.THMAX2)) GOTO 175
3015         ENDIF
3016 C  azimuthal angle
3017         PFPHI(2) = ATAN2(COF,SIF)
3018 C  photon momentum
3019         P2(1) = -PFIN(1,2)
3020         P2(2) = -PFIN(2,2)
3021         P2(3) = PINI(3,2)-PFIN(3,2)
3022         P2(4) = PINI(4,2)-PFIN(4,2)
3023 C  proton momentum
3024         P1(1) = 0.D0
3025         P1(2) = 0.D0
3026         P1(3) = SQRT(EE1**2-PROM2)
3027         P1(4) = EE1
3028 C  ECMS cut
3029         GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
3030      &         -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
3031         IF((GGECM.LT.ECMIN2).OR.(GGECM.GT.ECMAX2)) GOTO 175
3032         GGECM = SQRT(GGECM)
3033 C
3034         PGAM(1,2) = P2(1)
3035         PGAM(2,2) = P2(2)
3036         PGAM(3,2) = P2(3)
3037         PGAM(4,2) = P2(4)
3038         PGAM(5,2) = -SQRT(Q2)
3039 C  photon helicity
3040         IF(ISWMDL(10).GE.2) THEN
3041           WGH  = YEFF-2.D0*ELEM2*YY**2/Q2
3042           WGHL = 2.D0*(1-YY)
3043           IF(DT_RNDM(YY).GE.WGHL/WGH) THEN
3044             IGHEL(2) = 1
3045           ELSE
3046             IGHEL(2) = 0
3047           ENDIF
3048         ELSE
3049           IGHEL(2) = -1
3050         ENDIF
3051 C  user cuts
3052         CALL PHO_PRESEL(5,IREJ)
3053         IF(IREJ.NE.0) GOTO 175
3054 C  event generation
3055         CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
3056         IF(IREJ.NE.0) GOTO 150
3057 C  statistics
3058         AY = AY+YY
3059         AY2 = AY2+YY*YY
3060         YY2MIN = MIN(YY2MIN,YY)
3061         YY2MAX = MAX(YY2MAX,YY)
3062         Q22MIN = MIN(Q22MIN,Q2)
3063         Q22MAX = MAX(Q22MAX,Q2)
3064         Q22AVE = Q22AVE+Q2
3065         Q22AV2 = Q22AV2+Q2*Q2
3066         AN2MIN = MIN(AN2MIN,PFTHE(2))
3067         AN2MAX = MAX(AN2MAX,PFTHE(2))
3068 C  histograms
3069         CALL PHO_PHIST(1,HSWGHT(0))
3070         CALL PHO_LHIST(1,HSWGHT(0))
3071  200  CONTINUE
3072 C
3073       WGY = WGMAX*DBLE(ITRY)/DBLE(ITRW)/(137.D0*2.D0*PI)
3074       WGY = WGY*LOG(YMAX2/YMIN2)
3075       AY  = AY/DBLE(NITER)
3076       AY2 = AY2/DBLE(NITER)
3077       DAY = SQRT((AY2-AY**2)/DBLE(NITER))
3078       Q22AVE = Q22AVE/DBLE(NITER)
3079       Q22AV2 = Q22AV2/DBLE(NITER)
3080       Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
3081       WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
3082 C  output of histograms
3083       WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
3084      &'=========================================================',
3085      &' *****   simulated cross section: ',WEIGHT,' mb  *****',
3086      &'========================================================='
3087       WRITE(LO,'(//1X,A,3I10)')
3088      &  'PHO_GPHERA:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
3089       WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
3090      &  WGY,WEIGHT
3091       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y,DY                 ',AY,DAY
3092       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON       ',
3093      &  YY2MIN,YY2MAX
3094       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2               ',
3095      &  Q22AVE,Q22AV2
3096       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON      ',
3097      &  Q22MIN,Q22MAX
3098       WRITE(LO,'(1X,A,1P4E12.4)') 'SAMPLED THETA RANGE ELECTRON ',
3099      &  AN2MIN,AN2MAX,PI-AN2MAX,PI-AN2MIN
3100 C
3101       CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
3102       IF(NITER.GT.1) THEN
3103         CALL PHO_PHIST(-2,WEIGHT)
3104         CALL PHO_LHIST(-2,WEIGHT)
3105       ELSE
3106         WRITE(LO,'(1X,A,I4)') 'PHO_GPHERA:NO OUTPUT OF HISTOGRAMS',NITER
3107       ENDIF
3108
3109       END
3110
3111 *$ CREATE PHO_GGEPEM.FOR
3112 *COPY PHO_GGEPEM
3113 CDECK  ID>, PHO_GGEPEM
3114       SUBROUTINE PHO_GGEPEM(NEVENT,EE1,EE2)
3115 C**********************************************************************
3116 C
3117 C     interface to call PHOJET (variable energy run) for
3118 C     gamma-gamma collisions on e+e- collider
3119 C
3120 C     fully differential equivalent (improved) photon approximation
3121 C     to get photon flux
3122 C
3123 C     input:     EE1     LAB system energy of electron/positron 1
3124 C                EE2     LAB system energy of electron/positron 2
3125 C                NEVENT  >0  number of events to generate
3126 C                        -1   initialization
3127 C                        -2   final call (cross section calculation)
3128 C            from /LEPCUT/:
3129 C                YMIN1   lower limit of Y1
3130 C                        (energy fraction taken by photon from electron)
3131 C                YMAX1   upper limit of Y1
3132 C                Q2MIN1  lower limit of photon virtuality
3133 C                Q2MAX1  upper limit of photon virtuality
3134 C                THMIN1  lower limit of scattered electron
3135 C                THMAX1  upper limit of scattered electron
3136 C                YMIN2   lower limit of Y2
3137 C                        (energy fraction taken by photon from electron)
3138 C                YMAX2   upper limit of Y2
3139 C                Q2MIN2  lower limit of photon virtuality
3140 C                Q2MAX2  upper limit of photon virtuality
3141 C                THMIN2  lower limit of scattered electron
3142 C                THMAX2  upper limit of scattered electron
3143 C
3144 C     output:    after final call with NEVENT=-2
3145 C                EE1     e+ e- cross section (mb)
3146 C                EE2     gamma-gamma cross section (mb)
3147 C
3148 C**********************************************************************
3149       IMPLICIT NONE
3150       SAVE
3151
3152       DOUBLE PRECISION EE1,EE2
3153       INTEGER NEVENT
3154
3155 C  input/output channels
3156       INTEGER LI,LO
3157       COMMON /POINOU/ LI,LO
3158 C  event debugging information
3159       INTEGER NMAXD
3160       PARAMETER (NMAXD=100)
3161       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3162      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3163       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3164      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3165 C  model switches and parameters
3166       CHARACTER*8 MDLNA
3167       INTEGER ISWMDL,IPAMDL
3168       DOUBLE PRECISION PARMDL
3169       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3170 C  some constants
3171       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
3172       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
3173      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
3174 C  photon flux kinematics and cuts
3175       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
3176      &                 YMIN1,YMAX1,YMIN2,YMAX2,
3177      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
3178      &                 THMIN1,THMAX1,THMIN2,THMAX2
3179       INTEGER          ITAG1,ITAG2
3180       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
3181      &                YMIN1,YMAX1,YMIN2,YMAX2,
3182      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
3183      &                THMIN1,THMAX1,THMIN2,THMAX2,
3184      &                ITAG1,ITAG2
3185 C  gamma-lepton or gamma-hadron vertex information
3186       INTEGER IGHEL,IDPSRC,IDBSRC
3187       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
3188      &                 RADSRC,AMSRC,GAMSRC
3189       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
3190      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
3191      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
3192 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
3193       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3194       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3195       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3196      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3197 C  event weights and generated cross section
3198       INTEGER IPOWGC,ISWCUT,IVWGHT
3199       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
3200       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
3201      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
3202
3203 C  external functions
3204       DOUBLE PRECISION DT_RNDM
3205
3206 C  local variables
3207       DOUBLE PRECISION AN1MAX,AN1MIN,AN2MAX,AN2MIN,AY1,AY2,AYS1,AYS2,
3208      &  COF1,COF2,CPFTHE,DAY1,DAY2,DELLY,DITRY,DITRW,
3209      &  ECFRAC,ECMAX2,ECMIN2,EGAM,ELEM,ELEM2,FFL,FFT,FLUXL,FLUXT,
3210      &  FLXAPP,FLXQPM,GGECM2,P1,P2,PP,PT,PT2,Q21AV2,Q21AVE,Q21MAX,
3211      &  Q21MIN,Q22AV2,Q22AVE,Q22MAX,Q22MIN,Q2LOG1,Q2LOG2,Q2LOW1,
3212      &  Q2LOW2,Q2P1,Q2P2,SIF1,SIF2,SIGCUR,SIGMAX,THMAC1,
3213      &  THMAC2,THMIC1,THMIC2,WEIGHT,WG,WGFX,WGH,WGHAPP,WGHL,WGHQPM,
3214      &  WGMAX,WGY,X1DEL,X1MAX,X1MIN,X2DEL,X2MAX,X2MIN,Y1,Y2,YEFF1,YEFF2,
3215      &  YMI,YY1MAX,YY1MIN,YY2MAX,YY2MIN
3216
3217       INTEGER I,IHEAC1,IHEAC2,IHETRY,IREJ,ITRW_low,ITRW_high,ITRY_low,
3218      &  ITRY_high,K,Max_tab,NITER,ITG1,ITG2
3219
3220       DIMENSION P1(4),P2(4),IHETRY(4),IHEAC1(4),IHEAC2(4)
3221       integer ipho_pdg2id
3222
3223 C  initialization of event generation
3224
3225       if(NEVENT.eq.-1) then
3226
3227         DO 10 I=1,4
3228           IHETRY(I) = 0
3229           IHEAC1(I) = 0
3230           IHEAC2(I) = 0
3231  10     CONTINUE
3232
3233         WRITE(LO,'(//1X,A)') 'PHO_GGEPEM: initialization'
3234
3235 C  electron data
3236         ELEM = 0.512D-03
3237         ELEM2 = ELEM**2
3238         AMSRC(1) = ELEM
3239         AMSRC(2) = ELEM
3240 C  lepton numbers
3241         IDPSRC(1) = 11
3242         IDPSRC(2) = -11
3243         IDBSRC(1) = ipho_pdg2id(11)
3244         IDBSRC(2) = ipho_pdg2id(-11)
3245
3246 C  check/update kinematic limitations
3247
3248         Ymi = min(Ymax1,1.D0-ELEM/EE1)
3249         if(Ymi.lt.Ymax1) then
3250           WRITE(LO,'(/1X,A,2E12.5)')
3251      &      'PHO_GGEPEM: Ymax1 decreased (old/new)',Ymax1,Ymi
3252           Ymax1 = YMI
3253         endif
3254         Ymi = min(Ymax2,1.D0-ELEM/EE2)
3255         if(Ymi.lt.Ymax2) then
3256           WRITE(LO,'(/1X,A,2E12.5)')
3257      &      'PHO_GGEPEM: Ymax2 decreased (old/new)',Ymax2,Ymi
3258           Ymax2 = YMI
3259         endif
3260
3261         YMI = ECMIN**2/(4.D0*EE1*EE2*YMAX2)
3262         IF(YMIN1.LT.YMI) THEN
3263           WRITE(LO,'(/1X,A,2E12.5)')
3264      &      'PHO_GGEPEM: Ymin1 increased (old/new)',YMIN1,YMI
3265           YMIN1 = YMI
3266         ELSE IF(YMIN1.GT.YMI) THEN
3267           WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
3268      &      'PHO_GGEPEM:','ECM-CUT corresponds to YMIN1 of',YMI,
3269      &      '  INSTEAD OF',YMIN1
3270         ENDIF
3271         YMI = ECMIN**2/(4.D0*EE1*EE2*YMAX1)
3272         IF(YMIN2.LT.YMI) THEN
3273           WRITE(LO,'(/1X,A,2E12.5)')
3274      &      'PHO_GGEPEM: Ymin2 increased (old/new)',YMIN2,YMI
3275           YMIN2 = YMI
3276         ELSE IF(YMIN2.GT.YMI) THEN
3277           WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
3278      &      'PHO_GGEPEM:','ECM-CUT corresponds to YMIN2 of',YMI,
3279      &      '  INSTEAD OF',YMIN2
3280         ENDIF
3281
3282 C  store COS of angular tagging range
3283         THMIC1 = COS(MAX(0.D0,THMIN1))
3284         THMAC1 = COS(MIN(THMAX1,PI))
3285         THMIC2 = COS(MAX(0.D0,THMIN2))
3286         THMAC2 = COS(MIN(THMAX2,PI))
3287
3288         X1MAX = LOG(YMAX1)
3289         X1MIN = LOG(YMIN1)
3290         X1DEL = X1MAX-X1MIN
3291         X2MAX = LOG(YMAX2)
3292         X2MIN = LOG(YMIN2)
3293         X2DEL = X2MAX-X2MIN
3294
3295 C  debug: integrated photon flux
3296
3297         if(IDEB(30).ge.1) then
3298           Max_tab = 50
3299           FLUXT = 0.D0
3300           FLUXL = 0.D0
3301           DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
3302           IF(IDEB(30).GE.2) WRITE(LO,'(1X,2A,I5)') 'PHO_GGEPEM: ',
3303      &      'table of photon flux (trans/long side 1)',Max_tab
3304           do I=1,Max_tab
3305             Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
3306             if((1.D0-Y1).gt.1.D-8) then
3307               Q2LOW1 = MAX(Q2MIN1,ELEM2*Y1*Y1/(1.D0-Y1))
3308             else
3309               Q2low1 = 2.D0*Q2max1
3310             endif
3311             if(Q2low1.lt.Q2max1) then
3312               FFT = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
3313      &        -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))/(2.D0*PI*137.D0)
3314               FFL = 2.D0*(1.D0-Y1)*LOG(Q2MAX1/Q2LOW1)/(2.D0*PI*137.D0)
3315             else
3316               FFT = 0.D0
3317               FFL = 0.D0
3318             endif
3319             FLUXT = FLUXT + Y1*FFL
3320             FLUXL = FLUXL + Y1*FFT
3321             IF(IDEB(30).GE.2) WRITE(LO,'(5X,1P3E14.4)') Y1,FFT,FFL
3322           enddo
3323           FLUXT = FLUXT*DELLY
3324           FLUXL = FLUXL*DELLY
3325           WRITE(LO,'(1X,2A,1P2E12.4)') 'PHO_GGEPEM: ',
3326      &      'integrated flux (trans/long side 1):',FLUXT,FLUXL
3327         endif
3328
3329 C  maximum weight
3330
3331         Q2LOW1 = MAX(Q2MIN1,ELEM2*YMIN1**2/(1.D0-YMIN1))
3332         Q2LOW2 = MAX(Q2MIN2,ELEM2*YMIN2**2/(1.D0-YMIN2))
3333         Y1 = YMIN1
3334         Y2 = YMIN2
3335         IF(ISWMDL(10).GE.2) THEN
3336 C  long. and transversely polarized photons
3337           WGMAX = ((1.D0+(1.D0-Y1)**2+2.D0*(1.D0-Y1))*LOG(Q2MAX1/Q2LOW1)
3338      &           -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
3339      &           *((1.D0+(1.D0-Y2)**2+2.D0*(1.D0-Y2))*LOG(Q2MAX2/Q2LOW2)
3340      &           -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
3341         ELSE
3342 C  transversely polarized photons only
3343           WGMAX = ((1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
3344      &           -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
3345      &           *((1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
3346      &           -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
3347         ENDIF
3348
3349 C  initialize gamma-gamma event generator
3350
3351 C  photon 1
3352         EGAM = YMAX1*EE1
3353         P1(1) = 0.D0
3354         P1(2) = 0.D0
3355         P1(3) = SQRT(EGAM**2-Q2LOW1)
3356         P1(4) = EGAM
3357 C  photon 2
3358         EGAM = YMAX2*EE2
3359         P2(1) = 0.D0
3360         P2(2) = 0.D0
3361         P2(3) = -SQRT(EGAM**2-Q2LOW2)
3362         P2(4) = EGAM
3363 C  sum of helicities
3364         IGHEL(1) = -1
3365         IGHEL(2) = -1
3366
3367 C  set min. energy for interpolation tables
3368         parmdl(19) = min(parmdl(19),ecmin)
3369
3370 C  initialize event gneration
3371         CALL PHO_SETPAR(1,22,0,0.D0)
3372         CALL PHO_SETPAR(2,22,0,0.D0)
3373         CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
3374         CALL PHO_PHIST(-1,SIGMAX)
3375         CALL PHO_LHIST(-1,SIGMAX)
3376
3377 C  generation of events, flux calculation
3378         ECMIN2 = ECMIN**2
3379         ECMAX2 = ECMAX**2
3380         ECFRAC = ECMIN2/(4.D0*EE1*EE2)
3381         AY1  = 0.D0
3382         AY2  = 0.D0
3383         AYS1 = 0.D0
3384         AYS2 = 0.D0
3385         Q21MIN = 1.D30
3386         Q22MIN = 1.D30
3387         Q21MAX = 0.D0
3388         Q22MAX = 0.D0
3389         Q21AVE = 0.D0
3390         Q22AVE = 0.D0
3391         Q21AV2 = 0.D0
3392         Q22AV2 = 0.D0
3393         AN1MIN = 1.D30
3394         AN2MIN = 1.D30
3395         AN1MAX = 0.D0
3396         AN2MAX = 0.D0
3397         YY1MIN = 1.D30
3398         YY2MIN = 1.D30
3399         YY1MAX = 0.D0
3400         YY2MAX = 0.D0
3401         NITER = 0
3402         ITRY_low = 0
3403         ITRY_high = 0
3404         ITRW_low = 0
3405         ITRW_high = 0
3406
3407 C  generate NEVENT events (might be just 1 per call)
3408
3409       else if(NEVENT.gt.0) then
3410
3411         NITER = NITER+NEVENT
3412
3413         DO 200 I=1,NEVENT
3414
3415 C  sample y1, y2
3416  150      CONTINUE
3417           ITRY_low = ITRY_low+1
3418           if(ITRY_low.eq.1000000) then
3419             ITRY_low = 0
3420             ITRY_high = ITRY_high+1
3421           endif
3422
3423  175      CONTINUE
3424             ITRW_low = ITRW_low+1
3425             if(ITRW_low.eq.1000000) then
3426               ITRW_low = 0
3427               ITRW_high = ITRW_high+1
3428             endif
3429
3430             Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
3431             Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
3432             IF(Y1*Y2.LT.ECFRAC) GOTO 175
3433             IF(ISWMDL(10).GE.2) THEN
3434               YEFF1 = 1.D0+(1.D0-Y1)**2+2.D0*(1.D0-Y1)
3435               YEFF2 = 1.D0+(1.D0-Y2)**2+2.D0*(1.D0-Y2)
3436             ELSE
3437               YEFF1 = 1.D0+(1.D0-Y1)**2
3438               YEFF2 = 1.D0+(1.D0-Y2)**2
3439             ENDIF
3440
3441             Q2LOW1 = MAX(Q2MIN1,ELEM2*Y1**2/(1.D0-Y1))
3442             Q2LOW2 = MAX(Q2MIN2,ELEM2*Y2**2/(1.D0-Y2))
3443             Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
3444             Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
3445             WGH = (YEFF1*Q2LOG1
3446      &             -2.D0*ELEM2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
3447      &           *(YEFF2*Q2LOG2
3448      &             -2.D0*ELEM2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
3449             IF(WGMAX.LT.WGH) THEN
3450               WRITE(LO,'(1X,A,4E12.5)')
3451      &          'PHO_GGEPEM: inconsistent weight:',Y1,Y2,WGMAX,WGH
3452             ENDIF
3453           IF(DT_RNDM(AYS1)*WGMAX.GT.WGH) GOTO 175
3454
3455 C  limit on Ecm_gg (app. cut, precise cut applied later)
3456           GGECM2 = 4.D0*Y1*Y2*EE1*EE2
3457           if(GGECM2.lt.ECMIN2) goto 175
3458
3459 C  sample Q2
3460           IF(IPAMDL(174).EQ.1) THEN
3461  185        CONTINUE
3462               Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
3463               WEIGHT = (YEFF1-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF1
3464             IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
3465           ELSE
3466             Q2P1 = Q2LOW1
3467           ENDIF
3468
3469           IF(IPAMDL(174).EQ.1) THEN
3470  186        CONTINUE
3471               Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
3472               WEIGHT = (YEFF2-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF2
3473             IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
3474           ELSE
3475             Q2P2 = Q2LOW2
3476           ENDIF
3477
3478           GYY(1) = Y1
3479           GQ2(1) = Q2P1
3480           GYY(2) = Y2
3481           GQ2(2) = Q2P2
3482
3483 C  incoming electron 1
3484           PINI(1,1) = 0.D0
3485           PINI(2,1) = 0.D0
3486           PINI(3,1) = EE1*(1.D0-0.5D0*ELEM2/EE1**2)
3487           PINI(4,1) = EE1
3488           PINI(5,1) = ELEM
3489 C  photon 1
3490           PP = (2.D0*EE1**2*Y1+Q2P1)/(2.D0*PINI(3,1))
3491           PT2 = (EE1**2*(Q2P1*(1.D0-Y1)-ELEM2*Y1**2)
3492      &         -0.25D0*Q2P1**2-Q2P1*ELEM2)/PINI(3,1)**2
3493           IF(PT2.LT.0.D0) GOTO 175
3494           PT = SQRT(PT2)
3495           CALL PHO_SFECFE(SIF1,COF1)
3496           P1(1) = COF1*PT
3497           P1(2) = SIF1*PT
3498           P1(3) = PP
3499           P1(4) = EE1*Y1
3500 C  outgoing electron 1
3501           PFIN(1,1) = -P1(1)
3502           PFIN(2,1) = -P1(2)
3503           PFIN(3,1) = PINI(3,1)-P1(3)
3504           PFIN(4,1) = PINI(4,1)-P1(4)
3505           PFIN(5,1) = ELEM
3506 C  incoming electron 2
3507           PINI(1,2) = 0.D0
3508           PINI(2,2) = 0.D0
3509           PINI(3,2) = -EE2*(1.D0-0.5D0*ELEM2/EE2**2)
3510           PINI(4,2) = EE2
3511           PINI(5,2) = 0.D0
3512 C  photon 2
3513           PP = (2.D0*EE2**2*Y2+Q2P2)/(2.D0*PINI(3,2))
3514           PT2 = (EE2**2*(Q2P2*(1.D0-Y2)-ELEM2*Y2**2)
3515      &         -0.25D0*Q2P2**2-Q2P2*ELEM2)/PINI(3,2)**2
3516           IF(PT2.LT.0.D0) GOTO 175
3517           PT = SQRT(PT2)
3518           CALL PHO_SFECFE(SIF2,COF2)
3519           P2(1) = COF2*PT
3520           P2(2) = SIF2*PT
3521           P2(3) = PP
3522           P2(4) = EE2*Y2
3523 C  outgoing electron 2
3524           PFIN(1,2) = -P2(1)
3525           PFIN(2,2) = -P2(2)
3526           PFIN(3,2) = PINI(3,2)-P2(3)
3527           PFIN(4,2) = PINI(4,2)-P2(4)
3528           PFIN(5,2) = ELEM
3529
3530 C  precise ECMS cut
3531
3532           GGECM2 = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
3533      &           -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
3534           IF((GGECM2.LT.ECMIN2).OR.(GGECM2.GT.ECMAX2)) GOTO 175
3535           GGECM = SQRT(GGECM2)
3536
3537 C  beam lepton detector acceptance
3538
3539 C  lepton tagger 1
3540           CPFTHE = PFIN(3,1)/PFIN(4,1)
3541           ITG1 = 0
3542           IF(PFIN(4,1).GE.EEMIN1) THEN
3543             IF((CPFTHE.LE.THMIC1).AND.(CPFTHE.GE.THMAC1)) ITG1 = 1
3544           ENDIF
3545
3546 C  lepton tagger 2
3547           CPFTHE = PFIN(3,2)/PFIN(4,2)
3548           ITG2 = 0
3549           IF(PFIN(4,2).GE.EEMIN2) THEN
3550             IF((CPFTHE.LE.THMIC2).AND.(CPFTHE.GE.THMAC2)) ITG2 = 1
3551           ENDIF
3552
3553 C  beam lepton taggers
3554
3555 C  anti-tag
3556           IF((ITAG1.EQ.-1).AND.(ITG1.NE.0)) GOTO 175
3557           IF((ITAG2.EQ.-1).AND.(ITG2.NE.0)) GOTO 175
3558 C  tag
3559           IF((ITAG1.EQ.1).AND.(ITG1.EQ.0)) GOTO 175
3560           IF((ITAG2.EQ.1).AND.(ITG2.EQ.0)) GOTO 175
3561 C  single-tag inclusive
3562           IF((ITAG1.EQ.0).AND.(ITAG2.EQ.0).AND.(ITG1+ITG2.EQ.0))
3563      &      GOTO 175
3564 C  single-tag/anti-tag
3565           IF((ITAG1.EQ.2).AND.(ITAG2.EQ.2).AND.(ITG1+ITG2.NE.1))
3566      &      GOTO 175
3567
3568           PGAM(1,1) = P1(1)
3569           PGAM(2,1) = P1(2)
3570           PGAM(3,1) = P1(3)
3571           PGAM(4,1) = P1(4)
3572           PGAM(5,1) = -SQRT(Q2P1)
3573           PGAM(1,2) = P2(1)
3574           PGAM(2,2) = P2(2)
3575           PGAM(3,2) = P2(3)
3576           PGAM(4,2) = P2(4)
3577           PGAM(5,2) = -SQRT(Q2P2)
3578
3579 C  photon helicities
3580           IF(ISWMDL(10).GE.2) THEN
3581             WGH  = YEFF1-2.D0*ELEM2*Y1**2/Q2P1
3582             WGHL = 2.D0*(1-Y1)
3583             IF(DT_RNDM(Y1).GT.WGHL/WGH) THEN
3584               IGHEL(1) = 1
3585             ELSE
3586               IGHEL(1) = 0
3587             ENDIF
3588             WGH  = YEFF2-2.D0*ELEM2*Y2**2/Q2P2
3589             WGHL = 2.D0*(1-Y2)
3590             IF(DT_RNDM(Y2).GT.WGHL/WGH) THEN
3591               IGHEL(2) = 1
3592             ELSE
3593               IGHEL(2) = 0
3594             ENDIF
3595             K = 2*IGHEL(1)+IGHEL(2)+1
3596             IHETRY(K) = IHETRY(K)+1
3597           ELSE
3598             IGHEL(1) = -1
3599             IGHEL(2) = -1
3600           ENDIF
3601
3602 C  user cuts
3603           CALL PHO_PRESEL(5,IREJ)
3604           IF(IREJ.NE.0) GOTO 175
3605
3606           WGFX = 1.D0
3607 C  reweight according to LO photon emission diagrams (Budnev et al.)
3608           IF(IPAMDL(116).GE.1) THEN
3609             CALL PHO_WGEPEM(FLXAPP,FLXQPM,0)
3610             WGFX = FLXQPM/FLXAPP
3611             if(WGFX.gt.1.D0) then
3612               WRITE(LO,'(1x,a,/,5x,1p,5e11.4)')
3613      &          ' PHO_GGEPEM: flux weight > 1 (y1/2,Q21/2,W)',
3614      &          Y1,Y2,Q2P1,Q2P2,GGECM
3615             endif
3616           ENDIF
3617
3618 C  event generation
3619 *         IVWGHT(1) = 1
3620 *         EVWGHT(1) = MAX(WGFX,1.D0)
3621           CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
3622           IF(IREJ.NE.0) GOTO 150
3623           IF(ISWMDL(10).GE.2) THEN
3624             K = 2*IGHEL(1)+IGHEL(2)+1
3625             IHEAC1(K) = IHEAC1(K)+1
3626           ENDIF
3627
3628 C  reweight according to QPM model (e+e- collider only)
3629           IF((KHDIR.GT.0).AND.
3630      &      (IPAMDL(116).GE.2).AND.(ISWMDL(10).GE.2)) THEN
3631             CALL PHO_WGEPEM(WGHAPP,WGHQPM,1)
3632             WG = WGHQPM/WGHAPP/MAX(1.D0,WGFX)
3633             IF(DT_RNDM(WG).GT.WG) GOTO 150
3634           ELSE IF(IPAMDL(116).GE.1) THEN
3635             IF(DT_RNDM(WG).GT.WGFX) GOTO 150
3636           ENDIF
3637
3638 C  polar angle
3639           PFTHE(1) = ACOS(PFIN(3,1)/PFIN(4,1))
3640           PFTHE(2) = ACOS(PFIN(3,2)/PFIN(4,2))
3641 C  azimuthal angle
3642           PFPHI(1) = ATAN2(COF1,SIF1)
3643           PFPHI(2) = ATAN2(COF2,SIF2)
3644
3645 C  statistics
3646           AY1  = AY1+Y1
3647           AYS1 = AYS1+Y1*Y1
3648           AY2  = AY2+Y2
3649           AYS2 = AYS2+Y2*Y2
3650           Q21MIN = MIN(Q21MIN,Q2P1)
3651           Q22MIN = MIN(Q22MIN,Q2P2)
3652           Q21MAX = MAX(Q21MAX,Q2P1)
3653           Q22MAX = MAX(Q22MAX,Q2P2)
3654           AN1MIN = MIN(AN1MIN,PFTHE(1))
3655           AN2MIN = MIN(AN2MIN,PFTHE(2))
3656           AN1MAX = MAX(AN1MAX,PFTHE(1))
3657           AN2MAX = MAX(AN2MAX,PFTHE(2))
3658           YY1MIN = MIN(YY1MIN,Y1)
3659           YY2MIN = MIN(YY2MIN,Y2)
3660           YY1MAX = MAX(YY1MAX,Y1)
3661           YY2MAX = MAX(YY2MAX,Y2)
3662           Q21AVE = Q21AVE+Q2P1
3663           Q22AVE = Q22AVE+Q2P2
3664           Q21AV2 = Q21AV2+Q2P1*Q2P1
3665           Q22AV2 = Q22AV2+Q2P2*Q2P2
3666           IF(ISWMDL(10).GE.2) THEN
3667             K = 2*IGHEL(1)+IGHEL(2)+1
3668             IHEAC2(K) = IHEAC2(K)+1
3669           ENDIF
3670 C  external histograms
3671           CALL PHO_PHIST(1,HSWGHT(0))
3672           CALL PHO_LHIST(1,HSWGHT(0))
3673  200    CONTINUE
3674
3675 C  final cross section calculation and event generation summary
3676
3677       else if(NEVENT.eq.-2) then
3678
3679 *       EVWGHT(1) = 1.D0
3680 *       IVWGHT(1) = 0
3681         DITRY = dble(ITRY_high)*1.D+6+dble(ITRY_low)
3682         DITRW = dble(ITRW_high)*1.D+6+dble(ITRW_low)
3683         WGY  = WGMAX*DITRY/DITRW/(137.D0*2.D0*PI)**2
3684         WGY  = WGY*LOG(YMAX1/YMIN1)*LOG(YMAX2/YMIN2)
3685         AY1  = AY1/DBLE(NITER)
3686         AYS1 = AYS1/DBLE(NITER)
3687         DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
3688         AY2  = AY2/DBLE(NITER)
3689         AYS2 = AYS2/DBLE(NITER)
3690         DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
3691         Q21AVE = Q21AVE/DBLE(NITER)
3692         Q21AV2 = Q21AV2/DBLE(NITER)
3693         Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(NITER))
3694         Q22AVE = Q22AVE/DBLE(NITER)
3695         Q22AV2 = Q22AV2/DBLE(NITER)
3696         Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
3697         WEIGHT = WGY*SIGMAX*DBLE(NITER)/DITRY
3698         EE1 = WEIGHT
3699         EE2 = SIGMAX*DBLE(NITER)/DITRY
3700
3701 C  output of statistics, histograms
3702         WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
3703      &    '=========================================================',
3704      &    ' *****   simulated cross section: ',WEIGHT,' mb  *****',
3705      &    '========================================================='
3706         WRITE(LO,'(//1X,A,I10,1p,2e14.6)')
3707      &    'PHO_GGEPEM:summary: NITER,ITRY,ITRW',NITER,DITRY,DITRW
3708         WRITE(LO,'(1X,A,1P2E12.4)') 'effective weight (FLUX,TOTAL)',
3709      &    WGY,WEIGHT
3710         WRITE(LO,'(1X,A,1P2E12.4)') 'average Y1,DY1               ',
3711      &    AY1,DAY1
3712         WRITE(LO,'(1X,A,1P2E12.4)') 'average Y2,DY2               ',
3713      &    AY2,DAY2
3714         WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Y range photon 1     ',
3715      &    YY1MIN,YY1MAX
3716         WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Y range photon 2     ',
3717      &    YY2MIN,YY2MAX
3718         WRITE(LO,'(1X,A,1P2E12.4)') 'average Q2,DQ2 photon 1      ',
3719      &    Q21AVE,Q21AV2
3720         WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Q2 range photon 1    ',
3721      &    Q21MIN,Q21MAX
3722         WRITE(LO,'(1X,A,1P2E12.4)') 'average Q2,DQ2  photon 2     ',
3723      &    Q22AVE,Q22AV2
3724         WRITE(LO,'(1X,A,1P2E12.4)') 'sampled Q2 range photon 2    ',
3725      &    Q22MIN,Q22MAX
3726         WRITE(LO,'(1X,A,1P2E12.4)') 'sampled THETA range electron1',
3727      &    AN1MIN,AN1MAX
3728         WRITE(LO,'(1X,A,1P4E12.4)') 'sampled THETA range electron2',
3729      &    AN2MIN,AN2MAX,PI-AN2MAX,PI-AN2MIN
3730
3731         IF(ISWMDL(10).GE.2) THEN
3732           WRITE(LO,'(/1X,A,3(/1X,A,4I12))')
3733      &    'Helicity decomposition:    0 0      0 1      1 0       1 1',
3734      &    'tried:        ',IHETRY,
3735      &    'accepted (1): ',IHEAC1,
3736      &    'accepted (2): ',IHEAC2
3737         ENDIF
3738
3739         CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
3740         IF(NITER.GT.1) THEN
3741           CALL PHO_PHIST(-2,WEIGHT)
3742           CALL PHO_LHIST(-2,WEIGHT)
3743         ELSE
3744           WRITE(LO,'(1X,A,I4)')
3745      &      'PHO_GGEPEM: no output of histograms',NITER
3746         ENDIF
3747
3748       endif
3749
3750       END
3751
3752 *$ CREATE PHO_WGEPEM.FOR
3753 *COPY PHO_WGEPEM
3754 CDECK  ID>, PHO_WGEPEM
3755       SUBROUTINE PHO_WGEPEM(WGHAPP,WGHQPM,IMODE)
3756 C**********************************************************************
3757 C
3758 C     calculate cross section weights for
3759 C      fully differential equivalent (improved) photon approximation
3760 C     and/or
3761 C      fully differential QPM model with exact one-photon exchange graphs
3762 C
3763 C     (unpolarized lepton beams)
3764 C
3765 C     input:     IMODE     0   flux calculation only
3766 C                          1   flux folded with QPM cross section
3767 C                /POFSRC/  photon and electron momenta
3768 C                /POPRCS/  process type
3769 C                /POCKIN/  kinematics of hard scattering
3770 C
3771 C     output:    WGHAPP  weight of event according to approximation
3772 C                WGHQPM  weight of event according to one-photon exchange
3773 C
3774 C**********************************************************************
3775       IMPLICIT NONE
3776       SAVE
3777
3778       DOUBLE PRECISION WGHAPP,WGHQPM
3779       INTEGER IMODE
3780
3781 C  input/output channels
3782       INTEGER LI,LO
3783       COMMON /POINOU/ LI,LO
3784 C  event debugging information
3785       INTEGER NMAXD
3786       PARAMETER (NMAXD=100)
3787       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3788      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3789       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3790      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3791 C  model switches and parameters
3792       CHARACTER*8 MDLNA
3793       INTEGER ISWMDL,IPAMDL
3794       DOUBLE PRECISION PARMDL
3795       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3796 C  some constants
3797       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
3798       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
3799      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
3800 C  gamma-lepton or gamma-hadron vertex information
3801       INTEGER IGHEL,IDPSRC,IDBSRC
3802       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
3803      &                 RADSRC,AMSRC,GAMSRC
3804       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
3805      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
3806      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
3807 C  general process information
3808       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3809       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3810 C  data on most recent hard scattering
3811       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
3812       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
3813      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
3814      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
3815       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
3816      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
3817      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
3818      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
3819      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
3820 C  hard scattering parameters used for most recent hard interaction
3821       INTEGER NFbeta,NF
3822       DOUBLE PRECISION ALQCD2,BQCD
3823       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
3824 C  currently activated parton density parametrizations
3825       CHARACTER*8 PDFNAM
3826       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
3827       DOUBLE PRECISION PDFLAM,PDFQ2M
3828       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
3829      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
3830 C  standard particle data interface
3831       INTEGER NMXHEP
3832       PARAMETER (NMXHEP=4000)
3833       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
3834       DOUBLE PRECISION PHEP,VHEP
3835       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
3836      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
3837      &                VHEP(4,NMXHEP)
3838 C  extension to standard particle data interface (PHOJET specific)
3839       INTEGER IMPART,IPHIST,ICOLOR
3840       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
3841
3842       DOUBLE PRECISION AA,ALPHA1,ALPHA2,BB,CC,CCAP,DD,FAC,HELFLX,
3843      &  P1,P1P2,P1Q2,P2,P2Q1,Q1KK,Q1Q2,Q2,Q2KK,QC2,RHO100,RHO1PP,
3844      &  RHO200,RHO2PP,RHOP08,RHOPM2,RR,SH,SIGQPM,SP,SS,SW0000,SW0P0M,
3845      &  SW0P0P,SW0PM0,SWP00P,SWP0M0,SWP0P0,SWPMPM,SWPP00,SWPPMM,SWPPPP,
3846      &  TH,TP,UH,W2,WGHEQ,WGHQQ,XCAP,XK1,XK2,XKAM,XKAP,
3847      &  XM2,XQ2,XTM1,XTM2,XTM3,YCAP
3848       DOUBLE PRECISION PHO_ALPHAS,pho_alphae
3849
3850       INTEGER I,I1,I2,IDIR,IPFL1,IPFL2,IPOS,K
3851
3852       DIMENSION WGHEQ(2),XM2(2),P1(4),P2(4),XK1(4),XK2(4)
3853       DIMENSION HELFLX(6),SIGQPM(6)
3854
3855       WGHAPP = 1.D0
3856       WGHQPM = 0.D0
3857
3858 C  strict pt cutoff after putting partons on mass shell,
3859 C  calculated in gamma-gamma CMS
3860       if((Imode.eq.1).and.(ipamdl(121).gt.0)) then
3861         if(PTfin.lt.PTwant) then
3862           if(ipamdl(121).gt.1) return
3863           if((ipamdl(121).eq.1).and.(MSPR.eq.14)) return
3864         endif
3865       endif
3866
3867 C  cross section of sampled event (approximate treatment)
3868
3869 C  photon flux
3870       DO 50 K=1,2
3871         XM2(K) = AMSRC(K)**2
3872         IF(abs(IGHEL(K)).EQ.1) THEN
3873           WGHEQ(K) = ((1.D0+(1.D0-GYY(K))**2)/GYY(K)
3874      &              -2.D0*XM2(K)*GYY(K)/GQ2(K))/(137.D0*2.D0*PI*GQ2(K))
3875         ELSE
3876           WGHEQ(K) = (1.D0-GYY(K))/GYY(K)/(137.D0*PI*GQ2(K))
3877         ENDIF
3878  50   CONTINUE
3879
3880       W2 = GGECM*GGECM
3881       IDIR   = 0
3882       WGHQQ  = 1.D0
3883
3884 C  direct or single-resolved gam-gam interaction
3885       IF((IMODE.GE.1).AND.
3886      &   (IPROCE.EQ.8).AND.(MSPR.GE.10)) THEN
3887         IDIR   = 1
3888         WGHQQ = 0.D0
3889 C  determine final state partons
3890         DO 100 I=3,NHEP
3891           IF(ISTHEP(I).EQ.25) GOTO 110
3892  100    CONTINUE
3893         WRITE(LO,'(/1X,2A,I5)') 'PHO_WGEPEM:ERROR: ',
3894      &    'inconsistent process information (MSPR)',MSPR
3895         CALL PHO_ABORT
3896  110    CONTINUE
3897         IPOS = I
3898 C  final state flavors
3899         IPFL1 = ABS(IDHEP(IPOS+3))
3900         IPFL2 = ABS(IDHEP(IPOS+4))
3901         SH = X1*X2*W2
3902 C  calculate alpha-em
3903         ALPHA1 = pho_alphae(QQAL)
3904 C  calculate alpha-s
3905         IF(MSPR.LT.14) THEN
3906           ALPHA2 = PHO_ALPHAS(QQAL,3)
3907         ENDIF
3908 C  LO matrix element (8 pi s dsig/dt)
3909 *       QC2 = 4.D0/9.D0 - DBLE(MOD(IPFL2,2))*3.D0/9.D0
3910         QC2 = Q_ch2(IPFL2)
3911         IF(IPFL2.EQ.0) THEN
3912           WRITE(LO,'(1X,2A,/,5X,A,I12,I3,4I4)') 'PHO_WGEPEM:ERROR: ',
3913      &      'invalid hard process - flavor combination',
3914      &      'EVENT,MSPR,IA,IB,IC,ID:',KEVENT,MSPR,IA,IB,IC,ID
3915         ENDIF
3916         IF(MSPR.EQ.10) THEN
3917           WGHQQ  = -8.D0*PI/(3.D0*SH**2)*ALPHA1*QC2*ALPHA2*(U**2+1.D0)/U
3918      &            *8.D0*PI*SH
3919         ELSE IF(MSPR.EQ.11) THEN
3920           WGHQQ  = PI/SH**2*ALPHA1*QC2*ALPHA2*(V**2+U**2)/(U*V)
3921      &            *8.D0*PI*SH
3922         ELSE IF(MSPR.EQ.12) THEN
3923           WGHQQ  = -8.D0*PI/(3.D0*SH**2)*ALPHA1*QC2*ALPHA2*(V**2+1.D0)/V
3924      &            *8.D0*PI*SH
3925         ELSE IF(MSPR.EQ.13) THEN
3926           WGHQQ  = PI/SH**2*ALPHA1*QC2*ALPHA2*(V**2+U**2)/(U*V)
3927      &            *8.D0*PI*SH
3928         ELSE IF(MSPR.EQ.14) THEN
3929           WGHQQ  = 6.D0*PI/SH**2*(ALPHA1*QC2)**2*(V**2+U**2)/(U*V)
3930      &            *8.D0*PI*SH
3931         ENDIF
3932       ENDIF
3933
3934 C  fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
3935       WGHAPP = WGHEQ(1)*WGHEQ(2)*WGHQQ/(2.D0*PI)
3936
3937 C  full leading-order QPM prediction (Budnev et al.)
3938
3939 C  full two-gamma flux
3940
3941       P1Q2 = PINI(4,1)*PGAM(4,2)-PINI(1,1)*PGAM(1,2)
3942      &      -PINI(2,1)*PGAM(2,2)-PINI(3,1)*PGAM(3,2)
3943       P2Q1 = PINI(4,2)*PGAM(4,1)-PINI(1,2)*PGAM(1,1)
3944      &      -PINI(2,2)*PGAM(2,1)-PINI(3,2)*PGAM(3,1)
3945       Q1Q2 = PGAM(4,1)*PGAM(4,2)-PGAM(1,1)*PGAM(1,2)
3946      &      -PGAM(2,1)*PGAM(2,2)-PGAM(3,1)*PGAM(3,2)
3947       P1P2 = PINI(4,1)*PINI(4,2)-PINI(1,1)*PINI(1,2)
3948      &      -PINI(2,1)*PINI(2,2)-PINI(3,1)*PINI(3,2)
3949       DO 120 I=1,4
3950         P1(I) = 2.D0*PINI(I,1)-PGAM(I,1)
3951         P2(I) = 2.D0*PINI(I,2)-PGAM(I,2)
3952  120  CONTINUE
3953       XTM1 = 2.D0*P1Q2-Q1Q2
3954       XTM2 = 2.D0*P2Q1-Q1Q2
3955       XTM3 = P1(4)*P2(4)-P1(1)*P2(1)-P1(2)*P2(2)-P1(3)*P2(3)
3956       XCAP = Q1Q2**2-GQ2(1)*GQ2(2)
3957       YCAP = P1P2**2-XM2(1)*XM2(2)
3958       CCAP = -XTM3 + Q1Q2*XTM1*XTM2/XCAP
3959
3960       RHO1PP = (XTM1**2/XCAP+1.D0-4.D0*XM2(1)/GQ2(1))/2.D0
3961       RHO2PP = (XTM2**2/XCAP+1.D0-4.D0*XM2(2)/GQ2(2))/2.D0
3962       RHO100 = XTM1**2/XCAP-1.D0
3963       RHO200 = XTM2**2/XCAP-1.D0
3964       RHOPM2 = CCAP**2/(GQ2(1)*GQ2(2))-2.D0*(RHO1PP-1.D0)*(RHO2PP-1.D0)
3965       RHOP08 = 4.D0*XTM1*XTM2*CCAP/XCAP/SQRT(GQ2(1)*GQ2(2))
3966       SS     = 2.D0*P1P2+XM2(1)+XM2(2)
3967
3968       HELFLX(1) = 4.D0*RHO1PP*RHO2PP
3969       HELFLX(2) = RHOPM2
3970       HELFLX(3) = 2.D0*RHO1PP*RHO200
3971       HELFLX(4) = 2.D0*RHO100*RHO2PP
3972       HELFLX(5) = RHO100*RHO200
3973       HELFLX(6) = -RHOP08
3974
3975 C  only flux calculation
3976
3977       IF(IDIR.EQ.0) THEN
3978         IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.1)) THEN
3979           WEIGHT = HELFLX(1)
3980         ELSE IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.0)) THEN
3981           WEIGHT = HELFLX(3)
3982         ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.1)) THEN
3983           WEIGHT = HELFLX(4)
3984         ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.0)) THEN
3985           WEIGHT = HELFLX(5)
3986         ELSE IF((IGHEL(1).EQ.-1).AND.(IGHEL(2).EQ.-1)) THEN
3987           WEIGHT = HELFLX(1)
3988         ELSE
3989           WRITE(LO,'(/1X,A,2I3)')
3990      &      'PHO_GGEPEM:ERROR: invalid photon helicities: ',IGHEL
3991           WRITE(LO,'(1X,A,I12)')
3992      &      'PHO_GGEPEM: event rejected (KEVENT)',KEVENT
3993           WEIGHT = 0.D0
3994         ENDIF
3995
3996 C  fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
3997         WGHQPM = WEIGHT/(137.D0**2*16.D0*PI**4*GQ2(1)*GQ2(2))
3998      &          *SQRT(XCAP/YCAP)*PI*SS/(2.D0*YCAP)*PINI(4,1)*PINI(4,2)
3999
4000       ELSE
4001
4002 C  flux folded with cross section
4003 C  polarized, leading order gam gam --> q qbar cross sections
4004
4005         DO 125 I=1,6
4006           SIGQPM(I) = 0.D0
4007  125    CONTINUE
4008 C  momenta of produced parton pair
4009         I1 = IPOS+3
4010         I2 = IPOS+4
4011         DO 150 K=1,4
4012           XK1(K) = PHEP(K,I1)
4013           XK2(K) = PHEP(K,I2)
4014  150    CONTINUE
4015         XQ2 = PHEP(5,I2)**2
4016
4017         IF(MSPR.EQ.14) THEN
4018 C  direct photon-photon interaction
4019           XKAP = XQ2-(PGAM(4,1)-XK1(4))**2
4020      &          +(PGAM(1,1)-XK1(1))**2+(PGAM(2,1)-XK1(2))**2
4021      &          +(PGAM(3,1)-XK1(3))**2
4022           XKAM = XQ2-(PGAM(4,1)-XK2(4))**2
4023      &          +(PGAM(1,1)-XK2(1))**2+(PGAM(2,1)-XK2(2))**2
4024      &          +(PGAM(3,1)-XK2(3))**2
4025           CC = Q1Q2
4026           AA = XKAP*XKAM-GQ2(1)*GQ2(2)
4027           BB = CC**2-XKAP*XKAM
4028           DD = CC**2-GQ2(1)*GQ2(2)
4029           RR = -XQ2+W2*AA/(4.D0*DD)
4030           Q1KK = Q1Q2-GQ2(1)
4031           Q2KK = Q1Q2-GQ2(2)
4032           FAC = 192.D0*(PI*ALPHA1*QC2/(XKAP*XKAM))**2/(4.D0*SQRT(XCAP))
4033
4034         ELSE
4035 C  single-resolved photon-hadron interactions
4036 C  Mandelstam variables
4037           IF(MSPR.LE.11) THEN
4038             TH = (PGAM(4,1)-XK1(4))**2-(PGAM(1,1)-XK1(1))**2
4039      &          -(PGAM(2,1)-XK1(2))**2-(PGAM(3,1)-XK1(3))**2
4040             UH = (PGAM(4,1)-XK2(4))**2-(PGAM(1,1)-XK2(1))**2
4041      &          -(PGAM(2,1)-XK2(2))**2-(PGAM(3,1)-XK2(3))**2
4042           ELSE
4043             TH = (PGAM(4,2)-XK2(4))**2-(PGAM(1,2)-XK2(1))**2
4044      &          -(PGAM(2,2)-XK2(2))**2-(PGAM(3,2)-XK2(3))**2
4045             UH = (PGAM(4,2)-XK1(4))**2-(PGAM(1,2)-XK1(1))**2
4046      &          -(PGAM(2,2)-XK1(2))**2-(PGAM(3,2)-XK1(3))**2
4047           ENDIF
4048           V = TH/SH
4049           U = UH/SH
4050         ENDIF
4051
4052         WEIGHT = 0.D0
4053         IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.1)) THEN
4054           IF((MSPR.EQ.10).OR.(MSPR.EQ.12)) THEN
4055             IF(MSPR.EQ.10) THEN
4056               Q2 = -GQ2(1)
4057               SP = SH-XQ2
4058               TP = UH-XQ2
4059             ELSE
4060               Q2 = -GQ2(2)
4061               SP = SH-XQ2
4062               TP = TH-XQ2
4063             ENDIF
4064             SIGQPM(1)= -32.D0*PI**2*4.D0/3.D0*ALPHA1*QC2*ALPHA2
4065      &        *(SP*TP*(2.D0*Q2**4-4.D0*Q2*SP**3-2.D0*Q2**3*(3*SP+TP)
4066      &        +SP**2*(SP**2+TP**2)+Q2**2*(7.D0*SP**2+2.D0*SP*TP+TP**2))
4067      &       -2.D0*(2.D0*SP**3*TP*(SP+TP)+Q2**3*(SP**2+6.D0*SP*TP+TP**2)
4068      &        -2.D0*Q2**2*SP*(SP**2+4.D0*SP*TP+3.D0*TP**2)+Q2*SP*
4069      &        (SP**3+SP**2*TP-SP*TP**2+TP**3))*XQ2 +
4070      &        4.D0*(2.D0*Q2**2-SP**2)*(SP+TP)**2*XQ2**2)/
4071      &        (SP**2*TP**2*((Q2-SP)**2-4.D0*Q2*XQ2))
4072             WEIGHT = HELFLX(1)*SIGQPM(1)/(2.D0*(SH+GQ2(1)+GQ2(2)))
4073           ELSE IF((MSPR.EQ.11).OR.(MSPR.EQ.13)) THEN
4074             IF(MSPR.EQ.11) THEN
4075               Q2 = -GQ2(1)
4076             ELSE
4077               Q2 = -GQ2(2)
4078             ENDIF
4079             SP = SH
4080             TP = UH
4081             SIGQPM(1) = -32.D0*PI**2/2.D0*ALPHA1*QC2*ALPHA2
4082      &        *(-((Q2**2+SP**2)*TP*(Q2**3-SP**3-3.D0*SP**2*TP
4083      &        - 4.D0*SP*TP**2 - 2.D0*TP**3 - 3.D0*Q2**2*(SP + TP) + Q2*
4084      &            (3.D0*SP**2 + 6.D0*SP*TP + 4.D0*TP**2))) +
4085      &        (3.D0*Q2**5 - Q2**4*(11.D0*SP + 10.D0*TP) +
4086      &         4.D0*Q2**3*(4.D0*SP**2 + 5.D0*SP*TP + 4.D0*TP**2)
4087      &        +Q2*SP**2*(5.D0*SP**2+4.D0*SP*TP+8.D0*TP**2)-4.D0*Q2**2
4088      &        *(3.D0*SP**3+3.D0*SP**2*TP+4.D0*SP*TP**2+2.D0*TP**3)-
4089      &        SP**2*(SP**3+2.D0*SP**2*TP+8.D0*SP*TP**2+8.D0*TP**3))*XQ2+
4090      &        (11.D0*Q2**4-10.D0*Q2**3*(3.D0*SP+2.D0*TP)-2.D0*Q2*SP**2
4091      &        *(7.D0*SP+2.D0*TP)+2.D0*Q2**2*(15.D0*SP**2+10.D0*SP*TP
4092      &        +6.D0*TP**2)+SP**2*(3.D0*SP**2+4.D0*SP*TP+12.D0*TP**2))
4093      &        *XQ2**2+8.D0*(Q2**3-SP**2*TP-Q2**2*(SP+TP))*XQ2**3+
4094      &        2.D0*(Q2**2+SP**2)*XQ2**4)/((Q2-SP)**2*(-TP+XQ2)**2*
4095      &        (Q2-SP-TP+XQ2)**2)
4096             WEIGHT = HELFLX(1)*SIGQPM(1)/(2.D0*(SH+GQ2(1)+GQ2(2)))
4097           ELSE IF(MSPR.EQ.14) THEN
4098             SWPMPM = 4.D0*CC**2*RR*(W2-2.D0*RR)
4099             SWPPPP = SWPMPM +2.D0*(CC**2+BB)*(AA-4.D0*RR*CC)
4100             SWPPMM = 8.D0*RR*CC*(XKAP*XKAM-RR*CC)
4101      &              -2.D0*XKAP*XKAM*AA
4102             SIGQPM(1) = (SWPPPP+SWPMPM)/2.D0*FAC
4103             SIGQPM(2) = SWPPMM*FAC
4104             WEIGHT = HELFLX(1)*SIGQPM(1)
4105      &              +HELFLX(2)*SIGQPM(2)
4106           ENDIF
4107         ELSE IF((IGHEL(1).EQ.1).AND.(IGHEL(2).EQ.0)) THEN
4108           IF(MSPR.EQ.12) THEN
4109             Q2 = -GQ2(2)
4110             SP = SH-XQ2
4111             TP = TH-XQ2
4112             SIGQPM(3) = 32.D0*PI**2*8.D0/3.D0*ALPHA1*QC2*ALPHA2
4113      &               *Q2*(-(SP**2*TP**2*(-Q2 + SP + TP)) +
4114      &               SP*TP*(2.D0*Q2**2 + 3.D0*SP**2 + 2.D0*SP*TP -
4115      &               TP**2 - 2.D0*Q2*(3*SP + TP))*XQ2 -
4116      &               2.D0*(Q2*(SP**2 + 6.D0*SP*TP + TP**2) -
4117      &               2.D0*SP*(SP**2 + 4.D0*SP*TP + 3.D0*TP**2))*
4118      &               XQ2**2 + 8.D0*(SP + TP)**2*XQ2**3)/
4119      &               (SP**2*TP**2*((Q2 - SP)**2 - 4.D0*Q2*XQ2))
4120             WEIGHT = HELFLX(3)*SIGQPM(3)/(2.D0*(SH+GQ2(2)))
4121           ELSE IF(MSPR.EQ.13) THEN
4122             Q2 = -GQ2(2)
4123             SP = SH
4124             TP = TH
4125             SIGQPM(3) = 32.D0*PI**2*2.D0*ALPHA1*QC2*ALPHA2
4126      &        *(-Q2*(SP*TP*(-Q2+SP+TP)+(Q2**2-Q2*SP-2*SP*TP)*XQ2 +
4127      &        SP*XQ2**2))/((Q2-SP)**2*(-TP+XQ2)*(Q2-SP-TP+XQ2))
4128             WEIGHT = HELFLX(3)*SIGQPM(3)/(2.D0*(SH+GQ2(2)))
4129           ELSE IF(MSPR.EQ.14) THEN
4130             SWP0M0 = 4.D0*RR*GQ2(2)*(-CC**2*GQ2(1)*W2
4131      &              -XKAP*XKAM*Q1KK**2)/DD
4132             SWP0P0 = - SWP0M0+2.D0*GQ2(2)*GQ2(1)**2*W2*BB/DD
4133             SWPP00 = 2.D0*W2*BB*(AA-2.D0*CC*RR)
4134      &              *SQRT(GQ2(1)*GQ2(2))/DD
4135             SWP00P = 4.D0*RR*(CC**2*(GQ2(1)*Q2KK+GQ2(2)*Q1KK)
4136      &              +XKAP*XKAM*Q1KK*Q2KK)*SQRT(GQ2(1)*GQ2(2))/DD
4137             SW0PM0 = -SWP00P-2.D0*GQ2(1)*GQ2(2)*W2*BB
4138      &              *SQRT(GQ2(1)*GQ2(2))/DD
4139             SIGQPM(3) = SWP0P0*FAC
4140             SIGQPM(6) = (SWPP00+SW0PM0)/2.D0*FAC
4141             WEIGHT = HELFLX(3)*SIGQPM(3)
4142      &              +HELFLX(6)*SIGQPM(6)/2.D0
4143           ENDIF
4144         ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.1)) THEN
4145           IF(MSPR.EQ.10) THEN
4146             Q2 = -GQ2(1)
4147             SP = SH-XQ2
4148             TP = UH-XQ2
4149             SIGQPM(4) = 32.D0*PI**2*8.D0/3.D0*ALPHA1*QC2*ALPHA2
4150      &               *Q2*(-(SP**2*TP**2*(-Q2 + SP + TP)) +
4151      &               SP*TP*(2.D0*Q2**2 + 3.D0*SP**2 + 2.D0*SP*TP -
4152      &               TP**2 - 2.D0*Q2*(3*SP + TP))*XQ2 -
4153      &               2.D0*(Q2*(SP**2 + 6.D0*SP*TP + TP**2) -
4154      &               2.D0*SP*(SP**2 + 4.D0*SP*TP + 3.D0*TP**2))*
4155      &               XQ2**2 + 8.D0*(SP + TP)**2*XQ2**3)/
4156      &               (SP**2*TP**2*((Q2 - SP)**2 - 4.D0*Q2*XQ2))
4157             WEIGHT = HELFLX(4)*SIGQPM(4)/(2.D0*(SH+GQ2(1)))
4158           ELSE IF(MSPR.EQ.11) THEN
4159             Q2 = -GQ2(1)
4160             SP = SH
4161             TP = TH
4162             SIGQPM(4) = 32.D0*PI**2*2.D0*ALPHA1*QC2*ALPHA2
4163      &        *(-Q2*(SP*TP*(-Q2+SP+TP)+(Q2**2-Q2*SP-2*SP*TP)*XQ2 +
4164      &        SP*XQ2**2))/((Q2-SP)**2*(-TP+XQ2)*(Q2-SP-TP+XQ2))
4165             WEIGHT = HELFLX(4)*SIGQPM(4)/(2.D0*(SH+GQ2(2)))
4166           ELSE IF(MSPR.EQ.14) THEN
4167             SW0P0M = 4.D0*RR*GQ2(1)*(-CC**2*GQ2(2)*W2
4168      &                               -XKAP*XKAM*Q2KK**2)/DD
4169             SW0P0P = - SW0P0M+2.D0*GQ2(1)*GQ2(2)**2*W2*BB/DD
4170             SWPP00 = 2.D0*W2*BB*(AA-2.D0*CC*RR)
4171      &              *SQRT(GQ2(1)*GQ2(2))/DD
4172             SWP00P = 4.D0*RR*(CC**2*(GQ2(1)*Q2KK+GQ2(2)*Q1KK)
4173      &              +XKAP*XKAM*Q1KK*Q2KK)*SQRT(GQ2(1)*GQ2(2))/DD
4174             SW0PM0 = -SWP00P-2.D0*GQ2(1)*GQ2(2)*W2*BB
4175      &              *SQRT(GQ2(1)*GQ2(2))/DD
4176             SIGQPM(4) = SW0P0P*FAC
4177             SIGQPM(6) = (SWPP00+SW0PM0)/2.D0*FAC
4178             WEIGHT = HELFLX(4)*SIGQPM(4)
4179      &              +HELFLX(6)*SIGQPM(6)/2.D0
4180           ENDIF
4181         ELSE IF((IGHEL(1).EQ.0).AND.(IGHEL(2).EQ.0)) THEN
4182           IF(MSPR.EQ.14) THEN
4183             SW0000 = 2.D0*GQ2(1)*GQ2(2)*W2*W2*AA*BB/DD**2
4184             SIGQPM(5) = SW0000*FAC
4185             WEIGHT = HELFLX(5)*SIGQPM(5)
4186           ENDIF
4187         ELSE
4188           WRITE(LO,'(/1X,A,2I3)')
4189      &      'PHO_GGEPEM:ERROR: invalid photon helicities: ',IGHEL
4190           WRITE(LO,'(1X,A,I12)')
4191      &      'PHO_GGEPEM: event rejected (KEVENT)',KEVENT
4192           WEIGHT = 0.D0
4193         ENDIF
4194
4195 C  fully differential cross section dsig/(dQ_^2 dQ_2^2 dy_1 dy_2 dphi)
4196
4197         WGHQPM = WEIGHT/(137.D0**2*16.D0*PI**4*GQ2(1)*GQ2(2))
4198      &          *SQRT(XCAP/YCAP)*PI*SS/(2.D0*YCAP)*PINI(4,1)*PINI(4,2)
4199
4200       ENDIF
4201
4202       END
4203
4204 *$ CREATE PHO_GGBLSR.FOR
4205 *COPY PHO_GGBLSR
4206 CDECK  ID>, PHO_GGBLSR
4207       SUBROUTINE PHO_GGBLSR(NEVENT,EE1,EE2,
4208      &                      Pl_lam_1,Pl_lam_2,X_1,X_2,rho,A)
4209 C***********************************************************************
4210 C
4211 C     interface to call PHOJET (variable energy run) for
4212 C     gamma-gamma collisions via laser backscattering
4213 C
4214 C     input:     EE1         lab. system energy of electron/positron 1
4215 C                EE2         lab. system energy of electron/positron 2
4216 C                NEVENT      number of events to generate
4217 C                Pl_lam_1/2  product of electron and photon pol.
4218 C                X_1/2       standard X parameter
4219 C                rho         ratio of distance to conversion point and
4220 C                            transverse beam size
4221 C                A           ellipticity of electon beam
4222 C
4223 C                (see Ginzburg & Kotkin hep-ph/9905462)
4224 C
4225 C            from /LEPCUT/:
4226 C                YMIN1   lower limit of Y1
4227 C                        (energy fraction taken by photon from electron)
4228 C                YMAX1   upper limit of Y1
4229 C                YMIN2   lower limit of Y2
4230 C                        (energy fraction taken by photon from electron)
4231 C                YMAX2   upper limit of Y2
4232 C
4233 C***********************************************************************
4234       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4235       SAVE
4236
4237       PARAMETER ( PI   = 3.14159265359D0 )
4238
4239 C  input/output channels
4240       INTEGER LI,LO
4241       COMMON /POINOU/ LI,LO
4242 C  event debugging information
4243       INTEGER NMAXD
4244       PARAMETER (NMAXD=100)
4245       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4246      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4247       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4248      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4249 C  photon flux kinematics and cuts
4250       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
4251      &                 YMIN1,YMAX1,YMIN2,YMAX2,
4252      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4253      &                 THMIN1,THMAX1,THMIN2,THMAX2
4254       INTEGER          ITAG1,ITAG2
4255       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
4256      &                YMIN1,YMAX1,YMIN2,YMAX2,
4257      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4258      &                THMIN1,THMAX1,THMIN2,THMAX2,
4259      &                ITAG1,ITAG2
4260 C  gamma-lepton or gamma-hadron vertex information
4261       INTEGER IGHEL,IDPSRC,IDBSRC
4262       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
4263      &                 RADSRC,AMSRC,GAMSRC
4264       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
4265      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
4266      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
4267 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
4268       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
4269       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
4270       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
4271      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
4272 C  event weights and generated cross section
4273       INTEGER IPOWGC,ISWCUT,IVWGHT
4274       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
4275       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
4276      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
4277
4278       parameter (N_dim=100)
4279       dimension X_inp_1(N_dim),F_inp_1(N_dim),F_int_1(N_dim),
4280      &          X_inp_2(N_dim),F_inp_2(N_dim),F_int_2(N_dim),
4281      &          Xgrid(96),Wgrid(96)
4282
4283       DIMENSION P1(4),P2(4)
4284
4285       Pi2 = 2.D0*Pi
4286
4287       WRITE(LO,'(//1X,A,I10)') 'PHO_GGBLSR: events to process',NEVENT
4288
4289       YMAX1 = MIN(X_1/(1.D0+X_1),YMAX1)
4290       YMAX2 = MIN(X_2/(1.D0+X_2),YMAX2)
4291       IF((YMIN1.GT.YMAX1).OR.(YMIN2.GT.YMAX2)) THEN
4292         WRITE(LO,'(/1X,2A,2E12.4)') 'PHO_GGBLSR:ERROR: ',
4293      &    'invalid Ymin1,Ymin2',YMIN1,YMIN2
4294         RETURN
4295       ENDIF
4296       IDPSRC(1) = 0
4297       IDBSRC(1) = 0
4298       IDPSRC(2) = 0
4299       IDBSRC(2) = 0
4300
4301 C  initialize sampling
4302
4303       Max_tab = 50
4304       DELY1 = (YMAX1-YMIN1)/DBLE(Max_tab-1)
4305       DELY2 = (YMAX2-YMIN2)/DBLE(Max_tab-1)
4306
4307       IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
4308      &  'PHO_GGBLSR: table of photon flux ',Max_tab
4309
4310       DO 100 I=1,Max_tab
4311
4312         y1 = YMIN1+DELY1*DBLE(I-1)
4313         r1 = y1/(X_1*(1.D0-y1))
4314         X_inp_1(i) = y1
4315         F_inp_1(i) = 1.D0/(1.D0-y1)-y1+(2.D0*r1-1.D0)**2
4316      &            -Pl_lam_1*X_1*r1*(2.D0*r1-1.D0)*(2.D0-y1)
4317
4318         y2 = YMIN2+DELY2*DBLE(I-1)
4319         r2 = y2/(X_2*(1.D0-y2))
4320         X_inp_2(i) = y2
4321         F_inp_2(i) = 1.D0/(1.D0-y2)-y2+(2.D0*r2-1.D0)**2
4322      &            -Pl_lam_2*X_2*r2*(2.D0*r2-1.D0)*(2.D0-y2)
4323
4324         IF(IDEB(30).GE.1) WRITE(LO,'(5X,1p,2E13.4,5x,2E13.4)')
4325      &    y1,F_inp_1(i),y2,F_inp_2(i)
4326
4327  100  CONTINUE
4328
4329       call pho_samp1d(-1,X_inp_1,F_inp_1,F_int_1,Max_tab,X_out_1)
4330       call pho_samp1d(-1,X_inp_2,F_inp_2,F_int_2,Max_tab,X_out_2)
4331
4332 C  initialize event generator
4333
4334 C  photon 1
4335       EGAM = YMAX1*EE1
4336       P1(1) = 0.D0
4337       P1(2) = 0.D0
4338       P1(3) = EGAM
4339       P1(4) = EGAM
4340 C  photon 2
4341       EGAM = YMAX2*EE2
4342       P2(1) = 0.D0
4343       P2(2) = 0.D0
4344       P2(3) = -EGAM
4345       P2(4) = EGAM
4346       CALL PHO_SETPAR(1,22,0,0.D0)
4347       CALL PHO_SETPAR(2,22,0,0.D0)
4348       CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
4349       CALL PHO_PHIST(-1,SIGMAX)
4350       CALL PHO_LHIST(-1,SIGMAX)
4351
4352 C  generation of events
4353       AY1  = 0.D0
4354       AY2  = 0.D0
4355       AYS1 = 0.D0
4356       AYS2 = 0.D0
4357       NITER = NEVENT
4358       ITRY = 0
4359       ITRW = 0
4360       DO 200 I=1,NITER
4361  150    CONTINUE
4362         ITRY = ITRY+1
4363  175    CONTINUE
4364           ITRW = ITRW+1
4365
4366           call pho_samp1d(1,X_inp_1,F_inp_1,F_int_1,Max_tab,X_out_1)
4367           call pho_samp1d(1,X_inp_2,F_inp_2,F_int_2,Max_tab,X_out_2)
4368
4369           g_1 = sqrt(max(0.D0,X_1/(X_out_1+1.D-6)-X_1-1.D0))
4370           g_2 = sqrt(max(0.D0,X_2/(X_out_2+1.D-6)-X_2-1.D0))
4371           if(abs(1.D0-A).lt.1.D-3) then
4372             v = rho**2/4.D0*g_1*g_2
4373             Wght = exp(-rho**2/8.D0*(g_1-g_2)**2)*pho_ExpBessI0(v)
4374           else
4375             Nint = 16
4376             call pho_gauset(0.D0,Pi2,Nint,Xgrid,Wgrid)
4377             A2 = A**2
4378             fac = rho**2/(4.D0*(1.D0+A2))
4379             Wght = 0.D0
4380             do i1=1,Nint
4381               phi_1 = Xgrid(i1)
4382               do i2=1,Nint
4383                 phi_2 = Xgrid(i2)
4384                 Wght = Wght
4385      &            +exp(-fac*(A2*(g_1*cos(phi_1)+g_2*cos(phi_2))**2
4386      &                         +(g_1*sin(phi_1)+g_2*sin(phi_2))**2))
4387      &            *Wgrid(i1)*Wgrid(i2)
4388               enddo
4389             enddo
4390             Wght = Wght/Pi2**2
4391           endif
4392
4393           IF(Wght.GT.1.D0) THEN
4394             WRITE(LO,'(1X,A,5E11.4)')
4395      &        'PHO_GGBLSR:WEIGHT ERROR:',Y1,Y2,Wght
4396           ENDIF
4397         IF(DT_RNDM(dum).GT.Wght) GOTO 175
4398
4399         Y1 = X_out_1
4400         Y2 = X_out_2
4401
4402         Q2P1 = 0.D0
4403         Q2P2 = 0.D0
4404         GYY(1) = Y1
4405         GQ2(1) = Q2P1
4406         GYY(2) = Y2
4407         GQ2(2) = Q2P2
4408 C  incoming electron 1
4409         PINI(1,1) = 0.D0
4410         PINI(2,1) = 0.D0
4411         PINI(3,1) = EE1
4412         PINI(4,1) = EE1
4413         PINI(5,1) = 0.D0
4414 C  outgoing electron 1
4415         YQ2 = SQRT((1.D0-Y1)*Q2P2)
4416         Q2E = Q2P1/(4.D0*EE1)
4417         E1Y = EE1*(1.D0-Y1)
4418         CALL PHO_SFECFE(SIF,COF)
4419         PFIN(1,1) = YQ2*COF
4420         PFIN(2,1) = YQ2*SIF
4421         PFIN(3,1) = E1Y-Q2E
4422         PFIN(4,1) = E1Y+Q2E
4423         PFIN(5,1) = 0.D0
4424 C  photon 1
4425         P1(1) = -PFIN(1,1)
4426         P1(2) = -PFIN(2,1)
4427         P1(3) = PINI(3,1)-PFIN(3,1)
4428         P1(4) = PINI(4,1)-PFIN(4,1)
4429 C  incoming electron 2
4430         PINI(1,2) = 0.D0
4431         PINI(2,2) = 0.D0
4432         PINI(3,2) = -EE2
4433         PINI(4,2) = EE2
4434         PINI(5,2) = 0.D0
4435 C  outgoing electron 2
4436         YQ2 = SQRT((1.D0-Y2)*Q2P2)
4437         Q2E = Q2P2/(4.D0*EE2)
4438         E1Y = EE2*(1.D0-Y2)
4439         CALL PHO_SFECFE(SIF,COF)
4440         PFIN(1,2) = YQ2*COF
4441         PFIN(2,2) = YQ2*SIF
4442         PFIN(3,2) = -E1Y+Q2E
4443         PFIN(4,2) = E1Y+Q2E
4444         PFIN(5,2) = 0.D0
4445 C  photon 2
4446         P2(1) = -PFIN(1,2)
4447         P2(2) = -PFIN(2,2)
4448         P2(3) = PINI(3,2)-PFIN(3,2)
4449         P2(4) = PINI(4,2)-PFIN(4,2)
4450 C  ECMS cut
4451         GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
4452      &         -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
4453         IF(GGECM.LT.0.1D0) GOTO 175
4454         GGECM = SQRT(GGECM)
4455         IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
4456
4457         PGAM(1,1) = P1(1)
4458         PGAM(2,1) = P1(2)
4459         PGAM(3,1) = P1(3)
4460         PGAM(4,1) = P1(4)
4461         PGAM(5,1) = 0.D0
4462         PGAM(1,2) = P2(1)
4463         PGAM(2,2) = P2(2)
4464         PGAM(3,2) = P2(3)
4465         PGAM(4,2) = P2(4)
4466         PGAM(5,2) = 0.D0
4467 C  photon helicities
4468         IGHEL(1) = 1
4469         IGHEL(2) = 1
4470 C  cut given by user
4471         CALL PHO_PRESEL(5,IREJ)
4472         IF(IREJ.NE.0) GOTO 175
4473 C  event generation
4474         CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
4475         IF(IREJ.NE.0) GOTO 150
4476 C  statistics
4477         AY1  = AY1+Y1
4478         AYS1 = AYS1+Y1*Y1
4479         AY2  = AY2+Y2
4480         AYS2 = AYS2+Y2*Y2
4481 C  histograms
4482         CALL PHO_PHIST(1,HSWGHT(0))
4483         CALL PHO_LHIST(1,HSWGHT(0))
4484  200  CONTINUE
4485
4486       WGY  = DBLE(ITRY)/DBLE(ITRW)
4487       AY1  = AY1/DBLE(NITER)
4488       AYS1 = AYS1/DBLE(NITER)
4489       DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
4490       AY2  = AY2/DBLE(NITER)
4491       AYS2 = AYS2/DBLE(NITER)
4492       DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
4493       WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
4494 C  output of statistics, histograms
4495       WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
4496      &'=========================================================',
4497      &' *****   simulated cross section: ',WEIGHT,' mb  *****',
4498      &'========================================================='
4499       WRITE(LO,'(//1X,A,3I10)')
4500      &  'PHO_GGBLSR:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
4501       WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
4502      &  WGY,WEIGHT
4503       WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBLSR:AVERAGE Y1,DY1 ',AY1,DAY1
4504       WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBLSR:AVERAGE Y2,DY2 ',AY2,DAY2
4505
4506       CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
4507       IF(NITER.GT.1) THEN
4508         CALL PHO_PHIST(-2,WEIGHT)
4509         CALL PHO_LHIST(-2,WEIGHT)
4510       ELSE
4511         WRITE(LO,'(1X,A,I4)') 'PHO_GGBLSR:NO OUTPUT OF HISTOGRAMS',NITER
4512       ENDIF
4513
4514       END
4515
4516 *$ CREATE pho_samp1d.FOR
4517 *COPY pho_samp1d
4518 CDECK  ID>, pho_samp1d
4519       SUBROUTINE pho_samp1d(Imode,X_inp,F_inp,F_int,N_dim,X_out)
4520 C***********************************************************************
4521 C
4522 C     Monte Carlo sampling from arbitrary 1d distribution
4523 C     (linear interpolation to improve reproduction of initial function)
4524 C
4525 C     input: Imode          -1  initialization
4526 C                            1  sampling (after initialization)
4527 C            X_inp(N_dim)   array with x values
4528 C            F_inp(N_dim)   array with function values
4529 C            F_int(N_dim)   array with integral
4530 C
4531 C     output:  X_out        sampled value (Imode=1)
4532 C
4533 C                                                 (R.E. 10/99)
4534 C
4535 C***********************************************************************
4536       implicit none
4537       save
4538
4539 C  input/output channels
4540       INTEGER LI,LO
4541       COMMON /POINOU/ LI,LO
4542
4543       integer Imode,N_dim
4544       double precision X_inp,F_inp,F_int,X_out
4545       dimension X_inp(N_dim),F_inp(N_dim),F_int(N_dim)
4546
4547 C  local variables
4548       integer i
4549       double precision dum,xi,a,b
4550
4551 C  external functions
4552       double precision DT_RNDM
4553       external DT_RNDM
4554
4555       if(Imode.eq.-1) then
4556
4557 C  initialization
4558
4559         F_int(1) = 0.D0
4560         do i=2,N_dim
4561           F_int(i) = F_int(i-1)
4562      &       +0.5D0*(F_inp(i)+F_inp(i-1))*(X_inp(i)-X_inp(i-1))
4563         enddo
4564
4565       else if(Imode.eq.1) then
4566
4567 C  sample from previously calculated integral
4568
4569         xi = DT_RNDM(dum)*F_int(N_dim)
4570
4571         do i=2,N_dim
4572           if(xi.lt.F_int(i)) then
4573             a = (F_inp(i)-F_inp(i-1))/(X_inp(i)-X_inp(i-1))
4574             b = F_inp(i)-a*X_inp(i)
4575             xi = xi-F_int(i-1)+0.5D0*a*X_inp(i-1)**2+b*X_inp(i-1)
4576             X_out = (sqrt(b**2+2.D0*a*xi)-b)/a
4577             return
4578           endif
4579         enddo
4580         X_out = X_inp(N_dim)
4581
4582       else
4583
4584 C  invalid option Imode
4585
4586         WRITE(LO,'(1x,a,i6)') 'PHO_SAMP1D: invalid option Imode: ',Imode
4587         X_out = 0.D0
4588
4589       endif
4590
4591       END
4592
4593 *$ CREATE pho_ExpBessI0.FOR
4594 *COPY pho_ExpBessI0
4595 CDECK  ID>, pho_ExpBessI0
4596       DOUBLE PRECISION FUNCTION pho_ExpBessI0(X)
4597 C**********************************************************************
4598 C
4599 C     Bessel Function I0 times exponential function from neg. arg.
4600 C     (defined for pos. arguments only)
4601 C
4602 C**********************************************************************
4603       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4604       SAVE
4605
4606       AX = ABS(X)
4607       IF (AX .LT. 3.75D0) THEN
4608         Y = (X/3.75D0)**2
4609         pho_ExpBessI0 =
4610      &    (1.0D0+Y*(3.5156229D0+Y*(3.0899424D0+Y*(1.2067492D0
4611      &    +Y*(0.2659732D0+Y*(0.360768D-1+Y*0.45813D-2))))))*EXP(-AX)
4612       ELSE
4613         Y = 3.75D0/AX
4614         pho_ExpBessI0 =
4615      &    (1.D0/SQRT(AX))*(0.39894228D0+Y*(0.1328592D-1
4616      &    +Y*(0.225319D-2+Y*(-0.157565D-2+Y*(0.916281D-2
4617      &    +Y*(-0.2057706D-1+Y*(0.2635537D-1+Y*(-0.1647633D-1
4618      &    +Y*0.392377D-2))))))))
4619       ENDIF
4620
4621       END
4622
4623 *$ CREATE PHO_GGBEAM.FOR
4624 *COPY PHO_GGBEAM
4625 CDECK  ID>, PHO_GGBEAM
4626       SUBROUTINE PHO_GGBEAM(NEVENT,EE,YPSI,SIGX,SIGY,SIGZ,AEB)
4627 C**********************************************************************
4628 C
4629 C     interface to call PHOJET (variable energy run) for
4630 C     gamma-gamma collisions via beamstrahlung
4631 C
4632 C     input:     EE      LAB system energy of electron/positron
4633 C                YPSI    beamstrahlung parameter
4634 C                SIGX,Y  transverse bunch dimensions
4635 C                SIGZ    longitudinal bunch dimension
4636 C                AEB     number of electrons/positrons in a bunch
4637 C                NEVENT  number of events to generate
4638 C            from /LEPCUT/:
4639 C                YMIN1   lower limit of Y
4640 C                        (energy fraction taken by photon from electron)
4641 C                YMAX1   upper cutoff for Y, necessary to avoid
4642 C                        underflows
4643 C
4644 C**********************************************************************
4645       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4646       SAVE
4647
4648       PARAMETER ( DEPS = 1.D-20,
4649      &            PI   = 3.14159265359D0 )
4650
4651 C  input/output channels
4652       INTEGER LI,LO
4653       COMMON /POINOU/ LI,LO
4654 C  event debugging information
4655       INTEGER NMAXD
4656       PARAMETER (NMAXD=100)
4657       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4658      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4659       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4660      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4661 C  photon flux kinematics and cuts
4662       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
4663      &                 YMIN1,YMAX1,YMIN2,YMAX2,
4664      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4665      &                 THMIN1,THMAX1,THMIN2,THMAX2
4666       INTEGER          ITAG1,ITAG2
4667       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
4668      &                YMIN1,YMAX1,YMIN2,YMAX2,
4669      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4670      &                THMIN1,THMAX1,THMIN2,THMAX2,
4671      &                ITAG1,ITAG2
4672 C  gamma-lepton or gamma-hadron vertex information
4673       INTEGER IGHEL,IDPSRC,IDBSRC
4674       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
4675      &                 RADSRC,AMSRC,GAMSRC
4676       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
4677      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
4678      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
4679 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
4680       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
4681       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
4682       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
4683      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
4684 C  event weights and generated cross section
4685       INTEGER IPOWGC,ISWCUT,IVWGHT
4686       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
4687       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
4688      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
4689
4690       PARAMETER (Max_tab=100)
4691       DIMENSION P1(4),P2(4),TABCU(0:Max_tab),TABYL(0:Max_tab)
4692 C
4693       WRITE(LO,'(//1X,A,I10)') 'PHO_GGBEAM: events to process',NEVENT
4694 C  electron data
4695       RE = 2.818D-12
4696       ELEM = 0.512D-03
4697       IDPSRC(1) = 0
4698       IDBSRC(1) = 0
4699       IDPSRC(2) = 0
4700       IDBSRC(2) = 0
4701 C  table of flux function, log interpolation
4702       IF(YPSI.LE.0.D0) THEN
4703         YPSI  = 5.D0*RE**2*EE*AEB*137.D0/(6.D0*SIGZ*(SIGX+SIGY)*ELEM)
4704       ENDIF
4705       WRITE(LO,'(/1X,A,E12.4)')
4706      &  'PHO_GGBEAM: beamstrahlung parameter:',YPSI
4707       WRITE(LO,'(/1X,A,2E12.4)')
4708      &  'PHO_GGBEAM: sigma-z,ne-bunch:',SIGZ,AEB
4709       TT    = 2.D0/3.D0
4710       OT    = 1.D0/3.D0
4711 C     GAOT  = DGAMMA(OT)
4712       GAOT  = 2.6789385347D0
4713       AKAP  = TT/YPSI
4714       WW    = 1.D0/(6.D0*SQRT(AKAP))
4715       ANGAM = 5.D0*SIGZ*ELEM/(137.D0**2*2.D0*RE*EE)
4716      &       *YPSI/SQRT(1.D0+YPSI**TT)
4717
4718       YMIN = YMIN1
4719       YMAX = MIN(YMAX1,0.9D0)
4720       TABCU(0) = 0.D0
4721       TABYL(0) = LOG(YMIN)
4722       DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
4723       FLUX = 0.D0
4724       IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,I5)')
4725      &  'PHO_GGBEAM: table of photon flux',Max_tab
4726       DO 100 I=1,Max_tab
4727         Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
4728         GG = 1.D0-0.5D0*(1-Y)**TT*(1.D0-Y+(1.D0+Y)*SQRT(1.D0+YPSI**TT))
4729         FF = AKAP**OT/GAOT/Y**TT/(1.D0-Y)**OT*EXP(-AKAP*Y/(1.D0-Y))
4730      &      *((1.D0-WW)/GG*(1.D0-(1.D0-EXP(-ANGAM*GG))/(ANGAM*GG))
4731      &      +WW*(1.D0-(1.D0-EXP(-ANGAM))/ANGAM))
4732         TABCU(I) = TABCU(I-1)+FF*Y
4733         TABYL(I) = LOG(Y)
4734         FLUX = FLUX+Y*FF
4735         IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y,FF
4736  100  CONTINUE
4737       FLUX = FLUX*DELLY
4738       IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
4739      &  'PHO_GGBEAM: integrated flux (one side):',FLUX
4740
4741       EE1 = EE
4742       EE2 = EE
4743 C  photon 1
4744       EGAM = YMAX*EE
4745       P1(1) = 0.D0
4746       P1(2) = 0.D0
4747       P1(3) = EGAM
4748       P1(4) = EGAM
4749 C  photon 2
4750       EGAM = YMAX*EE
4751       P2(1) = 0.D0
4752       P2(2) = 0.D0
4753       P2(3) = -EGAM
4754       P2(4) = EGAM
4755       CALL PHO_SETPAR(1,22,0,0.D0)
4756       CALL PHO_SETPAR(2,22,0,0.D0)
4757       CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
4758       CALL PHO_PHIST(-1,SIGMAX)
4759       CALL PHO_LHIST(-1,SIGMAX)
4760
4761 C  generation of events
4762       AY1  = 0.D0
4763       AY2  = 0.D0
4764       AYS1 = 0.D0
4765       AYS2 = 0.D0
4766       NITER = NEVENT
4767       ITRY = 0
4768       ITRW = 0
4769       DO 200 I=1,NITER
4770  150    CONTINUE
4771         ITRY = ITRY+1
4772  175    CONTINUE
4773         ITRW = ITRW+1
4774         XI = DT_RNDM(AY1)*TABCU(Max_tab)
4775         DO 110 K=1,Max_tab
4776           IF(TABCU(K).GE.XI) THEN
4777             Y1 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
4778             Y1 = EXP(Y1)
4779             GOTO 120
4780           ENDIF
4781  110    CONTINUE
4782         Y1 = YMAX
4783  120    CONTINUE
4784         XI = DT_RNDM(AY2)*TABCU(Max_tab)
4785         DO 130 K=1,Max_tab
4786           IF(TABCU(K).GE.XI) THEN
4787             Y2 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
4788             Y2 = EXP(Y2)
4789             GOTO 140
4790           ENDIF
4791  130    CONTINUE
4792         Y2 = YMAX
4793  140    CONTINUE
4794         Q2P1 = 0.D0
4795         Q2P2 = 0.D0
4796         GYY(1) = Y1
4797         GQ2(1) = Q2P1
4798         GYY(2) = Y2
4799         GQ2(2) = Q2P2
4800 C  incoming electron 1
4801         PINI(1,1) = 0.D0
4802         PINI(2,1) = 0.D0
4803         PINI(3,1) = EE1
4804         PINI(4,1) = EE1
4805         PINI(5,1) = 0.D0
4806 C  outgoing electron 1
4807         YQ2 = SQRT((1.D0-Y1)*Q2P2)
4808         Q2E = Q2P1/(4.D0*EE1)
4809         E1Y = EE1*(1.D0-Y1)
4810         CALL PHO_SFECFE(SIF,COF)
4811         PFIN(1,1) = YQ2*COF
4812         PFIN(2,1) = YQ2*SIF
4813         PFIN(3,1) = E1Y-Q2E
4814         PFIN(4,1) = E1Y+Q2E
4815         PFIN(5,1) = 0.D0
4816 C  photon 1
4817         P1(1) = -PFIN(1,1)
4818         P1(2) = -PFIN(2,1)
4819         P1(3) = PINI(3,1)-PFIN(3,1)
4820         P1(4) = PINI(4,1)-PFIN(4,1)
4821 C  incoming electron 2
4822         PINI(1,2) = 0.D0
4823         PINI(2,2) = 0.D0
4824         PINI(3,2) = -EE2
4825         PINI(4,2) = EE2
4826         PINI(5,2) = 0.D0
4827 C  outgoing electron 2
4828         YQ2 = SQRT((1.D0-Y2)*Q2P2)
4829         Q2E = Q2P2/(4.D0*EE2)
4830         E1Y = EE2*(1.D0-Y2)
4831         CALL PHO_SFECFE(SIF,COF)
4832         PFIN(1,2) = YQ2*COF
4833         PFIN(2,2) = YQ2*SIF
4834         PFIN(3,2) = -E1Y+Q2E
4835         PFIN(4,2) = E1Y+Q2E
4836         PFIN(5,2) = 0.D0
4837 C  photon 2
4838         P2(1) = -PFIN(1,2)
4839         P2(2) = -PFIN(2,2)
4840         P2(3) = PINI(3,2)-PFIN(3,2)
4841         P2(4) = PINI(4,2)-PFIN(4,2)
4842 C  ECMS cut
4843         GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
4844      &         -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
4845         IF(GGECM.LT.0.1D0) GOTO 175
4846         GGECM = SQRT(GGECM)
4847         IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
4848 C
4849         PGAM(1,1) = P1(1)
4850         PGAM(2,1) = P1(2)
4851         PGAM(3,1) = P1(3)
4852         PGAM(4,1) = P1(4)
4853         PGAM(5,1) = 0.D0
4854         PGAM(1,2) = P2(1)
4855         PGAM(2,2) = P2(2)
4856         PGAM(3,2) = P2(3)
4857         PGAM(4,2) = P2(4)
4858         PGAM(5,2) = 0.D0
4859 C  photon helicities
4860         IGHEL(1) = 1
4861         IGHEL(2) = 1
4862 C  cut given by user
4863         CALL PHO_PRESEL(5,IREJ)
4864         IF(IREJ.NE.0) GOTO 175
4865 C  event generation
4866         CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
4867         IF(IREJ.NE.0) GOTO 150
4868         GGECML = LOG(GGECM)
4869 C  statistics
4870         AY1  = AY1+Y1
4871         AYS1 = AYS1+Y1*Y1
4872         AY2  = AY2+Y2
4873         AYS2 = AYS2+Y2*Y2
4874 C  histograms
4875         CALL PHO_PHIST(1,HSWGHT(0))
4876         CALL PHO_LHIST(1,HSWGHT(0))
4877  200  CONTINUE
4878 C
4879       WGY  = FLUX**2*DBLE(ITRY)/DBLE(ITRW)
4880       AY1  = AY1/DBLE(NITER)
4881       AYS1 = AYS1/DBLE(NITER)
4882       DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
4883       AY2  = AY2/DBLE(NITER)
4884       AYS2 = AYS2/DBLE(NITER)
4885       DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
4886       WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
4887 C  output of statistics, histograms
4888       WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
4889      &'=========================================================',
4890      &' *****   simulated cross section: ',WEIGHT,' mb  *****',
4891      &'========================================================='
4892       WRITE(LO,'(//1X,A,2I10)')
4893      &  'PHO_GGBEAM:SUMMARY:NITER,ITRY',NITER,ITRY
4894       WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
4895      &  WGY,WEIGHT
4896       WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBEAM:AVERAGE Y1,DY1 ',AY1,DAY1
4897       WRITE(LO,'(1X,A,2F10.5)') 'PHO_GGBEAM:AVERAGE Y2,DY2 ',AY2,DAY2
4898 C
4899       CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
4900       IF(NITER.GT.1) THEN
4901         CALL PHO_PHIST(-2,WEIGHT)
4902         CALL PHO_LHIST(-2,WEIGHT)
4903       ELSE
4904         WRITE(LO,'(1X,A,I4)') 'PHO_GGBEAM:NO OUTPUT OF HISTOGRAMS',NITER
4905       ENDIF
4906
4907       END
4908
4909 *$ CREATE PHO_GGHIOF.FOR
4910 *COPY PHO_GGHIOF
4911 CDECK  ID>, PHO_GGHIOF
4912       SUBROUTINE PHO_GGHIOF(NEVENT,EEN,NA,NZ)
4913 C**********************************************************************
4914 C
4915 C     interface to call PHOJET (variable energy run) for
4916 C     gamma-gamma collisions via heavy ions (form factor approach)
4917 C
4918 C     input:     EEN     LAB system energy per nucleon
4919 C                NA      atomic number of ion/hadron
4920 C                NZ      charge number of ion/hadron
4921 C                NEVENT  number of events to generate
4922 C            from /LEPCUT/:
4923 C                YMIN1,2 lower limit of Y
4924 C                        (energy fraction taken by photon from hadron)
4925 C                YMAX1,2 upper cutoff for Y, necessary to avoid
4926 C                        underflows
4927 C                Q2MIN1,2 minimum Q**2 of photons (should be set to 0)
4928 C                Q2MAX1,2 maximum Q**2 of photons (if necessary,
4929 C                        corrected according size of hadron)
4930 C
4931 C      currently implemented approximation similar to:
4932 C                E.Papageorgiu PhysLettB250(1990)155
4933 C
4934 C**********************************************************************
4935       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4936       SAVE
4937
4938       PARAMETER ( PI   = 3.14159265359D0 )
4939
4940 C  input/output channels
4941       INTEGER LI,LO
4942       COMMON /POINOU/ LI,LO
4943 C  model switches and parameters
4944       CHARACTER*8 MDLNA
4945       INTEGER ISWMDL,IPAMDL
4946       DOUBLE PRECISION PARMDL
4947       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4948 C  event debugging information
4949       INTEGER NMAXD
4950       PARAMETER (NMAXD=100)
4951       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4952      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4953       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4954      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4955 C  photon flux kinematics and cuts
4956       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
4957      &                 YMIN1,YMAX1,YMIN2,YMAX2,
4958      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4959      &                 THMIN1,THMAX1,THMIN2,THMAX2
4960       INTEGER          ITAG1,ITAG2
4961       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
4962      &                YMIN1,YMAX1,YMIN2,YMAX2,
4963      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
4964      &                THMIN1,THMAX1,THMIN2,THMAX2,
4965      &                ITAG1,ITAG2
4966 C  gamma-lepton or gamma-hadron vertex information
4967       INTEGER IGHEL,IDPSRC,IDBSRC
4968       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
4969      &                 RADSRC,AMSRC,GAMSRC
4970       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
4971      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
4972      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
4973 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
4974       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
4975       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
4976       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
4977      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
4978 C  event weights and generated cross section
4979       INTEGER IPOWGC,ISWCUT,IVWGHT
4980       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
4981       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
4982      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
4983
4984       DIMENSION P1(4),P2(4),BIMP(2,2)
4985 C
4986       WRITE(LO,'(2(/1X,A))') 'PHO_GGHIOF:GAMMA-GAMMA EVENT GENERATION',
4987      &                      '--------------------------------------'
4988 C  hadron size and mass
4989       FM2GEV = 5.07D0
4990       HIMASS = DBLE(NA)*0.938D0
4991       HIMA2  = HIMASS**2
4992       HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
4993       ALPHA  = DBLE(NZ**2)/137.D0
4994 C  correct Q2MAX1,2 according to hadron size
4995       Q2MAXH = 2.D0/HIRADI**2
4996       Q2MAX1 = MIN(Q2MAX1,Q2MAXH)
4997       Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
4998       IF(Q2MAX1.LT.1.D-20) Q2MAX1 = Q2MAXH
4999       IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
5000 C  total hadron / heavy ion energy
5001       EE = EEN*DBLE(NA)
5002       GAMMA = EE/HIMASS
5003 C  setup /POFSRC/
5004       GAMSRC(1) = GAMMA
5005       GAMSRC(2) = GAMMA
5006       RADSRC(1) = HIRADI
5007       RADSRC(2) = HIRADI
5008       AMSRC(1)  = HIMASS
5009       AMSRC(1)  = HIMASS
5010 C  kinematic limitations
5011       YMI = (ECMIN/(2.D0*EE))**2
5012       IF(YMIN1.LT.YMI) THEN
5013         WRITE(LO,'(/1X,A,2E12.5)')
5014      &    'PHO_GGHIOF: ymin1 increased to (old/new)',YMIN1,YMI
5015         YMIN1 = YMI
5016       ELSE IF(YMIN1.GT.YMI) THEN
5017         WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5018      &    'PHO_GGHIOF:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
5019      &    '  INSTEAD OF',YMIN1
5020       ENDIF
5021       IF(YMIN2.LT.YMI) THEN
5022         WRITE(LO,'(/1X,A,2E12.5)')
5023      &    'PHO_GGHIOF: ymin2 increased to (old/new)',YMIN2,YMI
5024         YMIN2 = YMI
5025       ELSE IF(YMIN2.GT.YMI) THEN
5026         WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5027      &    'PHO_GGHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
5028      &    '  INSTEAD OF',YMIN2
5029       ENDIF
5030 C  kinematic limitation
5031       Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
5032       Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
5033 C  debug output
5034       WRITE(LO,'(/6X,A,2I4)')   'MASS NUMBER, CHARGE NUMBER  ',NA,NZ
5035       WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV)           ',HIMASS
5036       WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1)     ',HIRADI
5037       WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 1 (GEV**2)',Q2LOW1,
5038      &  Q2MAX1
5039       WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
5040      &  Q2MAX2
5041       WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1            ',YMIN1,
5042      &  YMAX1
5043       WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2            ',YMIN2,
5044      &  YMAX2
5045       WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL  ',
5046      &  2.D0*EEN,2.D0*EE
5047       WRITE(LO,'(6X,A,I10)')   'EVENTS TO PROCESS           ',NEVENT
5048       IF(Q2LOW1.GE.Q2MAX1) THEN
5049         WRITE(LO,'(/1X,A,2E12.4)')
5050      &    'PHO_GGHIOF:ERROR:INCONSISTENT Q**2 RANGE 1',Q2LOW1,Q2MAX1
5051         CALL PHO_ABORT
5052       ENDIF
5053       IF(Q2LOW2.GE.Q2MAX2) THEN
5054         WRITE(LO,'(/1X,A,2E12.4)')
5055      &    'PHO_GGHIOF:ERROR:INCONSISTENT Q**2 RANGE 2',Q2LOW2,Q2MAX2
5056         CALL PHO_ABORT
5057       ENDIF
5058 C  hadron numbers set to 0
5059       IDPSRC(1) = 0
5060       IDPSRC(2) = 0
5061       IDBSRC(1) = 0
5062       IDBSRC(2) = 0
5063 C
5064       Max_tab = 100
5065       YMAX = YMAX1
5066       YMIN = YMIN1
5067       XMAX = LOG(YMAX)
5068       XMIN = LOG(YMIN)
5069       XDEL = XMAX-XMIN
5070       DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5071       DO 100 I=1,Max_tab
5072         Y1 = EXP(XMIN+DELLY*DBLE(I-1))
5073         Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
5074         IF(Q2LOW1.GE.Q2MAX1) THEN
5075           WRITE(LO,'(/1X,A,2E12.4)')
5076      &      'PHO_GGHIOF: ymax1 changed from/to',YMAX1,Y1
5077           YMAX1 = MIN(Y1,YMAX1)
5078           GOTO 101
5079         ENDIF
5080  100  CONTINUE
5081  101  CONTINUE
5082       YMAX = YMAX2
5083       YMIN = YMIN2
5084       XMAX = LOG(YMAX)
5085       XMIN = LOG(YMIN)
5086       XDEL = XMAX-XMIN
5087       DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5088       DO 102 I=1,Max_tab
5089         Y1 = EXP(XMIN+DELLY*DBLE(I-1))
5090         Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
5091         IF(Q2LOW2.GE.Q2MAX2) THEN
5092           WRITE(LO,'(/1X,A,2E12.4)')
5093      &      'PHO_GGHIOF: ymax2 changed from/to',YMAX2,Y1
5094           YMAX2 = MIN(Y1,YMAX2)
5095           GOTO 103
5096         ENDIF
5097  102  CONTINUE
5098  103  CONTINUE
5099       YMI = (ECMIN/(2.D0*EE))**2/YMAX2
5100       IF(YMI.GT.YMIN1) THEN
5101         WRITE(LO,'(/1X,A,2E12.4)')
5102      &    'PHO_GGHIOF: ymin1 changed from/to',YMIN1,YMI
5103         YMIN1 = YMI
5104       ENDIF
5105       YMI = (ECMIN/(2.D0*EE))**2/YMAX1
5106       IF(YMI.GT.YMIN2) THEN
5107         WRITE(LO,'(/1X,A,2E12.4)')
5108      &    'PHO_GGHIOF: ymin2 changed from/to',YMIN2,YMI
5109         YMIN2 = YMI
5110       ENDIF
5111 C
5112       X1MAX = LOG(YMAX1)
5113       X1MIN = LOG(YMIN1)
5114       X1DEL = X1MAX-X1MIN
5115       X2MAX = LOG(YMAX2)
5116       X2MIN = LOG(YMIN2)
5117       X2DEL = X2MAX-X2MIN
5118       DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
5119       FLUX = 0.D0
5120       IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
5121      &  'PHO_GGHIOF: table of raw photon flux (side 1)',Max_tab
5122       DO 105 I=1,Max_tab
5123         Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
5124         Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
5125         FF = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
5126      &        -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))*ALPHA/(2.D0*PI)
5127         FLUX = FLUX+Y1*FF
5128         IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y1,FF
5129  105  CONTINUE
5130       FLUX = FLUX*DELLY
5131       IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
5132      &  'PHO_GGHIOF: integrated flux (one side):',FLUX
5133 C
5134       Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
5135       Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
5136       Y1 = YMIN1
5137       Y2 = YMIN2
5138       WGMAX = ((1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
5139      &         -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
5140      &       *((1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
5141      &         -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
5142 C
5143 C  photon 1
5144       EGAM = YMAX1*EE
5145       P1(1) = 0.D0
5146       P1(2) = 0.D0
5147       P1(3) = EGAM
5148       P1(4) = EGAM
5149 C  photon 2
5150       EGAM = YMAX2*EE
5151       P2(1) = 0.D0
5152       P2(2) = 0.D0
5153       P2(3) = -EGAM
5154       P2(4) = EGAM
5155       CALL PHO_SETPAR(1,22,0,0.D0)
5156       CALL PHO_SETPAR(2,22,0,0.D0)
5157       CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
5158       CALL PHO_PHIST(-1,SIGMAX)
5159       CALL PHO_LHIST(-1,SIGMAX)
5160 C
5161 C  generation of events, flux calculation
5162       ECFRAC = ECMIN**2/(4.D0*EE*EE)
5163       AY1  = 0.D0
5164       AY2  = 0.D0
5165       AYS1 = 0.D0
5166       AYS2 = 0.D0
5167       Q21MIN = 1.D30
5168       Q22MIN = 1.D30
5169       Q21MAX = 0.D0
5170       Q22MAX = 0.D0
5171       Q21AVE = 0.D0
5172       Q22AVE = 0.D0
5173       Q21AV2 = 0.D0
5174       Q22AV2 = 0.D0
5175       YY1MIN = 1.D30
5176       YY2MIN = 1.D30
5177       YY1MAX = 0.D0
5178       YY2MAX = 0.D0
5179       NITER = NEVENT
5180       ITRY = 0
5181       ITRW = 0
5182       DO 200 I=1,NITER
5183 C  sample y1, y2
5184  150    CONTINUE
5185         ITRY = ITRY+1
5186  175    CONTINUE
5187           ITRW = ITRW+1
5188           Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
5189           Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
5190           IF(Y1*Y2.LT.ECFRAC) GOTO 175
5191 C
5192           Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1**2/(1.D0-Y1))
5193           IF(Q2LOW1.GE.Q2MAX1) GOTO 175
5194           Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
5195           IF(Q2LOW2.GE.Q2MAX2) GOTO 175
5196           Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
5197           Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
5198           WGH = ((1.D0+(1.D0-Y1)**2)*Q2LOG1
5199      &        -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1)
5200      &         *((1.D0+(1.D0-Y2)**2)*Q2LOG2
5201      &        -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2)
5202           IF(WGMAX.LT.WGH) THEN
5203             WRITE(LO,'(1X,A,4E12.5)')
5204      &        'PHO_GGHIOF:WEIGHT ERROR:',Y1,Y2,WGMAX,WGH
5205           ENDIF
5206         IF(DT_RNDM(AYS1)*WGMAX.GT.WGH) GOTO 175
5207 C  sample Q2
5208         IF(IPAMDL(174).EQ.1) THEN
5209           YEFF = 1.D0+(1.D0-Y1)**2
5210  185      CONTINUE
5211             Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
5212             WEIGHT = (YEFF-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF
5213           IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
5214         ELSE
5215           Q2P1 = Q2LOW1
5216         ENDIF
5217         IF(IPAMDL(174).EQ.1) THEN
5218           YEFF = 1.D0+(1.D0-Y2)**2
5219  186      CONTINUE
5220             Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
5221             WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
5222           IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
5223         ELSE
5224           Q2P2 = Q2LOW2
5225         ENDIF
5226 C  impact parameter
5227         GAIMP(1) = 1.D0/SQRT(Q2P1)
5228         GAIMP(2) = 1.D0/SQRT(Q2P2)
5229 C  form factor (squared)
5230         FF21 = 1.D0
5231         IF(GAIMP(1).LT.HIRADI) FF21 = 0.D0
5232         FF22 = 1.D0
5233         IF(GAIMP(2).LT.HIRADI) FF22 = 0.D0
5234         IF(DT_RNDM(Q2P1).GE.FF21*FF22) GOTO 175
5235 C  do the hadrons overlap?
5236         IF(ISWMDL(26).GT.0) THEN
5237           DO 190 K=1,2
5238             CALL PHO_SFECFE(SIF,COF)
5239             BIMP(1,K) = SIF*GAIMP(K)
5240             BIMP(2,K) = COF*GAIMP(K)
5241  190      CONTINUE
5242           BBABS = SQRT((BIMP(1,1)-BIMP(1,2))**2
5243      &                 +(BIMP(2,1)-BIMP(2,2))**2)
5244           IF(BBABS.LT.HIRADI+HIRADI) GOTO 175
5245         ENDIF
5246 C  photon data
5247         GYY(1) = Y1
5248         GQ2(1) = Q2P1
5249         GYY(2) = Y2
5250         GQ2(2) = Q2P2
5251 C
5252 C  incoming hadron 1
5253         PINI(1,1) = 0.D0
5254         PINI(2,1) = 0.D0
5255         PINI(3,1) = EE
5256         PINI(4,1) = EE
5257         PINI(5,1) = 0.D0
5258 C  outgoing hadron 1
5259         YQ2 = SQRT((1.D0-Y1)*Q2P1)
5260         Q2E = Q2P1/(4.D0*EE)
5261         E1Y = EE*(1.D0-Y1)
5262         CALL PHO_SFECFE(SIF,COF)
5263         PFIN(1,1) = YQ2*COF
5264         PFIN(2,1) = YQ2*SIF
5265         PFIN(3,1) = E1Y-Q2E
5266         PFIN(4,1) = E1Y+Q2E
5267         PFIN(5,1) = 0.D0
5268         PFPHI(1) = ATAN2(COF,SIF)
5269         PFTHE(1) = ACOS((E1Y-Q2E)/(Q2E+E1Y))
5270 C  photon 1
5271         P1(1) = -PFIN(1,1)
5272         P1(2) = -PFIN(2,1)
5273         P1(3) = PINI(3,1)-PFIN(3,1)
5274         P1(4) = PINI(4,1)-PFIN(4,1)
5275 C  incoming hadron 2
5276         PINI(1,2) = 0.D0
5277         PINI(2,2) = 0.D0
5278         PINI(3,2) = -EE
5279         PINI(4,2) = EE
5280         PINI(5,2) = 0.D0
5281 C  outgoing hadron 2
5282         YQ2 = SQRT((1.D0-Y2)*Q2P2)
5283         Q2E = Q2P2/(4.D0*EE)
5284         E1Y = EE*(1.D0-Y2)
5285         CALL PHO_SFECFE(SIF,COF)
5286         PFIN(1,2) = YQ2*COF
5287         PFIN(2,2) = YQ2*SIF
5288         PFIN(3,2) = -E1Y+Q2E
5289         PFIN(4,2) = E1Y+Q2E
5290         PFIN(5,2) = 0.D0
5291         PFPHI(2) = ATAN2(COF,SIF)
5292         PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
5293 C  photon 2
5294         P2(1) = -PFIN(1,2)
5295         P2(2) = -PFIN(2,2)
5296         P2(3) = PINI(3,2)-PFIN(3,2)
5297         P2(4) = PINI(4,2)-PFIN(4,2)
5298 C  ECMS cut
5299         GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
5300      &         -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
5301         IF(GGECM.LT.0.1D0) GOTO 175
5302         GGECM = SQRT(GGECM)
5303         IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
5304 C
5305         PGAM(1,1) = P1(1)
5306         PGAM(2,1) = P1(2)
5307         PGAM(3,1) = P1(3)
5308         PGAM(4,1) = P1(4)
5309         PGAM(5,1) = -SQRT(Q2P1)
5310         PGAM(1,2) = P2(1)
5311         PGAM(2,2) = P2(2)
5312         PGAM(3,2) = P2(3)
5313         PGAM(4,2) = P2(4)
5314         PGAM(5,2) = -SQRT(Q2P2)
5315 C  photon helicities
5316         IGHEL(1) = 1
5317         IGHEL(2) = 1
5318 C  cut given by user
5319         CALL PHO_PRESEL(5,IREJ)
5320         IF(IREJ.NE.0) GOTO 175
5321 C  event generation
5322         CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
5323         IF(IREJ.NE.0) GOTO 150
5324 C  statistics
5325         AY1  = AY1+Y1
5326         AYS1 = AYS1+Y1*Y1
5327         AY2  = AY2+Y2
5328         AYS2 = AYS2+Y2*Y2
5329         Q21MIN = MIN(Q21MIN,Q2P1)
5330         Q22MIN = MIN(Q22MIN,Q2P2)
5331         Q21MAX = MAX(Q21MAX,Q2P1)
5332         Q22MAX = MAX(Q22MAX,Q2P2)
5333         YY1MIN = MIN(YY1MIN,Y1)
5334         YY2MIN = MIN(YY2MIN,Y2)
5335         YY1MAX = MAX(YY1MAX,Y1)
5336         YY2MAX = MAX(YY2MAX,Y2)
5337         Q21AVE = Q21AVE+Q2P1
5338         Q22AVE = Q22AVE+Q2P2
5339         Q21AV2 = Q21AV2+Q2P1*Q2P1
5340         Q22AV2 = Q22AV2+Q2P2*Q2P2
5341 C  histograms
5342         CALL PHO_PHIST(1,HSWGHT(0))
5343         CALL PHO_LHIST(1,HSWGHT(0))
5344  200  CONTINUE
5345 C
5346       WGY  = WGMAX*DBLE(ITRY)/DBLE(ITRW)*(ALPHA/(2.D0*PI))**2
5347       WGY  = WGY*LOG(YMAX1/YMIN1)*LOG(YMAX2/YMIN2)
5348       AY1  = AY1/DBLE(NITER)
5349       AYS1 = AYS1/DBLE(NITER)
5350       DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
5351       AY2  = AY2/DBLE(NITER)
5352       AYS2 = AYS2/DBLE(NITER)
5353       DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
5354       Q21AVE = Q21AVE/DBLE(NITER)
5355       Q21AV2 = Q21AV2/DBLE(NITER)
5356       Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(NITER))
5357       Q22AVE = Q22AVE/DBLE(NITER)
5358       Q22AV2 = Q22AV2/DBLE(NITER)
5359       Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(NITER))
5360       WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
5361 C  output of statistics, histograms
5362       WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
5363      &'=========================================================',
5364      &' *****   simulated cross section: ',WEIGHT,' mb  *****',
5365      &'========================================================='
5366       WRITE(LO,'(//1X,A,3I10)')
5367      &  'PHO_GGHIOF:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
5368       WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
5369      &  WGY,WEIGHT
5370       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1               ',
5371      &  AY1,DAY1
5372       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2               ',
5373      &  AY2,DAY2
5374       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1     ',
5375      &  YY1MIN,YY1MAX
5376       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2     ',
5377      &  YY2MIN,YY2MAX
5378       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 1      ',
5379      &  Q21AVE,Q21AV2
5380       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 1    ',
5381      &  Q21MIN,Q21MAX
5382       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2  PHOTON 2     ',
5383      &  Q22AVE,Q22AV2
5384       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2    ',
5385      &  Q22MIN,Q22MAX
5386 C
5387       CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
5388       IF(NITER.GT.1) THEN
5389         CALL PHO_PHIST(-2,WEIGHT)
5390         CALL PHO_LHIST(-2,WEIGHT)
5391       ELSE
5392         WRITE(LO,'(1X,A,I4)') 'PHO_GGHIOF:NO OUTPUT OF HISTOGRAMS',NITER
5393       ENDIF
5394
5395       END
5396
5397 *$ CREATE PHO_GGHIOG.FOR
5398 *COPY PHO_GGHIOG
5399 CDECK  ID>, PHO_GGHIOG
5400       SUBROUTINE PHO_GGHIOG(NEVENT,EEN,NA,NZ)
5401 C**********************************************************************
5402 C
5403 C     interface to call PHOJET (variable energy run) for
5404 C     gamma-gamma collisions via heavy ions (geometrical approach)
5405 C
5406 C
5407 C     input:     EEN     LAB system energy per nucleon
5408 C                NA      atomic number of ion/hadron
5409 C                NZ      charge number of ion/hadron
5410 C                NEVENT  number of events to generate
5411 C            from /LEPCUT/:
5412 C                YMIN1,2 lower limit of Y
5413 C                        (energy fraction taken by photon from hadron)
5414 C                YMAX1,2 upper cutoff for Y, necessary to avoid
5415 C                        underflows
5416 C
5417 C      currently implemented approximation similar to:
5418 C
5419 C
5420 C**********************************************************************
5421       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5422       SAVE
5423
5424       PARAMETER ( DEPS = 1.D-20,
5425      &            PI   = 3.14159265359D0 )
5426
5427 C  input/output channels
5428       INTEGER LI,LO
5429       COMMON /POINOU/ LI,LO
5430 C  event debugging information
5431       INTEGER NMAXD
5432       PARAMETER (NMAXD=100)
5433       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
5434      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
5435       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
5436      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
5437 C  photon flux kinematics and cuts
5438       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
5439      &                 YMIN1,YMAX1,YMIN2,YMAX2,
5440      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
5441      &                 THMIN1,THMAX1,THMIN2,THMAX2
5442       INTEGER          ITAG1,ITAG2
5443       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
5444      &                YMIN1,YMAX1,YMIN2,YMAX2,
5445      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
5446      &                THMIN1,THMAX1,THMIN2,THMAX2,
5447      &                ITAG1,ITAG2
5448 C  gamma-lepton or gamma-hadron vertex information
5449       INTEGER IGHEL,IDPSRC,IDBSRC
5450       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
5451      &                 RADSRC,AMSRC,GAMSRC
5452       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
5453      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
5454      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
5455 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
5456       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
5457       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
5458       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
5459      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
5460 C  event weights and generated cross section
5461       INTEGER IPOWGC,ISWCUT,IVWGHT
5462       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
5463       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
5464      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
5465
5466       PARAMETER (Max_tab=100)
5467       DIMENSION P1(4),P2(4),TABCU(0:Max_tab),TABYL(0:Max_tab)
5468 C
5469       WRITE(LO,'(2(/1X,A))') 'PHO_GGHIOG: gamma-gamma event generation',
5470      &                      '---------------------------------------'
5471 C  hadron size and mass
5472       FM2GEV = 5.07D0
5473       HIMASS = DBLE(NA)*0.938D0
5474       HIMA2  = HIMASS**2
5475       HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
5476       ALPHA  = DBLE(NZ**2)/137.D0
5477 C  total hadron / heavy ion energy
5478       EE     = EEN*DBLE(NA)
5479       GAMMA  = EE/HIMASS
5480 C  setup /POFSRC/
5481       GAMSRC(1) = GAMMA
5482       GAMSRC(2) = GAMMA
5483       RADSRC(1) = HIRADI
5484       RADSRC(2) = HIRADI
5485       AMSRC(1)  = HIMASS
5486       AMSRC(1)  = HIMASS
5487 C  kinematic limitations
5488       YMI = (ECMIN/(2.D0*EE))**2
5489       IF(YMIN1.LT.YMI) THEN
5490         WRITE(LO,'(/1X,A,2E12.5)')
5491      &    'PHO_GGHIOG: ymin1 increased to (old/new)',YMIN1,YMI
5492         YMIN1 = YMI
5493       ELSE IF(YMIN1.GT.YMI) THEN
5494         WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5495      &    'PHO_GGHIOG:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
5496      &    '  INSTEAD OF',YMIN1
5497       ENDIF
5498       IF(YMIN2.LT.YMI) THEN
5499         WRITE(LO,'(/1X,A,2E12.5)')
5500      &    'PHO_GGHIOG: ymin2 increased to (old/new)',YMIN2,YMI
5501         YMIN2 = YMI
5502       ELSE IF(YMIN2.GT.YMI) THEN
5503         WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
5504      &    'PHO_GGHIOG:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
5505      &    '  INSTEAD OF',YMIN2
5506       ENDIF
5507 C  debug output
5508       WRITE(LO,'(/6X,A,2I4)')   'MASS NUMBER, CHARGE NUMBER  ',NA,NZ
5509       WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV)           ',HIMASS
5510       WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1)     ',HIRADI
5511       WRITE(LO,'(6X,A,E12.5)') 'LORENTZ GAMMA               ',GAMMA
5512       WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1            ',YMIN1,
5513      &  YMAX1
5514       WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2            ',YMIN2,
5515      &  YMAX2
5516       WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL  ',
5517      &  2.D0*EEN,2.D0*EE
5518       WRITE(LO,'(6X,A,I10)')   'EVENTS TO PROCESS           ',NEVENT
5519 C  hadron numbers set to 0
5520       IDPSRC(1) = 0
5521       IDBSRC(1) = 0
5522       IDPSRC(2) = 0
5523       IDBSRC(2) = 0
5524 C  table of flux function, log interpolation
5525       YMIN = YMIN1
5526       YMAX = YMAX1
5527       YMAX = MIN(YMAX,0.9999999D0)
5528       DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5529       TABYL(0) = LOG(YMIN)
5530       FFMAX = 0.D0
5531       DO 100 I=1,Max_tab
5532         Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
5533         WG = EE*Y
5534         XI = WG*HIRADI/GAMMA
5535         FF = ALPHA*PHO_GGFLCL(XI)/Y
5536         FFMAX = MAX(FF,FFMAX)
5537         IF(FF.LT.1.D-10*FFMAX) THEN
5538           WRITE(LO,'(/1X,A,2E12.4)')
5539      &      'PHO_GGHIOG: ymax1 changed from/to',YMAX1,Y
5540           YMAX1 = MIN(Y,YMAX1)
5541           GOTO 101
5542         ENDIF
5543  100  CONTINUE
5544  101  CONTINUE
5545       YMIN = YMIN2
5546       YMAX = YMAX2
5547       YMAX = MIN(YMAX,0.9999999D0)
5548       DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5549       TABYL(0) = LOG(YMIN)
5550       FFMAX = 0.D0
5551       DO 102 I=1,Max_tab
5552         Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
5553         WG = EE*Y
5554         XI = WG*HIRADI/GAMMA
5555         FF = ALPHA*PHO_GGFLCL(XI)/Y
5556         FFMAX = MAX(FF,FFMAX)
5557         IF(FF.LT.1.D-10*FFMAX) THEN
5558           WRITE(LO,'(/1X,A,2E12.4)')
5559      &      'PHO_GGHIOG: ymax2 changed from/to',YMAX2,Y
5560           YMAX2 = MIN(Y,YMAX2)
5561           GOTO 103
5562         ENDIF
5563  102  CONTINUE
5564  103  CONTINUE
5565       YMI = (ECMIN/(2.D0*EE))**2/YMAX2
5566       IF(YMI.GT.YMIN1) THEN
5567         WRITE(LO,'(/1X,A,2E12.4)')
5568      &    'PHO_GGHIOG: ymin1 changed from/to',YMIN1,YMI
5569         YMIN1 = YMI
5570       ENDIF
5571       YMAX1 = MIN(YMAX,YMAX1)
5572       YMI = (ECMIN/(2.D0*EE))**2/YMAX1
5573       IF(YMI.GT.YMIN2) THEN
5574         WRITE(LO,'(/1X,A,2E12.4)')
5575      &    'PHO_GGHIOG: ymin2 changed from/to',YMIN2,YMI
5576         YMIN2 = YMI
5577       ENDIF
5578 C
5579       YMIN = YMIN1
5580       YMAX = YMAX1
5581       DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
5582       TABCU(0) = 0.D0
5583       TABYL(0) = LOG(YMIN)
5584       FLUX = 0.D0
5585       IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
5586      &  'PHO_GGHIOG: table of raw photon flux (side 1)',Max_tab
5587       DO 105 I=1,Max_tab
5588         Y = EXP(TABYL(0)+DELLY*DBLE(I-1))
5589         WG = EE*Y
5590         XI = WG*HIRADI/GAMMA
5591         FF = ALPHA*PHO_GGFLCL(XI)/Y
5592         FFMAX = MAX(FF,FFMAX)
5593         TABCU(I) = TABCU(I-1)+FF*Y
5594         TABYL(I) = LOG(Y)
5595         FLUX = FLUX+Y*FF
5596         IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y,FF
5597  105  CONTINUE
5598       FLUX = FLUX*DELLY
5599       IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
5600      &  'PHO_GGHIOG: integrated flux (one side):',FLUX
5601 C
5602 C  initialization
5603 C  photon 1
5604       EGAM = YMAX*EE
5605       P1(1) = 0.D0
5606       P1(2) = 0.D0
5607       P1(3) = EGAM
5608       P1(4) = EGAM
5609 C  photon 2
5610       EGAM = YMAX*EE
5611       P2(1) = 0.D0
5612       P2(2) = 0.D0
5613       P2(3) = -EGAM
5614       P2(4) = EGAM
5615       CALL PHO_SETPAR(1,22,0,0.D0)
5616       CALL PHO_SETPAR(2,22,0,0.D0)
5617       CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
5618       CALL PHO_PHIST(-1,SIGMAX)
5619       CALL PHO_LHIST(-1,SIGMAX)
5620 C
5621 C  generation of events
5622       AY1  = 0.D0
5623       AY2  = 0.D0
5624       AYS1 = 0.D0
5625       AYS2 = 0.D0
5626       YY1MIN = 1.D30
5627       YY2MIN = 1.D30
5628       YY1MAX = 0.D0
5629       YY2MAX = 0.D0
5630       NITER = NEVENT
5631       ITRY = 0
5632       ITRW = 0
5633       DO 200 I=1,NITER
5634  150    CONTINUE
5635         ITRY = ITRY+1
5636  175    CONTINUE
5637         ITRW = ITRW+1
5638         XI = DT_RNDM(AY1)*TABCU(Max_tab)
5639         DO 110 K=1,Max_tab
5640           IF(TABCU(K).GE.XI) THEN
5641             Y1 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
5642             Y1 = EXP(Y1)
5643             GOTO 120
5644           ENDIF
5645  110    CONTINUE
5646         Y1 = YMAX1
5647  120    CONTINUE
5648         XI = DT_RNDM(AY2)*TABCU(Max_tab)
5649         DO 130 K=1,Max_tab
5650           IF(TABCU(K).GE.XI) THEN
5651             Y2 = DELLY/(TABCU(K)-TABCU(K-1))*(XI-TABCU(K-1))+TABYL(K-1)
5652             Y2 = EXP(Y2)
5653             GOTO 140
5654           ENDIF
5655  130    CONTINUE
5656         Y2 = YMAX2
5657  140    CONTINUE
5658 C  setup kinematics
5659         GYY(1) = Y1
5660         GQ2(1) = 0.D0
5661         GYY(2) = Y2
5662         GQ2(2) = 0.D0
5663 C  incoming electron 1
5664         PINI(1,1) = 0.D0
5665         PINI(2,1) = 0.D0
5666         PINI(3,1) = EE
5667         PINI(4,1) = EE
5668         PINI(5,1) = 0.D0
5669 C  outgoing electron 1
5670         E1Y = EE*(1.D0-Y1)
5671         PFIN(1,1) = 0.D0
5672         PFIN(2,1) = 0.D0
5673         PFIN(3,1) = E1Y
5674         PFIN(4,1) = E1Y
5675         PFIN(5,1) = 0.D0
5676 C  photon 1
5677         P1(1) = -PFIN(1,1)
5678         P1(2) = -PFIN(2,1)
5679         P1(3) = PINI(3,1)-PFIN(3,1)
5680         P1(4) = PINI(4,1)-PFIN(4,1)
5681 C  incoming electron 2
5682         PINI(1,2) = 0.D0
5683         PINI(2,2) = 0.D0
5684         PINI(3,2) = -EE
5685         PINI(4,2) = EE
5686         PINI(5,2) = 0.D0
5687 C  outgoing electron 2
5688         E1Y = EE*(1.D0-Y2)
5689         PFIN(1,2) = 0.D0
5690         PFIN(2,2) = 0.D0
5691         PFIN(3,2) = -E1Y
5692         PFIN(4,2) = E1Y
5693         PFIN(5,2) = 0.D0
5694 C  photon 2
5695         P2(1) = -PFIN(1,2)
5696         P2(2) = -PFIN(2,2)
5697         P2(3) = PINI(3,2)-PFIN(3,2)
5698         P2(4) = PINI(4,2)-PFIN(4,2)
5699 C  ECMS cut
5700         GGECM = (P1(4)+P2(4))**2-(P1(3)+P2(3))**2
5701         IF(GGECM.LT.0.1D0) GOTO 175
5702         GGECM = SQRT(GGECM)
5703         IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
5704         PGAM(1,1) = P1(1)
5705         PGAM(2,1) = P1(2)
5706         PGAM(3,1) = P1(3)
5707         PGAM(4,1) = P1(4)
5708         PGAM(5,1) = 0.D0
5709         PGAM(1,2) = P2(1)
5710         PGAM(2,2) = P2(2)
5711         PGAM(3,2) = P2(3)
5712         PGAM(4,2) = P2(4)
5713         PGAM(5,2) = 0.D0
5714 C  impact parameter constraints
5715         XI1   = P1(4)*HIRADI/GAMMA
5716         XI2   = P2(4)*HIRADI/GAMMA
5717         FLX   = PHO_GGFLCL(XI1)*PHO_GGFLCL(XI2)
5718         FCORR = PHO_GGFLCR(HIRADI)
5719         WGX   = (FLX-FCORR)/FLX
5720         IF(DT_RNDM(Y2).GT.WGX) GOTO 175
5721 C  photon helicities
5722         IGHEL(1) = 1
5723         IGHEL(2) = 1
5724 C  cut given by user
5725         CALL PHO_PRESEL(5,IREJ)
5726         IF(IREJ.NE.0) GOTO 175
5727 C  event generation
5728         CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
5729         IF(IREJ.NE.0) GOTO 150
5730 C  statistics
5731         AY1  = AY1+Y1
5732         AYS1 = AYS1+Y1*Y1
5733         AY2  = AY2+Y2
5734         AYS2 = AYS2+Y2*Y2
5735         YY1MIN = MIN(YY1MIN,Y1)
5736         YY2MIN = MIN(YY2MIN,Y2)
5737         YY1MAX = MAX(YY1MAX,Y1)
5738         YY2MAX = MAX(YY2MAX,Y2)
5739 C  histograms
5740         CALL PHO_PHIST(1,HSWGHT(0))
5741         CALL PHO_LHIST(1,HSWGHT(0))
5742  200  CONTINUE
5743 C
5744       WGY  = FLUX**2*DBLE(ITRY)/DBLE(ITRW)
5745       AY1  = AY1/DBLE(NITER)
5746       AYS1 = AYS1/DBLE(NITER)
5747       DAY1 = SQRT((AYS1-AY1**2)/DBLE(NITER))
5748       AY2  = AY2/DBLE(NITER)
5749       AYS2 = AYS2/DBLE(NITER)
5750       DAY2 = SQRT((AYS2-AY2**2)/DBLE(NITER))
5751       WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
5752 C  output of statistics, histograms
5753       WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
5754      &'=========================================================',
5755      &' *****   simulated cross section: ',WEIGHT,' mb  *****',
5756      &'========================================================='
5757       WRITE(LO,'(//1X,A,3I12)')
5758      &  'PHO_GGHIOG:SUMMARY:NITER,ITRY,ITRW',NITER,ITRY,ITRW
5759       WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
5760      &  WGY,WEIGHT
5761       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1               ',
5762      &  AY1,DAY1
5763       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2               ',
5764      &  AY2,DAY2
5765       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1     ',
5766      &  YY1MIN,YY1MAX
5767       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2     ',
5768      &  YY2MIN,YY2MAX
5769
5770 C
5771       CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
5772       IF(NITER.GT.1) THEN
5773         CALL PHO_PHIST(-2,WEIGHT)
5774         CALL PHO_LHIST(-2,WEIGHT)
5775       ELSE
5776         WRITE(LO,'(1X,A,I4)') 'PHO_GGHIOG:NO OUTPUT OF HISTOGRAMS',NITER
5777       ENDIF
5778
5779       END
5780
5781 *$ CREATE PHO_GGFLCL.FOR
5782 *COPY PHO_GGFLCL
5783 CDECK  ID>, PHO_GGFLCL
5784       DOUBLE PRECISION FUNCTION PHO_GGFLCL(XI)
5785 C*********************************************************************
5786 C
5787 C     semi-classical photon flux (geometrical model)
5788 C
5789 C*********************************************************************
5790       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5791       SAVE
5792
5793       PHO_GGFLCL = 2.D0/3.1415927D0*(XI*PHO_BESSK0(XI)*PHO_BESSK1(XI)
5794      &  -XI**2/2.D0*(PHO_BESSK1(XI)**2-PHO_BESSK0(XI)**2))
5795
5796       END
5797
5798 *$ CREATE PHO_GGFLCR.FOR
5799 *COPY PHO_GGFLCR
5800 CDECK  ID>, PHO_GGFLCR
5801       DOUBLE PRECISION FUNCTION PHO_GGFLCR(XI)
5802 C*********************************************************************
5803 C
5804 C     semi-classical photon flux correction due to
5805 C     overlap in impact parameter space (geometrical model)
5806 C
5807 C*********************************************************************
5808       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5809       SAVE
5810
5811       PARAMETER (PI = 3.14159265359D0, ACCUR = 1D-2)
5812
5813 C  input/output channels
5814       INTEGER LI,LO
5815       COMMON /POINOU/ LI,LO
5816 C  gamma-lepton or gamma-hadron vertex information
5817       INTEGER IGHEL,IDPSRC,IDBSRC
5818       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
5819      &                 RADSRC,AMSRC,GAMSRC
5820       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
5821      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
5822      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
5823
5824       DIMENSION XGAUSS(126),WGAUSS(126)
5825
5826       DATA XGAUSS(1)/ .57735026918962576D0/
5827       DATA XGAUSS(2)/-.57735026918962576D0/
5828       DATA WGAUSS(1)/ 1.00000000000000000D0/
5829       DATA WGAUSS(2)/ 1.00000000000000000D0/
5830
5831       DATA XGAUSS(3)/ .33998104358485627D0/
5832       DATA XGAUSS(4)/ .86113631159405258D0/
5833       DATA XGAUSS(5)/-.33998104358485627D0/
5834       DATA XGAUSS(6)/-.86113631159405258D0/
5835       DATA WGAUSS(3)/ .65214515486254613D0/
5836       DATA WGAUSS(4)/ .34785484513745385D0/
5837       DATA WGAUSS(5)/ .65214515486254613D0/
5838       DATA WGAUSS(6)/ .34785484513745385D0/
5839
5840       DATA XGAUSS(7)/ .18343464249564981D0/
5841       DATA XGAUSS(8)/ .52553240991632899D0/
5842       DATA XGAUSS(9)/ .79666647741362674D0/
5843       DATA XGAUSS(10)/ .96028985649753623D0/
5844       DATA XGAUSS(11)/-.18343464249564981D0/
5845       DATA XGAUSS(12)/-.52553240991632899D0/
5846       DATA XGAUSS(13)/-.79666647741362674D0/
5847       DATA XGAUSS(14)/-.96028985649753623D0/
5848       DATA WGAUSS(7)/ .36268378337836198D0/
5849       DATA WGAUSS(8)/ .31370664587788727D0/
5850       DATA WGAUSS(9)/ .22238103445337448D0/
5851       DATA WGAUSS(10)/ .10122853629037627D0/
5852       DATA WGAUSS(11)/ .36268378337836198D0/
5853       DATA WGAUSS(12)/ .31370664587788727D0/
5854       DATA WGAUSS(13)/ .22238103445337448D0/
5855       DATA WGAUSS(14)/ .10122853629037627D0/
5856
5857       DATA XGAUSS(15)/ .0950125098376374402D0/
5858       DATA XGAUSS(16)/ .281603550779258913D0/
5859       DATA XGAUSS(17)/ .458016777657227386D0/
5860       DATA XGAUSS(18)/ .617876244402643748D0/
5861       DATA XGAUSS(19)/ .755404408355003034D0/
5862       DATA XGAUSS(20)/ .865631202387831744D0/
5863       DATA XGAUSS(21)/ .944575023073232576D0/
5864       DATA XGAUSS(22)/ .989400934991649933D0/
5865       DATA XGAUSS(23)/-.0950125098376374402D0/
5866       DATA XGAUSS(24)/-.281603550779258913D0/
5867       DATA XGAUSS(25)/-.458016777657227386D0/
5868       DATA XGAUSS(26)/-.617876244402643748D0/
5869       DATA XGAUSS(27)/-.755404408355003034D0/
5870       DATA XGAUSS(28)/-.865631202387831744D0/
5871       DATA XGAUSS(29)/-.944575023073232576D0/
5872       DATA XGAUSS(30)/-.989400934991649933D0/
5873       DATA WGAUSS(15)/ .189450610455068496D0/
5874       DATA WGAUSS(16)/ .182603415044923589D0/
5875       DATA WGAUSS(17)/ .169156519395002538D0/
5876       DATA WGAUSS(18)/ .149595988816576732D0/
5877       DATA WGAUSS(19)/ .124628971255533872D0/
5878       DATA WGAUSS(20)/ .0951585116824927848D0/
5879       DATA WGAUSS(21)/ .0622535239386478929D0/
5880       DATA WGAUSS(22)/ .0271524594117540949D0/
5881       DATA WGAUSS(23)/ .189450610455068496D0/
5882       DATA WGAUSS(24)/ .182603415044923589D0/
5883       DATA WGAUSS(25)/ .169156519395002538D0/
5884       DATA WGAUSS(26)/ .149595988816576732D0/
5885       DATA WGAUSS(27)/ .124628971255533872D0/
5886       DATA WGAUSS(28)/ .0951585116824927848D0/
5887       DATA WGAUSS(29)/ .0622535239386478929D0/
5888       DATA WGAUSS(30)/ .0271524594117540949D0/
5889
5890       DATA XGAUSS(31)/ .0483076656877383162D0/
5891       DATA XGAUSS(32)/ .144471961582796493D0/
5892       DATA XGAUSS(33)/ .239287362252137075D0/
5893       DATA XGAUSS(34)/ .331868602282127650D0/
5894       DATA XGAUSS(35)/ .421351276130635345D0/
5895       DATA XGAUSS(36)/ .506899908932229390D0/
5896       DATA XGAUSS(37)/ .587715757240762329D0/
5897       DATA XGAUSS(38)/ .663044266930215201D0/
5898       DATA XGAUSS(39)/ .732182118740289680D0/
5899       DATA XGAUSS(40)/ .794483795967942407D0/
5900       DATA XGAUSS(41)/ .849367613732569970D0/
5901       DATA XGAUSS(42)/ .896321155766052124D0/
5902       DATA XGAUSS(43)/ .934906075937739689D0/
5903       DATA XGAUSS(44)/ .964762255587506430D0/
5904       DATA XGAUSS(45)/ .985611511545268335D0/
5905       DATA XGAUSS(46)/ .997263861849481564D0/
5906       DATA XGAUSS(47)/-.0483076656877383162D0/
5907       DATA XGAUSS(48)/-.144471961582796493D0/
5908       DATA XGAUSS(49)/-.239287362252137075D0/
5909       DATA XGAUSS(50)/-.331868602282127650D0/
5910       DATA XGAUSS(51)/-.421351276130635345D0/
5911       DATA XGAUSS(52)/-.506899908932229390D0/
5912       DATA XGAUSS(53)/-.587715757240762329D0/
5913       DATA XGAUSS(54)/-.663044266930215201D0/
5914       DATA XGAUSS(55)/-.732182118740289680D0/
5915       DATA XGAUSS(56)/-.794483795967942407D0/
5916       DATA XGAUSS(57)/-.849367613732569970D0/
5917       DATA XGAUSS(58)/-.896321155766052124D0/
5918       DATA XGAUSS(59)/-.934906075937739689D0/
5919       DATA XGAUSS(60)/-.964762255587506430D0/
5920       DATA XGAUSS(61)/-.985611511545268335D0/
5921       DATA XGAUSS(62)/-.997263861849481564D0/
5922       DATA WGAUSS(31)/ .0965400885147278006D0/
5923       DATA WGAUSS(32)/ .0956387200792748594D0/
5924       DATA WGAUSS(33)/ .0938443990808045654D0/
5925       DATA WGAUSS(34)/ .0911738786957638847D0/
5926       DATA WGAUSS(35)/ .0876520930044038111D0/
5927       DATA WGAUSS(36)/ .0833119242269467552D0/
5928       DATA WGAUSS(37)/ .0781938957870703065D0/
5929       DATA WGAUSS(38)/ .0723457941088485062D0/
5930       DATA WGAUSS(39)/ .0658222227763618468D0/
5931       DATA WGAUSS(40)/ .0586840934785355471D0/
5932       DATA WGAUSS(41)/ .0509980592623761762D0/
5933       DATA WGAUSS(42)/ .0428358980222266807D0/
5934       DATA WGAUSS(43)/ .0342738629130214331D0/
5935       DATA WGAUSS(44)/ .0253920653092620595D0/
5936       DATA WGAUSS(45)/ .0162743947309056706D0/
5937       DATA WGAUSS(46)/ .00701861000947009660D0/
5938       DATA WGAUSS(47)/ .0965400885147278006D0/
5939       DATA WGAUSS(48)/ .0956387200792748594D0/
5940       DATA WGAUSS(49)/ .0938443990808045654D0/
5941       DATA WGAUSS(50)/ .0911738786957638847D0/
5942       DATA WGAUSS(51)/ .0876520930044038111D0/
5943       DATA WGAUSS(52)/ .0833119242269467552D0/
5944       DATA WGAUSS(53)/ .0781938957870703065D0/
5945       DATA WGAUSS(54)/ .0723457941088485062D0/
5946       DATA WGAUSS(55)/ .0658222227763618468D0/
5947       DATA WGAUSS(56)/ .0586840934785355471D0/
5948       DATA WGAUSS(57)/ .0509980592623761762D0/
5949       DATA WGAUSS(58)/ .0428358980222266807D0/
5950       DATA WGAUSS(59)/ .0342738629130214331D0/
5951       DATA WGAUSS(60)/ .0253920653092620595D0/
5952       DATA WGAUSS(61)/ .0162743947309056706D0/
5953       DATA WGAUSS(62)/ .00701861000947009660D0/
5954
5955       DATA XGAUSS(63)/ .02435029266342443250D0/
5956       DATA XGAUSS(64)/ .0729931217877990394D0/
5957       DATA XGAUSS(65)/ .121462819296120554D0/
5958       DATA XGAUSS(66)/ .169644420423992818D0/
5959       DATA XGAUSS(67)/ .217423643740007084D0/
5960       DATA XGAUSS(68)/ .264687162208767416D0/
5961       DATA XGAUSS(69)/ .311322871990210956D0/
5962       DATA XGAUSS(70)/ .357220158337668116D0/
5963       DATA XGAUSS(71)/ .402270157963991604D0/
5964       DATA XGAUSS(72)/ .446366017253464088D0/
5965       DATA XGAUSS(73)/ .489403145707052957D0/
5966       DATA XGAUSS(74)/ .531279464019894546D0/
5967       DATA XGAUSS(75)/ .571895646202634034D0/
5968       DATA XGAUSS(76)/ .611155355172393250D0/
5969       DATA XGAUSS(77)/ .648965471254657340D0/
5970       DATA XGAUSS(78)/ .685236313054233243D0/
5971       DATA XGAUSS(79)/ .719881850171610827D0/
5972       DATA XGAUSS(80)/ .752819907260531897D0/
5973       DATA XGAUSS(81)/ .783972358943341408D0/
5974       DATA XGAUSS(82)/ .813265315122797560D0/
5975       DATA XGAUSS(83)/ .840629296252580363D0/
5976       DATA XGAUSS(84)/ .865999398154092820D0/
5977       DATA XGAUSS(85)/ .889315445995114106D0/
5978       DATA XGAUSS(86)/ .910522137078502806D0/
5979       DATA XGAUSS(87)/ .929569172131939576D0/
5980       DATA XGAUSS(88)/ .946411374858402816D0/
5981       DATA XGAUSS(89)/ .961008799652053719D0/
5982       DATA XGAUSS(90)/ .973326827789910964D0/
5983       DATA XGAUSS(91)/ .983336253884625957D0/
5984       DATA XGAUSS(92)/ .991013371476744321D0/
5985       DATA XGAUSS(93)/ .996340116771955279D0/
5986       DATA XGAUSS(94)/ .999305041735772139D0/
5987       DATA XGAUSS(95)/-.02435029266342443250D0/
5988       DATA XGAUSS(96)/-.0729931217877990394D0/
5989       DATA XGAUSS(97)/-.121462819296120554D0/
5990       DATA XGAUSS(98)/-.169644420423992818D0/
5991       DATA XGAUSS(99)/-.217423643740007084D0/
5992       DATA XGAUSS(100)/-.264687162208767416D0/
5993       DATA XGAUSS(101)/-.311322871990210956D0/
5994       DATA XGAUSS(102)/-.357220158337668116D0/
5995       DATA XGAUSS(103)/-.402270157963991604D0/
5996       DATA XGAUSS(104)/-.446366017253464088D0/
5997       DATA XGAUSS(105)/-.489403145707052957D0/
5998       DATA XGAUSS(106)/-.531279464019894546D0/
5999       DATA XGAUSS(107)/-.571895646202634034D0/
6000       DATA XGAUSS(108)/-.611155355172393250D0/
6001       DATA XGAUSS(109)/-.648965471254657340D0/
6002       DATA XGAUSS(110)/-.685236313054233243D0/
6003       DATA XGAUSS(111)/-.719881850171610827D0/
6004       DATA XGAUSS(112)/-.752819907260531897D0/
6005       DATA XGAUSS(113)/-.783972358943341408D0/
6006       DATA XGAUSS(114)/-.813265315122797560D0/
6007       DATA XGAUSS(115)/-.840629296252580363D0/
6008       DATA XGAUSS(116)/-.865999398154092820D0/
6009       DATA XGAUSS(117)/-.889315445995114106D0/
6010       DATA XGAUSS(118)/-.910522137078502806D0/
6011       DATA XGAUSS(119)/-.929569172131939576D0/
6012       DATA XGAUSS(120)/-.946411374858402816D0/
6013       DATA XGAUSS(121)/-.961008799652053719D0/
6014       DATA XGAUSS(122)/-.973326827789910964D0/
6015       DATA XGAUSS(123)/-.983336253884625957D0/
6016       DATA XGAUSS(124)/-.991013371476744321D0/
6017       DATA XGAUSS(125)/-.996340116771955279D0/
6018       DATA XGAUSS(126)/-.999305041735772139D0/
6019       DATA WGAUSS(63)/ .0486909570091397204D0/
6020       DATA WGAUSS(64)/ .0485754674415034269D0/
6021       DATA WGAUSS(65)/ .0483447622348029572D0/
6022       DATA WGAUSS(66)/ .0479993885964583077D0/
6023       DATA WGAUSS(67)/ .0475401657148303087D0/
6024       DATA WGAUSS(68)/ .0469681828162100173D0/
6025       DATA WGAUSS(69)/ .0462847965813144172D0/
6026       DATA WGAUSS(70)/ .0454916279274181445D0/
6027       DATA WGAUSS(71)/ .0445905581637565631D0/
6028       DATA WGAUSS(72)/ .0435837245293234534D0/
6029       DATA WGAUSS(73)/ .0424735151236535890D0/
6030       DATA WGAUSS(74)/ .0412625632426235286D0/
6031       DATA WGAUSS(75)/ .0399537411327203414D0/
6032       DATA WGAUSS(76)/ .0385501531786156291D0/
6033       DATA WGAUSS(77)/ .0370551285402400460D0/
6034       DATA WGAUSS(78)/ .0354722132568823838D0/
6035       DATA WGAUSS(79)/ .0338051618371416094D0/
6036       DATA WGAUSS(80)/ .0320579283548515535D0/
6037       DATA WGAUSS(81)/ .0302346570724024789D0/
6038       DATA WGAUSS(82)/ .0283396726142594832D0/
6039       DATA WGAUSS(83)/ .0263774697150546587D0/
6040       DATA WGAUSS(84)/ .0243527025687108733D0/
6041       DATA WGAUSS(85)/ .0222701738083832542D0/
6042       DATA WGAUSS(86)/ .0201348231535302094D0/
6043       DATA WGAUSS(87)/ .0179517157756973431D0/
6044       DATA WGAUSS(88)/ .0157260304760247193D0/
6045       DATA WGAUSS(89)/ .0134630478967186426D0/
6046       DATA WGAUSS(90)/ .0111681394601311288D0/
6047       DATA WGAUSS(91)/ .00884675982636394772D0/
6048       DATA WGAUSS(92)/ .00650445796897836286D0/
6049       DATA WGAUSS(93)/ .00414703326056246764D0/
6050       DATA WGAUSS(94)/ .00178328072169643295D0/
6051       DATA WGAUSS(95)/ .0486909570091397204D0/
6052       DATA WGAUSS(96)/ .0485754674415034269D0/
6053       DATA WGAUSS(97)/ .0483447622348029572D0/
6054       DATA WGAUSS(98)/ .0479993885964583077D0/
6055       DATA WGAUSS(99)/ .0475401657148303087D0/
6056       DATA WGAUSS(100)/ .0469681828162100173D0/
6057       DATA WGAUSS(101)/ .0462847965813144172D0/
6058       DATA WGAUSS(102)/ .0454916279274181445D0/
6059       DATA WGAUSS(103)/ .0445905581637565631D0/
6060       DATA WGAUSS(104)/ .0435837245293234534D0/
6061       DATA WGAUSS(105)/ .0424735151236535890D0/
6062       DATA WGAUSS(106)/ .0412625632426235286D0/
6063       DATA WGAUSS(107)/ .0399537411327203414D0/
6064       DATA WGAUSS(108)/ .0385501531786156291D0/
6065       DATA WGAUSS(109)/ .0370551285402400460D0/
6066       DATA WGAUSS(110)/ .0354722132568823838D0/
6067       DATA WGAUSS(111)/ .0338051618371416094D0/
6068       DATA WGAUSS(112)/ .0320579283548515535D0/
6069       DATA WGAUSS(113)/ .0302346570724024789D0/
6070       DATA WGAUSS(114)/ .0283396726142594832D0/
6071       DATA WGAUSS(115)/ .0263774697150546587D0/
6072       DATA WGAUSS(116)/ .0243527025687108733D0/
6073       DATA WGAUSS(117)/ .0222701738083832542D0/
6074       DATA WGAUSS(118)/ .0201348231535302094D0/
6075       DATA WGAUSS(119)/ .0179517157756973431D0/
6076       DATA WGAUSS(120)/ .0157260304760247193D0/
6077       DATA WGAUSS(121)/ .0134630478967186426D0/
6078       DATA WGAUSS(122)/ .0111681394601311288D0/
6079       DATA WGAUSS(123)/ .00884675982636394772D0/
6080       DATA WGAUSS(124)/ .00650445796897836286D0/
6081       DATA WGAUSS(125)/ .00414703326056246764D0/
6082       DATA WGAUSS(126)/ .00178328072169643295D0/
6083
6084 C integrate first over b1
6085 C
6086 C Loop incrementing the boundary
6087 C
6088       tmin = 0.D0
6089       tmax = 0.25D0
6090       Sum  = 0.D0
6091
6092  50   CONTINUE
6093
6094 C
6095 C Loop for the Gauss integration
6096 C
6097       XINT=0.D0
6098       DO 100 N=1,6
6099         XINT2 = XINT
6100         XINT=0.D0
6101         DO 200 I=2**N-1,2**(N+1)-2
6102           t = (tmax-tmin)/2.D0*XGAUSS(I)+(tmax+tmin)/2.D0
6103           b1 = RADSRC(1) * EXP (t)
6104           XINT=XINT+WGAUSS(I) * PHO_GGFAUX(b1) * b1**2
6105  200    CONTINUE
6106         XINT = (tmax-tmin)/2.D0*XINT
6107         IF (ABS ((XINT2-XINT)/XINT) .LT. ACCUR) GOTO 300
6108  100  CONTINUE
6109         WRITE(LO,*) ' (b1) GAUSS MAY BE INACCURATE'
6110  300  CONTINUE
6111
6112       Sum = Sum + XINT
6113       IF (ABS (XINT2/Sum) .GT. ACCUR) THEN
6114         tmin = tmax
6115         tmax = tmax + 0.5D0
6116         GOTO 50
6117       ENDIF
6118
6119       PHO_GGFLCR = 4.D0*Pi * Sum
6120
6121       END
6122
6123 *$ CREATE PHO_GGFAUX.FOR
6124 *COPY PHO_GGFAUX
6125 CDECK  ID>, PHO_GGFAUX
6126       DOUBLE PRECISION FUNCTION PHO_GGFAUX(b1)
6127 C*********************************************************************
6128 C
6129 C     auxiliary function for integration over b2,
6130 C     semi-classical photon flux correction due to
6131 C     overlap in impact parameter space (geometrical model)
6132 C
6133 C*********************************************************************
6134       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6135       SAVE
6136
6137       PARAMETER (PI = 3.14159265359D0, ACCUR = 1D-2)
6138
6139 C  input/output channels
6140       INTEGER LI,LO
6141       COMMON /POINOU/ LI,LO
6142 C  gamma-lepton or gamma-hadron vertex information
6143       INTEGER IGHEL,IDPSRC,IDBSRC
6144       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
6145      &                 RADSRC,AMSRC,GAMSRC
6146       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
6147      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
6148      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
6149
6150       DIMENSION XGAUSS(126),WGAUSS(126)
6151
6152       DATA XGAUSS(1)/ .57735026918962576D0/
6153       DATA XGAUSS(2)/-.57735026918962576D0/
6154       DATA WGAUSS(1)/ 1.00000000000000000D0/
6155       DATA WGAUSS(2)/ 1.00000000000000000D0/
6156
6157       DATA XGAUSS(3)/ .33998104358485627D0/
6158       DATA XGAUSS(4)/ .86113631159405258D0/
6159       DATA XGAUSS(5)/-.33998104358485627D0/
6160       DATA XGAUSS(6)/-.86113631159405258D0/
6161       DATA WGAUSS(3)/ .65214515486254613D0/
6162       DATA WGAUSS(4)/ .34785484513745385D0/
6163       DATA WGAUSS(5)/ .65214515486254613D0/
6164       DATA WGAUSS(6)/ .34785484513745385D0/
6165
6166       DATA XGAUSS(7)/ .18343464249564981D0/
6167       DATA XGAUSS(8)/ .52553240991632899D0/
6168       DATA XGAUSS(9)/ .79666647741362674D0/
6169       DATA XGAUSS(10)/ .96028985649753623D0/
6170       DATA XGAUSS(11)/-.18343464249564981D0/
6171       DATA XGAUSS(12)/-.52553240991632899D0/
6172       DATA XGAUSS(13)/-.79666647741362674D0/
6173       DATA XGAUSS(14)/-.96028985649753623D0/
6174       DATA WGAUSS(7)/ .36268378337836198D0/
6175       DATA WGAUSS(8)/ .31370664587788727D0/
6176       DATA WGAUSS(9)/ .22238103445337448D0/
6177       DATA WGAUSS(10)/ .10122853629037627D0/
6178       DATA WGAUSS(11)/ .36268378337836198D0/
6179       DATA WGAUSS(12)/ .31370664587788727D0/
6180       DATA WGAUSS(13)/ .22238103445337448D0/
6181       DATA WGAUSS(14)/ .10122853629037627D0/
6182
6183       DATA XGAUSS(15)/ .0950125098376374402D0/
6184       DATA XGAUSS(16)/ .281603550779258913D0/
6185       DATA XGAUSS(17)/ .458016777657227386D0/
6186       DATA XGAUSS(18)/ .617876244402643748D0/
6187       DATA XGAUSS(19)/ .755404408355003034D0/
6188       DATA XGAUSS(20)/ .865631202387831744D0/
6189       DATA XGAUSS(21)/ .944575023073232576D0/
6190       DATA XGAUSS(22)/ .989400934991649933D0/
6191       DATA XGAUSS(23)/-.0950125098376374402D0/
6192       DATA XGAUSS(24)/-.281603550779258913D0/
6193       DATA XGAUSS(25)/-.458016777657227386D0/
6194       DATA XGAUSS(26)/-.617876244402643748D0/
6195       DATA XGAUSS(27)/-.755404408355003034D0/
6196       DATA XGAUSS(28)/-.865631202387831744D0/
6197       DATA XGAUSS(29)/-.944575023073232576D0/
6198       DATA XGAUSS(30)/-.989400934991649933D0/
6199       DATA WGAUSS(15)/ .189450610455068496D0/
6200       DATA WGAUSS(16)/ .182603415044923589D0/
6201       DATA WGAUSS(17)/ .169156519395002538D0/
6202       DATA WGAUSS(18)/ .149595988816576732D0/
6203       DATA WGAUSS(19)/ .124628971255533872D0/
6204       DATA WGAUSS(20)/ .0951585116824927848D0/
6205       DATA WGAUSS(21)/ .0622535239386478929D0/
6206       DATA WGAUSS(22)/ .0271524594117540949D0/
6207       DATA WGAUSS(23)/ .189450610455068496D0/
6208       DATA WGAUSS(24)/ .182603415044923589D0/
6209       DATA WGAUSS(25)/ .169156519395002538D0/
6210       DATA WGAUSS(26)/ .149595988816576732D0/
6211       DATA WGAUSS(27)/ .124628971255533872D0/
6212       DATA WGAUSS(28)/ .0951585116824927848D0/
6213       DATA WGAUSS(29)/ .0622535239386478929D0/
6214       DATA WGAUSS(30)/ .0271524594117540949D0/
6215
6216       DATA XGAUSS(31)/ .0483076656877383162D0/
6217       DATA XGAUSS(32)/ .144471961582796493D0/
6218       DATA XGAUSS(33)/ .239287362252137075D0/
6219       DATA XGAUSS(34)/ .331868602282127650D0/
6220       DATA XGAUSS(35)/ .421351276130635345D0/
6221       DATA XGAUSS(36)/ .506899908932229390D0/
6222       DATA XGAUSS(37)/ .587715757240762329D0/
6223       DATA XGAUSS(38)/ .663044266930215201D0/
6224       DATA XGAUSS(39)/ .732182118740289680D0/
6225       DATA XGAUSS(40)/ .794483795967942407D0/
6226       DATA XGAUSS(41)/ .849367613732569970D0/
6227       DATA XGAUSS(42)/ .896321155766052124D0/
6228       DATA XGAUSS(43)/ .934906075937739689D0/
6229       DATA XGAUSS(44)/ .964762255587506430D0/
6230       DATA XGAUSS(45)/ .985611511545268335D0/
6231       DATA XGAUSS(46)/ .997263861849481564D0/
6232       DATA XGAUSS(47)/-.0483076656877383162D0/
6233       DATA XGAUSS(48)/-.144471961582796493D0/
6234       DATA XGAUSS(49)/-.239287362252137075D0/
6235       DATA XGAUSS(50)/-.331868602282127650D0/
6236       DATA XGAUSS(51)/-.421351276130635345D0/
6237       DATA XGAUSS(52)/-.506899908932229390D0/
6238       DATA XGAUSS(53)/-.587715757240762329D0/
6239       DATA XGAUSS(54)/-.663044266930215201D0/
6240       DATA XGAUSS(55)/-.732182118740289680D0/
6241       DATA XGAUSS(56)/-.794483795967942407D0/
6242       DATA XGAUSS(57)/-.849367613732569970D0/
6243       DATA XGAUSS(58)/-.896321155766052124D0/
6244       DATA XGAUSS(59)/-.934906075937739689D0/
6245       DATA XGAUSS(60)/-.964762255587506430D0/
6246       DATA XGAUSS(61)/-.985611511545268335D0/
6247       DATA XGAUSS(62)/-.997263861849481564D0/
6248       DATA WGAUSS(31)/ .0965400885147278006D0/
6249       DATA WGAUSS(32)/ .0956387200792748594D0/
6250       DATA WGAUSS(33)/ .0938443990808045654D0/
6251       DATA WGAUSS(34)/ .0911738786957638847D0/
6252       DATA WGAUSS(35)/ .0876520930044038111D0/
6253       DATA WGAUSS(36)/ .0833119242269467552D0/
6254       DATA WGAUSS(37)/ .0781938957870703065D0/
6255       DATA WGAUSS(38)/ .0723457941088485062D0/
6256       DATA WGAUSS(39)/ .0658222227763618468D0/
6257       DATA WGAUSS(40)/ .0586840934785355471D0/
6258       DATA WGAUSS(41)/ .0509980592623761762D0/
6259       DATA WGAUSS(42)/ .0428358980222266807D0/
6260       DATA WGAUSS(43)/ .0342738629130214331D0/
6261       DATA WGAUSS(44)/ .0253920653092620595D0/
6262       DATA WGAUSS(45)/ .0162743947309056706D0/
6263       DATA WGAUSS(46)/ .00701861000947009660D0/
6264       DATA WGAUSS(47)/ .0965400885147278006D0/
6265       DATA WGAUSS(48)/ .0956387200792748594D0/
6266       DATA WGAUSS(49)/ .0938443990808045654D0/
6267       DATA WGAUSS(50)/ .0911738786957638847D0/
6268       DATA WGAUSS(51)/ .0876520930044038111D0/
6269       DATA WGAUSS(52)/ .0833119242269467552D0/
6270       DATA WGAUSS(53)/ .0781938957870703065D0/
6271       DATA WGAUSS(54)/ .0723457941088485062D0/
6272       DATA WGAUSS(55)/ .0658222227763618468D0/
6273       DATA WGAUSS(56)/ .0586840934785355471D0/
6274       DATA WGAUSS(57)/ .0509980592623761762D0/
6275       DATA WGAUSS(58)/ .0428358980222266807D0/
6276       DATA WGAUSS(59)/ .0342738629130214331D0/
6277       DATA WGAUSS(60)/ .0253920653092620595D0/
6278       DATA WGAUSS(61)/ .0162743947309056706D0/
6279       DATA WGAUSS(62)/ .00701861000947009660D0/
6280
6281       DATA XGAUSS(63)/ .02435029266342443250D0/
6282       DATA XGAUSS(64)/ .0729931217877990394D0/
6283       DATA XGAUSS(65)/ .121462819296120554D0/
6284       DATA XGAUSS(66)/ .169644420423992818D0/
6285       DATA XGAUSS(67)/ .217423643740007084D0/
6286       DATA XGAUSS(68)/ .264687162208767416D0/
6287       DATA XGAUSS(69)/ .311322871990210956D0/
6288       DATA XGAUSS(70)/ .357220158337668116D0/
6289       DATA XGAUSS(71)/ .402270157963991604D0/
6290       DATA XGAUSS(72)/ .446366017253464088D0/
6291       DATA XGAUSS(73)/ .489403145707052957D0/
6292       DATA XGAUSS(74)/ .531279464019894546D0/
6293       DATA XGAUSS(75)/ .571895646202634034D0/
6294       DATA XGAUSS(76)/ .611155355172393250D0/
6295       DATA XGAUSS(77)/ .648965471254657340D0/
6296       DATA XGAUSS(78)/ .685236313054233243D0/
6297       DATA XGAUSS(79)/ .719881850171610827D0/
6298       DATA XGAUSS(80)/ .752819907260531897D0/
6299       DATA XGAUSS(81)/ .783972358943341408D0/
6300       DATA XGAUSS(82)/ .813265315122797560D0/
6301       DATA XGAUSS(83)/ .840629296252580363D0/
6302       DATA XGAUSS(84)/ .865999398154092820D0/
6303       DATA XGAUSS(85)/ .889315445995114106D0/
6304       DATA XGAUSS(86)/ .910522137078502806D0/
6305       DATA XGAUSS(87)/ .929569172131939576D0/
6306       DATA XGAUSS(88)/ .946411374858402816D0/
6307       DATA XGAUSS(89)/ .961008799652053719D0/
6308       DATA XGAUSS(90)/ .973326827789910964D0/
6309       DATA XGAUSS(91)/ .983336253884625957D0/
6310       DATA XGAUSS(92)/ .991013371476744321D0/
6311       DATA XGAUSS(93)/ .996340116771955279D0/
6312       DATA XGAUSS(94)/ .999305041735772139D0/
6313       DATA XGAUSS(95)/-.02435029266342443250D0/
6314       DATA XGAUSS(96)/-.0729931217877990394D0/
6315       DATA XGAUSS(97)/-.121462819296120554D0/
6316       DATA XGAUSS(98)/-.169644420423992818D0/
6317       DATA XGAUSS(99)/-.217423643740007084D0/
6318       DATA XGAUSS(100)/-.264687162208767416D0/
6319       DATA XGAUSS(101)/-.311322871990210956D0/
6320       DATA XGAUSS(102)/-.357220158337668116D0/
6321       DATA XGAUSS(103)/-.402270157963991604D0/
6322       DATA XGAUSS(104)/-.446366017253464088D0/
6323       DATA XGAUSS(105)/-.489403145707052957D0/
6324       DATA XGAUSS(106)/-.531279464019894546D0/
6325       DATA XGAUSS(107)/-.571895646202634034D0/
6326       DATA XGAUSS(108)/-.611155355172393250D0/
6327       DATA XGAUSS(109)/-.648965471254657340D0/
6328       DATA XGAUSS(110)/-.685236313054233243D0/
6329       DATA XGAUSS(111)/-.719881850171610827D0/
6330       DATA XGAUSS(112)/-.752819907260531897D0/
6331       DATA XGAUSS(113)/-.783972358943341408D0/
6332       DATA XGAUSS(114)/-.813265315122797560D0/
6333       DATA XGAUSS(115)/-.840629296252580363D0/
6334       DATA XGAUSS(116)/-.865999398154092820D0/
6335       DATA XGAUSS(117)/-.889315445995114106D0/
6336       DATA XGAUSS(118)/-.910522137078502806D0/
6337       DATA XGAUSS(119)/-.929569172131939576D0/
6338       DATA XGAUSS(120)/-.946411374858402816D0/
6339       DATA XGAUSS(121)/-.961008799652053719D0/
6340       DATA XGAUSS(122)/-.973326827789910964D0/
6341       DATA XGAUSS(123)/-.983336253884625957D0/
6342       DATA XGAUSS(124)/-.991013371476744321D0/
6343       DATA XGAUSS(125)/-.996340116771955279D0/
6344       DATA XGAUSS(126)/-.999305041735772139D0/
6345       DATA WGAUSS(63)/ .0486909570091397204D0/
6346       DATA WGAUSS(64)/ .0485754674415034269D0/
6347       DATA WGAUSS(65)/ .0483447622348029572D0/
6348       DATA WGAUSS(66)/ .0479993885964583077D0/
6349       DATA WGAUSS(67)/ .0475401657148303087D0/
6350       DATA WGAUSS(68)/ .0469681828162100173D0/
6351       DATA WGAUSS(69)/ .0462847965813144172D0/
6352       DATA WGAUSS(70)/ .0454916279274181445D0/
6353       DATA WGAUSS(71)/ .0445905581637565631D0/
6354       DATA WGAUSS(72)/ .0435837245293234534D0/
6355       DATA WGAUSS(73)/ .0424735151236535890D0/
6356       DATA WGAUSS(74)/ .0412625632426235286D0/
6357       DATA WGAUSS(75)/ .0399537411327203414D0/
6358       DATA WGAUSS(76)/ .0385501531786156291D0/
6359       DATA WGAUSS(77)/ .0370551285402400460D0/
6360       DATA WGAUSS(78)/ .0354722132568823838D0/
6361       DATA WGAUSS(79)/ .0338051618371416094D0/
6362       DATA WGAUSS(80)/ .0320579283548515535D0/
6363       DATA WGAUSS(81)/ .0302346570724024789D0/
6364       DATA WGAUSS(82)/ .0283396726142594832D0/
6365       DATA WGAUSS(83)/ .0263774697150546587D0/
6366       DATA WGAUSS(84)/ .0243527025687108733D0/
6367       DATA WGAUSS(85)/ .0222701738083832542D0/
6368       DATA WGAUSS(86)/ .0201348231535302094D0/
6369       DATA WGAUSS(87)/ .0179517157756973431D0/
6370       DATA WGAUSS(88)/ .0157260304760247193D0/
6371       DATA WGAUSS(89)/ .0134630478967186426D0/
6372       DATA WGAUSS(90)/ .0111681394601311288D0/
6373       DATA WGAUSS(91)/ .00884675982636394772D0/
6374       DATA WGAUSS(92)/ .00650445796897836286D0/
6375       DATA WGAUSS(93)/ .00414703326056246764D0/
6376       DATA WGAUSS(94)/ .00178328072169643295D0/
6377       DATA WGAUSS(95)/ .0486909570091397204D0/
6378       DATA WGAUSS(96)/ .0485754674415034269D0/
6379       DATA WGAUSS(97)/ .0483447622348029572D0/
6380       DATA WGAUSS(98)/ .0479993885964583077D0/
6381       DATA WGAUSS(99)/ .0475401657148303087D0/
6382       DATA WGAUSS(100)/ .0469681828162100173D0/
6383       DATA WGAUSS(101)/ .0462847965813144172D0/
6384       DATA WGAUSS(102)/ .0454916279274181445D0/
6385       DATA WGAUSS(103)/ .0445905581637565631D0/
6386       DATA WGAUSS(104)/ .0435837245293234534D0/
6387       DATA WGAUSS(105)/ .0424735151236535890D0/
6388       DATA WGAUSS(106)/ .0412625632426235286D0/
6389       DATA WGAUSS(107)/ .0399537411327203414D0/
6390       DATA WGAUSS(108)/ .0385501531786156291D0/
6391       DATA WGAUSS(109)/ .0370551285402400460D0/
6392       DATA WGAUSS(110)/ .0354722132568823838D0/
6393       DATA WGAUSS(111)/ .0338051618371416094D0/
6394       DATA WGAUSS(112)/ .0320579283548515535D0/
6395       DATA WGAUSS(113)/ .0302346570724024789D0/
6396       DATA WGAUSS(114)/ .0283396726142594832D0/
6397       DATA WGAUSS(115)/ .0263774697150546587D0/
6398       DATA WGAUSS(116)/ .0243527025687108733D0/
6399       DATA WGAUSS(117)/ .0222701738083832542D0/
6400       DATA WGAUSS(118)/ .0201348231535302094D0/
6401       DATA WGAUSS(119)/ .0179517157756973431D0/
6402       DATA WGAUSS(120)/ .0157260304760247193D0/
6403       DATA WGAUSS(121)/ .0134630478967186426D0/
6404       DATA WGAUSS(122)/ .0111681394601311288D0/
6405       DATA WGAUSS(123)/ .00884675982636394772D0/
6406       DATA WGAUSS(124)/ .00650445796897836286D0/
6407       DATA WGAUSS(125)/ .00414703326056246764D0/
6408       DATA WGAUSS(126)/ .00178328072169643295D0/
6409 C
6410       W1 = PGAM(4,1)
6411       W2 = PGAM(4,2)
6412       bmin = b1 - 2.D0*RADSRC(1)
6413       IF (RADSRC(1) .GT. bmin) THEN
6414         bmin = RADSRC(1)
6415       ENDIF
6416       bmax = b1 + 2.D0 * RADSRC(1)
6417
6418       XINT = 0.D0
6419       DO 100 N=1,6
6420         XINT2 = XINT
6421         XINT = 0.D0
6422         DO 200 I=2**N-1,2**(N+1)-2
6423           b2 = (bmax-bmin)/2.D0*XGAUSS(I)+(bmax+bmin)/2.D0
6424           XINT3 = PHO_GGFNUC(W1,b1,GAMSRC(1))
6425      &      * PHO_GGFNUC(W2,b2,GAMSRC(2))
6426      &      * ACOS ((b1**2+b2**2-4.D0*RADSRC(1)**2)/(2.D0*b1*b2))
6427           XINT = XINT +WGAUSS(I) * b2 * XINT3
6428  200    CONTINUE
6429         XINT = (bmax-bmin)/2.D0*XINT
6430         IF (ABS((XINT2 - XINT)/XINT) .LT. ACCUR) GOTO 300
6431  100  CONTINUE
6432       WRITE(LO,*) ' (b2) GAUSS MAY BE INACCURATE'
6433  300  CONTINUE
6434
6435       PHO_GGFAUX = XINT
6436
6437       END
6438
6439 *$ CREATE PHO_GGFNUC.FOR
6440 *COPY PHO_GGFNUC
6441 CDECK  ID>, PHO_GGFNUC
6442       DOUBLE PRECISION FUNCTION PHO_GGFNUC(W,Rho,Gamma)
6443 C**********************************************************************
6444 C
6445 C      differential photonnumber for a nucleus (geometrical model)
6446 C      (without form factor)
6447 C
6448 C*********************************************************************
6449       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6450       SAVE
6451
6452       PARAMETER (PI = 3.14159265359D0)
6453
6454       WGamma = W/Gamma
6455       Wphib = WGamma * PHO_BESSK1(WGamma*Rho)
6456
6457       PHO_GGFNUC = 1.D0/PI**2 * Wphib**2
6458
6459       END
6460
6461 *$ CREATE PHO_GHHIOF.FOR
6462 *COPY PHO_GHHIOF
6463 CDECK  ID>, PHO_GHHIOF
6464       SUBROUTINE PHO_GHHIOF(NEVENT,EEN,NA,NZ)
6465 C**********************************************************************
6466 C
6467 C     interface to call PHOJET (variable energy run) for
6468 C     gamma-hadron collisions in heavy ion collisions
6469 C     (form factor approach)
6470 C
6471 C     input:     EEN     LAB system energy per nucleon
6472 C                NA      atomic number of ion/hadron
6473 C                NZ      charge number of ion/hadron
6474 C                NEVENT  number of events to generate
6475 C            from /LEPCUT/:
6476 C                YMIN1,2 lower limit of Y
6477 C                        (energy fraction taken by photon from hadron)
6478 C                YMAX1,2 upper cutoff for Y, necessary to avoid
6479 C                        underflows
6480 C                Q2MIN1,2 minimum Q**2 of photons (should be set to 0)
6481 C                Q2MAX1,2 maximum Q**2 of photons (if necessary,
6482 C                        corrected according size of hadron)
6483 C
6484 C**********************************************************************
6485       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6486       SAVE
6487
6488       PARAMETER ( PI   = 3.14159265359D0 )
6489
6490 C  input/output channels
6491       INTEGER LI,LO
6492       COMMON /POINOU/ LI,LO
6493 C  model switches and parameters
6494       CHARACTER*8 MDLNA
6495       INTEGER ISWMDL,IPAMDL
6496       DOUBLE PRECISION PARMDL
6497       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
6498 C  event debugging information
6499       INTEGER NMAXD
6500       PARAMETER (NMAXD=100)
6501       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
6502      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
6503       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
6504      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
6505 C  photon flux kinematics and cuts
6506       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
6507      &                 YMIN1,YMAX1,YMIN2,YMAX2,
6508      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
6509      &                 THMIN1,THMAX1,THMIN2,THMAX2
6510       INTEGER          ITAG1,ITAG2
6511       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
6512      &                YMIN1,YMAX1,YMIN2,YMAX2,
6513      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
6514      &                THMIN1,THMAX1,THMIN2,THMAX2,
6515      &                ITAG1,ITAG2
6516 C  gamma-lepton or gamma-hadron vertex information
6517       INTEGER IGHEL,IDPSRC,IDBSRC
6518       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
6519      &                 RADSRC,AMSRC,GAMSRC
6520       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
6521      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
6522      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
6523 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
6524       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
6525       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
6526       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
6527      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
6528 C  standard particle data interface
6529       INTEGER NMXHEP
6530       PARAMETER (NMXHEP=4000)
6531       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
6532       DOUBLE PRECISION PHEP,VHEP
6533       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
6534      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
6535      &                VHEP(4,NMXHEP)
6536 C  extension to standard particle data interface (PHOJET specific)
6537       INTEGER IMPART,IPHIST,ICOLOR
6538       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
6539 C  event weights and generated cross section
6540       INTEGER IPOWGC,ISWCUT,IVWGHT
6541       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
6542       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
6543      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
6544
6545       DIMENSION P1(4),P2(4)
6546       DIMENSION NITERS(2),ITRW(2)
6547
6548       WRITE(LO,'(2(/1X,A))')
6549      &  'PHO_GHHIOF: gamma-hadron event generation',
6550      &  '-----------------------------------------'
6551 C  hadron size and mass
6552       FM2GEV = 5.07D0
6553       HIMASS = DBLE(NA)*0.938D0
6554       HIMA2  = HIMASS**2
6555       HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
6556       ALPHA  = DBLE(NZ**2)/137.D0
6557       AMP  = 0.938D0
6558       AMP2 = AMP**2
6559 C  correct Q2MAX1,2 according to hadron size
6560       Q2MAXH = 2.D0/HIRADI**2
6561       Q2MAX1 = MIN(Q2MAX1,Q2MAXH)
6562       Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
6563       IF(Q2MAX1.LT.1.D-20) Q2MAX1 = Q2MAXH
6564       IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
6565 C  total hadron / heavy ion energy
6566       EE = EEN*DBLE(NA)
6567       GAMMA = EE/HIMASS
6568 C  setup /POFSRC/
6569       GAMSRC(1) = GAMMA
6570       GAMSRC(2) = GAMMA
6571       RADSRC(1) = HIRADI
6572       RADSRC(2) = HIRADI
6573       AMSRC(1)  = HIMASS
6574       AMSRC(2)  = HIMASS
6575 C  check cuts on photon-hadron mass
6576       IF((0.765D0+PARMDL(46)).GT.(PARMDL(45)*ECMIN)) THEN
6577         YMI = ECMIN
6578         ECMIN =  PARMDL(46)/PARMDL(45)+0.1D0
6579         WRITE(LO,'(/1X,A,2E12.5)')
6580      &    'PHO_GHHIOF: ecmin corrected to (old/new)',YMI,ECMIN
6581       ENDIF
6582 C  check kinematic limitations
6583       YMI = ECMIN**2/(4.D0*EE*EEN)
6584       IF(YMIN1.LT.YMI) THEN
6585         WRITE(LO,'(/1X,A,2E12.5)')
6586      &    'PHO_GHHIOF: ymin1 increased to (old/new)',YMIN1,YMI
6587         YMIN1 = YMI
6588       ELSE IF(YMIN1.GT.YMI) THEN
6589         WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
6590      &    'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN1 OF',YMI,
6591      &    '  INSTEAD OF',YMIN1
6592       ENDIF
6593       IF(YMIN2.LT.YMI) THEN
6594         WRITE(LO,'(/1X,A,2E12.5)')
6595      &    'PHO_GHHIOF: ymin2 increased to (old/new)',YMIN2,YMI
6596         YMIN2 = YMI
6597       ELSE IF(YMIN2.GT.YMI) THEN
6598         WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
6599      &    'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
6600      &    '  INSTEAD OF',YMIN2
6601       ENDIF
6602 C  kinematic limitation
6603       Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
6604       Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
6605 C  debug output
6606       WRITE(LO,'(/6X,A,2I4)')   'MASS NUMBER, CHARGE NUMBER  ',NA,NZ
6607       WRITE(LO,'(6X,A,E12.5)') 'HADRON MASS (GeV)           ',HIMASS
6608       WRITE(LO,'(6X,A,E12.5)') 'HADRON RADIUS (GeV**-1)     ',HIRADI
6609       WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 1 (GEV**2)',Q2LOW1,
6610      &  Q2MAX1
6611       WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
6612      &  Q2MAX2
6613       WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 1            ',YMIN1,
6614      &  YMAX1
6615       WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2            ',YMIN2,
6616      &  YMAX2
6617       WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL  ',
6618      &  2.D0*EEN,2.D0*EE
6619       WRITE(LO,'(6X,A,2E12.5)') 'INV.MASS PHOTON-HADRON      ',ECMIN,
6620      &  ECMAX
6621       WRITE(LO,'(6X,A,E12.5)') 'MIN. INV.MASS PHOTON-POMERON',
6622      &  PARMDL(175)
6623       WRITE(LO,'(6X,A,I10)')   'EVENTS TO PROCESS           ',NEVENT
6624       IF(Q2LOW1.GE.Q2MAX1) THEN
6625         WRITE(LO,'(/1X,A,2E12.4)')
6626      &    'PHO_GHHIOF:ERROR:INCONSISTENT Q**2 RANGE 1',Q2LOW1,Q2MAX1
6627         CALL PHO_ABORT
6628       ENDIF
6629       IF(Q2LOW2.GE.Q2MAX2) THEN
6630         WRITE(LO,'(/1X,A,2E12.4)')
6631      &    'PHO_GHHIOF:ERROR:INCONSISTENT Q**2 RANGE 2',Q2LOW2,Q2MAX2
6632         CALL PHO_ABORT
6633       ENDIF
6634 C  hadron numbers set to 0
6635       IDPSRC(1) = 0
6636       IDPSRC(2) = 0
6637       IDBSRC(1) = 0
6638       IDBSRC(2) = 0
6639 C
6640       Max_tab = 100
6641       YMAX = YMAX1
6642       YMIN = YMIN1
6643       XMAX = LOG(YMAX)
6644       XMIN = LOG(YMIN)
6645       XDEL = XMAX-XMIN
6646       DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
6647       DO 100 I=1,Max_tab
6648         Y1 = EXP(XMIN+DELLY*DBLE(I-1))
6649         Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
6650         IF(Q2LOW1.GE.Q2MAX1) THEN
6651           WRITE(LO,'(/1X,A,2E12.4)')
6652      &      'PHO_GHHIOF: ymax1 changed from/to',YMAX1,Y1
6653           YMAX1 = MIN(Y1,YMAX1)
6654           GOTO 101
6655         ENDIF
6656  100  CONTINUE
6657  101  CONTINUE
6658       YMAX = YMAX2
6659       YMIN = YMIN2
6660       XMAX = LOG(YMAX)
6661       XMIN = LOG(YMIN)
6662       XDEL = XMAX-XMIN
6663       DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
6664       DO 102 I=1,Max_tab
6665         Y1 = EXP(XMIN+DELLY*DBLE(I-1))
6666         Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
6667         IF(Q2LOW2.GE.Q2MAX2) THEN
6668           WRITE(LO,'(/1X,A,2E12.4)')
6669      &      'PHO_GHHIOF: ymax2 changed from/to',YMAX2,Y1
6670           YMAX2 = MIN(Y1,YMAX2)
6671           GOTO 103
6672         ENDIF
6673  102  CONTINUE
6674  103  CONTINUE
6675 C
6676       X1MAX = LOG(YMAX1)
6677       X1MIN = LOG(YMIN1)
6678       X1DEL = X1MAX-X1MIN
6679       X2MAX = LOG(YMAX2)
6680       X2MIN = LOG(YMIN2)
6681       X2DEL = X2MAX-X2MIN
6682       DELLY = LOG(YMAX1/YMIN1)/DBLE(Max_tab-1)
6683       FLUX = 0.D0
6684       IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
6685      &  'PHO_GHHIOF: table of raw photon flux (side 1)',Max_tab
6686       DO 105 I=1,Max_tab
6687         Y1 = EXP(X1MIN+DELLY*DBLE(I-1))
6688         Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1*Y1/(1.D0-Y1))
6689         FF = ((1.D0+(1.D0-Y1)**2)/Y1*LOG(Q2MAX1/Q2LOW1)
6690      &        -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1))*ALPHA/(2.D0*PI)
6691         FLUX = FLUX+Y1*FF
6692         IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y1,FF
6693  105  CONTINUE
6694       FLUX = FLUX*DELLY
6695       IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
6696      &  'PHO_GHHIOF: integrated flux (one side):',FLUX
6697 C
6698 C  photon
6699       EGAM = MAX(YMAX1,YMAX2)*EE
6700       P1(1) = 0.D0
6701       P1(2) = 0.D0
6702       P1(3) = EGAM
6703       P1(4) = EGAM
6704 C  hadron
6705       P2(1) = 0.D0
6706       P2(2) = 0.D0
6707       P2(3) = -SQRT(EEN**2-AMP2)
6708       P2(4) = EEN
6709       CALL PHO_SETPAR(1,22,0,0.D0)
6710       CALL PHO_SETPAR(2,2212,0,0.D0)
6711       CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
6712 C
6713       Q2LOW1 = MAX(Q2MIN1,HIMA2*YMIN1**2/(1.D0-YMIN1))
6714       Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
6715       Y1 = YMIN1
6716       Y2 = YMIN2
6717       WGMAX1 = (1.D0+(1.D0-Y1)**2)*LOG(Q2MAX1/Q2LOW1)
6718      &         -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1
6719       WGMAX2 = (1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
6720      &         -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
6721 C
6722       IF(IPAMDL(175).EQ.1) WGMAX2 = 0.D0
6723       IF(IPAMDL(175).EQ.2) WGMAX1 = 0.D0
6724 C
6725       FAC12 = WGMAX1*LOG(YMAX1/YMIN1)
6726      &       /(WGMAX1*LOG(YMAX1/YMIN1)+WGMAX2*LOG(YMAX2/YMIN2))
6727 C
6728       CALL PHO_PHIST(-1,SIGMAX)
6729       CALL PHO_LHIST(-1,SIGMAX)
6730 C
6731 C  generation of events, flux calculation
6732       AY1  = 0.D0
6733       AY2  = 0.D0
6734       AYS1 = 0.D0
6735       AYS2 = 0.D0
6736       Q21MIN = 1.D30
6737       Q22MIN = 1.D30
6738       Q21MAX = 0.D0
6739       Q22MAX = 0.D0
6740       Q21AVE = 0.D0
6741       Q22AVE = 0.D0
6742       Q21AV2 = 0.D0
6743       Q22AV2 = 0.D0
6744       YY1MIN = 1.D30
6745       YY2MIN = 1.D30
6746       YY1MAX = 0.D0
6747       YY2MAX = 0.D0
6748       NITER = NEVENT
6749       NITERS(1) = 0
6750       NITERS(2) = 0
6751       ITRY = 0
6752       ITRW(1) = 0
6753       ITRW(2) = 0
6754       DO 200 I=1,NITER
6755 C  sample y1, y2
6756  150    CONTINUE
6757         ITRY = ITRY+1
6758  175    CONTINUE
6759 C
6760 C  select side of photon emission
6761         IF(DT_RNDM(AY1).LT.FAC12) THEN
6762           ITRW(1) = ITRW(1)+1
6763 C  select Y1
6764           Y1 = EXP(X1DEL*DT_RNDM(AY1)+X1MIN)
6765           Q2LOW1 = MAX(Q2MIN1,HIMA2*Y1**2/(1.D0-Y1))
6766           IF(Q2LOW1.GE.Q2MAX1) GOTO 175
6767           Q2LOG1 = LOG(Q2MAX1/Q2LOW1)
6768           WGH = (1.D0+(1.D0-Y1)**2)*Q2LOG1
6769      &          -2.D0*HIMA2*Y1*(1.D0/Q2LOW1-1.D0/Q2MAX1)*Y1
6770           IF(WGMAX1.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
6771      &        'PHO_GHHIOF:WEIGHT ERROR (1):',Y1,WGMAX1,WGH
6772           IF(DT_RNDM(AYS1)*WGMAX1.GT.WGH) GOTO 175
6773 C  sample Q2
6774           IF(IPAMDL(174).EQ.1) THEN
6775             YEFF = 1.D0+(1.D0-Y1)**2
6776  185        CONTINUE
6777               Q2P1 = Q2LOW1*EXP(Q2LOG1*DT_RNDM(Y1))
6778               WEIGHT = (YEFF-2.D0*(1.D0-Y1)*Q2LOW1/Q2P1)/YEFF
6779             IF(WEIGHT.LT.DT_RNDM(Q2P1)) GOTO 185
6780           ELSE
6781             Q2P1 = Q2LOW1
6782           ENDIF
6783 C  impact parameter
6784           GAIMP(1) = 1.D0/SQRT(Q2P1)
6785 C  form factor (squared)
6786           FF2 = 1.D0
6787           IF(GAIMP(1).LT.2.D0*HIRADI) FF2 = 0.D0
6788           IF(DT_RNDM(Q2P1).GE.FF2) GOTO 175
6789 C  photon data
6790           GYY(1) = Y1
6791           GQ2(1) = Q2P1
6792 C
6793 C  incoming hadron 1
6794           PINI(1,1) = 0.D0
6795           PINI(2,1) = 0.D0
6796           PINI(3,1) = SQRT(EE**2-AMP2)
6797           PINI(4,1) = EE
6798           PINI(5,1) = AMP
6799 C  outgoing hadron 1
6800           YQ2 = SQRT((1.D0-Y1)*Q2P1)
6801           Q2E = Q2P1/(4.D0*EE)
6802           E1Y = EE*(1.D0-Y1)
6803           CALL PHO_SFECFE(SIF,COF)
6804           PFIN(1,1) = YQ2*COF
6805           PFIN(2,1) = YQ2*SIF
6806           PFIN(3,1) = E1Y-Q2E
6807           PFIN(4,1) = E1Y+Q2E
6808           PFIN(5,1) = 0.D0
6809           PFPHI(1) = ATAN2(COF,SIF)
6810           PFTHE(1) = ACOS((E1Y-Q2E)/(Q2E+E1Y))
6811 C  incoming hadron 2
6812           PINI(1,2) = 0.D0
6813           PINI(2,2) = 0.D0
6814           PINI(3,2) = -SQRT(EE**2-AMP2)
6815           PINI(4,2) = EE
6816           PINI(5,2) = AMP
6817 C  scattering photon
6818           P1(1) = -PFIN(1,1)
6819           P1(2) = -PFIN(2,1)
6820           P1(3) = PINI(3,1)-PFIN(3,1)
6821           P1(4) = PINI(4,1)-PFIN(4,1)
6822 C  scattering hadron
6823           P2(1) = 0.D0
6824           P2(2) = 0.D0
6825           P2(3) = -SQRT(EEN**2-AMP2)
6826           P2(4) = EEN
6827           ISIDE = 1
6828 C
6829         ELSE
6830 C
6831           ITRW(2) = ITRW(2)+1
6832 C  select Y2
6833           Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
6834           Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
6835           IF(Q2LOW2.GE.Q2MAX2) GOTO 175
6836           Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
6837           WGH = (1.D0+(1.D0-Y2)**2)*Q2LOG2
6838      &          -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
6839           IF(WGMAX2.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
6840      &        'PHO_GHHIOF:WEIGHT ERROR (2):',Y2,WGMAX2,WGH
6841           IF(DT_RNDM(AYS1)*WGMAX2.GT.WGH) GOTO 175
6842 C  sample Q2
6843           IF(IPAMDL(174).EQ.1) THEN
6844             YEFF = 1.D0+(1.D0-Y2)**2
6845  186        CONTINUE
6846               Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
6847               WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
6848             IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
6849           ELSE
6850             Q2P2 = Q2LOW2
6851           ENDIF
6852 C  impact parameter
6853           GAIMP(2) = 1.D0/SQRT(Q2P2)
6854 C  form factor (squared)
6855           FF2 = 1.D0
6856           IF(GAIMP(2).LT.2.D0*HIRADI) FF2 = 0.D0
6857           IF(DT_RNDM(Q2P2).GE.FF2) GOTO 175
6858 C  photon data
6859           GYY(2) = Y2
6860           GQ2(2) = Q2P2
6861 C
6862 C  incoming hadron 1
6863           PINI(1,1) = 0.D0
6864           PINI(2,1) = 0.D0
6865           PINI(3,1) = SQRT(EE**2-AMP2)
6866           PINI(4,1) = EE
6867           PINI(5,1) = AMP
6868 C  incoming hadron 2
6869           PINI(1,2) = 0.D0
6870           PINI(2,2) = 0.D0
6871           PINI(3,2) = -SQRT(EE**2-AMP2)
6872           PINI(4,2) = EE
6873           PINI(5,2) = AMP
6874 C  outgoing hadron 2
6875           YQ2 = SQRT((1.D0-Y2)*Q2P2)
6876           Q2E = Q2P2/(4.D0*EE)
6877           E1Y = EE*(1.D0-Y2)
6878           CALL PHO_SFECFE(SIF,COF)
6879           PFIN(1,2) = YQ2*COF
6880           PFIN(2,2) = YQ2*SIF
6881           PFIN(3,2) = -E1Y+Q2E
6882           PFIN(4,2) = E1Y+Q2E
6883           PFIN(5,2) = 0.D0
6884           PFPHI(2) = ATAN2(COF,SIF)
6885           PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
6886 C  scattering hadron
6887           P2(1) = 0.D0
6888           P2(2) = 0.D0
6889           P2(3) = SQRT(EEN**2-AMP2)
6890           P2(4) = EEN
6891 C  scattering photon
6892           P1(1) = -PFIN(1,2)
6893           P1(2) = -PFIN(2,2)
6894           P1(3) = PINI(3,2)-PFIN(3,2)
6895           P1(4) = PINI(4,2)-PFIN(4,2)
6896           ISIDE = 2
6897         ENDIF
6898 C  ECMS cut
6899         GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
6900      &         -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
6901         IF(GGECM.LT.0.1D0) GOTO 175
6902         GGECM = SQRT(GGECM)
6903         IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
6904 C
6905         PGAM(1,1) = P1(1)
6906         PGAM(2,1) = P1(2)
6907         PGAM(3,1) = P1(3)
6908         PGAM(4,1) = P1(4)
6909         PGAM(5,1) = -SQRT(Q2P1)
6910         PGAM(1,2) = P2(1)
6911         PGAM(2,2) = P2(2)
6912         PGAM(3,2) = P2(3)
6913         PGAM(4,2) = P2(4)
6914         PGAM(5,2) = -SQRT(Q2P2)
6915         CALL PHO_PRESEL(5,IREJ)
6916 C  photon helicities
6917         IGHEL(1) = 1
6918         IGHEL(2) = 1
6919 C  user cuts
6920         IF(IREJ.NE.0) GOTO 175
6921 C  event generation
6922         CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
6923         IF(IREJ.NE.0) GOTO 150
6924 C  cut on diffractive mass
6925         DO 250 K=1,NHEP
6926           IF(ISTHEP(K).EQ.30) THEN
6927             GHDIFF = PHEP(1,K)
6928             IF(GHDIFF.GE.PARMDL(175)) THEN
6929               GOTO 251
6930             ELSE
6931               GOTO 150
6932             ENDIF
6933           ENDIF
6934  250    CONTINUE
6935         WRITE(LO,'(/,1X,A)')
6936      &    'PHO_GHHIOF: no diffractive entry found'
6937           CALL PHO_PREVNT(-1)
6938         GOTO 150
6939  251    CONTINUE
6940 C  remove quasi-elastically scattered hadron
6941         DO 260 K=1,NHEP
6942           IF((ISTHEP(K).EQ.1).AND.(IDHEP(K).EQ.2212)) THEN
6943             XF = ABS(PHEP(3,K)/EEN)
6944             IF(XF.LT.PARMDL(72)) GOTO 150
6945 *           ISTHEP(K) = 2
6946             GOTO 261
6947           ENDIF
6948  260    CONTINUE
6949  261    CONTINUE
6950 C
6951 C  statistics
6952         NITERS(ISIDE) = NITERS(ISIDE)+1
6953         IF(ISIDE.EQ.1) THEN
6954           AY1  = AY1+Y1
6955           AYS1 = AYS1+Y1*Y1
6956           Q21AVE = Q21AVE+Q2P1
6957           Q21AV2 = Q21AV2+Q2P1*Q2P1
6958           Q21MIN = MIN(Q21MIN,Q2P1)
6959           Q21MAX = MAX(Q21MAX,Q2P1)
6960           YY1MIN = MIN(YY1MIN,Y1)
6961           YY1MAX = MAX(YY1MAX,Y1)
6962         ELSE
6963           AY2  = AY2+Y2
6964           AYS2 = AYS2+Y2*Y2
6965           Q22AVE = Q22AVE+Q2P2
6966           Q22AV2 = Q22AV2+Q2P2*Q2P2
6967           Q22MIN = MIN(Q22MIN,Q2P2)
6968           Q22MAX = MAX(Q22MAX,Q2P2)
6969           YY2MIN = MIN(YY2MIN,Y2)
6970           YY2MAX = MAX(YY2MAX,Y2)
6971         ENDIF
6972 C  histograms
6973         CALL PHO_PHIST(1,HSWGHT(0))
6974         CALL PHO_LHIST(1,HSWGHT(0))
6975  200  CONTINUE
6976 C
6977       WGMAX = WGMAX1*LOG(YMAX1/YMIN1)*FAC12
6978       WGY1 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW(1),1))*ALPHA/(2.D0*PI)
6979       WGMAX = WGMAX2*LOG(YMAX2/YMIN2)*(1.D0-FAC12)
6980       WGY2 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW(2),1))*ALPHA/(2.D0*PI)
6981       AY1  = AY1/DBLE(MAX(NITERS(1),1))
6982       AYS1 = AYS1/DBLE(MAX(NITERS(1),1))
6983       DAY1 = SQRT((AYS1-AY1**2)/DBLE(MAX(NITERS(1),1)))
6984       AY2  = AY2/DBLE(MAX(NITERS(2),1))
6985       AYS2 = AYS2/DBLE(MAX(NITERS(2),1))
6986       DAY2 = SQRT((AYS2-AY2**2)/DBLE(MAX(NITERS(2),1)))
6987       Q21AVE = Q21AVE/DBLE(MAX(NITERS(1),1))
6988       Q21AV2 = Q21AV2/DBLE(MAX(NITERS(1),1))
6989       Q21AV2 = SQRT((Q21AV2-Q21AVE**2)/DBLE(MAX(NITERS(1),1)))
6990       Q22AVE = Q22AVE/DBLE(MAX(NITERS(2),1))
6991       Q22AV2 = Q22AV2/DBLE(MAX(NITERS(2),1))
6992       Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(MAX(NITERS(2),1)))
6993       WGMAX  = WGMAX1*LOG(YMAX1/YMIN1)+WGMAX2*LOG(YMAX2/YMIN2)
6994       WGY    = WGMAX*DBLE(ITRY)/DBLE(ITRW(1)+ITRW(2))*ALPHA/(2.D0*PI)
6995       WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
6996 C  output of statistics, histograms
6997       WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
6998      &'=========================================================',
6999      &' *****   simulated cross section: ',WEIGHT,' mb  *****',
7000      &'========================================================='
7001       WRITE(LO,'(//1X,A,/3X,6I12)')
7002      &  'PHO_GHHIOF:SUMMARY:  NITER,   NITERS1/2,   ITRY,    ITRW1,2',
7003      &  NITER,NITERS,ITRY,ITRW
7004       WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
7005      &  WGY,WEIGHT
7006       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y1,DY1               ',
7007      &  AY1,DAY1
7008       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2               ',
7009      &  AY2,DAY2
7010       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 1     ',
7011      &  YY1MIN,YY1MAX
7012       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2     ',
7013      &  YY2MIN,YY2MAX
7014       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2 PHOTON 1      ',
7015      &  Q21AVE,Q21AV2
7016       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 1    ',
7017      &  Q21MIN,Q21MAX
7018       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2  PHOTON 2     ',
7019      &  Q22AVE,Q22AV2
7020       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2    ',
7021      &  Q22MIN,Q22MAX
7022 C
7023       CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
7024       IF(NITER.GT.1) THEN
7025         CALL PHO_PHIST(-2,WEIGHT)
7026         CALL PHO_LHIST(-2,WEIGHT)
7027       ELSE
7028         WRITE(LO,'(1X,A,I4)') 'PHO_GHHIOF:NO OUTPUT OF HISTOGRAMS',NITER
7029       ENDIF
7030
7031       END
7032
7033 *$ CREATE PHO_GHHIAS.FOR
7034 *COPY PHO_GHHIAS
7035 CDECK  ID>, PHO_GHHIAS
7036       SUBROUTINE PHO_GHHIAS(NEVENT,EEP,EEN,NA,NZ)
7037 C**********************************************************************
7038 C
7039 C     interface to call PHOJET (variable energy run) for
7040 C     gamma-hadron collisions in heavy ion - hadron
7041 C     collisions (form factor approach)
7042 C
7043 C     input:     EEP     LAB system energy of proton (GeV)
7044 C                EEN     LAB system energy per nucleon (GeV)
7045 C                NA      atomic number of ion/hadron
7046 C                NZ      charge number of ion/hadron
7047 C                NEVENT  number of events to generate
7048 C            from /LEPCUT/:
7049 C                YMIN2   lower limit of Y
7050 C                        (energy fraction taken by photon from hadron)
7051 C                YMAX2   upper cutoff for Y, necessary to avoid
7052 C                        underflows
7053 C                Q2MIN2  minimum Q**2 of photons (should be set to 0)
7054 C                Q2MAX2  maximum Q**2 of photons (if necessary,
7055 C                        corrected according size of hadron)
7056 C
7057 C**********************************************************************
7058       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7059       SAVE
7060
7061       PARAMETER ( PI   = 3.14159265359D0 )
7062
7063 C  input/output channels
7064       INTEGER LI,LO
7065       COMMON /POINOU/ LI,LO
7066 C  model switches and parameters
7067       CHARACTER*8 MDLNA
7068       INTEGER ISWMDL,IPAMDL
7069       DOUBLE PRECISION PARMDL
7070       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
7071 C  event debugging information
7072       INTEGER NMAXD
7073       PARAMETER (NMAXD=100)
7074       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
7075      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7076       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
7077      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7078 C  photon flux kinematics and cuts
7079       DOUBLE PRECISION ECMIN,ECMAX,EEMIN1,EEMIN2,
7080      &                 YMIN1,YMAX1,YMIN2,YMAX2,
7081      &                 Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
7082      &                 THMIN1,THMAX1,THMIN2,THMAX2
7083       INTEGER          ITAG1,ITAG2
7084       COMMON /POFCUT/ ECMIN,ECMAX,EEMIN1,EEMIN2,
7085      &                YMIN1,YMAX1,YMIN2,YMAX2,
7086      &                Q2MIN1,Q2MAX1,Q2MIN2,Q2MAX2,
7087      &                THMIN1,THMAX1,THMIN2,THMAX2,
7088      &                ITAG1,ITAG2
7089 C  gamma-lepton or gamma-hadron vertex information
7090       INTEGER IGHEL,IDPSRC,IDBSRC
7091       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
7092      &                 RADSRC,AMSRC,GAMSRC
7093       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
7094      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
7095      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
7096 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
7097       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
7098       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
7099       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
7100      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
7101 C  standard particle data interface
7102       INTEGER NMXHEP
7103       PARAMETER (NMXHEP=4000)
7104       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
7105       DOUBLE PRECISION PHEP,VHEP
7106       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
7107      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
7108      &                VHEP(4,NMXHEP)
7109 C  extension to standard particle data interface (PHOJET specific)
7110       INTEGER IMPART,IPHIST,ICOLOR
7111       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
7112 C  event weights and generated cross section
7113       INTEGER IPOWGC,ISWCUT,IVWGHT
7114       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
7115       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
7116      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
7117
7118       DIMENSION P1(4),P2(4)
7119
7120       WRITE(LO,'(2(/1X,A))')
7121      &  'PHO_GHHIAS: hadron-gamma event generation',
7122      &  '-----------------------------------------'
7123 C  hadron size and mass
7124       FM2GEV = 5.07D0
7125       HIMASS = DBLE(NA)*0.938D0
7126       HIMA2  = HIMASS**2
7127       HIRADI = 1.2D0*FM2GEV*DBLE(NA)**0.333
7128       ALPHA  = DBLE(NZ**2)/137.D0
7129       AMP  = 0.938D0
7130       AMP2 = AMP**2
7131 C  correct Q2MAX2 according to hadron size
7132       Q2MAXH = 2.D0/HIRADI**2
7133       Q2MAX2 = MIN(Q2MAX2,Q2MAXH)
7134       IF(Q2MAX2.LT.1.D-20) Q2MAX2 = Q2MAXH
7135 C  total hadron / heavy ion energy
7136       EE = EEN*DBLE(NA)
7137       GAMMA = EE/HIMASS
7138 C  setup /POFSRC/
7139       GAMSRC(2) = GAMMA
7140       RADSRC(2) = HIRADI
7141       AMSRC(2)  = HIMASS
7142 C  check kinematic limitations
7143       YMI = ECMIN**2/(4.D0*EE*EEP)
7144       IF(YMIN2.LT.YMI) THEN
7145         WRITE(LO,'(/1X,A,2E12.5)')
7146      &    'PHO_GHHIOF: ymin2 increased to (old/new)',YMIN2,YMI
7147         YMIN2 = YMI
7148       ELSE IF(YMIN2.GT.YMI) THEN
7149         WRITE(LO,'(/1X,A,/1X,A,E12.5,A,E12.5)')
7150      &    'PHO_GHHIOF:','ECM-CUT CORRESPONDS TO YMIN2 OF',YMI,
7151      &    '  INSTEAD OF',YMIN2
7152       ENDIF
7153 C  kinematic limitation
7154       Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
7155 C  debug output
7156       WRITE(LO,'(/6X,A,2I4)')   'MASS NUMBER, CHARGE NUMBER  ',NA,NZ
7157       WRITE(LO,'(6X,A,E12.5)') 'HEAVY ION MASS (GeV)        ',HIMASS
7158       WRITE(LO,'(6X,A,E12.5)') 'HEAVY ION  RADIUS (GeV**-1) ',HIRADI
7159       WRITE(LO,'(6X,A,2E12.5)') 'Q**2 RANGE PHOTON 2 (GEV**2)',Q2LOW2,
7160      &  Q2MAX2
7161       WRITE(LO,'(6X,A,2E12.5)') 'Y RANGE PHOTON 2            ',YMIN2,
7162      &  YMAX2
7163       WRITE(LO,'(6X,A,2E12.5)') 'SQRT(S) PER NUCLEON, TOTAL  ',
7164      &  2.D0*SQRT(EEN*EEP),2.D0*SQRT(EE*EEP)
7165       WRITE(LO,'(6X,A,2E12.5)') 'INV.MASS HADRON-PHOTON      ',ECMIN,
7166      &  ECMAX
7167       WRITE(LO,'(6X,A,I10)')   'EVENTS TO PROCESS           ',NEVENT
7168       IF(Q2LOW2.GE.Q2MAX2) THEN
7169         WRITE(LO,'(/1X,A,2E12.4)')
7170      &    'PHO_GHHIOF:ERROR:inconsistent Q**2 range 2',Q2LOW2,Q2MAX2
7171         CALL PHO_ABORT
7172       ENDIF
7173 C  hadron numbers set to 0
7174       IDPSRC(1) = 0
7175       IDPSRC(2) = 0
7176       IDBSRC(1) = 0
7177       IDBSRC(2) = 0
7178 C
7179       Max_tab = 100
7180       YMAX = YMAX2
7181       YMIN = YMIN2
7182       XMAX = LOG(YMAX)
7183       XMIN = LOG(YMIN)
7184       XDEL = XMAX-XMIN
7185       DELLY = LOG(YMAX/YMIN)/DBLE(Max_tab-1)
7186       DO 102 I=1,Max_tab
7187         Y1 = EXP(XMIN+DELLY*DBLE(I-1))
7188         Q2LOW2 = MAX(Q2MIN2,HIMA2*Y1*Y1/(1.D0-Y1))
7189         IF(Q2LOW2.GE.Q2MAX2) THEN
7190           WRITE(LO,'(/1X,A,2E12.4)')
7191      &      'PHO_GHHIOF: ymax2 changed from/to',YMAX2,Y1
7192           YMAX2 = MIN(Y1,YMAX2)
7193           GOTO 103
7194         ENDIF
7195  102  CONTINUE
7196  103  CONTINUE
7197 C
7198       X2MAX = LOG(YMAX2)
7199       X2MIN = LOG(YMIN2)
7200       X2DEL = X2MAX-X2MIN
7201       DELLY = LOG(YMAX2/YMIN2)/DBLE(Max_tab-1)
7202       FLUX = 0.D0
7203       IF(IDEB(30).GE.1) WRITE(LO,'(/1X,A,I5)')
7204      &  'PHO_GHHIAS: table of raw photon flux (side 2)',Max_tab
7205       DO 105 I=1,Max_tab
7206         Y2 = EXP(X2MIN+DELLY*DBLE(I-1))
7207         Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2*Y2/(1.D0-Y2))
7208         FF = ((1.D0+(1.D0-Y2)**2)/Y2*LOG(Q2MAX2/Q2LOW2)
7209      &        -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2))*ALPHA/(2.D0*PI)
7210         FLUX = FLUX+Y2*FF
7211         IF(IDEB(30).GE.1) WRITE(LO,'(5X,2E15.4)') Y2,FF
7212  105  CONTINUE
7213       FLUX = FLUX*DELLY
7214       IF(IDEB(30).GE.1) WRITE(LO,'(1X,A,E12.4)')
7215      &  'PHO_GHHIAS: integrated flux:',FLUX
7216 C
7217 C  hadron
7218       P1(1) = 0.D0
7219       P1(2) = 0.D0
7220       P1(3) = -SQRT(EEP**2-AMP2)
7221       P1(4) = EEP
7222 C  photon
7223       EGAM = YMAX2*EE
7224       P2(1) = 0.D0
7225       P2(2) = 0.D0
7226       P2(3) = EGAM
7227       P2(4) = EGAM
7228       CALL PHO_SETPAR(1,2212,0,0.D0)
7229       CALL PHO_SETPAR(2,22,0,0.D0)
7230       CALL PHO_EVENT(-1,P1,P2,SIGMAX,IREJ)
7231 C
7232       Q2LOW2 = MAX(Q2MIN2,HIMA2*YMIN2**2/(1.D0-YMIN2))
7233       Y2 = YMIN2
7234       WGMAX2 = (1.D0+(1.D0-Y2)**2)*LOG(Q2MAX2/Q2LOW2)
7235      &         -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
7236 C
7237       CALL PHO_PHIST(-1,SIGMAX)
7238       CALL PHO_LHIST(-1,SIGMAX)
7239 C
7240 C  generation of events, flux calculation
7241       AY1  = 0.D0
7242       AY2  = 0.D0
7243       AYS1 = 0.D0
7244       AYS2 = 0.D0
7245       Q22MIN = 1.D30
7246       Q22MAX = 0.D0
7247       Q22AVE = 0.D0
7248       Q22AV2 = 0.D0
7249       YY2MIN = 1.D30
7250       YY2MAX = 0.D0
7251       NITER = NEVENT
7252       NITERS = 0
7253       ITRY = 0
7254       ITRW = 0
7255       DO 200 I=1,NITER
7256 C  sample photon flux
7257  150    CONTINUE
7258         ITRY = ITRY+1
7259  175    CONTINUE
7260 C
7261           ITRW = ITRW+1
7262 C  select Y2
7263           Y2 = EXP(X2DEL*DT_RNDM(AY2)+X2MIN)
7264           Q2LOW2 = MAX(Q2MIN2,HIMA2*Y2**2/(1.D0-Y2))
7265           IF(Q2LOW2.GE.Q2MAX2) GOTO 175
7266           Q2LOG2 = LOG(Q2MAX2/Q2LOW2)
7267           WGH = (1.D0+(1.D0-Y2)**2)*Q2LOG2
7268      &          -2.D0*HIMA2*Y2*(1.D0/Q2LOW2-1.D0/Q2MAX2)*Y2
7269           IF(WGMAX2.LT.WGH) WRITE(LO,'(1X,A,3E12.5)')
7270      &        'PHO_GHHIOF:WEIGHT ERROR (2):',Y2,WGMAX2,WGH
7271           IF(DT_RNDM(AYS1)*WGMAX2.GT.WGH) GOTO 175
7272 C  sample Q2
7273           IF(IPAMDL(174).EQ.1) THEN
7274             YEFF = 1.D0+(1.D0-Y2)**2
7275  186        CONTINUE
7276               Q2P2 = Q2LOW2*EXP(Q2LOG2*DT_RNDM(Y2))
7277               WEIGHT = (YEFF-2.D0*(1.D0-Y2)*Q2LOW2/Q2P2)/YEFF
7278             IF(WEIGHT.LT.DT_RNDM(Q2P2)) GOTO 186
7279           ELSE
7280             Q2P2 = Q2LOW2
7281           ENDIF
7282 C  impact parameter
7283           GAIMP(2) = 1.D0/SQRT(Q2P2)
7284 C  form factor (squared)
7285           FF2 = 1.D0
7286           IF(GAIMP(2).LT.2.D0*HIRADI) FF2 = 0.D0
7287           IF(DT_RNDM(Q2P2).GE.FF2) GOTO 175
7288 C  photon data
7289           GYY(2) = Y2
7290           GQ2(2) = Q2P2
7291 C
7292 C  incoming hadron 1
7293           PINI(1,1) = 0.D0
7294           PINI(2,1) = 0.D0
7295           PINI(3,1) = SQRT(EEP**2-AMP2)
7296           PINI(4,1) = EEP
7297           PINI(5,1) = AMP
7298 C  incoming hadron 2
7299           PINI(1,2) = 0.D0
7300           PINI(2,2) = 0.D0
7301           PINI(3,2) = -SQRT(EE**2-AMP2)
7302           PINI(4,2) = EE
7303           PINI(5,2) = AMP
7304 C  outgoing hadron 2
7305           YQ2 = SQRT((1.D0-Y2)*Q2P2)
7306           Q2E = Q2P2/(4.D0*EE)
7307           E1Y = EE*(1.D0-Y2)
7308           CALL PHO_SFECFE(SIF,COF)
7309           PFIN(1,2) = YQ2*COF
7310           PFIN(2,2) = YQ2*SIF
7311           PFIN(3,2) = -E1Y+Q2E
7312           PFIN(4,2) = E1Y+Q2E
7313           PFIN(5,2) = 0.D0
7314           PFPHI(2) = ATAN2(COF,SIF)
7315           PFTHE(2) = ACOS((Q2E-E1Y)/(Q2E+E1Y))
7316 C  scattering hadron
7317           P1(1) = 0.D0
7318           P1(2) = 0.D0
7319           P1(3) = SQRT(EEP**2-AMP2)
7320           P1(4) = EEP
7321           Q2P1  = AMP2
7322 C  scattering photon
7323           P2(1) = -PFIN(1,2)
7324           P2(2) = -PFIN(2,2)
7325           P2(3) = PINI(3,2)-PFIN(3,2)
7326           P2(4) = PINI(4,2)-PFIN(4,2)
7327           ISIDE = 2
7328 C
7329 C  ECMS cut
7330         GGECM = (P1(4)+P2(4))**2-(P1(1)+P2(1))**2
7331      &         -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2
7332         IF(GGECM.LT.0.1D0) GOTO 175
7333         GGECM = SQRT(GGECM)
7334         IF((GGECM.LT.ECMIN).OR.(GGECM.GT.ECMAX)) GOTO 175
7335 C
7336         PGAM(1,1) = P1(1)
7337         PGAM(2,1) = P1(2)
7338         PGAM(3,1) = P1(3)
7339         PGAM(4,1) = P1(4)
7340         PGAM(5,1) = AMP
7341         PGAM(1,2) = P2(1)
7342         PGAM(2,2) = P2(2)
7343         PGAM(3,2) = P2(3)
7344         PGAM(4,2) = P2(4)
7345         PGAM(5,2) = -SQRT(Q2P2)
7346 C  photon helicities
7347         IGHEL(2) = 1
7348 C  user cuts
7349         CALL PHO_PRESEL(5,IREJ)
7350         IF(IREJ.NE.0) GOTO 175
7351 C  event generation
7352         CALL PHO_EVENT(1,P1,P2,SIGCUR,IREJ)
7353         IF(IREJ.NE.0) GOTO 150
7354 C  cut on diffractive mass
7355         DO 250 K=1,NHEP
7356           IF(ISTHEP(K).EQ.30) THEN
7357             GHDIFF = PHEP(1,K)
7358             IF(GHDIFF.GE.PARMDL(175)) THEN
7359               GOTO 251
7360             ELSE
7361               GOTO 150
7362             ENDIF
7363           ENDIF
7364  250    CONTINUE
7365         WRITE(LO,'(/,1X,A)')
7366      &    'PHO_GHHIOF: no diffractive entry found'
7367           CALL PHO_PREVNT(-1)
7368         GOTO 150
7369  251    CONTINUE
7370 C  remove quasi-elastically scattered hadron
7371         DO 260 K=1,NHEP
7372           IF((ISTHEP(K).EQ.1).AND.(IDHEP(K).EQ.2212)) THEN
7373             XF = ABS(PHEP(3,K)/EEN)
7374             IF(XF.LT.PARMDL(72)) GOTO 150
7375 *           ISTHEP(K) = 2
7376             GOTO 261
7377           ENDIF
7378  260    CONTINUE
7379  261    CONTINUE
7380 C
7381 C  statistics
7382         NITERS = NITERS+1
7383         AY2  = AY2+Y2
7384         AYS2 = AYS2+Y2*Y2
7385         Q22AVE = Q22AVE+Q2P2
7386         Q22AV2 = Q22AV2+Q2P2*Q2P2
7387         Q22MIN = MIN(Q22MIN,Q2P2)
7388         Q22MAX = MAX(Q22MAX,Q2P2)
7389         YY2MIN = MIN(YY2MIN,Y2)
7390         YY2MAX = MAX(YY2MAX,Y2)
7391 C  histograms
7392         CALL PHO_PHIST(1,HSWGHT(0))
7393         CALL PHO_LHIST(1,HSWGHT(0))
7394  200  CONTINUE
7395 C
7396       WGMAX = WGMAX2*LOG(YMAX2/YMIN2)
7397       WGY2 = WGMAX*DBLE(ITRY)/DBLE(MAX(ITRW,1))*ALPHA/(2.D0*PI)
7398       AY2  = AY2/DBLE(MAX(NITERS,1))
7399       AYS2 = AYS2/DBLE(MAX(NITERS,1))
7400       DAY2 = SQRT((AYS2-AY2**2)/DBLE(MAX(NITERS,1)))
7401       Q22AVE = Q22AVE/DBLE(MAX(NITERS,1))
7402       Q22AV2 = Q22AV2/DBLE(MAX(NITERS,1))
7403       Q22AV2 = SQRT((Q22AV2-Q22AVE**2)/DBLE(MAX(NITERS,1)))
7404       WGMAX  = WGMAX2*LOG(YMAX2/YMIN2)
7405       WGY    = WGMAX*DBLE(ITRY)/DBLE(ITRW)*ALPHA/(2.D0*PI)
7406       WEIGHT = WGY*SIGMAX*DBLE(NITER)/DBLE(ITRY)
7407 C  output of statistics, histograms
7408       WRITE(LO,'(//1X,A,/1X,A,1PE12.3,A,/1X,A)')
7409      &'=========================================================',
7410      &' *****   simulated cross section: ',WEIGHT,' mb  *****',
7411      &'========================================================='
7412       WRITE(LO,'(//1X,A,/3X,4I12)')
7413      &  'PHO_GHHIOF:SUMMARY:  NITER,    NITERS,    ITRY,     ITRW',
7414      &  NITER,NITERS,ITRY,ITRW
7415       WRITE(LO,'(1X,A,1P2E12.4)') 'EFFECTIVE WEIGHT (FLUX,TOTAL)',
7416      &  WGY,WEIGHT
7417       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Y2,DY2               ',
7418      &  AY2,DAY2
7419       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Y RANGE PHOTON 2     ',
7420      &  YY2MIN,YY2MAX
7421       WRITE(LO,'(1X,A,1P2E12.4)') 'AVERAGE Q2,DQ2  PHOTON 2     ',
7422      &  Q22AVE,Q22AV2
7423       WRITE(LO,'(1X,A,1P2E12.4)') 'SAMPLED Q2 RANGE PHOTON 2    ',
7424      &  Q22MIN,Q22MAX
7425 C
7426       CALL PHO_EVENT(-2,P1,P2,WEIGHT,IREJ)
7427       IF(NITER.GT.1) THEN
7428         CALL PHO_PHIST(-2,WEIGHT)
7429         CALL PHO_LHIST(-2,WEIGHT)
7430       ELSE
7431         WRITE(LO,'(1X,A,I4)')
7432      &    'PHO_GHHIOF: no output of histograms',NITER
7433       ENDIF
7434
7435       END
7436
7437 *$ CREATE PHO_FITPAR.FOR
7438 *COPY PHO_FITPAR
7439 CDECK  ID>, PHO_FITPAR
7440       SUBROUTINE PHO_FITPAR(IOUTP)
7441 C**********************************************************************
7442 C
7443 C     read input parameters according to PDFs
7444 C
7445 C**********************************************************************
7446       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7447       SAVE
7448
7449       PARAMETER ( DEFA=-99999.D0,
7450      &            DEFB=-100000.D0,
7451      &           THOUS=1.D3)
7452
7453 C  input/output channels
7454       INTEGER LI,LO
7455       COMMON /POINOU/ LI,LO
7456 C  event debugging information
7457       INTEGER NMAXD
7458       PARAMETER (NMAXD=100)
7459       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
7460      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7461       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
7462      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
7463 C  model switches and parameters
7464       CHARACTER*8 MDLNA
7465       INTEGER ISWMDL,IPAMDL
7466       DOUBLE PRECISION PARMDL
7467       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
7468 C  global event kinematics and particle IDs
7469       INTEGER IFPAP,IFPAB
7470       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
7471       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
7472 C  currently activated parton density parametrizations
7473       CHARACTER*8 PDFNAM
7474       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
7475       DOUBLE PRECISION PDFLAM,PDFQ2M
7476       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
7477      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
7478 C  Reggeon phenomenology parameters
7479       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
7480      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
7481       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
7482      &                ALREG,ALREGP,GR(2),B0REG(2),
7483      &                GPPP,GPPR,B0PPP,B0PPR,
7484      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
7485 C  parameters of 2x2 channel model
7486       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
7487       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
7488
7489       DIMENSION   INUM(3),IFPAS(2)
7490       CHARACTER*8 CNAME8,PDFNA1,PDFNA2
7491       CHARACTER*10 CNAM10
7492
7493       PARAMETER ( Max_tab = 22 )
7494       DIMENSION XDPtab(27,Max_tab),IDPtab(8,Max_tab)
7495       REAL XDPtab
7496       INTEGER IDPtab
7497
7498 C  parameter set for   2212 (GRV94 LO)     2212 (GRV94 LO)
7499       DATA (IDPtab(k,  1),k=1,8) /
7500      &    2212,     5,     6,     0,  2212,     5,     6,     0 /
7501       DATA (XDPtab(k,  1),k=1,27) /
7502      &1.1000E+00,2.5000E-01,6.3870E+00,6.3870E+00,1.1610E+00,1.1610E+00,
7503      &4.5000E-01,9.0000E-01,1.0263E+01,1.0263E+01,1.1710E+00,1.1710E+00,
7504      &1.5600E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7505      &1.0000E+00,0.0000E+00,1.0000E+00,0.0000E+00,3.5000E+00,2.0000E+00,
7506      &6.0000E-01,6.0000E-01,1.1000E+00,1.1000E+00,3.000E+00 /
7507
7508 C  parameter set for   2212 (GRV94 LO)    -2212 (GRV94 LO)
7509       DATA (IDPtab(k,  2),k=1,8) /
7510      &    2212,     5,     6,     0, -2212,     5,     6,     0 /
7511       DATA (XDPtab(k,  2),k=1,27) /
7512      &1.1000E+00,2.5000E-01,6.3870E+00,6.3870E+00,1.1610E+00,1.1610E+00,
7513      &4.5000E-01,9.0000E-01,1.5174E+01,1.5174E+01,1.5400E+00,1.5400E+00,
7514      &1.5600E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7515      &1.0000E+00,0.0000E+00,1.0000E+00,0.0000E+00,3.5000E+00,2.0000E+00,
7516      &6.0000E-01,6.0000E-01,1.1000E+00,1.1000E+00,3.000E+00 /
7517
7518 C  parameter set for     22 (GRV-G LO)     2212 (GRV94 LO)
7519       DATA (IDPtab(k,  3),k=1,8) /
7520      &      22,     5,     3,     0,  2212,     5,     6,     0 /
7521       DATA (XDPtab(k,  3),k=1,27) /
7522      &1.0970E+00,2.5000E-01,2.7450E+00,6.8270E+00,1.2250E+00,1.1360E+00,
7523      &5.0000E-01,1.0000E+00,4.7210E+00,1.1740E+01,4.6200E-01,4.2800E-01,
7524      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7525      &4.3100E-03,8.0000E-05,1.0000E+00,0.0000E+00,3.2000E+00,1.0000E+00,
7526      &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7527
7528 C  parameter set for     22 (GRV-G LO)       22 (GRV-G LO)
7529       DATA (IDPtab(k,  4),k=1,8) /
7530      &      22,     5,     3,     0,    22,     5,     3,     0 /
7531       DATA (XDPtab(k,  4),k=1,27) /
7532      &1.0970E+00,2.5000E-01,2.7450E+00,2.7450E+00,1.2250E+00,1.2250E+00,
7533      &5.0000E-01,1.0000E+00,4.7210E+00,4.7210E+00,4.6200E-01,4.6200E-01,
7534      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7535      &4.3100E-03,8.0000E-05,4.3100E-03,8.0000E-05,3.2000E+00,1.0000E+00,
7536      &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7537
7538 C  parameter set for     22 (GRS-G LO)     2212 (GRV94 LO)
7539       DATA (IDPtab(k,  5),k=1,8) /
7540      &      22,     5,     4,     4,  2212,     5,     6,     0 /
7541       DATA (XDPtab(k,  5),k=1,27) /
7542      &1.0970E+00,2.5000E-01,2.7450E+00,6.8270E+00,1.2250E+00,1.1360E+00,
7543      &5.0000E-01,1.0000E+00,4.7210E+00,1.1740E+01,4.6200E-01,4.2800E-01,
7544      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7545      &4.3100E-03,8.0000E-05,1.0000E+00,0.0000E+00,3.2000E+00,1.0000E+00,
7546      &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7547
7548 C  parameter set for     22 (GRS-G LO)       22 (GRS-G LO)
7549       DATA (IDPtab(k,  6),k=1,8) /
7550      &      22,     5,     4,     4,    22,     5,     4,     4 /
7551       DATA (XDPtab(k,  6),k=1,27) /
7552      &1.0970E+00,2.5000E-01,2.7450E+00,2.7450E+00,1.2250E+00,1.2250E+00,
7553      &5.0000E-01,1.0000E+00,4.7210E+00,4.7210E+00,4.6200E-01,4.6200E-01,
7554      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7555      &4.3100E-03,8.0000E-05,4.3100E-03,8.0000E-05,3.2000E+00,1.0000E+00,
7556      &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7557
7558 C  parameter set for     22 (SaS-1D  )       22 (SaS-1D  )
7559       DATA (IDPtab(k,  7),k=1,8) /
7560      &      22,     1,     1,     4,    22,     1,     1,     4 /
7561       DATA (XDPtab(k,  7),k=1,27) /
7562      &1.0970E+00,2.5000E-01,3.1170E+00,3.1170E+00,1.3450E+00,1.3450E+00,
7563      &3.0200E-01,1.0000E+00,6.6050E+00,6.6050E+00,1.7500E-01,1.7500E-01,
7564      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7565      &4.0900E-03,9.0000E-05,4.0900E-03,9.0000E-05,3.2000E+00,1.0000E+00,
7566      &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7567
7568 C  parameter set for     22 (SaS-1M  )       22 (SaS-1M  )
7569       DATA (IDPtab(k,  8),k=1,8) /
7570      &      22,     1,     2,     4,    22,     1,     2,     4 /
7571       DATA (XDPtab(k,  8),k=1,27) /
7572      &1.0970E+00,2.5000E-01,2.5540E+00,2.5540E+00,1.0910E+00,1.0910E+00,
7573      &5.0000E-01,1.0000E+00,4.2580E+00,4.2580E+00,4.9000E-01,4.9000E-01,
7574      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7575      &4.5700E-03,1.0000E-04,4.5700E-03,1.0000E-04,3.2000E+00,1.0000E+00,
7576      &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7577
7578 C  parameter set for     22 (SaS-2D  )       22 (SaS-2D  )
7579       DATA (IDPtab(k,  9),k=1,8) /
7580      &      22,     1,     3,     4,    22,     1,     3,     4 /
7581       DATA (XDPtab(k,  9),k=1,27) /
7582      &1.0970E+00,2.5000E-01,2.5330E+00,2.5330E+00,1.1340E+00,1.1340E+00,
7583      &5.0100E-01,1.0000E+00,4.2300E+00,4.2300E+00,4.9300E-01,4.9300E-01,
7584      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7585      &4.5900E-03,1.0000E-04,4.5900E-03,1.0000E-04,3.2000E+00,1.0000E+00,
7586      &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7587
7588 C  parameter set for     22 (SaS-2M  )       22 (SaS-2M  )
7589       DATA (IDPtab(k, 10),k=1,8) /
7590      &      22,     1,     4,     4,    22,     1,     4,     4 /
7591       DATA (XDPtab(k, 10),k=1,27) /
7592      &1.0970E+00,2.5000E-01,2.8220E+00,2.8220E+00,1.0910E+00,1.0910E+00,
7593      &4.9100E-01,1.0000E+00,4.6870E+00,4.6870E+00,4.5800E-01,4.5800E-01,
7594      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7595      &4.6600E-03,3.0000E-05,4.6600E-03,3.0000E-05,3.2000E+00,1.0000E+00,
7596      &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7597
7598 C  parameter set for     22 (LAC     )     2212 (GRV94 LO)
7599       DATA (IDPtab(k, 11),k=1,8) /
7600      &      22,     3,     1,     3,  2212,     5,     6,     0 /
7601       DATA (XDPtab(k, 11),k=1,27) /
7602      &1.0970E+00,2.5000E-01,3.3050E+00,6.8270E+00,9.4500E-01,1.1360E+00,
7603      &4.5000E-01,1.0000E+00,6.7120E+00,1.1740E+01,2.5800E-01,4.6200E-01,
7604      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7605      &3.3400E-03,2.4000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7606      &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7607
7608 C  parameter set for     22 (PDFLIB2 )     2212 (GRV94 LO)
7609       DATA (IDPtab(k, 12),k=1,8) /
7610      &      22,     3,     1,     2,  2212,     5,     6,     0 /
7611       DATA (XDPtab(k, 12),k=1,27) /
7612      &1.0970E+00,2.5000E-01,3.3050E+00,6.8270E+00,9.4500E-01,1.1360E+00,
7613      &4.5000E-01,1.0000E+00,6.7120E+00,1.1740E+01,2.5800E-01,4.6200E-01,
7614      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7615      &3.3400E-03,2.4000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7616      &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7617
7618 C  parameter set for     22 (LAC     )       22 (LAC     )
7619       DATA (IDPtab(k, 13),k=1,8) /
7620      &      22,     3,     1,     3,    22,     3,     1,     3 /
7621       DATA (XDPtab(k, 13),k=1,27) /
7622      &1.0970E+00,2.5000E-01,3.3050E+00,3.3050E+00,9.4500E-01,9.4500E-01,
7623      &4.5000E-01,1.0000E+00,6.7120E+00,6.7120E+00,2.5800E-01,2.5800E-01,
7624      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7625      &3.3400E-03,2.4000E-04,3.3400E-03,2.4000E-04,2.0000E+00,1.0000E+00,
7626      &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7627
7628 C  parameter set for     22 (PDFLIB2 )       22 (PDFLIB2 )
7629       DATA (IDPtab(k, 14),k=1,8) /
7630      &      22,     3,     1,     2,    22,     3,     1,     2 /
7631       DATA (XDPtab(k, 14),k=1,27) /
7632      &1.0970E+00,2.5000E-01,3.3050E+00,3.3050E+00,9.4500E-01,9.4500E-01,
7633      &4.5000E-01,1.0000E+00,6.7120E+00,6.7120E+00,2.5800E-01,2.5800E-01,
7634      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7635      &3.3400E-03,2.4000E-04,3.3400E-03,2.4000E-04,2.0000E+00,1.0000E+00,
7636      &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7637
7638 C  parameter set for     22 (LAC     )     2212 (GRV94 LO)
7639       DATA (IDPtab(k, 15),k=1,8) /
7640      &      22,     3,     2,     3,  2212,     5,     6,     0 /
7641       DATA (XDPtab(k, 15),k=1,27) /
7642      &1.0970E+00,2.5000E-01,3.1450E+00,6.8270E+00,1.0490E+00,1.1360E+00,
7643      &4.5000E-01,1.0000E+00,6.3680E+00,1.1740E+01,1.4700E-01,4.6200E-01,
7644      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7645      &3.8700E-03,1.1000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7646      &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7647
7648 C  parameter set for     22 (PDFLIB2 )     2212 (GRV94 LO)
7649       DATA (IDPtab(k, 16),k=1,8) /
7650      &      22,     3,     2,     2,  2212,     5,     6,     0 /
7651       DATA (XDPtab(k, 16),k=1,27) /
7652      &1.0970E+00,2.5000E-01,3.1450E+00,6.8270E+00,1.0490E+00,1.1360E+00,
7653      &4.5000E-01,1.0000E+00,6.3680E+00,1.1740E+01,1.4700E-01,4.6200E-01,
7654      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7655      &3.8700E-03,1.1000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7656      &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7657
7658 C  parameter set for     22 (LAC     )       22 (LAC     )
7659       DATA (IDPtab(k, 17),k=1,8) /
7660      &      22,     3,     2,     3,    22,     3,     2,     3 /
7661       DATA (XDPtab(k, 17),k=1,27) /
7662      &1.0970E+00,2.5000E-01,3.1450E+00,3.1450E+00,1.0490E+00,1.0490E+00,
7663      &4.5000E-01,1.0000E+00,6.3680E+00,6.3680E+00,1.4700E-01,1.4700E-01,
7664      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7665      &3.8700E-03,1.1000E-04,3.8700E-03,1.0000E-04,2.0000E+00,1.0000E+00,
7666      &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7667
7668 C  parameter set for     22 (PDFLIB2 )       22 (PDFLIB2 )
7669       DATA (IDPtab(k, 18),k=1,8) /
7670      &      22,     3,     2,     2,    22,     3,     2,     2 /
7671       DATA (XDPtab(k, 18),k=1,27) /
7672      &1.0970E+00,2.5000E-01,3.1450E+00,3.1450E+00,1.0490E+00,1.0490E+00,
7673      &4.5000E-01,1.0000E+00,6.3680E+00,6.3680E+00,1.4700E-01,1.4700E-01,
7674      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7675      &3.8700E-03,1.1000E-04,3.8700E-03,1.0000E-04,2.0000E+00,1.0000E+00,
7676      &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7677
7678 C  parameter set for     22 (LAC     )     2212 (GRV94 LO)
7679       DATA (IDPtab(k, 19),k=1,8) /
7680      &      22,     3,     3,     3,  2212,     5,     6,     0 /
7681       DATA (XDPtab(k, 19),k=1,27) /
7682      &1.0970E+00,2.5000E-01,3.0510E+00,6.8270E+00,1.0500E+00,1.1360E+00,
7683      &4.5000E-01,1.0000E+00,6.0060E+00,1.1740E+01,2.0500E-01,4.6200E-01,
7684      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7685      &4.0200E-03,1.0000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7686      &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7687
7688 C  parameter set for     22 (PDFLIB2 )     2212 (GRV94 LO)
7689       DATA (IDPtab(k, 20),k=1,8) /
7690      &      22,     3,     3,     2,  2212,     5,     6,     0 /
7691       DATA (XDPtab(k, 20),k=1,27) /
7692      &1.0970E+00,2.5000E-01,3.0510E+00,6.8270E+00,1.0500E+00,1.1360E+00,
7693      &4.5000E-01,1.0000E+00,6.0060E+00,1.1740E+01,2.0500E-01,4.6200E-01,
7694      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7695      &4.0200E-03,1.0000E-04,1.0000E+00,0.0000E+00,2.0000E+00,1.0000E+00,
7696      &7.0000E-01,6.0000E-01,1.0000E+00,1.1000E+00,3.000E+00 /
7697
7698 C  parameter set for     22 (LAC     )       22 (LAC     )
7699       DATA (IDPtab(k, 21),k=1,8) /
7700      &      22,     3,     3,     3,    22,     3,     3,     3 /
7701       DATA (XDPtab(k, 21),k=1,27) /
7702      &1.0970E+00,2.5000E-01,3.0510E+00,3.0510E+00,1.0500E+00,1.0500E+00,
7703      &4.5000E-01,1.0000E+00,6.0060E+00,6.0060E+00,2.0500E-01,2.0500E-01,
7704      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7705      &4.0200E-03,1.0000E-04,4.0200E-03,1.0000E-04,2.0000E+00,1.0000E+00,
7706      &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7707
7708 C  parameter set for     22 (PDFLIB2 )       22 (PDFLIB2 )
7709       DATA (IDPtab(k, 22),k=1,8) /
7710      &      22,     3,     3,     2,    22,     3,     3,     2 /
7711       DATA (XDPtab(k, 22),k=1,27) /
7712      &1.0970E+00,2.5000E-01,3.0510E+00,3.0510E+00,1.0500E+00,1.0500E+00,
7713      &4.5000E-01,1.0000E+00,6.0060E+00,6.0060E+00,2.0500E-01,2.0500E-01,
7714      &1.7000E-01,5.0000E-01,6.1200E-01,3.0000E-01,
7715      &4.0200E-03,1.0000E-04,4.0200E-03,1.0000E-04,2.0000E+00,1.0000E+00,
7716      &7.0000E-01,7.0000E-01,1.0000E+00,1.0000E+00,3.000E+00 /
7717
7718       DATA CNAME8 /'        '/
7719       DATA CNAM10 /'          '/
7720       DATA INIT / 0 /
7721       DATA IFPAS / 0, 0 /
7722
7723       IF((INIT.EQ.1).AND.
7724      &   (IFPAP(1).EQ.IFPAS(1)).AND.(IFPAP(2).EQ.IFPAS(2))) GOTO 1300
7725
7726       INIT=1
7727       IFPAS(1) = IFPAP(1)
7728       IFPAS(2) = IFPAP(2)
7729
7730 C  parton distribution functions
7731       CALL PHO_ACTPDF(IFPAP(1),1)
7732       CALL PHO_GETPDF(1,PDFNA1,ALAM2,Q2MIN,Q2MAX,XMIN,XMAX)
7733       CALL PHO_ACTPDF(IFPAP(2),2)
7734       CALL PHO_GETPDF(2,PDFNA2,ALAM2,Q2MIN,Q2MAX,XMIN,XMAX)
7735 C  initialize alpha_s calculation
7736       DUMMY = PHO_ALPHAS(0.D0,-4)
7737
7738       IF(IDEB(54).GE.0) THEN
7739         WRITE(LO,'(/1X,A,I7,2X,A,3I7)') 'PHO_FITPAR: looking for PDF',
7740      &    IFPAP(1),PDFNA1,IGRP(1),ISET(1),IEXT(1)
7741         WRITE(LO,'(1X,A,I7,2X,A,3I7)') 'PHO_FITPAR: looking for PDF',
7742      &    IFPAP(2),PDFNA2,IGRP(2),ISET(2),IEXT(2)
7743       ENDIF
7744
7745       IFOUND = 0
7746
7747 C  load parameter set from internal tables
7748       I1 = 1
7749       I2 = 2
7750  110  CONTINUE
7751
7752       DO I=1,Max_tab
7753         IF((IFPAP(I1).EQ.IDPtab(1,I))
7754      &     .AND.(IGRP(I1).EQ.IDPtab(2,I))
7755      &     .AND.(ISET(I1).EQ.IDPtab(3,I))
7756      &     .AND.(IEXT(I1).EQ.IDPtab(4,I))) THEN
7757           IF((IFPAP(I2).EQ.IDPtab(5,I))
7758      &       .AND.(IGRP(I2).EQ.IDPtab(6,I))
7759      &       .AND.(ISET(I2).EQ.IDPtab(7,I))
7760      &       .AND.(IEXT(I2).EQ.IDPtab(8,I))) THEN
7761             WRITE(LO,'(/1X,A)')
7762      &        'PHO_FITPAR: parameter set found in internal table'
7763             ALPOM    = XDPtab(1,I)
7764             ALPOMP   = XDPtab(2,I)
7765             GP(I1)   = XDPtab(3,I)
7766             GP(I2)   = XDPtab(4,I)
7767             B0POM(I1) = XDPtab(5,I)
7768             B0POM(I2) = XDPtab(6,I)
7769             ALREG    = XDPtab(7,I)
7770             ALREGP   = XDPtab(8,I)
7771             GR(I1)   = XDPtab(9,I)
7772             GR(I2)   = XDPtab(10,I)
7773             B0REG(I1) = XDPtab(11,I)
7774             B0REG(I2) = XDPtab(12,I)
7775             GPPP     = XDPtab(13,I)
7776             B0PPP    = XDPtab(14,I)
7777             GPPR     = XDPtab(15,I)
7778             B0PPR    = XDPtab(16,I)
7779             VDMFAC(2*I1-1) = XDPtab(17,I)
7780             VDMFAC(2*I1)   = XDPtab(18,I)
7781             VDMFAC(2*I2-1) = XDPtab(19,I)
7782             VDMFAC(2*I2)   = XDPtab(20,I)
7783             B0HAR    = XDPtab(21,I)
7784             AKFAC    = XDPtab(22,I)
7785             PHISUP(I1) = XDPtab(23,I)
7786             PHISUP(I2) = XDPtab(24,I)
7787             RMASS(I1) = XDPtab(25,I)
7788             RMASS(I2) = XDPtab(26,I)
7789             VAR      = XDPtab(27,I)
7790             IFOUND = 1
7791             GOTO 1200
7792           ENDIF
7793         ENDIF
7794       ENDDO
7795
7796       IF(I1.EQ.1) THEN
7797         I1 = 2
7798         I2 = 1
7799         GOTO 110
7800       ELSE
7801         WRITE(LO,'(/1X,A)')
7802      &    'PHO_FITPAR: parameter set not found in internal table'
7803       ENDIF
7804
7805  1200 CONTINUE
7806
7807 C  get parameters of soft cross sections from fitpar.dat
7808       IF(IPAMDL(99).GT.IFOUND) THEN
7809
7810         WRITE(LO,'(/1X,A)')
7811      &    'PHO_FITPAR: loading parameter set from file fitpar.dat'
7812         OPEN(12,FILE='fitpar.dat',ERR=1010,STATUS='OLD')
7813
7814  100    CONTINUE
7815           READ(12,'(A8)',ERR=1020,END=1010) CNAME8
7816           IF(CNAME8.EQ.'STOP') GOTO 1010
7817           IF(CNAME8.EQ.'NEXTDATA') THEN
7818             READ(12,'(I8,2X,A8,3I6)',ERR=1020,END=1010)
7819      &        IDPA1,CNAME8,INUM
7820             IF((IDPA1.EQ.IFPAP(1)).AND.(CNAME8.EQ.PDFNA1)
7821      &         .AND.(INUM(1).EQ.IGRP(1)).AND.(INUM(2).EQ.ISET(1))) THEN
7822               READ(12,'(I8,2X,A8,3I6)',ERR=1020,END=1010)
7823      &          IDPA2,CNAME8,INUM
7824               IF((IDPA2.EQ.IFPAP(2)).AND.(CNAME8.EQ.PDFNA2).AND.
7825      &           (INUM(1).EQ.IGRP(2)).AND.(INUM(2).EQ.ISET(2))) THEN
7826                 WRITE(LO,'(/1X,A)') 'PHO_FITPAR: parameter set found'
7827                 READ(12,*) ALPOM,ALPOMP,GP,B0POM
7828                 READ(12,*) ALREG,ALREGP,GR,B0REG
7829                 READ(12,*) GPPP,B0PPP,GPPR,B0PPR
7830                 READ(12,*) VDMFAC(1),VDMFAC(2),VDMFAC(3),VDMFAC(4)
7831                 READ(12,*) B0HAR
7832                 READ(12,*) AKFAC
7833                 READ(12,*) PHISUP
7834                 READ(12,*) RMASS,VAR
7835                 IFOUND = 1
7836                 GOTO 1100
7837               ENDIF
7838             ENDIF
7839           ENDIF
7840         GOTO 100
7841
7842  1020 CONTINUE
7843         WRITE(LO,'(/A)') ' PHO_FITPAR: cannot read file fitpar.dat'
7844         WRITE(LO,'(A,A10,A8)') ' last data card: ',CNAM10,CNAME8
7845  1010 CONTINUE
7846         WRITE(LO,'(/A)')
7847      &    ' PHO_FITPAR: cannot find parameter set in file fitpar.dat'
7848
7849  1100   CONTINUE
7850         CLOSE(12)
7851
7852       ENDIF
7853
7854 C  nothing found
7855       IF(IFOUND.EQ.0) THEN
7856         WRITE(LO,'(/A)') ' PHO_FITPAR: could not find parameter set'
7857         WRITE(LO,'(3(10X,A,/))')
7858      &    '(copy fitpar.dat into the working directory and/or',
7859      &    ' request the missing parameter set via e-mail from',
7860      &    ' ralph.engel@fzk.de)'
7861         STOP
7862       ENDIF
7863
7864  1300 CONTINUE
7865
7866 C  overwrite parameters with user settings
7867       IF(PARMDL(301).GT.DEFA) THEN
7868         ALPOM     = PARMDL(301)
7869         PARMDL(301) = DEFB
7870       ENDIF
7871       IF(PARMDL(302).GT.DEFA) THEN
7872         ALPOMP    = PARMDL(302)
7873         PARMDL(302) = DEFB
7874       ENDIF
7875       IF(PARMDL(303).GT.DEFA) THEN
7876         GP(1)     = PARMDL(303)
7877         PARMDL(303) = DEFB
7878       ENDIF
7879       IF(PARMDL(304).GT.DEFA) THEN
7880         GP(2)     = PARMDL(304)
7881         PARMDL(304) = DEFB
7882       ENDIF
7883       IF(PARMDL(305).GT.DEFA) THEN
7884         B0POM(1)  = PARMDL(305)
7885         PARMDL(305) = DEFB
7886       ENDIF
7887       IF(PARMDL(306).GT.DEFA) THEN
7888         B0POM(2)  = PARMDL(306)
7889         PARMDL(306) = DEFB
7890       ENDIF
7891       IF(PARMDL(307).GT.DEFA) THEN
7892         ALREG     = PARMDL(307)
7893         PARMDL(307) = DEFB
7894       ENDIF
7895       IF(PARMDL(308).GT.DEFA) THEN
7896         ALREGP    = PARMDL(308)
7897         PARMDL(308) = DEFB
7898       ENDIF
7899       IF(PARMDL(309).GT.DEFA) THEN
7900         GR(1)     = PARMDL(309)
7901         PARMDL(309) = DEFB
7902       ENDIF
7903       IF(PARMDL(310).GT.DEFA) THEN
7904         GR(2)      = PARMDL(310)
7905         PARMDL(310) = DEFB
7906       ENDIF
7907       IF(PARMDL(311).GT.DEFA) THEN
7908         B0REG(1)  = PARMDL(311)
7909         PARMDL(311) = DEFB
7910       ENDIF
7911       IF(PARMDL(312).GT.DEFA) THEN
7912         B0REG(2)  = PARMDL(312)
7913         PARMDL(312) = DEFB
7914       ENDIF
7915       IF(PARMDL(313).GT.DEFA) THEN
7916         GPPP      = PARMDL(313)
7917         PARMDL(313) = DEFB
7918       ENDIF
7919       IF(PARMDL(314).GT.DEFA) THEN
7920         B0PPP     = PARMDL(314)
7921         PARMDL(314)= DEFB
7922       ENDIF
7923       IF(PARMDL(315).GT.DEFA) THEN
7924         VDMFAC(1) = PARMDL(315)
7925         PARMDL(315)= DEFB
7926       ENDIF
7927       IF(PARMDL(316).GT.DEFA) THEN
7928         VDMFAC(2) = PARMDL(316)
7929         PARMDL(316)= DEFB
7930       ENDIF
7931       IF(PARMDL(317).GT.DEFA) THEN
7932         VDMFAC(3) = PARMDL(317)
7933         PARMDL(317)= DEFB
7934       ENDIF
7935       IF(PARMDL(318).GT.DEFA) THEN
7936         VDMFAC(4) = PARMDL(318)
7937         PARMDL(318)= DEFB
7938       ENDIF
7939       IF(PARMDL(319).GT.DEFA) THEN
7940         B0HAR     = PARMDL(319)
7941         PARMDL(319)= DEFB
7942       ENDIF
7943       IF(PARMDL(320).GT.DEFA) THEN
7944         AKFAC     = PARMDL(320)
7945         PARMDL(320)= DEFB
7946       ENDIF
7947       IF(PARMDL(321).GT.DEFA) THEN
7948         PHISUP(1) = PARMDL(321)
7949         PARMDL(321)= DEFB
7950       ENDIF
7951       IF(PARMDL(322).GT.DEFA) THEN
7952         PHISUP(2) = PARMDL(322)
7953         PARMDL(322)= DEFB
7954       ENDIF
7955       IF(PARMDL(323).GT.DEFA) THEN
7956         RMASS(1)  = PARMDL(323)
7957         PARMDL(323)= DEFB
7958       ENDIF
7959       IF(PARMDL(324).GT.DEFA) THEN
7960         RMASS(2)  = PARMDL(324)
7961         PARMDL(324)= DEFB
7962       ENDIF
7963       IF(PARMDL(325).GT.DEFA) THEN
7964         VAR       = PARMDL(325)
7965         PARMDL(325)= DEFB
7966       ENDIF
7967       IF(PARMDL(327).GT.DEFA) THEN
7968         GPPR      = PARMDL(327)
7969         PARMDL(327)= DEFB
7970       ENDIF
7971       IF(PARMDL(328).GT.DEFA) THEN
7972         B0PPR     = PARMDL(328)
7973         PARMDL(328)= DEFB
7974       ENDIF
7975
7976       VDMQ2F(1) = VDMFAC(1)
7977       VDMQ2F(2) = VDMFAC(2)
7978       VDMQ2F(3) = VDMFAC(3)
7979       VDMQ2F(4) = VDMFAC(4)
7980
7981 C  output of parameter set
7982       IF((IDEB(54).GE.5).OR.(IOUTP.GT.0)) THEN
7983         WRITE(LO,'(/,A,/,A)') ' PHO_FITPAR: parameter set',
7984      &                       ' -------------------------'
7985         WRITE(LO,'(2(A,F7.3),2(A,2F9.3))')
7986      &  '  ALPOM:',ALPOM,' ALPOMP:',ALPOMP,' GP:',GP,' B0POM:',
7987      &  B0POM
7988         WRITE(LO,'(2(A,F7.3),2(A,2F9.3))')
7989      &  '  ALREG:',ALREG,' ALREGP:',ALREGP,' GR:',GR,' B0REG:',
7990      &  B0REG
7991         WRITE(LO,'(4(A,F7.3))')
7992      &  '  GPPP :',GPPP,' B0PPP:',B0PPP,' GPPR :',GPPR,' B0PPR:',B0PPR
7993         WRITE(LO,'(A,4F10.5)') ' VDMFAC:',VDMFAC
7994         WRITE(LO,'(A,4F10.5)') ' VDMQ2F:',VDMQ2F
7995         WRITE(LO,'(A,F8.3)')  '  B0HAR:',B0HAR
7996         WRITE(LO,'(A,F8.3)')  '  AKFAC:',AKFAC
7997         WRITE(LO,'(A,2F8.3)') ' PHISUP:',PHISUP
7998         WRITE(LO,'(A,3F8.3)') '  RMASS:',RMASS,VAR
7999       ENDIF
8000
8001       CALL PHO_HARINI(1,IFPAP(1),IFPAP(2),PVIRT(1),PVIRT(2),6,IOUTP-1)
8002
8003       END
8004
8005 *$ CREATE PHO_BORNCS.FOR
8006 *COPY PHO_BORNCS
8007 CDECK  ID>, PHO_BORNCS
8008       SUBROUTINE PHO_BORNCS(IP,IFHARD,XM1,XM2,XM3,XM4)
8009 C*********************************************************************
8010 C
8011 C     calculation of Born graph cross sections and slopes
8012 C
8013 C     input: IP               particle combination
8014 C            IFHARD           -1 calculate hard Born graph cross section
8015 C                             0  take hard Born graph cross section
8016 C                                from interpolation table if available
8017 C                             1  assume that correct hard cross
8018 C                                sections are already stored in /POSBRN/
8019 C            XM1,XM2,XM3,XM4  masses of external lines
8020 C                   /GLOCMS/  energy and PT cut-off
8021 C                   /POPREG/  soft and hard parameters
8022 C                   /POSBRN/  input cross sections
8023 C                   /POZBRN/  scaled input values
8024 C                    IFHARD   0  calculate hard input cross sections
8025 C                             1  assume hard input cross sections exist
8026 C
8027 C     output: ZPOM            scaled pomeron cross section
8028 C             ZIGR            scaled reggeon cross section
8029 C             ZIGHR           scaled hard resolved cross section
8030 C             ZIGHD           scaled hard direct cross section
8031 C             ZIGT1           scaled triple-Pomeron cross section
8032 C             ZIGT2           scaled triple-Pomeron cross section
8033 C             ZIGL            scaled loop-Pomeron cross section
8034 C
8035 C*********************************************************************
8036       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8037       SAVE
8038
8039       PARAMETER(ITWO=2,
8040      &        ITHREE=3,
8041      &         IFOUR=4,
8042      &         IFIVE=5,
8043      &          FIVE=5.D0,
8044      &         THOUS=1.D3,
8045      &           EPS=0.01D0,
8046      &          DEPS=1.D-30)
8047
8048 C  input/output channels
8049       INTEGER LI,LO
8050       COMMON /POINOU/ LI,LO
8051 C  some constants
8052       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
8053       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
8054      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
8055 C  event debugging information
8056       INTEGER NMAXD
8057       PARAMETER (NMAXD=100)
8058       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
8059      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8060       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
8061      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8062 C  model switches and parameters
8063       CHARACTER*8 MDLNA
8064       INTEGER ISWMDL,IPAMDL
8065       DOUBLE PRECISION PARMDL
8066       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
8067 C  names of hard scattering processes
8068       INTEGER Max_pro_1
8069       PARAMETER ( Max_pro_1 = 16 )
8070       CHARACTER*18 PROC
8071       COMMON /POHPRO/ PROC(0:Max_pro_1)
8072 C  hard cross sections and MC selection weights
8073       INTEGER Max_pro_2
8074       PARAMETER ( Max_pro_2 = 16 )
8075       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
8076      &  MH_acc_1,MH_acc_2
8077       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
8078       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
8079      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
8080      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
8081      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
8082      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
8083 C  interpolation tables for hard cross section and MC selection weights
8084       INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
8085       PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
8086       INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
8087       DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
8088      &  HQ2a_tab,HQ2b_tab,HEcm_tab
8089       COMMON /POHTAB/
8090      &  Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8091      &  HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8092      &  HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8093      &  Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
8094      &  HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
8095      &  HEcm_tab(1:Max_tab_E,0:4),
8096      &  IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
8097 C  Born graph cross sections and slopes
8098       INTEGER Max_pro_3
8099       PARAMETER ( Max_pro_3 = 16 )
8100       COMPLEX*16      SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
8101      &                SIGD1,SIGD2,DSIGH
8102       COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
8103      &                SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
8104 C  scaled cross sections and slopes
8105       COMPLEX*16      ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1,ZIGT2,ZIGL,ZIGDP,
8106      &                ZIGD1,ZIGD2,
8107      &                BPOM,BREG,BHAR,BHAD,BTR1,BTR2,BLOO,BDP,BD1,BD2
8108       COMMON /POZBRN/ ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1(2),ZIGT2(2),ZIGL,
8109      &                ZIGDP(4),ZIGD1(2),ZIGD2(2),
8110      &                BPOM,BREG,BHAR,BHAD,BTR1(2),BTR2(2),BLOO,BDP(4),
8111      &                BD1(2),BD2(2)
8112 C  Reggeon phenomenology parameters
8113       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
8114      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
8115       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
8116      &                ALREG,ALREGP,GR(2),B0REG(2),
8117      &                GPPP,GPPR,B0PPP,B0PPR,
8118      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
8119 C  parameters of 2x2 channel model
8120       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
8121       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
8122 C  data of c.m. system of Pomeron / Reggeon exchange
8123       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
8124       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
8125      &                 SIDP,CODP,SIFP,COFP
8126       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
8127      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
8128      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
8129 C  obsolete cut-off information
8130       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
8131       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
8132 C  data needed for soft-pt calculation
8133       DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
8134       COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
8135
8136       COMPLEX*16      CZERO,BP4,BR4,BHR4,BHD4,BT14,BT24,BD4,SP,SR,SS,
8137      &                BPOM1,BPOM2,BREG1,BREG2,B0HARD
8138       DIMENSION       SCB1(4),SCB2(4),SCG1(4),SCG2(4)
8139       DIMENSION       BT14(2),BT24(2),BD4(4)
8140       DIMENSION       DSPT(0:Max_pro_2)
8141
8142       DATA  XMPOM / 0.766D0 /
8143       DATA  CZERO /(0.D0,0.D0)/
8144
8145       CDABS(SS) = ABS(SS)
8146       DCMPLX(X,Y) = CMPLX(X,Y)
8147
8148 C  debug output
8149       IF(IDEB(48).GE.10) WRITE(LO,'(/1X,A,I3,4E12.3,I3)')
8150      &  'PHO_BORNCS: IP,M1..M4,IFHARD',IP,XM1,XM2,XM3,XM4,IFHARD
8151 C  scales
8152       CALL PHO_SCALES(XM1,XM2,XM3,XM4,SCALE1,SCALE2,SCALB1,SCALB2)
8153 C
8154 C  calculate hard input cross sections (output in mb)
8155       IF(IFHARD.NE.1) THEN
8156         IF((IFHARD.EQ.0).AND.(HEcm_tab(1,IP).GT.1.D0)) THEN
8157 C  double-log interpolation
8158           CALL PHO_HARINT(IP,ECMP,0.D0,0.D0,0,Max_pro_2,3,4,1)
8159           DO 60 M=0,Max_pro_2
8160             DSIGH(M) = HSig(M)
8161             DSPT(M)  = Hdpt(M)
8162  60       CONTINUE
8163         ELSE
8164 C  new calculation
8165           CALL PHO_HARINT(IP,ECMP,0.D0,0.D0,0,-2,0,0,1)
8166           CALL PHO_HARXTO(ECMP,PTCUT(IP),PTCUT(IP),DSIGH,DSPT)
8167         ENDIF
8168 C
8169 C  save values to calculate soft pt distribution
8170         IF(IP.EQ.1) THEN
8171           VDMQ2F(1) = VDMFAC(1)
8172           VDMQ2F(2) = VDMFAC(2)
8173           VDMQ2F(3) = VDMFAC(3)
8174           VDMQ2F(4) = VDMFAC(4)
8175         ELSE IF(IP.EQ.2) THEN
8176           VDMQ2F(1) = VDMFAC(1)
8177           VDMQ2F(2) = VDMFAC(2)
8178           VDMQ2F(3) = 1.D0
8179           VDMQ2F(4) = 0.D0
8180         ELSE IF(IP.EQ.3) THEN
8181           VDMQ2F(1) = VDMFAC(3)
8182           VDMQ2F(2) = VDMFAC(4)
8183           VDMQ2F(3) = 1.D0
8184           VDMQ2F(4) = 0.D0
8185         ELSE
8186           VDMQ2F(1) = 1.D0
8187           VDMQ2F(2) = 0.D0
8188           VDMQ2F(3) = 1.D0
8189           VDMQ2F(4) = 0.D0
8190         ENDIF
8191 C  VDM factors
8192         AMPFAC(1) = SQRT(VDMQ2F(1)*VDMQ2F(3))
8193         AMPFAC(2) = SQRT(VDMQ2F(2)*VDMQ2F(3))
8194         AMPFAC(3) = SQRT(VDMQ2F(1)*VDMQ2F(4))
8195         AMPFAC(4) = SQRT(VDMQ2F(2)*VDMQ2F(4))
8196         ELAFAC(1) = VDMQ2F(1)*VDMQ2F(3)+VDMQ2F(2)*VDMQ2F(3)
8197      &             +VDMQ2F(1)*VDMQ2F(4)+VDMQ2F(2)*VDMQ2F(4)
8198         ELAFAC(2) = 2.D0*(AMPFAC(1)*AMPFAC(2)+AMPFAC(3)*AMPFAC(4))
8199         ELAFAC(3) = 2.D0*(AMPFAC(1)*AMPFAC(3)+AMPFAC(2)*AMPFAC(4))
8200         ELAFAC(4) = 4.D0*AMPFAC(1)*AMPFAC(4)
8201         VFAC = ELAFAC(1)+PHISUP(1)*PHISUP(2)*ELAFAC(4)
8202      &        +PHISUP(1)*ELAFAC(2)+PHISUP(2)*ELAFAC(3)
8203         DSIGHP = DSPT(9)/VFAC
8204         SIGH   = DSIGH(9)/VFAC
8205 C  extract real part
8206         IF(IPAMDL(1).EQ.0) THEN
8207           DO 50 I=0,Max_pro_2
8208             DSIGH(I)=DCMPLX(DREAL(DSIGH(I)),0.D0)
8209  50       CONTINUE
8210         ENDIF
8211 C  write out results
8212         IF(IDEB(48).GE.15) THEN
8213           WRITE(LO,'(/1X,A,1P,2E11.3)')
8214      &       'PHO_BORNCS: QCD-PM cross sections (mb)',ECMP,PTCUT(IP)
8215           DO 200 I=0,Max_pro_2
8216             WRITE(LO,'(10X,A,2E14.4)') PROC(I),DSIGH(I)
8217  200      CONTINUE
8218         ENDIF
8219       ENDIF
8220
8221 C  DPMJET interface: subtract anomalous part
8222       IF((IP.EQ.1).AND.(IPAMDL(13).GT.0))
8223      &  DSIGH(9) = DSIGH(9)-DCMPLX(DT_SANO(ECMP),0.D0)
8224
8225       SCALE = CDABS(DSIGH(15))
8226       IF(SCALE.LT.DEPS) THEN
8227         SIGHD=CZERO
8228       ELSE
8229         SIGHD=DSIGH(15)
8230       ENDIF
8231       SCALE = CDABS(DSIGH(9))
8232       IF(SCALE.LT.DEPS) THEN
8233         SIGHR=CZERO
8234       ELSE
8235         SIGHR=DSIGH(9)*SCALE1*SCALE2/VFAC
8236       ENDIF
8237
8238 C  calculate soft input cross sections (output in mb)
8239       SS=DCMPLX(ECMP**2-PMASSP(1)**2-PMASSP(2)**2+0.01D0,0.D0)
8240       IF(IPAMDL(1).EQ.1) THEN
8241 C  pomeron signature
8242         SP=SS*DCMPLX(0.D0,-1.D0)
8243 C  reggeon signature
8244         SR=SS*DCMPLX(0.D0,1.D0)
8245       ELSE
8246         SP=SS
8247         SR=SS
8248       ENDIF
8249 C  coupling constants (mb**1/2)
8250 C  particle dependent slopes (GeV**-2)
8251       IF(IP.EQ.1) THEN
8252         GP1 = GP(1)
8253         GP2 = GP(2)
8254         GR1 = GR(1)
8255         GR2 = GR(2)
8256         B0POM1 = B0POM(1)
8257         B0POM2 = B0POM(2)
8258         B0REG1 = B0REG(1)
8259         B0REG2 = B0REG(2)
8260         B0HARD = B0HAR
8261         RMASS1 = RMASS(1)
8262         RMASS2 = RMASS(2)
8263       ELSE IF(IP.EQ.2) THEN
8264         GP1 = GP(1)
8265         GP2 = PARMDL(77)
8266         GR1 = GR(1)
8267         GR2 = PARMDL(77)*GPPR/GPPP
8268         B0POM1 = B0POM(1)
8269         B0POM2 = B0PPP
8270         B0REG1 = B0REG(1)
8271         B0REG2 = B0PPR
8272         B0HARD = B0POM1+B0POM2
8273         RMASS1 = RMASS(1)
8274         RMASS2 = XMPOM
8275       ELSE IF(IP.EQ.3) THEN
8276         GP1 = GP(2)
8277         GP2 = PARMDL(77)
8278         GR1 = GR(2)
8279         GR2 = PARMDL(77)*GPPR/GPPP
8280         B0POM1 = B0POM(2)
8281         B0POM2 = B0PPP
8282         B0REG1 = B0REG(2)
8283         B0REG2 = B0PPR
8284         B0HARD = B0POM1+B0POM2
8285         RMASS1 = RMASS(2)
8286         RMASS2 = XMPOM
8287       ELSE IF(IP.EQ.4) THEN
8288         GP1 = PARMDL(77)
8289         GP2 = GP1
8290         GR1 = PARMDL(77)*GPPR/GPPP
8291         GR2 = GR1
8292         B0POM1 = B0PPP
8293         B0POM2 = B0PPP
8294         B0REG1 = B0PPR
8295         B0REG2 = B0PPR
8296         B0HARD = B0POM1+B0POM2
8297         RMASS1 = XMPOM
8298         RMASS2 = XMPOM
8299       ELSE
8300         WRITE(LO,'(/1X,A,I7)') 'PHO_BORNCS:ERROR:invalid IP',IP
8301         CALL PHO_ABORT
8302       ENDIF
8303       GP1 = GP1*SCALE1
8304       GP2 = GP2*SCALE2
8305       GR1 = GR1*SCALE1
8306       GR2 = GR2*SCALE2
8307 C  input slope parameters (GeV**-2)
8308       BPOM1 = B0POM1*SCALB1
8309       BPOM2 = B0POM2*SCALB2
8310       BREG1 = B0REG1*SCALB1
8311       BREG2 = B0REG2*SCALB2
8312 C  effective slopes
8313       XMR2 = (2.D0*MIN(XM1,XM3)*MIN(XM2,XM4))**2
8314       SCALE = SS*XMR2/((XM1**2+XM3**2)*(XM2**2+XM4**2))+2.D0
8315       BPOM = BPOM1 + BPOM2 + ALPOMP*LOG(SCALE)
8316       BREG = BREG1 + BREG2 + ALREGP*LOG(SCALE)
8317       IF(IPAMDL(9).EQ.0) THEN
8318         BHAR = B0HARD
8319         BHAD = B0HARD
8320       ELSE IF(IPAMDL(9).EQ.1) THEN
8321         BHAR = B0HARD*(SCALB1+SCALB2)/2.D0
8322         BHAD = BHAR
8323       ELSE IF(IPAMDL(9).EQ.2) THEN
8324         BHAR = BPOM1+BPOM2
8325         BHAD = BHAR
8326       ELSE
8327         BHAR = BPOM
8328         BHAD = BPOM
8329       ENDIF
8330 C  input cross section pomeron
8331       SIGP=GP1*GP2*EXP((ALPOM-1.D0)*LOG(SP))
8332       SIGR=GR1*GR2*EXP((ALREG-1.D0)*LOG(SR))
8333 C  save value to calculate soft pt distribution
8334       SIGS = (SIGR+SIGP)/(SCALE1*SCALE2)
8335
8336 C  higher order graphs
8337       VIRT1 = PVIRTP(1)
8338       VIRT2 = PVIRTP(2)
8339 C  bare/renormalized intercept for enhanced graphs
8340       IF(IPAMDL(8).EQ.0) THEN
8341         DELTAP = ALPOM-1.D0
8342       ELSE
8343         DELTAP = PARMDL(48)-1.D0
8344       ENDIF
8345       SD = ECMP**2
8346       BP1 = 2.D0*BPOM1
8347       BP2 = 2.D0*BPOM2
8348 C  input cross section high-mass double diffraction
8349       CALL PHO_LOOREG(SD,GP1,BP1,GP2,BP2,
8350      &            DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,VIRT2,SIGTR,BTR)
8351       SIGL = DCMPLX(SIGTR,0.D0)
8352       BLOO = DCMPLX(BTR,0.D0)
8353 C
8354 C  input cross section high mass diffraction particle 1
8355 C  first possibility
8356       CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
8357      &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8358       CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
8359      &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8360       SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8361       SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8362       BP1 = 2.D0*BPOM1*SCALB1
8363       BP2 = 2.D0*BPOM2*SCALB2
8364 C  input cross section high mass diffraction
8365       CALL PHO_TRIREG(SD,GP1,BP1,GP2,BP2,
8366      &               DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,SIGTR,BTR)
8367       SIGT1(1) = SCG1(1)*SCG2(1)*SCG2(2)*DCMPLX(SIGTR,0.D0)
8368       BTR1(1)  = DCMPLX(BTR,0.D0)
8369 C  second possibility:  high-low mass double diffraction
8370       CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
8371      &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8372       CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
8373      &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8374       SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8375       SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8376       BP1 = 2.D0*BPOM1*SCALB1
8377       BP2 = 2.D0*BPOM2*SCALB2
8378 C  input cross section high mass diffraction
8379       CALL PHO_TRIREG(SD,GP1,BP1,GP2,BP2,
8380      &               DELTAP,ALPOMP,GPPP,B0PPP,VIRT1,SIGTR,BTR)
8381       SIGT1(2) = SCG1(1)*SCG2(1)*SCG2(2)*DCMPLX(SIGTR,0.D0)
8382       BTR1(2)  = DCMPLX(BTR,0.D0)
8383 C
8384 C  input cross section high mass diffraction particle 2
8385 C  first possibility
8386       CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
8387      &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8388       CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
8389      &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8390       SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8391       SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8392       BP1 = 2.D0*BPOM1*SCALB1
8393       BP2 = 2.D0*BPOM2*SCALB2
8394 C  input cross section high mass diffraction
8395       CALL PHO_TRIREG(SD,GP2,BP2,GP1,BP1,
8396      &               DELTAP,ALPOMP,GPPP,B0PPP,VIRT2,SIGTR,BTR)
8397       SIGT2(1) = SCG1(1)*SCG1(2)*SCG2(1)*DCMPLX(SIGTR,0.D0)
8398       BTR2(1)  = DCMPLX(BTR,0.D0)
8399 C  second possibility:  high-low mass double diffraction
8400       CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
8401      &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8402       CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
8403      &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8404       SCALB1 = (SCB1(1)+SCB1(2))/2.D0
8405       SCALB2 = (SCB2(1)+SCB2(2))/2.D0
8406       BP1 = 2.D0*BPOM1*SCALB1
8407       BP2 = 2.D0*BPOM2*SCALB2
8408 C  input cross section high mass diffraction
8409       CALL PHO_TRIREG(SD,GP2,BP2,GP1,BP1,
8410      &               DELTAP,ALPOMP,GPPP,B0PPP,VIRT2,SIGTR,BTR)
8411       SIGT2(2) = SCG1(1)*SCG1(2)*SCG2(1)*DCMPLX(SIGTR,0.D0)
8412       BTR2(2)  = DCMPLX(BTR,0.D0)
8413 C
8414 C  input cross section for loop-pomeron
8415 C  first possibility
8416       CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
8417      &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8418       CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
8419      &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8420       CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
8421      &  SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8422       CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
8423      &  SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8424       SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8425       SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8426       BP1 = BPOM1*SCALB1
8427       BP2 = BPOM2*SCALB2
8428       CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8429      &  SIGTX,BTX)
8430       SIGDP(1) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8431       BDP(1)   = DCMPLX(BTX,0.D0)
8432 C  second possibility
8433       CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
8434      &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8435       CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
8436      &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8437       CALL PHO_SCALES(XM1,XM2,XM3,PMASSP(2),
8438      &  SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8439       CALL PHO_SCALES(XM1,PMASSP(2),XM3,XM4,
8440      &  SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8441       SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8442       SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8443       BP1 = BPOM1*SCALB1
8444       BP2 = BPOM2*SCALB2
8445       CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8446      &  SIGTX,BTX)
8447       SIGDP(2) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8448       BDP(2)   = DCMPLX(BTX,0.D0)
8449 C  third possibility
8450       CALL PHO_SCALES(XM1,XM2,PMASSP(1),XM4,
8451      &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8452       CALL PHO_SCALES(PMASSP(1),XM2,XM3,XM4,
8453      &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8454       CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
8455      &  SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8456       CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
8457      &  SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8458       SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8459       SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8460       BP1 = BPOM1*SCALB1
8461       BP2 = BPOM2*SCALB2
8462       CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8463      &  SIGTX,BTX)
8464       SIGDP(3) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8465       BDP(3)   = DCMPLX(BTX,0.D0)
8466 C  fourth possibility
8467       CALL PHO_SCALES(XM1,XM2,RMASS1,XM4,
8468      &  SCG1(1),SCG2(1),SCB1(1),SCB2(1))
8469       CALL PHO_SCALES(RMASS1,XM2,XM3,XM4,
8470      &  SCG1(2),SCG2(2),SCB1(2),SCB2(2))
8471       CALL PHO_SCALES(XM1,XM2,XM3,RMASS2,
8472      &  SCG1(3),SCG2(3),SCB1(3),SCB2(3))
8473       CALL PHO_SCALES(XM1,RMASS2,XM3,XM4,
8474      &  SCG1(4),SCG2(4),SCB1(4),SCB2(4))
8475       SCALB1 = (SCB1(1)+SCB1(2)+SCB1(3)+SCB1(4))/4.D0
8476       SCALB2 = (SCB2(1)+SCB2(2)+SCB2(3)+SCB2(4))/4.D0
8477       BP1 = BPOM1*SCALB1
8478       BP2 = BPOM2*SCALB2
8479       CALL PHO_TRXPOM(SD,GP2,BP2,GP1,BP1,DELTAP,ALPOMP,GPPP,B0PPP,
8480      &  SIGTX,BTX)
8481       SIGDP(4) = SCG1(1)*SCG1(2)*SCG2(3)*SCG2(4)*DCMPLX(SIGTX,0.D0)
8482       BDP(4)   = DCMPLX(BTX,0.D0)
8483 C
8484 C  input cross section for YY-iterated triple-pomeron
8485 C     .....
8486 C
8487 C  write out input cross sections
8488       IF(IDEB(48).GE.5) THEN
8489         WRITE(LO,'(2(/1X,A))')
8490      &    'Born graph input cross sections and slopes',
8491      &    '------------------------------------------'
8492         WRITE(LO,'(1X,A,3E12.3)') 'energy                  ',ECMP,PVIRTP
8493         WRITE(LO,'(1X,A,4E12.3)') 'external masses 1,2,3,4 ',
8494      &       XM1,XM2,XM3,XM4
8495         WRITE(LO,'(A)') ' input cross sections (millibarn):'
8496         WRITE(LO,'(A,2E12.3)') '           SIGR     ',SIGR
8497         WRITE(LO,'(A,2E12.3)') ' (soft)    SIGP     ',SIGP
8498         WRITE(LO,'(A,2E12.3)') ' (hard)    SIGHR    ',SIGHR
8499         WRITE(LO,'(A,2E12.3)') '           SIGHD    ',SIGHD
8500         WRITE(LO,'(A,4E12.3)') '           SIGT1    ',SIGT1
8501         WRITE(LO,'(A,4E12.3)') '           SIGT2    ',SIGT2
8502         WRITE(LO,'(A,2E12.3)') '           SIGL     ',SIGL
8503         WRITE(LO,'(A,4E12.3)') '         SIGDP(1-2) ',SIGDP(1),SIGDP(2)
8504         WRITE(LO,'(A,4E12.3)') '         SIGDP(3-4) ',SIGDP(3),SIGDP(4)
8505         WRITE(LO,'(A)') ' input slopes (GeV**-2)'
8506         WRITE(LO,'(A,2E12.3)') '           BREG     ',BREG
8507         WRITE(LO,'(A,2E12.3)') '            BREG1   ',BREG1
8508         WRITE(LO,'(A,2E12.3)') '            BREG2   ',BREG2
8509         WRITE(LO,'(A,2E12.3)') '           BPOM     ',BPOM
8510         WRITE(LO,'(A,2E12.3)') '            BPOM1   ',BPOM1
8511         WRITE(LO,'(A,2E12.3)') '            BPOM2   ',BPOM2
8512         WRITE(LO,'(A,2E12.3)') '           BHAR     ',BHAR
8513         WRITE(LO,'(A,2E12.3)') '           BHAD     ',BHAD
8514         WRITE(LO,'(A,E12.3)')  '           B0PPP    ',B0PPP
8515         WRITE(LO,'(A,4E12.3)') '           BTR1     ',BTR1
8516         WRITE(LO,'(A,4E12.3)') '           BTR2     ',BTR2
8517         WRITE(LO,'(A,2E12.3)') '           BLOO     ',BLOO
8518         WRITE(LO,'(A,4E12.3)') '           BDP(1-2) ',BDP(1),BDP(2)
8519         WRITE(LO,'(A,4E12.3)') '           BDP(3-4) ',BDP(3),BDP(4)
8520       ENDIF
8521 C
8522       BPOM  = BPOM*GEV2MB
8523       BREG  = BREG*GEV2MB
8524       BHAR  = BHAR*GEV2MB
8525       BHAD  = BHAD*GEV2MB
8526       BTR1(1)  = BTR1(1)*GEV2MB
8527       BTR1(2)  = BTR1(2)*GEV2MB
8528       BTR2(1)  = BTR2(1)*GEV2MB
8529       BTR2(2)  = BTR2(2)*GEV2MB
8530       BLOO  = BLOO*GEV2MB
8531 C
8532       BP4 =BPOM*4.D0
8533       BR4 =BREG*4.D0
8534       BHR4=BHAR*4.D0
8535       BHD4=BHAD*4.D0
8536       BT14(1)=BTR1(1)*4.D0
8537       BT14(2)=BTR1(2)*4.D0
8538       BT24(1)=BTR2(1)*4.D0
8539       BT24(2)=BTR2(2)*4.D0
8540       BL4 =BLOO*4.D0
8541 C
8542       ZIGP     = SIGP/(PI2*BP4)
8543       ZIGR     = SIGR/(PI2*BR4)
8544       ZIGHR    = SIGHR/(PI2*BHR4)
8545       ZIGHD    = SIGHD/(PI2*BHD4)
8546       ZIGT1(1) = SIGT1(1)/(PI2*BT14(1))
8547       ZIGT1(2) = SIGT1(2)/(PI2*BT14(2))
8548       ZIGT2(1) = SIGT2(1)/(PI2*BT24(1))
8549       ZIGT2(2) = SIGT2(2)/(PI2*BT24(2))
8550       ZIGL = SIGL/(PI2*BL4)
8551       DO 20 I=1,4
8552         BDP(I) = BDP(I)*GEV2MB
8553         BD4(I) = BDP(I)*4.D0
8554         ZIGDP(I) = SIGDP(I)/(PI2*BD4(I))
8555  20   CONTINUE
8556 C
8557       IF(IDEB(48).GE.10) THEN
8558         WRITE(LO,'(A)') ' normalized input values:'
8559         WRITE(LO,'(A,2E12.3)') '           ZIGR ',ZIGR
8560         WRITE(LO,'(A,2E12.3)') '           BREG ',BREG
8561         WRITE(LO,'(A,2E12.3)') '           ZIGP ',ZIGP
8562         WRITE(LO,'(A,2E12.3)') '           BPOM ',BPOM
8563         WRITE(LO,'(A,2E12.3)') '          ZIGHR ',ZIGHR
8564         WRITE(LO,'(A,2E12.3)') '           BHAR ',BHAR
8565         WRITE(LO,'(A,2E12.3)') '          ZIGHD ',ZIGHD
8566         WRITE(LO,'(A,2E12.3)') '           BHAD ',BHAD
8567         WRITE(LO,'(A,4E12.3)') '          ZIGT1 ',ZIGT1
8568         WRITE(LO,'(A,4E12.3)') '          ZIGT2 ',ZIGT2
8569         WRITE(LO,'(A,2E12.3)') '           ZIGL ',ZIGL
8570         WRITE(LO,'(A,4E12.3)') '     ZIGDP(1-2) ',ZIGDP(1),ZIGDP(2)
8571         WRITE(LO,'(A,4E12.3)') '     ZIGDP(3-4) ',ZIGDP(3),ZIGDP(4)
8572       ENDIF
8573       END
8574
8575 *$ CREATE PHO_SCALES.FOR
8576 *COPY PHO_SCALES
8577 CDECK  ID>, PHO_SCALES
8578       SUBROUTINE PHO_SCALES(XM1,XM2,XM3,XM4,SCG1,SCG2,SCB1,SCB2)
8579 C**********************************************************************
8580 C
8581 C     calculation of scale factors
8582 C              (mass dependent couplings and slopes)
8583 C
8584 C     input:   XM1..XM4     external masses
8585 C
8586 C     output:  SCG1,SCG2    scales of coupling constants
8587 C              SCB1,SCB2    scales of coupling slope parameter
8588 C
8589 C*********************************************************************
8590       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8591       SAVE
8592
8593       PARAMETER ( EPS  = 1.D-3 )
8594
8595 C  input/output channels
8596       INTEGER LI,LO
8597       COMMON /POINOU/ LI,LO
8598 C  event debugging information
8599       INTEGER NMAXD
8600       PARAMETER (NMAXD=100)
8601       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
8602      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8603       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
8604      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8605 C  Reggeon phenomenology parameters
8606       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
8607      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
8608       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
8609      &                ALREG,ALREGP,GR(2),B0REG(2),
8610      &                GPPP,GPPR,B0PPP,B0PPR,
8611      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
8612 C  parameters of 2x2 channel model
8613       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
8614       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
8615 C  data of c.m. system of Pomeron / Reggeon exchange
8616       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
8617       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
8618      &                 SIDP,CODP,SIFP,COFP
8619       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
8620      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
8621      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
8622 C  model switches and parameters
8623       CHARACTER*8 MDLNA
8624       INTEGER ISWMDL,IPAMDL
8625       DOUBLE PRECISION PARMDL
8626       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
8627
8628 C  scale factors for couplings
8629       ECMMIN = 2.D0
8630 *     ECMTP = 6.D0
8631       ECMTP = 1.D0
8632       IF(ABS(XM1-XM3).GT.EPS) THEN
8633         IF(ECMP.LT.ECMTP) THEN
8634           SCG1 = PHISUP(1)*LOG(ECMP**2/ECMMIN)/LOG(ECMTP**2/ECMMIN)
8635         ELSE
8636           SCG1 = PHISUP(1)
8637         ENDIF
8638       ELSE
8639         SCG1 = 1.D0
8640       ENDIF
8641       IF(ABS(XM2-XM4).GT.EPS) THEN
8642         IF(ECMP.LT.ECMTP) THEN
8643           SCG2 = PHISUP(2)*LOG(ECMP**2/ECMMIN)/LOG(ECMTP**2/ECMMIN)
8644         ELSE
8645           SCG2 = PHISUP(2)
8646         ENDIF
8647       ELSE
8648         SCG2 = 1.D0
8649       ENDIF
8650 C
8651 C  scale factors for slope parameters
8652       IF((ISWMDL(1).LT.2).OR.(IPAMDL(10).EQ.1)) THEN
8653         SCB1 = 1.D0
8654         SCB2 = 1.D0
8655       ELSE IF(ISWMDL(1).EQ.2) THEN
8656 C  rational
8657         SCB1 = 2.D0*PMASSP(1)**2/(XM1**2+XM3**2)
8658         SCB2 = 2.D0*PMASSP(2)**2/(XM2**2+XM4**2)
8659       ELSE IF(ISWMDL(1).GE.3) THEN
8660 C  symmetric gaussian
8661         SCB1 = VAR*(XM1-XM3)**2
8662         IF(SCB1.LT.25.D0) THEN
8663           SCB1 = EXP(-SCB1)
8664         ELSE
8665           SCB1 = 0.D0
8666         ENDIF
8667         SCB2 = VAR*(XM2-XM4)**2
8668         IF(SCB2.LT.25.D0) THEN
8669           SCB2 = EXP(-SCB2)
8670         ELSE
8671           SCB2 = 0.D0
8672         ENDIF
8673       ELSE
8674         WRITE(LO,'(/,1X,A,I4)') 'PHO_SCALES:ERROR:invalid ISWMDL(1)',
8675      &    ISWMDL(1)
8676         CALL PHO_ABORT
8677       ENDIF
8678 C  debug output
8679       IF(IDEB(65).GE.10) THEN
8680         WRITE(LO,'(1X,A,4E11.3)') 'PHO_SCALES: M1..M4 ',
8681      &       XM1,XM2,XM3,XM4
8682         WRITE(LO,'(5X,A,4E11.3)') 'SCB1,SCB2,SCG1,SCG2',
8683      &       SCB1,SCB2,SCG1,SCG2
8684       ENDIF
8685       END
8686
8687 *$ CREATE PHO_EIKON.FOR
8688 *COPY PHO_EIKON
8689 CDECK  ID>, PHO_EIKON
8690       SUBROUTINE PHO_EIKON(IP,IFHARD,B)
8691 C*********************************************************************
8692 C
8693 C     calculation of unitarized amplitudes
8694 C
8695 C     input: IP               particle combination
8696 C            IFHARD           -1  ignore previously calculated Born
8697 C                                 cross sections
8698 C                             0   calculate hard Born cross sections or
8699 C                                 take them from interpolation table
8700 C                                 (if available)
8701 C                             1   take hard cross sections from /POSBRN/
8702 C            B                impact parameter (mb**(1/2))
8703 C                   /POSBRN/  input cross sections
8704 C                   /GLOCMS/  cm energy
8705 C                   /POPREG/  soft and hard parameters
8706 C
8707 C     output: /POINT4/
8708 C             AMPEL           purely elastic amplitude
8709 C             AMPVM           quasi-elastically vectormeson prod.
8710 C             AMLMSD(2)       amplitudes of low mass sing. diffr.
8711 C             AMHMSD(2)       amplitudes of high mass sing. diffr.
8712 C             AMLMDD          amplitude of low mass double diffr.
8713 C             AMHMDD          amplitude of high mass double diffr.
8714 C
8715 C*********************************************************************
8716       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8717       SAVE
8718
8719       PARAMETER(ITWO=2,
8720      &        ITHREE=3,
8721      &         IFOUR=4,
8722      &         IFIVE=5,
8723      &          ISIX=6,
8724      &          FIVE=5.D0,
8725      &         THOUS=1.D3,
8726      &        EXPMAX=70.D0,
8727      &          DEPS=1.D-20)
8728
8729 C  input/output channels
8730       INTEGER LI,LO
8731       COMMON /POINOU/ LI,LO
8732 C  event debugging information
8733       INTEGER NMAXD
8734       PARAMETER (NMAXD=100)
8735       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
8736      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8737       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
8738      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
8739 C  complex Born graph amplitudes used for unitarization
8740       COMPLEX*16      AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
8741      &                AMHMDD,AMPDP
8742       COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
8743      &                AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
8744 C  cross sections
8745       INTEGER IPFIL,IFAFIL,IFBFIL
8746       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
8747      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
8748      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
8749      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
8750      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
8751       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
8752      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
8753      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
8754      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
8755      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
8756      &                IPFIL,IFAFIL,IFBFIL
8757 C  Born graph cross sections and slopes
8758       INTEGER Max_pro_3
8759       PARAMETER ( Max_pro_3 = 16 )
8760       COMPLEX*16      SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
8761      &                SIGD1,SIGD2,DSIGH
8762       COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
8763      &                SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
8764 C  scaled cross sections and slopes
8765       COMPLEX*16      ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1,ZIGT2,ZIGL,ZIGDP,
8766      &                ZIGD1,ZIGD2,
8767      &                BPOM,BREG,BHAR,BHAD,BTR1,BTR2,BLOO,BDP,BD1,BD2
8768       COMMON /POZBRN/ ZIGP,ZIGR,ZIGHD,ZIGHR,ZIGT1(2),ZIGT2(2),ZIGL,
8769      &                ZIGDP(4),ZIGD1(2),ZIGD2(2),
8770      &                BPOM,BREG,BHAR,BHAD,BTR1(2),BTR2(2),BLOO,BDP(4),
8771      &                BD1(2),BD2(2)
8772 C  Born graph cross sections after applying diffraction model
8773       DOUBLE PRECISION SBOPOM,SBOREG,SBOHAR,SBOHAD,SBOTR1,SBOTR2,
8774      &                 SBOLPO,SBODPO
8775       COMMON /POINT1/ SBOPOM(0:4),SBOREG(0:4),SBOHAR(0:4),SBOHAD(0:4),
8776      &                SBOTR1(0:4,2),SBOTR2(0:4,2),SBOLPO(0:4),
8777      &                SBODPO(0:4,4)
8778 C  global event kinematics and particle IDs
8779       INTEGER IFPAP,IFPAB
8780       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
8781       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
8782 C  data of c.m. system of Pomeron / Reggeon exchange
8783       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
8784       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
8785      &                 SIDP,CODP,SIFP,COFP
8786       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
8787      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
8788      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
8789 C  Reggeon phenomenology parameters
8790       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
8791      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
8792       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
8793      &                ALREG,ALREGP,GR(2),B0REG(2),
8794      &                GPPP,GPPR,B0PPP,B0PPR,
8795      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
8796 C  parameters of 2x2 channel model
8797       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
8798       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
8799 C  model switches and parameters
8800       CHARACTER*8 MDLNA
8801       INTEGER ISWMDL,IPAMDL
8802       DOUBLE PRECISION PARMDL
8803       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
8804 C  unitarized amplitudes for different diffraction channels
8805       DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
8806      &                 ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
8807      &                 ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
8808      &                 ZXL,BXL
8809       COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
8810      &                ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
8811      &                ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
8812      &                ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
8813      &                ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
8814      &                ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
8815      &                ZXL(4,4),BXL(4,4)
8816
8817       COMPLEX*16      CZERO,CONE,B24,AUXP,AUXR,AUXH,AUXD,AUXT1,AUXT2,
8818      &                AUXL,AMPR,AMPO,AMPP,AMPQ
8819
8820       DIMENSION PVOLD(2)
8821
8822       DATA  ELAST / 0.D0 /
8823       DATA  IPOLD / -1 /
8824       DATA  PVOLD / -1.D0, -1.D0 /
8825       DATA  XMPOM / 0.766D0 /
8826       DATA  XMVDM / 0.766D0 /
8827
8828       DCMPLX(X,Y) = CMPLX(X,Y)
8829
8830 C  calculation of scaled cross sections and slopes
8831
8832 C  test for redundant calculation
8833       IF((ECM.NE.ELAST).OR.(IFHARD.EQ.-1).OR.(PVIRT(1).NE.PVOLD(1))
8834      &   .OR.(PVIRT(2).NE.PVOLD(2)).OR.(IP.NE.IPOLD)) THEN
8835 C  effective particle masses, VDM assumption
8836         XMASS1 = PMASS(1)
8837         XMASS2 = PMASS(2)
8838         RMASS1 = RMASS(1)
8839         RMASS2 = RMASS(2)
8840         IF(IFPAP(1).EQ.22) THEN
8841           XMASS1 = XMVDM
8842         ELSE IF(IFPAP(1).EQ.990) THEN
8843           XMASS1 = XMPOM
8844         ENDIF
8845         IF(IFPAP(2).EQ.22) THEN
8846           XMASS2 = XMVDM
8847         ELSE IF(IFPAP(2).EQ.990) THEN
8848           XMASS2 = XMPOM
8849         ENDIF
8850 C  different particle combinations
8851         IF(IP.EQ.3) THEN
8852           XMASS1 = XMASS2
8853           RMASS1 = RMASS2
8854         ELSE IF(IP.EQ.4) THEN
8855           XMASS1 = XMPOM
8856           RMASS1 = XMASS1
8857         ENDIF
8858         IF(IP.GT.1) THEN
8859           XMASS2 = XMPOM
8860           RMASS2 = XMASS2
8861         ENDIF
8862 C  update pomeron CM system
8863         PMASSP(1) = XMASS1
8864         PMASSP(2) = XMASS2
8865         ECMP = ECM
8866
8867         CZERO    = DCMPLX(0.D0,0.D0)
8868         CONE     = DCMPLX(1.D0,0.D0)
8869         ELAST    = ECM
8870         PVOLD(1) = PVIRT(1)
8871         PVOLD(2) = PVIRT(2)
8872         IPOLD    = IP
8873
8874 C  purely elastic scattering
8875         CALL PHO_BORNCS(IP,IFHARD,XMASS1,XMASS2,XMASS1,XMASS2)
8876           ZXP(1,1) = ZIGP
8877           BXP(1,1) = BPOM
8878           ZXR(1,1) = ZIGR
8879           BXR(1,1) = BREG
8880           ZXH(1,1) = ZIGHR
8881           BXH(1,1) = BHAR
8882           ZXD(1,1) = ZIGHD
8883           BXD(1,1) = BHAD
8884           ZXT1A(1,1) = ZIGT1(1)
8885           BXT1A(1,1) = BTR1(1)
8886           ZXT1B(1,1) = ZIGT1(2)
8887           BXT1B(1,1) = BTR1(2)
8888           ZXT2A(1,1) = ZIGT2(1)
8889           BXT2A(1,1) = BTR2(1)
8890           ZXT2B(1,1) = ZIGT2(2)
8891           BXT2B(1,1) = BTR2(2)
8892           ZXL(1,1) = ZIGL
8893           BXL(1,1) = BLOO
8894           ZXDPE(1,1) = ZIGDP(1)
8895           BXDPE(1,1) = BDP(1)
8896           ZXDPA(1,1) = ZIGDP(2)
8897           BXDPA(1,1) = BDP(2)
8898           ZXDPB(1,1) = ZIGDP(3)
8899           BXDPB(1,1) = BDP(3)
8900           ZXDPD(1,1) = ZIGDP(4)
8901           BXDPD(1,1) = BDP(4)
8902           SBOPOM(1) = SIGP
8903           SBOREG(1) = SIGR
8904           SBOHAR(1) = SIGHR
8905           SBOHAD(1) = SIGHD
8906           SBOTR1(1,1) = SIGT1(1)
8907           SBOTR1(1,2) = SIGT1(2)
8908           SBOTR2(1,1) = SIGT2(1)
8909           SBOTR2(1,2) = SIGT2(2)
8910           SBOLPO(1) = SIGL
8911           SBODPO(1,1) = SIGDP(1)
8912           SBODPO(1,2) = SIGDP(2)
8913           SBODPO(1,3) = SIGDP(3)
8914           SBODPO(1,4) = SIGDP(4)
8915
8916 C  low mass single diffractive scattering 1
8917         CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,RMASS1,XMASS2)
8918           ZXP(1,2) = ZIGP
8919           BXP(1,2) = BPOM
8920           ZXR(1,2) = ZIGR
8921           BXR(1,2) = BREG
8922           ZXH(1,2) = ZIGHR
8923           BXH(1,2) = BHAR
8924           ZXD(1,2) = ZIGHD
8925           BXD(1,2) = BHAD
8926           ZXT1A(1,2) = ZIGT1(1)
8927           BXT1A(1,2) = BTR1(1)
8928           ZXT1B(1,2) = ZIGT1(2)
8929           BXT1B(1,2) = BTR1(2)
8930           ZXT2A(1,2) = ZIGT2(1)
8931           BXT2A(1,2) = BTR2(1)
8932           ZXT2B(1,2) = ZIGT2(2)
8933           BXT2B(1,2) = BTR2(2)
8934           ZXL(1,2) = ZIGL
8935           BXL(1,2) = BLOO
8936           ZXDPE(1,2) = ZIGDP(1)
8937           BXDPE(1,2) = BDP(1)
8938           ZXDPA(1,2) = ZIGDP(2)
8939           BXDPA(1,2) = BDP(2)
8940           ZXDPB(1,2) = ZIGDP(3)
8941           BXDPB(1,2) = BDP(3)
8942           ZXDPD(1,2) = ZIGDP(4)
8943           BXDPD(1,2) = BDP(4)
8944           SBOPOM(2) = SIGP
8945           SBOREG(2) = SIGR
8946           SBOHAR(2) = SIGHR
8947           SBOHAD(2) = 0.D0
8948           SBOTR1(2,1) = SIGT1(1)
8949           SBOTR1(2,2) = SIGT1(2)
8950           SBOTR2(2,1) = SIGT2(1)
8951           SBOTR2(2,2) = SIGT2(2)
8952           SBOLPO(2) = SIGL
8953           SBODPO(2,1) = SIGDP(1)
8954           SBODPO(2,2) = SIGDP(2)
8955           SBODPO(2,3) = SIGDP(3)
8956           SBODPO(2,4) = SIGDP(4)
8957
8958 C  low mass single diffractive scattering 2
8959         CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,XMASS1,RMASS2)
8960           ZXP(1,3) = ZIGP
8961           BXP(1,3) = BPOM
8962           ZXR(1,3) = ZIGR
8963           BXR(1,3) = BREG
8964           ZXH(1,3) = ZIGHR
8965           BXH(1,3) = BHAR
8966           ZXD(1,3) = ZIGHD
8967           BXD(1,3) = BHAD
8968           ZXT1A(1,3) = ZIGT1(1)
8969           BXT1A(1,3) = BTR1(1)
8970           ZXT1B(1,3) = ZIGT1(2)
8971           BXT1B(1,3) = BTR1(2)
8972           ZXT2A(1,3) = ZIGT2(1)
8973           BXT2A(1,3) = BTR2(1)
8974           ZXT2B(1,3) = ZIGT2(2)
8975           BXT2B(1,3) = BTR2(2)
8976           ZXL(1,3) = ZIGL
8977           BXL(1,3) = BLOO
8978           ZXDPE(1,3) = ZIGDP(1)
8979           BXDPE(1,3) = BDP(1)
8980           ZXDPA(1,3) = ZIGDP(2)
8981           BXDPA(1,3) = BDP(2)
8982           ZXDPB(1,3) = ZIGDP(3)
8983           BXDPB(1,3) = BDP(3)
8984           ZXDPD(1,3) = ZIGDP(4)
8985           BXDPD(1,3) = BDP(4)
8986           SBOPOM(3) = SIGP
8987           SBOREG(3) = SIGR
8988           SBOHAR(3) = SIGHR
8989           SBOHAD(3) = 0.D0
8990           SBOTR1(3,1) = SIGT1(1)
8991           SBOTR1(3,2) = SIGT1(2)
8992           SBOTR2(3,1) = SIGT2(1)
8993           SBOTR2(3,2) = SIGT2(2)
8994           SBOLPO(3) = SIGL
8995           SBODPO(3,1) = SIGDP(1)
8996           SBODPO(3,2) = SIGDP(2)
8997           SBODPO(3,3) = SIGDP(3)
8998           SBODPO(3,4) = SIGDP(4)
8999
9000 C  low mass double diffractive scattering
9001         CALL PHO_BORNCS(IP,1,XMASS1,XMASS2,RMASS1,RMASS2)
9002           ZXP(1,4) = ZIGP
9003           BXP(1,4) = BPOM
9004           ZXR(1,4) = ZIGR
9005           BXR(1,4) = BREG
9006           ZXH(1,4) = ZIGHR
9007           BXH(1,4) = BHAR
9008           ZXD(1,4) = ZIGHD
9009           BXD(1,4) = BHAD
9010           ZXT1A(1,4) = ZIGT1(1)
9011           BXT1A(1,4) = BTR1(1)
9012           ZXT1B(1,4) = ZIGT1(2)
9013           BXT1B(1,4) = BTR1(2)
9014           ZXT2A(1,4) = ZIGT2(1)
9015           BXT2A(1,4) = BTR2(1)
9016           ZXT2B(1,4) = ZIGT2(2)
9017           BXT2B(1,4) = BTR2(2)
9018           ZXL(1,4) = ZIGL
9019           BXL(1,4) = BLOO
9020           ZXDPE(1,4) = ZIGDP(1)
9021           BXDPE(1,4) = BDP(1)
9022           ZXDPA(1,4) = ZIGDP(2)
9023           BXDPA(1,4) = BDP(2)
9024           ZXDPB(1,4) = ZIGDP(3)
9025           BXDPB(1,4) = BDP(3)
9026           ZXDPD(1,4) = ZIGDP(4)
9027           BXDPD(1,4) = BDP(4)
9028           SBOPOM(4) = SIGP
9029           SBOREG(4) = SIGR
9030           SBOHAR(4) = SIGHR
9031           SBOHAD(4) = 0.D0
9032           SBOTR1(4,1) = SIGT1(1)
9033           SBOTR1(4,2) = SIGT1(2)
9034           SBOTR2(4,1) = SIGT2(1)
9035           SBOTR2(4,2) = SIGT2(2)
9036           SBOLPO(4) = SIGL
9037           SBODPO(4,1) = SIGDP(1)
9038           SBODPO(4,2) = SIGDP(2)
9039           SBODPO(4,3) = SIGDP(3)
9040           SBODPO(4,4) = SIGDP(4)
9041
9042 C  calculate Born graph cross sections
9043         SBOPOM(0) = 0.D0
9044         SBOREG(0) = 0.D0
9045         SBOHAR(0) = 0.D0
9046         SBOHAD(0) = 0.D0
9047         SBOTR1(0,1) = 0.D0
9048         SBOTR1(0,2) = 0.D0
9049         SBOTR2(0,1) = 0.D0
9050         SBOTR2(0,2) = 0.D0
9051         SBOLPO(0) = 0.D0
9052         SBODPO(0,1) = 0.D0
9053         SBODPO(0,2) = 0.D0
9054         SBODPO(0,3) = 0.D0
9055         SBODPO(0,4) = 0.D0
9056         DO 150 I=1,4
9057           SBOPOM(0) = SBOPOM(0) + ELAFAC(I)*SBOPOM(I)
9058           SBOREG(0) = SBOREG(0) + ELAFAC(I)*SBOREG(I)
9059           SBOHAR(0) = SBOHAR(0) + ELAFAC(I)*SBOHAR(I)
9060           SBOHAD(0) = SBOHAD(0) + ELAFAC(I)*SBOHAD(I)
9061           SBOTR1(0,1) = SBOTR1(0,1) + ELAFAC(I)*SBOTR1(I,1)
9062           SBOTR1(0,2) = SBOTR1(0,2) + ELAFAC(I)*SBOTR1(I,2)
9063           SBOTR2(0,1) = SBOTR2(0,1) + ELAFAC(I)*SBOTR2(I,1)
9064           SBOTR2(0,2) = SBOTR2(0,2) + ELAFAC(I)*SBOTR2(I,2)
9065           SBOLPO(0) = SBOLPO(0) + ELAFAC(I)*SBOLPO(I)
9066           SBODPO(0,1) = SBODPO(0,1) + ELAFAC(I)*SBODPO(I,1)
9067           SBODPO(0,2) = SBODPO(0,2) + ELAFAC(I)*SBODPO(I,2)
9068           SBODPO(0,3) = SBODPO(0,3) + ELAFAC(I)*SBODPO(I,3)
9069           SBODPO(0,4) = SBODPO(0,4) + ELAFAC(I)*SBODPO(I,4)
9070  150    CONTINUE
9071
9072         SIGPOM = SBOPOM(0)
9073         SIGREG = SBOREG(0)
9074         SIGTR1(1) = SBOTR1(0,1)
9075         SIGTR1(2) = SBOTR1(0,2)
9076         SIGTR2(1) = SBOTR2(0,1)
9077         SIGTR2(2) = SBOTR2(0,2)
9078         SIGLOO = SBOLPO(0)
9079         SIGDPO(1) = SBODPO(0,1)
9080         SIGDPO(2) = SBODPO(0,2)
9081         SIGDPO(3) = SBODPO(0,3)
9082         SIGDPO(4) = SBODPO(0,4)
9083         SIGHAR = SBOHAR(0)
9084         SIGDIR = SBOHAD(0)
9085       ENDIF
9086
9087       B24=DCMPLX(B**2,0.D0)/4.D0
9088
9089       AMPEL     = CZERO
9090       AMPR      = CZERO
9091       AMPO      = CZERO
9092       AMPP      = CZERO
9093       AMPQ      = CZERO
9094       AMLMSD(1) = CZERO
9095       AMLMSD(2) = CZERO
9096       AMHMSD(1) = CZERO
9097       AMHMSD(2) = CZERO
9098       AMLMDD    = CZERO
9099       AMHMDD    = CZERO
9100
9101 C  different models
9102
9103       IF(ISWMDL(1).LT.3) THEN
9104 C  pomeron
9105         AUXP  = ZXP(1,1)*EXP(-B24/BXP(1,1))
9106 C  reggeon
9107         AUXR  = ZXR(1,1)*EXP(-B24/BXR(1,1))
9108 C  hard resolved processes
9109         AUXH  = ZXH(1,1)*EXP(-B24/BXH(1,1))
9110 C  hard direct processes
9111         AUXD  = ZXD(1,1)*EXP(-B24/BXD(1,1))
9112 C  triple-Pomeron: baryon high mass diffraction
9113         AUXT1 = ZXT1A(1,1)*EXP(-B24/BXT1A(1,1))
9114      &        + ZXT1B(1,1)*EXP(-B24/BXT1B(1,1))
9115 C  triple-Pomeron: photon/meson high mass diffraction
9116         AUXT2 = ZXT2A(1,1)*EXP(-B24/BXT2A(1,1))
9117      &        + ZXT2B(1,1)*EXP(-B24/BXT2B(1,1))
9118 C  loop-Pomeron
9119         AUXL  = ZXL(1,1)*EXP(-B24/BXL(1,1))
9120       ENDIF
9121
9122       IF(ISWMDL(1).EQ.0) THEN
9123         AMPEL = 0.5D0*((VDMQ2F(1)+VDMQ2F(2)+VDMQ2F(3)+VDMQ2F(4))
9124      &                 *(CONE-EXP(-AUXR-AUXP-AUXH+AUXT1+AUXT2+AUXL))
9125      &        +(CONE-(VDMQ2F(1)-VDMQ2F(2)-VDMQ2F(3)-VDMQ2F(4)))*AUXD
9126      &               )
9127         AMPR = 0.5D0*SQRT(VDMQ2F(1))*(CONE-EXP(-AUXR-AUXP-AUXH
9128      &                                      +AUXT1+AUXT2+AUXL))
9129         AMPO = 0.5D0*SQRT(VDMQ2F(2))*(CONE-EXP(-AUXR-AUXP-AUXH
9130      &                                      +AUXT1+AUXT2+AUXL))
9131         AMPP = 0.5D0*SQRT(VDMQ2F(3))*(CONE-EXP(-AUXR-AUXP-AUXH
9132      &                                      +AUXT1+AUXT2+AUXL))
9133         AMPQ = 0.5D0*SQRT(VDMQ2F(4))*(CONE-EXP(-AUXR-AUXP-AUXH
9134      &                                      +AUXT1+AUXT2+AUXL))
9135
9136       ELSE IF(ISWMDL(1).EQ.1) THEN
9137         AMPR = 0.5D0*SQRT(VDMQ2F(1))*
9138      &         ( CONE-EXP(-AUXR-AUXP-AUXH*VDMQ2F(1)) )
9139         AMPO = 0.5D0*SQRT(VDMQ2F(2))*
9140      &         ( CONE-EXP(-3.D0*AUXR-AUXP-AUXH*VDMQ2F(2)) )
9141         AMPP = 0.5D0*SQRT(VDMQ2F(3))*
9142      &         ( CONE-EXP(-AUXP-AUXH*VDMQ2F(3)) )
9143         AMPQ = 0.5D0*SQRT(VDMQ2F(4))*
9144      &         ( CONE-EXP(-AUXR-AUXP-AUXH*VDMQ2F(4)) )
9145         AMPEL = SQRT(VDMQ2F(1))*AMPR
9146      &         + SQRT(VDMQ2F(2))*AMPO
9147      &         + SQRT(VDMQ2F(3))*AMPP
9148      &         + SQRT(VDMQ2F(4))*AMPQ
9149      &         + AUXD/2.D0
9150
9151 C  simple analytic two channel model (version A)
9152       ELSE IF(ISWMDL(1).EQ.3) THEN
9153         CALL PHO_CHAN2A(B)
9154
9155       ELSE
9156         WRITE(LO,'(1X,A,I2)')
9157      &       'EIKON: ERROR: unsupported model ISWMDL(1) ',ISWMDL(1)
9158         STOP
9159       ENDIF
9160
9161       END
9162
9163 *$ CREATE PHO_DSIGDT.FOR
9164 *COPY PHO_DSIGDT
9165 CDECK  ID>, PHO_DSIGDT
9166       SUBROUTINE PHO_DSIGDT(EE,XTA,NFILL)
9167 C*********************************************************************
9168 C
9169 C     calculation of unitarized amplitude
9170 C                    and differential cross section
9171 C
9172 C     input:   EE       cm energy (GeV)
9173 C              XTA(1,*) t values (GeV**2)
9174 C              NFILL    entries in t table
9175 C
9176 C     output:  XTA(2,*)  DSIG/DT  g p --> g h/V (mub/GeV**2)
9177 C              XTA(3,*)  DSIG/DT  g p --> rho0 h/V
9178 C              XTA(4,*)  DSIG/DT  g p --> omega0 h/V
9179 C              XTA(5,*)  DSIG/DT  g p --> phi h/V
9180 C              XTA(6,*)  DSIG/DT  g p --> pi+ pi- h/V (continuum)
9181 C
9182 C*********************************************************************
9183       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9184       SAVE
9185
9186       PARAMETER(ITWO=2,
9187      &        ITHREE=3,
9188      &         THOUS=1.D3,
9189      &          DEPS=1.D-20)
9190
9191       DIMENSION XTA(6,NFILL)
9192
9193 C  input/output channels
9194       INTEGER LI,LO
9195       COMMON /POINOU/ LI,LO
9196 C  some constants
9197       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
9198       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
9199      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
9200 C  integration precision for hard cross sections (obsolete)
9201       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9202       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9203 C  event debugging information
9204       INTEGER NMAXD
9205       PARAMETER (NMAXD=100)
9206       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9207      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9208       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9209      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9210 C  global event kinematics and particle IDs
9211       INTEGER IFPAP,IFPAB
9212       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
9213       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
9214 C  complex Born graph amplitudes used for unitarization
9215       COMPLEX*16      AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
9216      &                AMHMDD,AMPDP
9217       COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
9218      &                AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
9219
9220       COMPLEX*16   XT,AMP,CZERO
9221       DIMENSION    AMP(5),XPNT(96),WGHT(96),XT(5,100)
9222       CHARACTER*12 FNA
9223
9224       CDABS(AMPEL) = ABS(AMPEL)
9225       DCMPLX(X,Y) = CMPLX(X,Y)
9226
9227       CZERO=DCMPLX(0.D0,0.D0)
9228
9229       ETMP = ECM
9230       ECM  = EE
9231
9232       IF(NFILL.GT.100) THEN
9233         WRITE(LO,'(1X,A,I4)')
9234      &    'PHO_DSIGDT:ERROR: too many entries in table',NFILL
9235         STOP
9236       ENDIF
9237 C
9238       DO 100 K=1,NFILL
9239         DO 150 L=1,5
9240           XT(L,K)=CZERO
9241  150    CONTINUE
9242  100  CONTINUE
9243 C
9244 C  impact parameter integration
9245 C     BMAX=12.D0*SQRT(MAX(BPOM,BREG))
9246       BMAX=10.D0
9247       CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
9248       IAMP = 5
9249       IF((IFPAP(1).EQ.22).AND.(IFPAP(2).NE.22)) THEN
9250         I1 = 1
9251         I2 = 0
9252       ELSE IF((IFPAP(1).NE.22).AND.(IFPAP(2).EQ.22)) THEN
9253         I1 = 0
9254         I2 = 1
9255       ELSE IF((IFPAP(1).EQ.22).AND.(IFPAP(2).EQ.22)) THEN
9256         I1 = 1
9257         I2 = 1
9258       ELSE
9259         I1 = 0
9260         I2 = 0
9261         IAMP = 1
9262       ENDIF
9263       J1 = I1*2
9264       K1 = I1*3
9265       L1 = I1*4
9266       J2 = I2*2
9267       K2 = I2*3
9268       L2 = I2*4
9269 C
9270       DO 200 I=1,NGAUSO
9271         WG=WGHT(I)*XPNT(I)
9272 C  calculate amplitudes
9273         IF(I.EQ.1) THEN
9274           CALL PHO_EIKON(1,-1,XPNT(I))
9275         ELSE
9276           CALL PHO_EIKON(1,1,XPNT(I))
9277         ENDIF
9278         AMP(1) = AMPEL
9279         AMP(2) = AMPVM(I1,I2)
9280         AMP(3) = AMPVM(J1,J2)
9281         AMP(4) = AMPVM(K1,K2)
9282         AMP(5) = AMPVM(L1,L2)
9283 C
9284         DO 400 J=1,NFILL
9285           XX=XPNT(I)*SQRT(XTA(1,J)/GEV2MB)
9286           FAC = PHO_BESSJ0(XX)*WG
9287           DO 500 K=1,IAMP
9288             XT(1,J)=XT(1,J)+AMP(K)*FAC
9289  500      CONTINUE
9290  400    CONTINUE
9291  200  CONTINUE
9292 C
9293 C  change units to mb/GeV**2
9294       FAC = 4.D0*PI/GEV2MB
9295       FNA = '(mb/GeV**2) '
9296       IF(I1+I2.EQ.1) THEN
9297         FAC = FAC*THOUS
9298         FNA = '(mub/GeV**2)'
9299       ELSE IF(I1+I2.EQ.2) THEN
9300         FAC = FAC*THOUS*THOUS
9301         FNA = '(nb/GeV**2) '
9302       ENDIF
9303       IF(IDEB(56).GE.5) THEN
9304         WRITE(LO,'(1X,A,A12,/1X,A)') 'table:  -T (GeV**2)   DSIG/DT ',
9305      &    FNA,'------------------------------------------'
9306       ENDIF
9307       DO 600 J=1,NFILL
9308         DO 700 K=1,IAMP
9309           XTA(K+1,J)=CDABS(XT(K,J))**2*FAC
9310  700    CONTINUE
9311         IF(IDEB(56).GE.5) THEN
9312           WRITE(LO,'(5X,6E12.3)') (XTA(I,J),I=1,IAMP+1)
9313         ENDIF
9314  600  CONTINUE
9315
9316       ECM = ETMP
9317       END
9318
9319 *$ CREATE PHO_XSECT.FOR
9320 *COPY PHO_XSECT
9321 CDECK  ID>, PHO_XSECT
9322       SUBROUTINE PHO_XSECT(IP,IFHARD,EE)
9323 C*********************************************************************
9324 C
9325 C     calculation of physical cross sections
9326 C
9327 C     input:   IP      particle combination
9328 C              IFHARD  -1 reset Born graph cross section tables
9329 C                      0  calculate hard cross sections or take them
9330 C                         from interpolation table (if available)
9331 C                      1  assume that hard cross sections are already
9332 C                         calculated and stored in /POSBRN/
9333 C              EE      cms energy (GeV)
9334 C
9335 C     output:  /POSBRN/  input cross sections
9336 C              /POZBRN/  scaled input cross values
9337 C              /POCSEC/  physical cross sections and slopes
9338 C
9339 C              slopes in GeV**-2, cross sections in mb
9340 C
9341 C*********************************************************************
9342       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9343       SAVE
9344
9345       PARAMETER(ONEM=-1.D0,
9346      &         THOUS=1.D3,
9347      &          DEPS=1.D-20)
9348
9349 C  input/output channels
9350       INTEGER LI,LO
9351       COMMON /POINOU/ LI,LO
9352 C  some constants
9353       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
9354       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
9355      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
9356 C  event debugging information
9357       INTEGER NMAXD
9358       PARAMETER (NMAXD=100)
9359       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9360      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9361       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9362      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9363 C  integration precision for hard cross sections (obsolete)
9364       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9365       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9366 C  model switches and parameters
9367       CHARACTER*8 MDLNA
9368       INTEGER ISWMDL,IPAMDL
9369       DOUBLE PRECISION PARMDL
9370       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
9371 C  Born graph cross sections and slopes
9372       INTEGER Max_pro_3
9373       PARAMETER ( Max_pro_3 = 16 )
9374       COMPLEX*16      SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
9375      &                SIGD1,SIGD2,DSIGH
9376       COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
9377      &                SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
9378 C  cross sections
9379       INTEGER IPFIL,IFAFIL,IFBFIL
9380       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
9381      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
9382      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
9383      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
9384      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
9385       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
9386      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
9387      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
9388      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
9389      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
9390      &                IPFIL,IFAFIL,IFBFIL
9391 C  global event kinematics and particle IDs
9392       INTEGER IFPAP,IFPAB
9393       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
9394       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
9395
9396       CHARACTER*15    PHO_PNAME
9397
9398 C  complex Born graph amplitudes used for unitarization
9399       COMPLEX*16      AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
9400      &                AMHMDD,AMPDP
9401       COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
9402      &                AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
9403
9404       DIMENSION XPNT(96),WGHT(96),SLVM1(4,4),SLVM2(4,4)
9405       CHARACTER*8 VMESA(0:4),VMESB(0:4)
9406       DATA VMESA / 'vmeson  ','rho     ','omega   ','phi     ',
9407      &             'pi+pi-  ' /
9408       DATA VMESB / 'vmeson  ','rho     ','omega   ','phi     ',
9409      &             'pi+pi-  ' /
9410
9411       CDABS(AMPEL) = ABS(AMPEL)
9412
9413       ETMP = ECM
9414       IF(EE.LT.0.D0) GOTO 500
9415       ECM = EE
9416
9417 C  impact parameter integration
9418 C     BMAX=12.D0*SQRT(MAX(BPOM,BREG))
9419       BMAX=10.D0
9420       CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
9421       SIGTOT    = 0.D0
9422       SIGINE    = 0.D0
9423       SIGELA    = 0.D0
9424       SIGNDF    = 0.D0
9425       SIGLSD(1) = 0.D0
9426       SIGLSD(2) = 0.D0
9427       SIGLDD    = 0.D0
9428       SIGHSD(1) = 0.D0
9429       SIGHSD(2) = 0.D0
9430       SIGHDD    = 0.D0
9431       SIGCDF(0) = 0.D0
9432       SIG1SO    = 0.D0
9433       SIG1HA    = 0.D0
9434       SLEL1 = 0.D0
9435       SLEL2 = 0.D0
9436       DO 50 I=1,4
9437         SIGCDF(I) = 0.D0
9438         DO 55 K=1,4
9439           SIGVM(I,K) = 0.D0
9440           SLVM1(I,K) = 0.D0
9441           SLVM2(I,K) = 0.D0
9442  55     CONTINUE
9443  50   CONTINUE
9444
9445       DO 100 I=1,NGAUSO
9446         B2  = XPNT(I)**2
9447         WG  = WGHT(I)*XPNT(I)
9448         WGB = B2*WG
9449
9450 C  calculate impact parameter amplitude, results in /POINT4/
9451         IF(I.EQ.1) THEN
9452           CALL PHO_EIKON(IP,IFHARD,XPNT(I))
9453         ELSE
9454           CALL PHO_EIKON(IP,1,XPNT(I))
9455         ENDIF
9456
9457         SIGTOT    = SIGTOT + DREAL(AMPEL)*WG
9458         SIGELA    = SIGELA + CDABS(AMPEL)**2*WG
9459         SLEL1     = SLEL1  + AMPEL*WGB
9460         SLEL2     = SLEL2  + AMPEL*WG
9461
9462         DO 110 J=1,4
9463           DO 120 K=1,4
9464             SIGVM(J,K) = SIGVM(J,K) + CDABS(AMPVM(J,K))**2*WG
9465             SLVM1(J,K) = SLVM1(J,K) + AMPVM(J,K)*WGB
9466             SLVM2(J,K) = SLVM2(J,K) + AMPVM(J,K)*WG
9467  120      CONTINUE
9468           SIGCDF(J)   = SIGCDF(J)   + DREAL(AMPDP(J))*WG
9469  110    CONTINUE
9470
9471         SIGLSD(1) = SIGLSD(1) + CDABS(AMLMSD(1))**2*WG
9472         SIGLSD(2) = SIGLSD(2) + CDABS(AMLMSD(2))**2*WG
9473         SIGLDD    = SIGLDD    + CDABS(AMLMDD)**2*WG
9474         SIG1SO    = SIG1SO    + DREAL(AMPSOF)*WG
9475         SIG1HA    = SIG1HA    + DREAL(AMPHAR)*WG
9476         SIGHSD(1) = SIGHSD(1) + DREAL(AMHMSD(1))*WG
9477         SIGHSD(2) = SIGHSD(2) + DREAL(AMHMSD(2))*WG
9478         SIGHDD    = SIGHDD    + DREAL(AMHMDD)*WG
9479
9480  100  CONTINUE
9481
9482       SIGDIR = DREAL(SIGHD)
9483       FAC    = 4.D0*PI2
9484       SIGTOT = SIGTOT*FAC
9485       SIGELA = SIGELA*FAC
9486       FACSL  = 0.5D0/GEV2MB
9487       SLOEL  = SLEL1/MAX(DEPS,SLEL2)*FACSL
9488
9489       IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22)) THEN
9490         DO 130 I=1,4
9491           DO 140 J=1,4
9492             SIGVM(I,J) = SIGVM(I,J)*FAC
9493             SLOVM(I,J) = SLVM1(I,J)/MAX(DEPS,SLVM2(I,J))*FACSL
9494  140      CONTINUE
9495  130    CONTINUE
9496         SIGVM(0,0) = 0.D0
9497         DO 150 I=1,4
9498           SIGVM(0,I) = 0.D0
9499           SIGVM(I,0) = 0.D0
9500           DO 160 J=1,4
9501             SIGVM(0,I) = SIGVM(0,I) + SIGVM(J,I)
9502             SIGVM(I,0) = SIGVM(I,0) + SIGVM(I,J)
9503  160      CONTINUE
9504           SIGVM(0,0) = SIGVM(0,0) + SIGVM(I,0)
9505  150    CONTINUE
9506       ENDIF
9507
9508 C  diffractive cross sections
9509
9510       SIGLSD(1) = SIGLSD(1)*FAC*PARMDL(40)
9511       SIGLSD(2) = SIGLSD(2)*FAC*PARMDL(41)
9512       SIGLDD    = SIGLDD   *FAC*PARMDL(42)
9513       SIGHSD(1) = (SIGHSD(1)-2.D0*(SIGCDF(1)+SIGCDF(2)))*FAC*PARMDL(40)
9514       SIGHSD(2) = (SIGHSD(2)-2.D0*(SIGCDF(1)+SIGCDF(3)))*FAC*PARMDL(41)
9515       SIGHDD    = (SIGHDD-2.D0*(SIGCDF(2)+SIGCDF(3)+2.D0*SIGCDF(4)))
9516      &            *FAC*PARMDL(42)
9517
9518 C  double pomeron scattering
9519
9520       SIGCDF(0) = 0.D0
9521       DO 170 I=1,4
9522         SIGCDF(I) = SIGCDF(I)*FAC
9523         SIGCDF(0) = SIGCDF(0)+SIGCDF(I)
9524  170  CONTINUE
9525
9526       SIG1SO    = SIG1SO   *FAC
9527       SIG1HA    = SIG1HA   *FAC
9528
9529       SIGINE    = SIGTOT - SIGELA
9530
9531 C  user-forced change of diffractive cross section
9532
9533       IF((IP.EQ.1).AND.(ISWMDL(30).GE.1)) THEN
9534
9535 C  use optional explicit parametrization for single-diffraction
9536
9537         SIGSD1 = SIGLSD(1)+SIGHSD(1)
9538         SIGSD2 = SIGLSD(2)+SIGHSD(2)
9539         SS = EE*EE
9540         XI_MIN = 1.5D0/SS
9541         XI_MAX = PARMDL(45)**2
9542         CALL PHO_CSDIFF(IFPAP(1),IFPAP(2),SS,XI_MIN,XI_MAX,
9543      &    SIG_SD1,SIG_SD2,SIG_DD)
9544         SIG_SD1 = SIG_SD1*PARMDL(40)
9545         SIG_SD2 = SIG_SD2*PARMDL(41)
9546 **sr
9547 C       DEL_SD1 = SIG_SD1-SIGSD1
9548         DEL_SD1 = PARMDL(200)*(SIG_SD1-SIGSD1)
9549 **
9550         FAC = SIGLSD(1)/SIGSD1
9551         SIGLSD(1) = SIGLSD(1)+FAC*DEL_SD1
9552         SIGHSD(1) = SIGHSD(1)+(1.D0-FAC)*DEL_SD1
9553 C       DEL_SD2 = SIG_SD2-SIGSD2
9554         DEL_SD2 = PARMDL(200)*(SIG_SD2-SIGSD2)
9555         FAC = SIGLSD(2)/SIGSD2
9556         SIGLSD(2) = SIGLSD(2)+FAC*DEL_SD2
9557         SIGHSD(2) = SIGHSD(2)+(1.D0-FAC)*DEL_SD2
9558
9559         IF(ISWMDL(30).GE.2) THEN
9560
9561 C  use explicit parametrization also for double diffraction diss.
9562           SIGDD  = SIGLDD+SIGHDD
9563           SIG_DD = SIG_DD*PARMDL(42)
9564           DEL_DD = SIG_DD-SIGDD
9565           FAC = SIGLDD/SIGDD
9566           SIGLDD = SIGLDD+FAC*DEL_DD
9567           SIGHDD = SIGHDD+(1.D0-FAC)*DEL_DD
9568           SIGCOR = DEL_SD1 + DEL_SD2 + DEL_DD
9569
9570         ELSE
9571
9572 C  rescale double diffraction cross sections
9573           SIGLDD    = SIGLDD   *PARMDL(42)
9574           SIGHDD    = SIGHDD   *PARMDL(42)
9575           SIGCOR = DEL_SD1 + DEL_SD2
9576      &      +(SIGLDD+SIGHDD)*(PARMDL(42)-1.D0)
9577
9578         ENDIF
9579
9580       ELSE
9581
9582 C  rescale unitarized cross sections for diffraction dissociation
9583
9584         SIGLSD(1) = SIGLSD(1)*PARMDL(40)
9585         SIGHSD(1) = SIGHSD(1)*PARMDL(40)
9586         SIGLSD(2) = SIGLSD(2)*PARMDL(41)
9587         SIGHSD(2) = SIGHSD(2)*PARMDL(41)
9588         SIGLDD    = SIGLDD   *PARMDL(42)
9589         SIGHDD    = SIGHDD   *PARMDL(42)
9590         SIGCOR = (SIGLSD(1)+SIGHSD(1))*(PARMDL(40)-1.D0)
9591      &          +(SIGLSD(2)+SIGHSD(2))*(PARMDL(41)-1.D0)
9592      &          +(SIGLDD+SIGHDD)*(PARMDL(42)-1.D0)
9593
9594       ENDIF
9595
9596 C  non-diffractive inelastic cross section
9597
9598       SIGNDF    = SIGTOT-SIGELA-SIGVM(0,0)-SIGCDF(0)-SIGDIR
9599      &            -SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
9600      &            -SIGLDD-SIGHDD
9601
9602 C  specify elastic scattering channel
9603
9604  500  CONTINUE
9605       IF(IFPAP(1).NE.22) THEN
9606         VMESA(1) = PHO_PNAME(IFPAB(1),0)
9607       ELSE
9608         VMESA(1) = 'rho           '
9609       ENDIF
9610       IF(IFPAP(2).NE.22) THEN
9611         VMESB(1) = PHO_PNAME(IFPAB(2),0)
9612       ELSE
9613         VMESB(1) = 'rho           '
9614       ENDIF
9615
9616 C  write out physical cross sections
9617
9618       IF(IDEB(57).GE.5) THEN
9619         WRITE(LO,'(/1X,A,I3,/1X,A)')
9620      &    'PHO_XSECT: cross sections (mb) for combination',IP,
9621      &    '----------------------------------------------'
9622         WRITE(LO,'(5X,A,E12.3,2E11.3)')'energy,virtualities',ECM,PVIRT
9623         WRITE(LO,'(5X,A,E12.3)') '             total ',SIGTOT
9624         WRITE(LO,'(5X,A,E12.3)') '    purely elastic ',SIGELA
9625         WRITE(LO,'(5X,A,E12.3)') '         inelastic ',SIGINE
9626         WRITE(LO,'(5X,A,E12.3)') ' s-diff.particle 1 ',
9627      &    SIGLSD(1)+SIGHSD(1)
9628         IF(IDEB(57).GE.7) THEN
9629           WRITE(LO,'(5X,A,E12.3)') '     low-mass part ',SIGLSD(1)
9630           WRITE(LO,'(5X,A,E12.3)') '    high-mass part ',SIGHSD(1)
9631         ENDIF
9632         WRITE(LO,'(5X,A,E12.3)') ' s-diff.particle 2 ',
9633      &    SIGLSD(2)+SIGHSD(2)
9634         IF(IDEB(57).GE.7) THEN
9635           WRITE(LO,'(5X,A,E12.3)') '     low-mass part ',SIGLSD(2)
9636           WRITE(LO,'(5X,A,E12.3)') '    high-mass part ',SIGHSD(2)
9637         ENDIF
9638         WRITE(LO,'(5X,A,E12.3)') '       double diff ',SIGLDD+SIGHDD
9639         IF(IDEB(57).GE.7) THEN
9640           WRITE(LO,'(5X,A,E12.3)') '     low-mass part ',SIGLDD
9641           WRITE(LO,'(5X,A,E12.3)') '    high-mass part ',SIGHDD
9642         ENDIF
9643         WRITE(LO,'(5X,A,E12.3)') '    double pomeron ',SIGCDF(0)
9644         IF(IDEB(57).GE.7) THEN
9645           WRITE(LO,'(5X,A,E12.3)') '    purely elastic ',SIGCDF(1)
9646           WRITE(LO,'(5X,A,E12.3)') ' excitation part.1 ',SIGCDF(2)
9647           WRITE(LO,'(5X,A,E12.3)') ' excitation part.2 ',SIGCDF(3)
9648           WRITE(LO,'(5X,A,E12.3)') '   excitation both ',SIGCDF(4)
9649         ENDIF
9650         WRITE(LO,'(5X,A,E12.3)') '     elastic slope ',SLOEL
9651         DO 200 I=1,4
9652           DO 210 J=1,4
9653             IF(SIGVM(I,J).GT.DEPS) THEN
9654               WRITE(LO,'(1X,3A)') 'q-elastic production of ',
9655      &          VMESA(I),VMESB(J)
9656               WRITE(LO,'(10X,A,E12.3)') 'cross section ',SIGVM(I,J)
9657               IF((I.NE.0).AND.(J.NE.0))
9658      &          WRITE(LO,'(18X,A,E12.3)') 'slope ',SLOVM(I,J)
9659             ENDIF
9660  210      CONTINUE
9661  200    CONTINUE
9662         IF(IDEB(57).GE.7) THEN
9663           WRITE(LO,'(5X,A,E12.3)') ' vmeson production ',SIGVM(0,0)
9664           WRITE(LO,'(5X,A,E12.3)') '  one-pomeron soft ',SIG1SO
9665           WRITE(LO,'(5X,A,E12.3)') '  one-pomeron hard ',SIG1HA
9666           WRITE(LO,'(5X,A,E12.3)') '  pomeron exchange ',SIGPOM
9667           WRITE(LO,'(5X,A,E12.3)') '  reggeon exchange ',SIGREG
9668           WRITE(LO,'(5X,A,E12.3)') ' hard resolved QCD ',DREAL(DSIGH(9))
9669           WRITE(LO,'(5X,A,E12.3/)')'   hard direct QCD ',
9670      &      DREAL(DSIGH(15))
9671         ENDIF
9672       ENDIF
9673
9674       ECM = ETMP
9675
9676       END
9677
9678 *$ CREATE PHO_IMPAMP.FOR
9679 *COPY PHO_IMPAMP
9680 CDECK  ID>, PHO_IMPAMP
9681       SUBROUTINE PHO_IMPAMP(EE,BMIN,BMAX,NSTEP)
9682 C*********************************************************************
9683 C
9684 C     calculation of physical  impact parameter amplitude
9685 C
9686 C     input:   EE      cm energy (GeV)
9687 C              BMIN    lower bound in B
9688 C              BMAX    upper bound in B
9689 C              NSTEP   number of values (linear)
9690 C
9691 C     output:  values written to output unit
9692 C
9693 C*********************************************************************
9694       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9695       SAVE
9696
9697       PARAMETER(ONEM=-1.D0,
9698      &         THOUS=1.D3,
9699      &          DEPS=1.D-20)
9700
9701 C  input/output channels
9702       INTEGER LI,LO
9703       COMMON /POINOU/ LI,LO
9704 C  event debugging information
9705       INTEGER NMAXD
9706       PARAMETER (NMAXD=100)
9707       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9708      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9709       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9710      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9711 C  model switches and parameters
9712       CHARACTER*8 MDLNA
9713       INTEGER ISWMDL,IPAMDL
9714       DOUBLE PRECISION PARMDL
9715       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
9716 C  global event kinematics and particle IDs
9717       INTEGER IFPAP,IFPAB
9718       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
9719       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
9720 C  complex Born graph amplitudes used for unitarization
9721       COMPLEX*16      AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
9722      &                AMHMDD,AMPDP
9723       COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
9724      &                AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
9725
9726       ECM=EE
9727       BSTEP = (BMAX-BMIN)/DBLE(NSTEP-1)
9728 C
9729       WRITE(LO,'(3(/,1X,A))')
9730      &  'impact parameter amplitudes:',
9731      &  '  B  AMP-EL  AMP-LMSD(1,2)  AMP-HMSD(1,2)  AMP-LMDD  AMP-HMDD',
9732      &  '-------------------------------------------------------------'
9733 C
9734       BB = BMIN
9735       DO 100 I=1,NSTEP
9736 C  calculate impact parameter amplitudes
9737         IF(I.EQ.1) THEN
9738           CALL PHO_EIKON(1,-1,BMIN)
9739         ELSE
9740           CALL PHO_EIKON(1,1,BB)
9741         ENDIF
9742         WRITE(LO,'(1X,8E12.4)') BB,DREAL(AMPEL),
9743      &    DREAL(AMLMSD(1)),DREAL(AMLMSD(2)),
9744      &    DREAL(AMHMSD(1)),DREAL(AMHMSD(2)),DREAL(AMLMDD),DREAL(AMHMDD)
9745         BB = BB+BSTEP
9746  100  CONTINUE
9747
9748       END
9749
9750 *$ CREATE PHO_PRBDIS.FOR
9751 *COPY PHO_PRBDIS
9752 CDECK  ID>, PHO_PRBDIS
9753       SUBROUTINE PHO_PRBDIS(IP,ECM,IE)
9754 C*********************************************************************
9755 C
9756 C     calculation of multi interactions probabilities
9757 C
9758 C     input:  IP        particle combination to scatter
9759 C             ECM       CMS energy
9760 C             IE        index for weight storing
9761 C             /PROBAB/
9762 C             IMAX      max. number of soft pomeron interactions
9763 C             KMAX      max. number of hard pomeron interactions
9764 C
9765 C     output: /PROBAB/
9766 C             PROB      field of probabilities
9767 C
9768 C*********************************************************************
9769       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9770       SAVE
9771
9772       PARAMETER ( EPS=1.D-10 )
9773
9774 C  input/output channels
9775       INTEGER LI,LO
9776       COMMON /POINOU/ LI,LO
9777 C  event debugging information
9778       INTEGER NMAXD
9779       PARAMETER (NMAXD=100)
9780       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
9781      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9782       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
9783      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
9784 C  Reggeon phenomenology parameters
9785       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
9786      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
9787       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
9788      &                ALREG,ALREGP,GR(2),B0REG(2),
9789      &                GPPP,GPPR,B0PPP,B0PPR,
9790      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
9791 C  parameters of 2x2 channel model
9792       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
9793       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
9794 C  Born graph cross sections and slopes
9795       INTEGER Max_pro_3
9796       PARAMETER ( Max_pro_3 = 16 )
9797       COMPLEX*16      SIGP,SIGR,SIGHD,SIGHR,SIGT1,SIGT2,SIGL,SIGDP,
9798      &                SIGD1,SIGD2,DSIGH
9799       COMMON /POSBRN/ SIGP,SIGR,SIGHD,SIGHR,SIGT1(2),SIGT2(2),SIGL,
9800      &                SIGDP(4),SIGD1(2),SIGD2(2),DSIGH(0:Max_pro_3)
9801 C  obsolete cut-off information
9802       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
9803       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
9804 C  Born graph cross sections after applying diffraction model
9805       DOUBLE PRECISION SBOPOM,SBOREG,SBOHAR,SBOHAD,SBOTR1,SBOTR2,
9806      &                 SBOLPO,SBODPO
9807       COMMON /POINT1/ SBOPOM(0:4),SBOREG(0:4),SBOHAR(0:4),SBOHAD(0:4),
9808      &                SBOTR1(0:4,2),SBOTR2(0:4,2),SBOLPO(0:4),
9809      &                SBODPO(0:4,4)
9810 C  cross sections
9811       INTEGER IPFIL,IFAFIL,IFBFIL
9812       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
9813      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
9814      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
9815      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
9816      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
9817       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
9818      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
9819      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
9820      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
9821      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
9822      &                IPFIL,IFAFIL,IFBFIL
9823 C  cut probability distribution
9824       INTEGER IEETA1,IIMAX,KKMAX
9825       PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
9826       INTEGER IEEMAX,IMAX,KMAX
9827       REAL PROB
9828       DOUBLE PRECISION EPTAB
9829       COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
9830      &                IEEMAX,IMAX,KMAX
9831 C  energy-interpolation table
9832       INTEGER IEETA2
9833       PARAMETER ( IEETA2 = 20 )
9834       INTEGER ISIMAX
9835       DOUBLE PRECISION SIGTAB,SIGECM
9836       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
9837 C  average number of cut soft and hard ladders (obsolete)
9838       DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
9839       COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
9840 C  some constants
9841       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
9842       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
9843      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
9844 C  integration precision for hard cross sections (obsolete)
9845       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9846       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
9847 C  model switches and parameters
9848       CHARACTER*8 MDLNA
9849       INTEGER ISWMDL,IPAMDL
9850       DOUBLE PRECISION PARMDL
9851       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
9852 C  unitarized amplitudes for different diffraction channels
9853       DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
9854      &                 ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
9855      &                 ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
9856      &                 ZXL,BXL
9857       COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
9858      &                ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
9859      &                ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
9860      &                ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
9861      &                ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
9862      &                ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
9863      &                ZXL(4,4),BXL(4,4)
9864
9865 C  local variables
9866       DIMENSION  AB(4,4),CHI2(4),ABSUM2(4,4),ABSTMP(4),CHITMP(4)
9867       PARAMETER (ICHMAX=40)
9868       DIMENSION CHIFAC(4,4),AMPCOF(4)
9869       DIMENSION PCHAIN(2,ICHMAX),XPNT(96),WGHT(96)
9870       DIMENSION FACLOG(0:30),PSOFT(0:30),PHARD(0:30)
9871
9872 C  combinatorical factors
9873       DATA      CHIFAC / 1.D0, 1.D0,-1.D0,-1.D0,
9874      &                   1.D0,-1.D0, 1.D0,-1.D0,
9875      &                   1.D0,-1.D0,-1.D0, 1.D0,
9876      &                   1.D0, 1.D0, 1.D0, 1.D0 /
9877
9878       DATA FACLOG /           .000000000000000D+00,
9879      &  .000000000000000D+00, .693147180559945D+00,
9880      &  .109861228866811D+01, .138629436111989D+01,
9881      &  .160943791243410D+01, .179175946922805D+01,
9882      &  .194591014905531D+01, .207944154167984D+01,
9883      &  .219722457733622D+01, .230258509299405D+01,
9884      &  .239789527279837D+01, .248490664978800D+01,
9885      &  .256494935746154D+01, .263905732961526D+01,
9886      &  .270805020110221D+01, .277258872223978D+01,
9887      &  .283321334405622D+01, .289037175789616D+01,
9888      &  .294443897916644D+01, .299573227355399D+01,
9889      &  .304452243772342D+01, .309104245335832D+01,
9890      &  .313549421592915D+01, .317805383034795D+01,
9891      &  .321887582486820D+01, .325809653802148D+01,
9892      &  .329583686600433D+01, .333220451017520D+01,
9893      &  .336729582998647D+01, .340119738166216D+01 /
9894
9895       DATA  ELAST / 0.D0 /
9896       DATA  IPLAST / 0 /
9897
9898 C  test for redundant calculation: skip cs calculation
9899       IF((ECM.NE.ELAST).OR.(IP.NE.IPLAST)) THEN
9900         ELAST = ECM
9901         IPLAST = IP
9902         CALL PHO_XSECT(IP,0,ELAST)
9903         ISIMAX = IE
9904         SIGECM(IP,IE) = ECM
9905         SIGTAB(IP,1,IE) = SIGTOT
9906         SIGTAB(IP,2,IE) = SIGELA
9907         J = 2
9908         DO 5 I=0,4
9909           DO 6 K=0,4
9910             J = J+1
9911             SIGTAB(IP,J,IE) = SIGVM(I,K)
9912  6        CONTINUE
9913  5      CONTINUE
9914         SIGTAB(IP,28,IE) = SIGINE
9915         SIGTAB(IP,29,IE) = SIGDIR
9916         SIGTAB(IP,30,IE) = SIGLSD(1)
9917         SIGTAB(IP,31,IE) = SIGLSD(2)
9918         SIGTAB(IP,32,IE) = SIGHSD(1)
9919         SIGTAB(IP,33,IE) = SIGHSD(2)
9920         SIGTAB(IP,34,IE) = SIGLDD
9921         SIGTAB(IP,35,IE) = SIGHDD
9922         SIGTAB(IP,36,IE) = SIGCDF(0)
9923         SIGTAB(IP,37,IE) = SIG1SO
9924         SIGTAB(IP,38,IE) = SIG1HA
9925         SIGTAB(IP,39,IE) = SLOEL
9926         J = 39
9927         DO 7 I=1,4
9928           DO 8 K=1,4
9929             J = J+1
9930             SIGTAB(IP,J,IE) = SLOVM(I,K)
9931  8        CONTINUE
9932  7      CONTINUE
9933         SIGTAB(IP,56,IE) = SIGPOM
9934         SIGTAB(IP,57,IE) = SIGREG
9935         SIGTAB(IP,58,IE) = SIGHAR
9936         SIGTAB(IP,59,IE) = SIGDIR
9937         SIGTAB(IP,60,IE) = SIGTR1(1)
9938         SIGTAB(IP,61,IE) = SIGTR1(2)
9939         SIGTAB(IP,62,IE) = SIGTR2(1)
9940         SIGTAB(IP,63,IE) = SIGTR2(2)
9941         SIGTAB(IP,64,IE) = SIGLOO
9942         SIGTAB(IP,65,IE) = SIGDPO(1)
9943         SIGTAB(IP,66,IE) = SIGDPO(2)
9944         SIGTAB(IP,67,IE) = SIGDPO(3)
9945         SIGTAB(IP,68,IE) = SIGDPO(4)
9946
9947 C  consistency check
9948         SIGNDF = SIGTOT-SIGELA-SIGVM(0,0)-SIGCDF(0)-SIGDIR
9949      &          -SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
9950      &          -SIGLDD-SIGHDD
9951
9952         IF(SIGNDF.LE.0.D0) THEN
9953           WRITE(LO,'(//1X,A,/)')
9954      &      'PHO_PRBDIS:ERROR: neg.cross section for unitarization!'
9955           WRITE(LO,'(1X,A,I3,1P,2E12.4)')
9956      &      'PHO_PRBDIS: IP,ECM,SIGNDF:',IP,ECM,SIGNDF
9957           WRITE(LO,'(4X,A,/1P,8E10.3)')
9958      &'(SIGTOT,SIGELA,SIGVM,SIGCDF,SIGDIR,SIGLSD(1),SIGLSD(2),SIGLDD):',
9959      &      SIGTOT,SIGELA,SIGVM(0,0),SIGCDF(0),SIGDIR,SIGLSD(1),
9960      &      SIGLSD(2),SIGLDD
9961           STOP
9962         ENDIF
9963
9964         IF((IDEB(55).GE.2).AND.(IP.EQ.1)) THEN
9965           WRITE(LO,*) '------------------------------------------------'
9966           WRITE(LO,*) 'IP,ECM:',IP,ECM
9967           WRITE(LO,*) 'SIGTOT:',SIGTOT
9968           WRITE(LO,*) 'SIGELA:',SIGELA
9969           WRITE(LO,*) 'SIGVM :',SIGVM(0,0)
9970           WRITE(LO,*) 'SIGCDF:',SIGCDF(0)
9971           WRITE(LO,*) 'SIGDIR:',SIGDIR
9972           WRITE(LO,*) 'SIGLSD:',SIGLSD
9973           WRITE(LO,*) 'SIGHSD:',SIGHSD
9974           WRITE(LO,*) 'SIGLDD:',SIGLDD
9975           WRITE(LO,*) 'SIGHDD:',SIGHDD
9976           WRITE(LO,*) 'SIGNDF:',SIGNDF
9977
9978           WRITE(LO,*) 'SIGPOM:',SIGPOM
9979           WRITE(LO,*) 'SIGREG:',SIGREG
9980           WRITE(LO,*) 'SIGHAR:',SIGHAR
9981           WRITE(LO,*) 'SIGDIR:',SIGDIR
9982           WRITE(LO,*) 'SIGTR1:',SIGTR1
9983           WRITE(LO,*) 'SIGTR2:',SIGTR2
9984           WRITE(LO,*) 'SIGLOO:',SIGLOO
9985           WRITE(LO,*) 'SIGDPO:',SIGDPO
9986           WRITE(LO,*) 'SIG1SO:',SIG1SO
9987           WRITE(LO,*) 'SIG1HA:',SIG1HA
9988         ENDIF
9989
9990         SIGTAB(IP,77,IE) = PTCUT(IP)
9991         SIGTAB(IP,78,IE) = SIGNDF
9992
9993         AUXFAC = PI2/SIGNDF
9994         IF(ISWMDL(1).EQ.3) THEN
9995           DO 133 I=1,4
9996             AMPCOF(I) = 0.D0
9997             DO 135 K=1,4
9998               AMPCOF(I) = AMPCOF(I) + 0.25D0*ELAFAC(K)*CHIFAC(K,I)
9999  135        CONTINUE
10000             AMPCOF(I) = AMPCOF(I)*AUXFAC
10001  133      CONTINUE
10002         ENDIF
10003 C
10004 *       BMAX=5.D0*SQRT(DBLE(BPOM))
10005         BMAX=10.D0
10006         EPTAB(IP,IE) = ECM
10007         CALL PHO_GAUSET(0.D0,BMAX,NGAUSO,XPNT,WGHT)
10008 C
10009       ENDIF
10010 C
10011       DO 160 K=0,KMAX
10012         DO 170 I=0,IMAX
10013           PROB(IP,IE,I,K) = 0.D0
10014  170    CONTINUE
10015  160  CONTINUE
10016       DO 120 I=1,ICHMAX
10017         PCHAIN(1,I) = 0.D0
10018         PCHAIN(2,I) = 0.D0
10019  120  CONTINUE
10020 C
10021 C  main cross section loop
10022 C**********************************************************
10023       DO 5000 IB=1,NGAUSO
10024         B24=XPNT(IB)**2/4.D0
10025         FAC = XPNT(IB)*WGHT(IB)
10026 C
10027         IF((ISWMDL(1).EQ.3).OR.(ISWMDL(1).EQ.4)) THEN
10028 C
10029 C  amplitude construction
10030           DO 525 I=1,4
10031             AB(1,I)=ZXP(1,I)*EXP(-B24/BXP(1,I))
10032      &              +ZXR(1,I)*EXP(-B24/BXR(1,I))
10033             AB(2,I)=ZXH(1,I)*EXP(-B24/BXH(1,I))
10034             AB(3,I)=-ZXT1A(1,I)*EXP(-B24/BXT1A(1,I))
10035      &              -ZXT1B(1,I)*EXP(-B24/BXT1B(1,I))
10036      &              -ZXT2A(1,I)*EXP(-B24/BXT2A(1,I))
10037      &              -ZXT2B(1,I)*EXP(-B24/BXT2B(1,I))
10038      &              -ZXL(1,I)*EXP(-B24/BXL(1,I))
10039             AB(4,I)=ZXDPE(1,I)*EXP(-B24/BXDPE(1,I))
10040      &              +ZXDPA(1,I)*EXP(-B24/BXDPA(1,I))
10041      &              +ZXDPB(1,I)*EXP(-B24/BXDPB(1,I))
10042      &              +ZXDPD(1,I)*EXP(-B24/BXDPD(1,I))
10043             AB(1,I) = AB(1,I)+AB(3,I)+AB(4,I)
10044             AB(2,I) = AB(2,I)
10045             AB(3,I) = 0.D0
10046             AB(4,I) = 0.D0
10047 *
10048  525      CONTINUE
10049 C
10050           DO 460 I=1,4
10051             DO 500 K=1,4
10052               ABSUM2(I,K) = 0.D0
10053               DO 550 L=1,4
10054                 ABSUM2(I,K) = ABSUM2(I,K) + CHIFAC(L,K)*AB(I,L)
10055  550          CONTINUE
10056               ABSUM2(I,K) = 2.D0*ABSUM2(I,K)
10057  500        CONTINUE
10058  460      CONTINUE
10059           DO 600 I=1,4
10060             CHI2(I) = 0.D0
10061             DO 650 K=1,4
10062               CHI2(I) = CHI2(I) + ABSUM2(K,I)
10063  650        CONTINUE
10064  600      CONTINUE
10065 C  sums instead of products
10066           DO 660 I=1,4
10067             DO 670 KD=1,4
10068               DTMP = ABS(ABSUM2(I,KD))
10069               IF(DTMP.LT.1.D-30) THEN
10070                 ABSUM2(I,KD) = -50.D0
10071               ELSE
10072                 ABSUM2(I,KD) = LOG(DTMP)
10073               ENDIF
10074  670        CONTINUE
10075  660      CONTINUE
10076
10077           IF(MAX(IMAX,KMAX).GT.30) THEN
10078             WRITE(LO,'(1X,2A,3I6)') 'PHO_PRBDIS: internal field ',
10079      &        'dimension too small (IMAX,KMAX,int):',IMAX,KMAX,30
10080             CALL PHO_ABORT
10081           ENDIF
10082           DO 700 KD=1,4
10083             DO 750 I=1,4
10084               ABSTMP(I) = ABSUM2(I,KD)
10085  750        CONTINUE
10086 C  recursive sum
10087             CHITMP(1) = -ABSUM2(1,KD)
10088             DO 800 I=0,IMAX
10089               CHITMP(1) = CHITMP(1)+ABSTMP(1)-FACLOG(I)
10090               CHITMP(2) = -ABSTMP(2)
10091               DO 810 K=0,KMAX
10092                 CHITMP(2) = CHITMP(2)+ABSTMP(2)-FACLOG(K)
10093 C  calculation of elastic part
10094                 DTMP = -CHI2(KD)+CHITMP(1)+CHITMP(2)
10095                 IF(DTMP.LT.-30.D0) THEN
10096                   DTMP = 0.D0
10097                 ELSE
10098                   DTMP = EXP(DTMP)*FAC*AMPCOF(KD)
10099                 ENDIF
10100                 PROB(IP,IE,I,K) = PROB(IP,IE,I,K) + DTMP
10101  810          CONTINUE
10102  800        CONTINUE
10103  700      CONTINUE
10104           PROB(IP,IE,0,0) = 0.D0
10105 C
10106 C**********************************************************
10107         ELSE
10108           WRITE(LO,'(1X,A,I3)')
10109      &      'PHO_PRBDIS:ERROR: invalid setting of ISWMDL(1)',ISWMDL(1)
10110           STOP
10111         ENDIF
10112  5000 CONTINUE
10113
10114 C  debug output
10115       IF(IDEB(55).GE.15) THEN
10116         WRITE(LO,'(/,1X,A,I3,E11.4)')
10117      &    'PHO_PRBDIS: list of probabilities (uncorrected,IP,ECM)',
10118      &    IP,ECM
10119         DO 905 I=0,MIN(IMAX,5)
10120           DO 915 K=0,MIN(KMAX,5)
10121             IF(ABS(PROB(IP,IE,I,K)).GT.1.D-10)
10122      &        WRITE(LO,'(10X,2I3,5X,E12.3)') I,K,PROB(IP,IE,I,K)
10123  915      CONTINUE
10124  905    CONTINUE
10125       ENDIF
10126 C  string probability (uncorrected)
10127       IF(IDEB(55).GE.5) THEN
10128         DO 955 I=0,IMAX
10129           DO 965 K=0,KMAX
10130             INDX = 2*I+2*K
10131             IF((INDX.LE.ICHMAX).AND.(INDX.GT.0)) THEN
10132               PCHAIN(1,INDX) = PCHAIN(1,INDX) + PROB(IP,IE,I,K)
10133             ENDIF
10134  965      CONTINUE
10135  955    CONTINUE
10136         WRITE(LO,'(/1X,2A,E11.4)') 'PHO_PRBDIS: ',
10137      &    'list of selected probabilities (uncorr,ECM)',ECM
10138         WRITE(LO,'(10X,A)') 'I,   0HPOM,   1HPOM,   2HPOM'
10139         DO 183 I=0,IIMAX
10140           IF(ABS(PROB(IP,IE,I,0)).GT.1.D-10)
10141      &      WRITE(LO,'(5X,I4,3E12.4)') I,PROB(IP,IE,I,0),
10142      &      PROB(IP,IE,I,1),PROB(IP,IE,I,2)
10143  183    CONTINUE
10144       ENDIF
10145 C  substract high-mass single and double diffraction
10146       PROB(IP,IE,1,0) = PROB(IP,IE,1,0)
10147      &                 -(SIGHSD(1)+SIGHSD(2)+SIGHDD+SIGCDF(0))/SIGNDF
10148       PROB(IP,IE,1,0) = MAX(0.01,PROB(IP,IE,1,0))
10149 C
10150 C  probability check
10151       CHKSUM = 0.D0
10152       PRONEG = 0.D0
10153       AVERI =  0.D0
10154       AVERK =  0.D0
10155       AVERL =  0.D0
10156       AVERM =  0.D0
10157       AVERN =  0.D0
10158       SIGMI =  0.D0
10159       SIGMK =  0.D0
10160       SIGML =  0.D0
10161       SIGMM =  0.D0
10162       DO 1001 I=0,IMAX
10163         PSOFT(I) = 0.D0
10164  1001 CONTINUE
10165       DO 1002 K=0,KMAX
10166         PHARD(K) = 0.D0
10167  1002 CONTINUE
10168       DO 1000 K=0,KMAX
10169         DO 1010 I=0,IMAX
10170           TMP = PROB(IP,IE,I,K)
10171           IF(TMP.LT.0.D0) THEN
10172             IF((IDEB(55).GE.0).AND.(TMP.LT.-EPS)) THEN
10173               WRITE(LO,'(1X,A,4I4,E14.4)')
10174      &          'PHO_PRBDIS: neg.probability:',
10175      &              IP,IE,I,K,PROB(IP,IE,I,K)
10176             ENDIF
10177             PRONEG = PRONEG+TMP
10178             TMP = 0.D0
10179           ENDIF
10180           CHKSUM = CHKSUM+TMP
10181           AVERI = AVERI+DBLE(I)*TMP
10182           AVERK = AVERK+DBLE(K)*TMP
10183           SIGMI = SIGMI+DBLE(I**2)*TMP
10184           SIGMK = SIGMK+DBLE(K**2)*TMP
10185           PSOFT(I) = PSOFT(I)+PROB(IP,IE,I,K)
10186           PHARD(K) = PHARD(K)+PROB(IP,IE,I,K)
10187           PROB(IP,IE,I,K) = CHKSUM
10188  1010   CONTINUE
10189  1000 CONTINUE
10190 C
10191       IF(IDEB(55).GE.1) WRITE(LO,'(/,1X,A,2E15.6)')
10192      &  'PHO_PRBDIS: first sum of probabilities',CHKSUM,PRONEG
10193 C  cut probabilites output
10194       IF(IDEB(55).GE.5) THEN
10195         WRITE(LO,'(/1X,A)') 'list of cut probabilities (uncorr/corr)'
10196         DO 185 I=1,ICHMAX
10197           IF(ABS(PCHAIN(1,I)).GT.1.D-10)
10198      &      WRITE(LO,'(5X,I4,2E12.3)') I,PCHAIN(1,I),PCHAIN(1,I)/CHKSUM
10199  185    CONTINUE
10200       ENDIF
10201 C  rescaling necessary
10202       IF(ABS(CHKSUM-1.D0).GT.1.D-15) THEN
10203         FAC = 1.D0/CHKSUM
10204         IF(IDEB(55).GE.1) WRITE(LO,'(/,1X,A,E15.6)')
10205      &    'PHO_PRBDIS: rescaling of probabilities with factor',FAC
10206         DO 40 K=0,KMAX
10207           DO 50 I=0,IMAX
10208             PROB(IP,IE,I,K) = PROB(IP,IE,I,K)*FAC
10209   50      CONTINUE
10210   40    CONTINUE
10211         AVERI = AVERI*FAC
10212         AVERK = AVERK*FAC
10213         AVERL = AVERL*FAC
10214         AVERM = AVERM*FAC
10215         SIGMI = SIGMI*FAC**2
10216         SIGMK = SIGMK*FAC**2
10217         SIGML = SIGML*FAC**2
10218         SIGMM = SIGMM*FAC**2
10219       ENDIF
10220 C
10221 C  probability to find Reggeon/Pomeron
10222       PROB(IP,IE,0,0) = -SIGREG/(SIGPOM+SIGREG)
10223       AVERJ = -PROB(IP,IE,0,0)*AVERI
10224       AVERII = AVERI-AVERJ
10225 C
10226       SIGTAB(IP,74,IE) = AVERII
10227       SIGTAB(IP,75,IE) = AVERK
10228       SIGTAB(IP,76,IE) = AVERJ
10229 C
10230       SIGTAB(IP,79,IE) = PROB(IP,IE,IMAX,0)*SIGNDF
10231       SIGTAB(IP,80,IE) = SIGNDF-SIGTAB(IP,79,IE)
10232 C
10233       IF(IDEB(55).GE.1) THEN
10234
10235 C  average interaction probabilities
10236         WRITE(LO,'(/1X,A,/1X,A)')
10237      &    'PHO_PRBDIS: expected interaction statistics',
10238      &    '-------------------------------------------'
10239         WRITE(LO,'(1X,A,E12.4,2I3)')
10240      &    'energy,IP,table index:',EPTAB(IP,IE),IP,IE
10241         WRITE(LO,'(1X,A,2I4)') 'current limitations (soft,hard):',
10242      &    IMAX,KMAX
10243         WRITE(LO,'(1X,A,E12.4/,4X,A,/,1X,6E11.3)')
10244      &    'averaged number of cuts per event (eff. cs):',SIGNDF,
10245      &    ' (Pom / Pom-h / Reg / enh-tri-loop / enh-dble / sum):',
10246      &    AVERII,AVERK,AVERJ,AVERL,AVERM,
10247      &    AVERI+AVERK+AVERL+AVERM
10248         WRITE(LO,'(1X,A,/,4X,A,/,1X,4E11.3)')
10249      &    'standard deviation ( sqrt(sigma) ):',
10250      &    ' (Pomeron / Pomeron-h / enh-tri-loop / enh-dble):',
10251      &    SQRT(ABS(SIGMI-AVERI**2)),SQRT(ABS(SIGMK-AVERK**2)),
10252      &    SQRT(ABS(SIGML-AVERL**2)),SQRT(ABS(SIGMM-AVERM**2))
10253         WRITE(LO,'(1X,A)') 'cross section / probability  soft, hard'
10254         DO I=0,MIN(IMAX,KMAX)
10255           WRITE(LO,'(I5,2E12.4,3X,2E12.4)')
10256      &      I,PSOFT(I)*SIGNDF,PSOFT(I),PHARD(I)*SIGNDF,PHARD(I)
10257         ENDDO
10258
10259 C  cross check of probability distribution and inclusive cross section
10260         PSsum_1 = 0.D0
10261         PSsum_2 = 0.D0
10262         PHsum_1 = 0.D0
10263         PHsum_2 = 0.D0
10264         do i=1,IMAX
10265           PSsum_1 = PSsum_1+PSOFT(i)*FAC
10266           PSsum_2 = PSsum_2+PSOFT(i)*FAC*dble(i)
10267         enddo
10268         do k=1,KMAX
10269           PHsum_1 = PHsum_1+PHARD(k)
10270           PHsum_2 = PHsum_2+PHARD(k)*FAC*dble(k)
10271         enddo
10272         WRITE(LO,'(1x,a,2E12.4,3X,2E12.4)') 'sum:',
10273      &    PSsum_2*SIGNDF,PSsum_1,PHsum_2*SIGNDF,PHsum_1
10274
10275       ENDIF
10276
10277       END
10278
10279 *$ CREATE PHO_SAMPRO.FOR
10280 *COPY PHO_SAMPRO
10281 CDECK  ID>, PHO_SAMPRO
10282       SUBROUTINE PHO_SAMPRO(IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB,IPROC)
10283 C***********************************************************************
10284 C
10285 C     routine to sample kind of process
10286 C
10287 C     input:   IP        particle combination
10288 C              IFP1/2    PDG number of particle 1/2
10289 C              ECM       c.m. energy (GeV)
10290 C              PVIR1/2   virtuality of particle 1/2 (GeV**2, positive)
10291 C              SPROB     suppression factor for processes 1-7
10292 C                        due to rapidity gap survival probability
10293 C              IPROC     mode
10294 C                          -2     output of statistics
10295 C                          -1     initialization
10296 C                           0     sampling of process
10297 C
10298 C     output:  IPROC     kind of interaction process:
10299 C                           1  non-diffractive resolved process
10300 C                           2  elastic scattering
10301 C                           3  quasi-elastic rho/omega/phi production
10302 C                           4  central diffraction
10303 C                           5  single diffraction according to IDIFF1
10304 C                           6  single diffraction according to IDIFF2
10305 C                           7  double diffraction
10306 C                           8  single-resolved / direct processes
10307 C
10308 C***********************************************************************
10309       IMPLICIT NONE
10310       SAVE
10311
10312       INTEGER IP,IFP1,IFP2,IPROC
10313       DOUBLE PRECISION ECM,PVIR1,PVIR2,SPROB
10314
10315 C  input/output channels
10316       INTEGER LI,LO
10317       COMMON /POINOU/ LI,LO
10318 C  event debugging information
10319       INTEGER NMAXD
10320       PARAMETER (NMAXD=100)
10321       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
10322      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10323       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
10324      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10325 C  cross sections
10326       INTEGER IPFIL,IFAFIL,IFBFIL
10327       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
10328      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
10329      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
10330      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
10331      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
10332       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
10333      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
10334      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
10335      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
10336      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
10337      &                IPFIL,IFAFIL,IFBFIL
10338 C  model switches and parameters
10339       CHARACTER*8 MDLNA
10340       INTEGER ISWMDL,IPAMDL
10341       DOUBLE PRECISION PARMDL
10342       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
10343 C  general process information
10344       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
10345       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
10346 C  event weights and generated cross section
10347       INTEGER IPOWGC,ISWCUT,IVWGHT
10348       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
10349       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
10350      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
10351
10352       DOUBLE PRECISION PRO,XPROB,SIGSDI,CALLS,SIGSUM,ECMSUM
10353       DIMENSION PRO(8,4),XPROB(8),SIGSDI(2)
10354       DIMENSION CALLS(4),SIGSUM(4),ECMSUM(4)
10355
10356       INTEGER I,K,KMAX
10357       DOUBLE PRECISION DT_RNDM
10358       DOUBLE PRECISION SIGDDI,SIGHD,SIGHR,SIGNDR,XI
10359
10360       IF(IDEB(11).GE.15) WRITE(LO,'(/,1X,A,/5X,I3,2I6,1P4E11.3)')
10361      &  'PHO_SAMPRO: called with IP,IFP1/2,ECM,PVIR1/2,SPROB',
10362      &  IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB
10363
10364       IF(IPROC.GE.0) THEN
10365
10366 C  interpolate cross sections
10367         CALL PHO_CSINT(IP,IFP1,IFP2,-1,-1,ECM,PVIR1,PVIR2)
10368
10369 C  cross check
10370         IF((IP.EQ.1).and.((SPROB.gt.1.D0).or.(SPROB.lt.0.D0))) THEN
10371           WRITE(LO,'(/,1X,A,/5X,I12,I3,2I6,1P4E11.3)')
10372      &      'PHO_SAMPRO: inconsistent gap survival probability',
10373      &      'EVENT,IP,IFP1/2,ECM,PVIR1/2,SPROB:',
10374      &      KEVENT,IP,IFP1,IFP2,ECM,PVIR1,PVIR2,SPROB
10375         ENDIF
10376
10377 C  calculate cumulative probabilities
10378         IF(ISWMDL(1).EQ.3) THEN
10379           IF(ISWMDL(2).GE.1) THEN
10380             SIGSDI(1) = SIGLSD(1)+SIGHSD(1)
10381             SIGSDI(2) = SIGLSD(2)+SIGHSD(2)
10382             SIGDDI    = SIGLDD+SIGHDD
10383             SIGNDR    = SIGINE-SIGVM(0,0)-SIGCDF(0)-SIGDIR
10384      &                - SIGSDI(1)-SIGSDI(2)-SIGDDI
10385             XPROB(1)  = SIGNDR*SPROB*DBLE(IPRON(1,IP))
10386             XPROB(2)  = XPROB(1)+SIGELA*SPROB*DBLE(IPRON(2,IP))
10387             XPROB(3)  = XPROB(2)+SIGVM(0,0)*SPROB*DBLE(IPRON(3,IP))
10388             XPROB(4)  = XPROB(3)+SIGCDF(0)*SPROB*DBLE(IPRON(4,IP))
10389             XPROB(5)  = XPROB(4)+SIGSDI(1)*SPROB*DBLE(IPRON(5,IP))
10390             XPROB(6)  = XPROB(5)+SIGSDI(2)*SPROB*DBLE(IPRON(6,IP))
10391             XPROB(7)  = XPROB(6)+SIGDDI*SPROB*DBLE(IPRON(7,IP))
10392             XPROB(8)  = XPROB(7)+SIGDIR*DBLE(IPRON(8,IP))
10393           ELSE
10394             SIGHR = 0.D0
10395             IF(IPRON(1,IP).EQ.1) SIGHR = SIGHAR
10396             SIGHD = 0.D0
10397             IF(IPRON(8,IP).EQ.1) SIGHD = SIGDIR
10398             XPROB(1) = SIGHR/(SIGHR+SIGHD)
10399             XPROB(2) = XPROB(1)
10400             XPROB(3) = XPROB(1)
10401             XPROB(4) = XPROB(1)
10402             XPROB(5) = XPROB(1)
10403             XPROB(6) = XPROB(1)
10404             XPROB(7) = XPROB(1)
10405             XPROB(8) = XPROB(1)+SIGHD/(SIGHR+SIGHD)
10406           ENDIF
10407
10408           IF(IDEB(11).GE.15) THEN
10409             WRITE(LO,'(1X,A,I3)')
10410      &        'PHO_SAMPRO: partial cross sections for IP',IP
10411             WRITE(LO,'(5X,I3,2X,1PE12.4)') 1,XPROB(1)
10412             DO 240 I=2,8
10413               WRITE(LO,'(5X,I3,2X,1PE12.4)') I,XPROB(I)-XPROB(I-1)
10414  240        CONTINUE
10415           ENDIF
10416
10417         ELSE
10418           WRITE(LO,'(/,1X,A,I4)') 'PHO_SAMPRO:ERROR: unsupported model',
10419      &      ISWMDL(1)
10420           CALL PHO_ABORT
10421         ENDIF
10422
10423         IF(XPROB(8).LT.1.D-20) THEN
10424           IF(IDEB(11).GE.2)
10425      &      WRITE(LO,'(1X,2A,/10X,A,1P3E11.3)') 'PHO_SAMPRO:ERROR: ',
10426      &      'activated processes have vanishing cross section sum',
10427      &      'IP,ECM,SIG_sum:',IP,ECM,XPROB(8)
10428           IPROC = 0
10429           RETURN
10430         ENDIF
10431
10432 C  sample process
10433         XI = DT_RNDM(XI)*XPROB(8)
10434         DO 100 I=1,8
10435           IF(XI.LE.XPROB(I)) GOTO 110
10436  100    CONTINUE
10437  110    CONTINUE
10438         IPROC = MIN(I,8)
10439
10440         CALLS(IP)     = CALLS(IP)+1.D0
10441         PRO(IPROC,IP) = PRO(IPROC,IP)+1.D0
10442         ECMSUM(IP)    = ECMSUM(IP)+ECM
10443         IF(ISWMDL(2).GE.1) THEN
10444           SIGSUM(IP) = SIGSUM(IP)+XPROB(8)
10445         ELSE
10446           SIGSUM(IP) = SIGSUM(IP)+SIGGEN(3)
10447         ENDIF
10448
10449 C  debug output
10450         IF(IDEB(11).GE.5) WRITE(LO,'(1X,A,I3,I12,I4)')
10451      &    'PHO_SAMPRO: IP,CALL,PROC-ID',
10452      &    IP,INT(CALLS(IP)+0.1D0),IPROC
10453
10454 C  statistics initialization
10455       ELSE IF(IPROC.EQ.-1) THEN
10456         DO 260 K=1,4
10457           DO 250 I=1,8
10458             PRO(I,K) = 0.D0
10459  250      CONTINUE
10460           CALLS(K)  = 0.D0
10461           SIGSUM(K) = 0.D0
10462           ECMSUM(K) = 0.D0
10463  260    CONTINUE
10464
10465 C  write out statistics
10466       ELSE IF(IPROC.EQ.-2) THEN
10467         KMAX = 4
10468         IF(ISWMDL(2).EQ.0) KMAX=1
10469         DO 270 K=1,KMAX
10470           IF(CALLS(K).GT.0.5D0) THEN
10471             SIGSUM(K) = SIGSUM(K)/CALLS(K)**2
10472             ECMSUM(K) = ECMSUM(K)/CALLS(K)
10473             IF(IDEB(11).GE.0) THEN
10474               WRITE(LO,'(/,1X,2A,I4,1PE12.3,/,1X,A)')
10475      &          'PHO_SAMPRO: internal process statistics ',
10476      &          '(IP,<Ecm>)',K,ECMSUM(K),
10477      &          '---------------------------------------'
10478               WRITE(LO,'(8X,A)')
10479      &          '        process      sampled    cross section'
10480               IF(ISWMDL(2).GE.1) THEN
10481                 WRITE(LO,'(9(/5X,A,0PF12.0,5X,1PE12.3))')
10482      &            '    all processes',CALLS(K),CALLS(K)*SIGSUM(K),
10483      &            ' nondif.inelastic',PRO(1,K),PRO(1,K)*SIGSUM(K),
10484      &            '          elastic',PRO(2,K),PRO(2,K)*SIGSUM(K),
10485      &            'vmeson production',PRO(3,K),PRO(3,K)*SIGSUM(K),
10486      &            '   double pomeron',PRO(4,K),PRO(4,K)*SIGSUM(K),
10487      &            ' single diffr.(1)',PRO(5,K),PRO(5,K)*SIGSUM(K),
10488      &            ' single diffr.(2)',PRO(6,K),PRO(6,K)*SIGSUM(K),
10489      &            ' double diffract.',PRO(7,K),PRO(7,K)*SIGSUM(K),
10490      &            ' direct processes',PRO(8,K),PRO(8,K)*SIGSUM(K)
10491               ELSE
10492                 WRITE(LO,'(3(/5X,A,0PF12.0,5X,1PE12.3))')
10493      &            '    all processes',CALLS(K),CALLS(K)*SIGSUM(K),
10494      &            '  double resolved',PRO(1,K),PRO(1,K)*SIGSUM(K),
10495      &            ' single res + dir',PRO(8,K),PRO(8,K)*SIGSUM(K)
10496               ENDIF
10497             ENDIF
10498           ENDIF
10499  270    CONTINUE
10500       ENDIF
10501
10502       END
10503
10504 *$ CREATE PHO_SAMPRB.FOR
10505 *COPY PHO_SAMPRB
10506 CDECK  ID>, PHO_SAMPRB
10507       SUBROUTINE PHO_SAMPRB(ECMI,IP,ISAM,JSAM,KSAM)
10508 C********************************************************************
10509 C
10510 C     routine to sample number of cut graphs of different kind
10511 C
10512 C     input:  IP      scattering particle combination
10513 C             ECMI    CMS energy
10514 C             IP      -1         initialization
10515 C                     -2         output of statistics
10516 C                     others     sampling of cuts
10517 C
10518 C     output: ISAM    number of soft Pomerons cut
10519 C             JSAM    number of soft Reggeons cut
10520 C             KSAM    number of hard Pomerons cut
10521 C
10522 C     PHO_PRBDIS has to be called before
10523 C
10524 C********************************************************************
10525       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10526       SAVE
10527
10528 C  input/output channels
10529       INTEGER LI,LO
10530       COMMON /POINOU/ LI,LO
10531 C  event debugging information
10532       INTEGER NMAXD
10533       PARAMETER (NMAXD=100)
10534       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
10535      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10536       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
10537      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10538 C  model switches and parameters
10539       CHARACTER*8 MDLNA
10540       INTEGER ISWMDL,IPAMDL
10541       DOUBLE PRECISION PARMDL
10542       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
10543 C  general process information
10544       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
10545       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
10546 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
10547       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
10548       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
10549       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
10550      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
10551 C  obsolete cut-off information
10552       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
10553       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10554 C  cut probability distribution
10555       INTEGER IEETA1,IIMAX,KKMAX
10556       PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
10557       INTEGER IEEMAX,IMAX,KMAX
10558       REAL PROB
10559       DOUBLE PRECISION EPTAB
10560       COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
10561      &                IEEMAX,IMAX,KMAX
10562 C  global event kinematics and particle IDs
10563       INTEGER IFPAP,IFPAB
10564       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
10565       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
10566 C  cross sections
10567       INTEGER IPFIL,IFAFIL,IFBFIL
10568       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
10569      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
10570      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
10571      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
10572      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
10573       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
10574      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
10575      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
10576      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
10577      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
10578      &                IPFIL,IFAFIL,IFBFIL
10579 C  table of particle indices for recursive PHOJET calls
10580       INTEGER MAXIPX
10581       PARAMETER ( MAXIPX = 100 )
10582       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
10583       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
10584      &                IPOIX1,IPOIX2,IPOIX3
10585
10586       DIMENSION ECMS1(4),ECMS2(4),AVERB(0:3,4),AVERC(0:3,4)
10587
10588 C  sample number of interactions
10589       IF(IP.GE.0) THEN
10590         ITER = 0
10591         ECMX = ECMI
10592         ECMC = ECMI
10593         KLIM = 1
10594         IF((IPAMDL(13).GT.0).AND.(IPROCE.EQ.1).AND.(IPOIX3.EQ.0)) THEN
10595           IF(IPAMDL(16).EQ.0) ECMC = SECM
10596           KLIM = 0
10597         ENDIF
10598
10599 C  sample up to kinematic limits only
10600         IMAX1 = MIN(IMAX,INT(0.4D0*ECMC/PARMDL(161)))
10601         IF(IMAX1.LT.1) THEN
10602           IF(IPAMDL(2).EQ.1) THEN
10603 C  reggeon allowed
10604             ISAM = 0
10605             JSAM = 1
10606             KSAM = 0
10607             AVERB(3,IP) = AVERB(3,IP)+1.D0
10608           ELSE
10609 C  only pomeron even at very low energies
10610             ISAM = 1
10611             JSAM = 0
10612             KSAM = 0
10613             AVERB(1,IP) = AVERB(1,IP)+1.D0
10614           ENDIF
10615           AVERB(0,IP) = AVERB(0,IP)+1.D0
10616           GOTO 150
10617         ENDIF
10618 C  find interpolation factors
10619         IF(ECMX.LE.EPTAB(IP,1)) THEN
10620           I1 = 1
10621           I2 = 1
10622         ELSE IF(ECMX.LT.EPTAB(IP,IEEMAX)) THEN
10623           DO 50 I=2,IEEMAX
10624             IF(ECMX.LE.EPTAB(IP,I)) GOTO 200
10625  50       CONTINUE
10626  200      CONTINUE
10627           I1 = I-1
10628           I2 = I
10629         ELSE
10630           WRITE(LO,'(/1X,A,2E12.3)')
10631      &      'PHO_SAMPRB:too high energy',ECMX,EPTAB(IP,IEEMAX)
10632           CALL PHO_PREVNT(-1)
10633           I1 = IEEMAX
10634           I2 = IEEMAX
10635         ENDIF
10636         FAC2 = 0.D0
10637         IF(I1.NE.I2)
10638      &    FAC2=LOG(ECMX/EPTAB(IP,I1))/LOG(EPTAB(IP,I2)/EPTAB(IP,I1))
10639         FAC1=1.D0-FAC2
10640 C  reggeon probability
10641         PREG = -(PROB(IP,I1,0,0)*FAC1+PROB(IP,I2,0,0)*FAC2)
10642 C  calculate soft suppression factor
10643         IF(IP.EQ.1) FSUPP = PARMDL(35)**2
10644      &         /((PVIRT(1)+PARMDL(35))*(PVIRT(2)+PARMDL(35)))
10645 C
10646  10     CONTINUE
10647         ITER = ITER+1
10648         XI = DT_RNDM(FAC2)
10649         DO 260 KSAM=0,KMAX
10650           DO 270 ISAM=0,IMAX
10651             PRO = PROB(IP,I1,ISAM,KSAM)*FAC1
10652      &           +PROB(IP,I2,ISAM,KSAM)*FAC2
10653             IF(PRO.GT.XI) GOTO 100
10654  270      CONTINUE
10655  260    CONTINUE
10656         ISAM = MIN(IMAX,ISAM)
10657         KSAM = MIN(KMAX,KSAM)
10658
10659  100    CONTINUE
10660
10661         IF(ITER.GT.100) THEN
10662
10663           ISAM = 0
10664           JSAM = 1
10665           KSAM = 0
10666           IF(IDEB(12).GE.3) WRITE(LO,'(1X,A,I10,E11.3,I6)')
10667      &      'PHO_SAMPRB: rejection (EV,ECM,ITER)',KEVENT,ECMX,ITER
10668
10669         ELSE
10670
10671 C  reggeon contribution
10672           JSAM = 0
10673           IF(IPAMDL(2).EQ.1) THEN
10674             DO 90 I=1,ISAM
10675               IF(DT_RNDM(PRO).LT.PREG) JSAM = JSAM+1
10676  90         CONTINUE
10677             ISAM = ISAM-JSAM
10678           ENDIF
10679 C  statistics of bare cuts
10680           IF(ITER.EQ.1) THEN
10681             AVERB(0,IP) = AVERB(0,IP)+1.D0
10682             AVERB(1,IP) = AVERB(1,IP)+DBLE(ISAM)
10683             AVERB(2,IP) = AVERB(2,IP)+DBLE(KSAM)
10684             AVERB(3,IP) = AVERB(3,IP)+DBLE(JSAM)
10685           ENDIF
10686 C  limitation given by field dimensions
10687           IF((2*ISAM+JSAM+3*KSAM).GT.50) GOTO 10
10688
10689           IF(IP.EQ.1) THEN
10690
10691 C  reweight according to virtualities and PDF treatment
10692             IF(IPAMDL(115).GE.1) THEN
10693               IF(KSAM.EQ.0) THEN
10694                 IF(FSUP(1)*FSUP(2).LT.DT_RNDM(ECMI)) GOTO 10
10695               ENDIF
10696             ENDIF
10697
10698 C  reduce number of cuts according to photon virtualities
10699             IF(IPAMDL(114).GE.1) THEN
10700  110          CONTINUE
10701               I = ISAM+JSAM
10702               WGX = FSUPP**I
10703               IF(DT_RNDM(WGX).GT.WGX) THEN
10704                 IF(ISAM+JSAM+KSAM.GT.1) THEN
10705                   IF(JSAM.GT.0) THEN
10706                     JSAM = JSAM-1
10707                     GOTO 110
10708                   ELSE IF(ISAM.GT.0) THEN
10709                     ISAM = ISAM-1
10710                     GOTO 110
10711                   ENDIF
10712                 ENDIF
10713               ENDIF
10714             ENDIF
10715
10716           ENDIF
10717
10718 C  phase space limitation
10719  120      CONTINUE
10720           XM = DBLE(2*ISAM+JSAM)*PARMDL(160+IP)
10721      &        +DBLE(2*KSAM)*PTCUT(IP)
10722           PACC = EXP(PARMDL(9)*(PARMDL(160+IP)-XM)/ECMC)
10723           IF(DT_RNDM(XM).GT.PACC) THEN
10724             IF(ISAM+JSAM+KSAM.GT.1) THEN
10725               IF(JSAM.GT.0) THEN
10726                 JSAM = JSAM-1
10727                 GOTO 120
10728               ELSE IF(ISAM.GT.0) THEN
10729                 ISAM = ISAM-1
10730                 GOTO 120
10731               ELSE IF(KSAM.GT.KLIM) THEN
10732                 KSAM = KSAM-1
10733                 GOTO 120
10734               ENDIF
10735             ENDIF
10736           ENDIF
10737
10738         ENDIF
10739
10740         ISAM = ISAM+JSAM/2
10741         JSAM = MOD(JSAM,2)
10742 C  collect statistics
10743  150    CONTINUE
10744         ECMS1(IP) = ECMS1(IP)+ECMX
10745         ECMS2(IP) = ECMS2(IP)+ECMC
10746         AVERC(0,IP) = AVERC(0,IP)+1.D0
10747         AVERC(1,IP) = AVERC(1,IP)+DBLE(ISAM)
10748         AVERC(2,IP) = AVERC(2,IP)+DBLE(KSAM)
10749         AVERC(3,IP) = AVERC(3,IP)+DBLE(JSAM)
10750 C
10751         IF(IDEB(12).GE.10) WRITE(LO,'(1X,A,2E11.4,3I4)')
10752      &    'PHO_SAMPRB: ECM,I,J,K',ECM,ECMX,ISAM,JSAM,KSAM
10753 C
10754 C  initialize statistics
10755       ELSE IF(IP.EQ.-1) THEN
10756         DO 60 I=1,4
10757           ECMS1(I) = 0.D0
10758           ECMS2(I) = 0.D0
10759           DO 65 K=0,3
10760             AVERB(K,I) = 0.D0
10761             AVERC(K,I) = 0.D0
10762  65       CONTINUE
10763  60     CONTINUE
10764         RETURN
10765 C
10766 C  write out statistics
10767       ELSE IF(IP.EQ.-2) THEN
10768         WRITE(LO,'(2(/1X,A))') 'PHO_SAMPRB: interaction statistics',
10769      &                        '----------------------------------'
10770         DO 70 I=1,4
10771           IF(AVERB(0,I).LT.2.D0) GOTO 75
10772           WRITE(LO,'(1X,A,I3,1P,2E13.3)')
10773      &      'statistics for IP,<Ecm_1>,<Ecm_2>',I,
10774      &      ECMS1(I)/MAX(AVERB(0,I),1.D0),ECMS2(I)/MAX(AVERB(0,I),1.D0)
10775           WRITE(LO,'(5X,A)')
10776      &      'average number of s-pom,h-pom,reg cuts (bare)'
10777           WRITE(LO,'(5X,F12.0,1P3E12.4)') AVERB(0,I),
10778      &      (AVERB(K,I)/AVERB(0,I),K=1,3)
10779           WRITE(LO,'(5X,A)')
10780      &      'average (with energy/virtuality corrections)'
10781           WRITE(LO,'(5X,F12.0,1P3E12.4)') AVERC(0,I),
10782      &      (AVERC(K,I)/AVERC(0,I),K=1,3)
10783
10784  75       CONTINUE
10785  70     CONTINUE
10786         RETURN
10787       ENDIF
10788       END
10789
10790 *$ CREATE PHO_TRIREG.FOR
10791 *COPY PHO_TRIREG
10792 CDECK  ID>, PHO_TRIREG
10793       SUBROUTINE PHO_TRIREG(S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP,VIR2A,
10794      &                     SIGTR,BTR)
10795 C**********************************************************************
10796 C
10797 C     calculation of triple-Pomeron total cross section
10798 C     according to Gribov's Regge theory
10799 C
10800 C     input:        S        squared cms energy
10801 C                   GA       coupling constant to diffractive line
10802 C                   AA       slope related to GA (GeV**-2)
10803 C                   GB       coupling constant to elastic line
10804 C                   BB       slope related to GB (GeV**-2)
10805 C                   DELTA    effective pomeron delta (intercept-1)
10806 C                   ALPHAP   slope of pomeron trajectory (GeV**-2)
10807 C                   GPPP     triple-Pomeron coupling
10808 C                   BPPP     slope related to B0PPP (GeV**-2)
10809 C                   VIR2A    virtuality of particle a (GeV**2)
10810 C                   note: units of all coupling constants are mb**1/2
10811 C
10812 C     output:       SIGTR    total triple-Pomeron cross section
10813 C                   BTR      effective triple-Pomeron slope
10814 C                            (differs from diffractive slope!)
10815 C
10816 C     uses E_i (Exponential-Integral function)
10817 C
10818 C**********************************************************************
10819       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10820       SAVE
10821
10822       PARAMETER (EPS =0.0001D0)
10823
10824 C  input/output channels
10825       INTEGER LI,LO
10826       COMMON /POINOU/ LI,LO
10827 C  event debugging information
10828       INTEGER NMAXD
10829       PARAMETER (NMAXD=100)
10830       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
10831      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10832       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
10833      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10834 C  some constants
10835       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
10836       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
10837      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
10838
10839 C  integration cut-off Sigma_U ( see Nucl.Phys.B97(1975)493 )
10840       SIGU = 2.5
10841 C  integration cut-off Sigma_L (min. squared mass of diff. blob)
10842       SIGL = 5.+VIR2A
10843 C  debug output
10844       IF(IDEB(50).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
10845      &       'PHO_TRIREG: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP ',
10846      &       S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
10847 C
10848       IF(S.LT.5.D0) THEN
10849         SIGTR = 0.D0
10850         BTR = BPPP+BB
10851         RETURN
10852       ENDIF
10853 C  change units of ALPHAP to mb
10854       ALSCA  = ALPHAP*GEV2MB
10855 C
10856 C  cross section
10857       PART1=GA*GB**2*GPPP/(16.*PI*2.*ALSCA)*S**DELTA*
10858      &        EXP(-(BB+BPPP)/(2.*ALPHAP)*DELTA)
10859       PART2=PHO_EXPINT(((BB+BPPP)/(2.*ALPHAP)+LOG(S/SIGL))*DELTA)
10860       PART3=PHO_EXPINT(((BB+BPPP)/(2.*ALPHAP)+LOG(SIGU))*DELTA)
10861 C
10862       SIGTR=PART1*(PART2-PART3)
10863 C
10864 C  slope
10865       PART1 = (BB+BPPP+2.*ALPHAP*LOG(S/SIGL))/
10866      &        (BB+BPPP+2.*ALPHAP*LOG(SIGU))
10867       PART2 = LOG(PART1)
10868       PART1 = 0.5D0*ALPHAP*LOG(1.D0+S/(SIGU*SIGL))/PART2
10869       BTR = (AA+BB/2.D0)/2.D0+BPPP+ALPHAP*LOG(S/4.D0)
10870       BTR = BTR-PART1
10871 C
10872       IF(SIGTR.LT.EPS) SIGTR = 0.D0
10873       IF(BTR.LT.BB)  BTR = BB
10874 C
10875       IF(IDEB(50).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
10876      &  'PHO_TRIREG: ENERGY,SIGTR,BTR ',SQRT(S),SIGTR,BTR
10877       END
10878
10879 *$ CREATE PHO_LOOREG.FOR
10880 *COPY PHO_LOOREG
10881 CDECK  ID>, PHO_LOOREG
10882       SUBROUTINE PHO_LOOREG(S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP,
10883      &                     VIR2A,VIR2B,SIGLO,BLO)
10884 C**********************************************************************
10885 C
10886 C     calculation of loop-Pomeron total cross section
10887 C     according to Gribov's Regge theory
10888 C
10889 C     input:        S        squared cms energy
10890 C                   GA       coupling constant to diffractive line
10891 C                   AA       slope related to GA (GeV**-2)
10892 C                   GB       coupling constant to elastic line
10893 C                   BB       slope related to GB (GeV**-2)
10894 C                   DELTA    effective pomeron delta (intercept-1)
10895 C                   ALPHAP   slope of pomeron trajectory (GeV**-2)
10896 C                   GPPP     triple-Pomeron coupling
10897 C                   BPPP     slope related to B0PPP (GeV**-2)
10898 C                   VIR2A    virtuality of particle a (GeV**2)
10899 C                   VIR2B    virtuality of particle b (GeV**2)
10900 C                   note: units of all coupling constants are mb**1/2
10901 C
10902 C     output:       SIGLO    total loop-Pomeron cross section
10903 C                   BLO      effective loop-Pomeron slope
10904 C                            (differs from double diffractive slope!)
10905 C
10906 C     uses E_i (Exponential-Integral function)
10907 C
10908 C**********************************************************************
10909       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10910       SAVE
10911
10912       PARAMETER (EPS =0.0001D0)
10913
10914 C  input/output channels
10915       INTEGER LI,LO
10916       COMMON /POINOU/ LI,LO
10917 C  event debugging information
10918       INTEGER NMAXD
10919       PARAMETER (NMAXD=100)
10920       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
10921      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10922       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
10923      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
10924 C  some constants
10925       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
10926       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
10927      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
10928
10929 C  integration cut-off Sigma_U ( see Nucl.Phys.B97(1975)493 )
10930       SIGU = 2.5
10931 C  integration cut-off Sigma_L (min. squared mass of diff. blob)
10932       SIGL = 5.+VIR2A+VIR2B
10933 C  debug output
10934       IF(IDEB(51).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
10935      &       'PHO_LOOREG: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP ',
10936      &       S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
10937 C
10938       IF(S.LT.5.D0) THEN
10939         SIGLO = 0.D0
10940         BLO = 2.D0*BPPP
10941         RETURN
10942       ENDIF
10943
10944 C
10945 C  change units of ALPHAP to mb
10946       ALSCA  = ALPHAP*GEV2MB
10947 C
10948 C  cross section
10949       PART1=GA*GB*GPPP**2/(16.*PI*2.*ALSCA)*S**DELTA*
10950      &        EXP(-DELTA*BPPP/ALPHAP)
10951       PARTA=BPPP/ALPHAP+LOG(S/SIGL**2)
10952       PARTB=BPPP/ALPHAP+LOG(SIGU)
10953       SIGLO=PART1*(PARTA*(PHO_EXPINT(PARTA*DELTA)
10954      &                    -PHO_EXPINT(PARTB*DELTA))
10955      &             +EXP(PARTA*DELTA)/DELTA-EXP(PARTB*DELTA)/DELTA
10956      &            )
10957 C
10958 C  slope
10959       PART1 = LOG(ABS(PARTA/PARTB))
10960      &       *(PARTA-LOG(1.D0+S/(SIGL**2*SIGU)))
10961       PART1 = 0.25*ALPHAP*LOG(1.D0+S/(SIGU*SIGL))**2/PART1
10962       BLO = (AA+BB)/2.+2.*BPPP+ALPHAP*LOG(S/4.D0)
10963       BLO = BLO-PART1
10964 C
10965       IF(SIGLO.LT.EPS) SIGLO = 0.D0
10966       IF(BLO.LT.2.D0*BPPP) BLO = 2.D0*BPPP
10967 C
10968       IF(IDEB(51).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
10969      &  'PHO_LOOREG: ENERGY,SIGLO,BLO',SQRT(S),SIGLO,BLO
10970       END
10971
10972 *$ CREATE PHO_TRXPOM.FOR
10973 *COPY PHO_TRXPOM
10974 CDECK  ID>, PHO_TRXPOM
10975       SUBROUTINE PHO_TRXPOM(S,GA,AA,GB,BB,DELTA,ALPHAP,
10976      &                     GPPP,BPPP,SIGDP,BDP)
10977 C**********************************************************************
10978 C
10979 C     calculation of total cross section of two tripe-Pomeron
10980 C     graphs in X configuration according to Gribov's Reggeon field
10981 C     theory
10982 C
10983 C     input:        S        squared cms energy
10984 C                   GA       coupling constant to elastic line 1
10985 C                   AA       slope related to GA (GeV**-2)
10986 C                   GB       coupling constant to elastic line 2
10987 C                   BB       slope related to GB (GeV**-2)
10988 C                   DELTA    effective pomeron delta (intercept-1)
10989 C                   ALPHAP   slope of pomeron trajectory (GeV**-2)
10990 C                   BPPP     triple-Pomeron coupling
10991 C                   BTR      slope related to B0PPP (GeV**-2)
10992 C                   note: units of all coupling constants are mb**1/2
10993 C
10994 C     output:       SIGDP    total cross section for double-Pomeron
10995 C                            scattering
10996 C                   BDP      effective double-Pomeron slope
10997 C
10998 C**********************************************************************
10999       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11000       SAVE
11001
11002       PARAMETER (EPS =0.0001D0)
11003
11004 C  input/output channels
11005       INTEGER LI,LO
11006       COMMON /POINOU/ LI,LO
11007 C  event debugging information
11008       INTEGER NMAXD
11009       PARAMETER (NMAXD=100)
11010       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11011      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11012       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11013      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11014 C  model switches and parameters
11015       CHARACTER*8 MDLNA
11016       INTEGER ISWMDL,IPAMDL
11017       DOUBLE PRECISION PARMDL
11018       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11019 C  some constants
11020       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
11021       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
11022      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
11023
11024       DIMENSION XWGH1(96),XPOS1(96)
11025
11026 C  lower integration cut-off Sigma_L
11027       SIGL = PARMDL(71)**2
11028 C  upper integration cut-off Sigma_U
11029       C = 1.D0-1.D0/PARMDL(70)**2
11030       C = MAX(PARMDL(72),C)
11031       SIGU = (1.D0-C)**2*S
11032 C  integration precision
11033       NGAUS1=16
11034 C
11035 C  debug output
11036       IF(IDEB(52).GE.10) WRITE(LO,'(1X,A,/1X,1P,9E10.3)')
11037      &       'PHO_TRXPOM: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP',
11038      &       S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP
11039 C
11040       IF(SIGU.LE.SIGL) THEN
11041         SIGDP = 0.D0
11042         BDP = AA+BB
11043         RETURN
11044       ENDIF
11045 C
11046 C  cross section
11047 C
11048       XIL = LOG(SIGL)
11049       XIU = LOG(SIGU)
11050       XI = LOG(S)
11051       FAC = (GPPP*GA*GB)**2/(256.D0*PI2)/ALPHAP/GEV2MB**2
11052       ALPHA2 = 2.D0*ALPHAP
11053       ALOC = LOG(1.D0/(1.D0-C))
11054       CALL PHO_GAUSET(XIL,XIU,NGAUS1,XPOS1,XWGH1)
11055       XSUM = 0.D0
11056       DO 100 I1=1,NGAUS1
11057         AMXSQ  = EXP(XPOS1(I1))
11058         ALOSMX = LOG(S/AMXSQ)
11059         ALCSMX = LOG((1.D0-C)*S/AMXSQ)
11060         W = LOG((AA+BPPP+ALPHA2*ALCSMX)/(BB+BPPP+ALPHA2*ALOC))
11061         W = MAX(0.D0,W)
11062         WN=(AA+BB+2.D0*BPPP+ALPHA2*ALOSMX)
11063 C  supercritical part
11064         WSC = AMXSQ**DELTA*(S/AMXSQ)**(2.D0*DELTA)
11065         XSUM = XSUM + W*XWGH1(I1)/WN*WSC
11066  100  CONTINUE
11067       SIGDP = XSUM*FAC
11068 C
11069 C  slope
11070       BDP = 0.5*(AA+BB+BPPP+ALPHAP*XI)
11071 C
11072       IF(IDEB(52).GE.7) WRITE(LO,'(1X,A,1P,3E12.3)')
11073      &  'PHO_TRXPOM: ENERGY,SIGDP,BDP',SQRT(S),SIGDP,BDP
11074       END
11075
11076 *$ CREATE PHO_CHAN2A.FOR
11077 *COPY PHO_CHAN2A
11078 CDECK  ID>, PHO_CHAN2A
11079       SUBROUTINE PHO_CHAN2A(BB)
11080 C***********************************************************************
11081 C
11082 C     simple two channel model to realize low mass diffraction
11083 C     (version A, iteration of triple- and loop-Pomeron)
11084 C
11085 C     input:     BB      impact parameter (mb**1/2)
11086 C
11087 C     output:    /POINT4/
11088 C                AMPEL      elastic amplitude
11089 C                AMPVM(4,4) q-elastic VM production
11090 C                AMLMSD(2)  low mass single diffraction amplitude
11091 C                AMHMSD(2)  high mass single diffraction amplitude
11092 C                AMLMDD     low mass double diffraction amplitude
11093 C                AMHMDD     high mass double diffraction amplitude
11094 C                AMPDP(4)   central diffraction amplitude
11095 C
11096 C***********************************************************************
11097       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11098       SAVE
11099
11100       PARAMETER (DEPS  = 1.D-5,
11101      &           EIGHT = 8.D0)
11102
11103 C  input/output channels
11104       INTEGER LI,LO
11105       COMMON /POINOU/ LI,LO
11106 C  event debugging information
11107       INTEGER NMAXD
11108       PARAMETER (NMAXD=100)
11109       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11110      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11111       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11112      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11113 C  model switches and parameters
11114       CHARACTER*8 MDLNA
11115       INTEGER ISWMDL,IPAMDL
11116       DOUBLE PRECISION PARMDL
11117       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11118 C  some constants
11119       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
11120       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
11121      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
11122 C  complex Born graph amplitudes used for unitarization
11123       COMPLEX*16      AMPEL,AMPVM,AMPSOF,AMPHAR,AMLMSD,AMHMSD,AMLMDD,
11124      &                AMHMDD,AMPDP
11125       COMMON /POINT4/ AMPEL,AMPVM(4,4),AMPSOF,AMPHAR,AMLMSD(2),
11126      &                AMHMSD(2),AMLMDD,AMHMDD,AMPDP(4)
11127 C  unitarized amplitudes for different diffraction channels
11128       DOUBLE PRECISION ZXP,BXP,ZXR,BXR,ZXH,BXH,ZXD,BXD,
11129      &                 ZXT1A,BXT1A,ZXT1B,BXT1B,ZXT2A,BXT2A,ZXT2B,BXT2B,
11130      &                 ZXDPE,BXDPE,ZXDPA,BXDPA,ZXDPB,BXDPB,ZXDPD,BXDPD,
11131      &                 ZXL,BXL
11132       COMMON /POINT5/ ZXP(4,4),BXP(4,4),ZXR(4,4),BXR(4,4),
11133      &                ZXH(4,4),BXH(4,4),ZXD(4,4),BXD(4,4),
11134      &                ZXT1A(4,4),BXT1A(4,4),ZXT1B(4,4),BXT1B(4,4),
11135      &                ZXT2A(4,4),BXT2A(4,4),ZXT2B(4,4),BXT2B(4,4),
11136      &                ZXDPE(4,4),BXDPE(4,4),ZXDPA(4,4),BXDPA(4,4),
11137      &                ZXDPB(4,4),BXDPB(4,4),ZXDPD(4,4),BXDPD(4,4),
11138      &                ZXL(4,4),BXL(4,4)
11139 C  Reggeon phenomenology parameters
11140       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
11141      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
11142       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
11143      &                ALREG,ALREGP,GR(2),B0REG(2),
11144      &                GPPP,GPPR,B0PPP,B0PPR,
11145      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
11146 C  parameters of 2x2 channel model
11147       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
11148       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
11149 C  global event kinematics and particle IDs
11150       INTEGER IFPAP,IFPAB
11151       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
11152       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
11153
11154 C  local variables
11155       DIMENSION  AB(9,4),CHI(4),CHDS(4),CHDH(4),CHDA(4),CHDB(4),
11156      &           CHDD(4),CHDPE(4),CHDPA(4),CHDPB(4),CHDPD(4),
11157      &           AMPCHA(4),EX1CHI(4),EX2CHI(4),ABSUM(4),AMPELA(4,0:9)
11158       DIMENSION CHIFAC(4,4),EXPFAC(4,4),IELTAB(4,4)
11159
11160 C  combinatorical factors
11161       DATA      CHIFAC / 1.D0, 1.D0,-1.D0,-1.D0,
11162      &                   1.D0,-1.D0, 1.D0,-1.D0,
11163      &                   1.D0,-1.D0,-1.D0, 1.D0,
11164      &                   1.D0, 1.D0, 1.D0, 1.D0 /
11165       DATA      EXPFAC / 1.D0, 1.D0, 1.D0, 1.D0,
11166      &                   1.D0,-1.D0,-1.D0, 1.D0,
11167      &                  -1.D0, 1.D0,-1.D0, 1.D0,
11168      &                  -1.D0,-1.D0, 1.D0, 1.D0 /
11169       DATA      IELTAB / 1, 2, 3, 4,
11170      &                   2, 1, 4, 3,
11171      &                   3, 4, 1, 2,
11172      &                   4, 3, 2, 1 /
11173
11174       IF(IDEB(86).GE.20) WRITE(LO,'(1X,A,E12.3)')
11175      &  'PHO_CHAN2A: impact parameter B',BB
11176
11177       B24 = BB**2/4.D0
11178       DO 25 I=1,4
11179         AB(1,I) = ZXP(1,I)*EXP(-B24/BXP(1,I))
11180      &           +ZXR(1,I)*EXP(-B24/BXR(1,I))
11181         AB(2,I) = ZXH(1,I)*EXP(-B24/BXH(1,I))
11182         AB(3,I) =-ZXT1A(1,I)*EXP(-B24/BXT1A(1,I))
11183         AB(4,I) =-ZXT2A(1,I)*EXP(-B24/BXT2A(1,I))
11184         AB(5,I) =-ZXL(1,I)*EXP(-B24/BXL(1,I))
11185      &           -ZXT1B(1,I)*EXP(-B24/BXT1B(1,I))
11186      &           -ZXT2B(1,I)*EXP(-B24/BXT2B(1,I))
11187         AB(6,I) = ZXDPE(1,I)*EXP(-B24/BXDPE(1,I))
11188         AB(7,I) = ZXDPA(1,I)*EXP(-B24/BXDPA(1,I))
11189         AB(8,I) = ZXDPB(1,I)*EXP(-B24/BXDPB(1,I))
11190         AB(9,I) = ZXDPD(1,I)*EXP(-B24/BXDPD(1,I))
11191  25   CONTINUE
11192
11193       DO 50 I=1,4
11194         ABSUM(I)  = 0.D0
11195         DO 75 II=9,1,-1
11196           ABSUM(I) = ABSUM(I) + AB(II,I)
11197  75     CONTINUE
11198  50   CONTINUE
11199       IF(IDEB(86).GE.20) WRITE(LO,'(1X,A,4E12.3)')
11200      &  'PHO_CHAN2A: ABSUM',ABSUM
11201
11202       DO 100 I=1,4
11203         CHI(I)  = 0.D0
11204         CHDS(I) = 0.D0
11205         CHDH(I) = 0.D0
11206         CHDA(I) = 0.D0
11207         CHDB(I) = 0.D0
11208         CHDD(I) = 0.D0
11209         CHDPE(I) = 0.D0
11210         CHDPA(I) = 0.D0
11211         CHDPB(I) = 0.D0
11212         CHDPD(I) = 0.D0
11213         AMPELA(I,0) = 0.D0
11214         AMPELA(I,9) = 0.D0
11215         DO 200 K=1,4
11216           AMPELA(I,K) = 0.D0
11217           AMPELA(I,K+4) = 0.D0
11218           AMPVM(I,K)  = 0.D0
11219           CHI(I)  = CHI(I)  + CHIFAC(K,I)*ABSUM(K)
11220           CHDS(I) = CHDS(I) + CHIFAC(K,I)*AB(1,K)
11221           CHDH(I) = CHDH(I) + CHIFAC(K,I)*AB(2,K)
11222           CHDA(I) = CHDA(I) + CHIFAC(K,I)*AB(3,K)
11223           CHDB(I) = CHDB(I) + CHIFAC(K,I)*AB(4,K)
11224           CHDD(I) = CHDD(I) + CHIFAC(K,I)*AB(5,K)
11225           CHDPE(I) = CHDPE(I) + CHIFAC(K,I)*AB(6,K)
11226           CHDPA(I) = CHDPA(I) + CHIFAC(K,I)*AB(7,K)
11227           CHDPB(I) = CHDPB(I) + CHIFAC(K,I)*AB(8,K)
11228           CHDPD(I) = CHDPD(I) + CHIFAC(K,I)*AB(9,K)
11229  200    CONTINUE
11230         IF(CHI(I).LT.-DEPS) THEN
11231           IF(IDEB(86).GE.0) THEN
11232             WRITE(LO,'(1X,A,I3,2E12.3)')
11233      &        'PHO_CHAN2A: neg.eigenvalue (I,B,CHI)',I,BB,CHI(I)
11234             WRITE(LO,'(5X,A,5E12.3)') 'E,CHIs:',ECM,(ABSUM(K),K=1,4)
11235           ENDIF
11236         ENDIF
11237         IF(ABS(CHI(I)).GT.200.D0) THEN
11238           EX1CHI(I) = 0.D0
11239           EX2CHI(I) = 0.D0
11240         ELSE
11241           TMP       = EXP(-CHI(I))
11242           EX1CHI(I) = TMP
11243           EX2CHI(I) = TMP*TMP
11244         ENDIF
11245  100  CONTINUE
11246       IF(IDEB(86).GE.20) THEN
11247         WRITE(LO,'(1X,A,4E12.3)') 'PHO_CHAN2A: EX1CHI',EX1CHI
11248       ENDIF
11249
11250       AMPELA(1,0) = 4.D0
11251       DO 300 K=1,4
11252         DO 400 J=1,4
11253           CFAC = 2.D0*EXPFAC(J,K)*EX2CHI(J)
11254           AMPELA(K,0) = AMPELA(K,0) - EXPFAC(J,K)*EX1CHI(J)
11255           AMPELA(K,1) = AMPELA(K,1) + CFAC*CHDS(J)
11256           AMPELA(K,2) = AMPELA(K,2) + CFAC*CHDH(J)
11257           AMPELA(K,3) = AMPELA(K,3) - CFAC*CHDA(J)
11258           AMPELA(K,4) = AMPELA(K,4) - CFAC*CHDB(J)
11259           AMPELA(K,5) = AMPELA(K,5) - CFAC*CHDD(J)
11260           AMPELA(K,6) = AMPELA(K,6) + CFAC*CHDPE(J)
11261           AMPELA(K,7) = AMPELA(K,7) + CFAC*CHDPA(J)
11262           AMPELA(K,8) = AMPELA(K,8) + CFAC*CHDPB(J)
11263           AMPELA(K,9) = AMPELA(K,9) + CFAC*CHDPD(J)
11264  400    CONTINUE
11265  300  CONTINUE
11266
11267       IF(IDEB(86).GE.25) THEN
11268         DO 305 I=1,9
11269           WRITE(LO,'(1X,A,I3,4E10.3)') 'PHO_CHAN2A: AMPELA(1-4,I)',I,
11270      &      (AMPELA(K,1),K=1,4)
11271  305    CONTINUE
11272       ENDIF
11273
11274 C  VDM factors --> amplitudes
11275 C  low mass excitations
11276       DO 500 I=1,4
11277         AMPCHA(I) = 0.D0
11278         DO 600 K=1,4
11279           AMPCHA(I) = AMPCHA(I) + AMPFAC(K)*AMPELA(IELTAB(K,I),0)
11280  600    CONTINUE
11281  500  CONTINUE
11282       AMPVME    = AMPCHA(1)/EIGHT
11283       AMLMSD(1) = AMPCHA(2)/EIGHT
11284       AMLMSD(2) = AMPCHA(3)/EIGHT
11285       AMLMDD    = AMPCHA(4)/EIGHT
11286 C  elastic part, high mass diffraction
11287       AMPEL = 0.5D0*ZXD(1,1)*EXP(-B24/BXD(1,1))
11288       AMPSOF    = 0.D0
11289       AMPHAR    = 0.D0
11290       AMHMSD(1) = 0.D0
11291       AMHMSD(2) = 0.D0
11292       AMHMDD    = 0.D0
11293       AMPDP(1)  = 0.D0
11294       AMPDP(2)  = 0.D0
11295       AMPDP(3)  = 0.D0
11296       AMPDP(4)  = 0.D0
11297       DO 450 I=1,4
11298         AMPEL     = AMPEL     + ELAFAC(I)*AMPELA(I,0)/8.D0
11299         AMPSOF    = AMPSOF    + ELAFAC(I)*AMPELA(I,1)
11300         AMPHAR    = AMPHAR    + ELAFAC(I)*AMPELA(I,2)
11301         AMHMSD(1) = AMHMSD(1) + ELAFAC(I)*AMPELA(I,3)
11302         AMHMSD(2) = AMHMSD(2) + ELAFAC(I)*AMPELA(I,4)
11303         AMHMDD    = AMHMDD    + ELAFAC(I)*AMPELA(I,5)
11304         AMPDP(1)  = AMPDP(1)  + ELAFAC(I)*AMPELA(I,6)
11305         AMPDP(2)  = AMPDP(2)  + ELAFAC(I)*AMPELA(I,7)
11306         AMPDP(3)  = AMPDP(3)  + ELAFAC(I)*AMPELA(I,8)
11307         AMPDP(4)  = AMPDP(4)  + ELAFAC(I)*AMPELA(I,9)
11308  450  CONTINUE
11309       AMPSOF    = AMPSOF/16.D0
11310       AMPHAR    = AMPHAR/16.D0
11311       AMHMSD(1) = AMHMSD(1)/16.D0
11312       AMHMSD(2) = AMHMSD(2)/16.D0
11313       AMHMDD    = AMHMDD/16.D0
11314       AMPDP(1)  = AMPDP(1)/16.D0
11315       AMPDP(2)  = AMPDP(2)/16.D0
11316       AMPDP(3)  = AMPDP(3)/16.D0
11317       AMPDP(4)  = AMPDP(4)/16.D0
11318       IF(DREAL(AMHMSD(1)).LE.0.D0) AMHMSD(1) = 0.D0
11319       IF(DREAL(AMHMSD(2)).LE.0.D0) AMHMSD(2) = 0.D0
11320       IF(DREAL(AMHMDD).LE.0.D0)    AMHMDD = 0.D0
11321       IF(DREAL(AMPDP(1)).LE.0.D0) AMPDP(1) = 0.D0
11322       IF(DREAL(AMPDP(2)).LE.0.D0) AMPDP(2) = 0.D0
11323       IF(DREAL(AMPDP(3)).LE.0.D0) AMPDP(3) = 0.D0
11324       IF(DREAL(AMPDP(4)).LE.0.D0) AMPDP(4) = 0.D0
11325
11326 C  vector-meson production, weight factors
11327       IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22)) THEN
11328         IF(IFPAP(1).EQ.22) THEN
11329           IF(IFPAP(2).EQ.22) THEN
11330             DO 10 I=1,4
11331               DO 15 J=1,4
11332                 AMPVM(I,J) = PARMDL(9+I)*PARMDL(9+J)*AMPVME
11333  15           CONTINUE
11334  10         CONTINUE
11335           ELSE
11336             AMPVM(1,1) = PARMDL(10)*AMPVME
11337             AMPVM(2,1) = PARMDL(11)*AMPVME
11338             AMPVM(3,1) = PARMDL(12)*AMPVME
11339             AMPVM(4,1) = PARMDL(13)*AMPVME
11340           ENDIF
11341         ELSE IF(IFPAP(2).EQ.22) THEN
11342           AMPVM(1,1) = PARMDL(10)*AMPVME
11343           AMPVM(1,2) = PARMDL(11)*AMPVME
11344           AMPVM(1,3) = PARMDL(12)*AMPVME
11345           AMPVM(1,4) = PARMDL(13)*AMPVME
11346         ENDIF
11347       ENDIF
11348 C  debug output
11349       IF(IDEB(86).GE.5) THEN
11350         WRITE(LO,'(/,1X,A)')
11351      &    'PHO_CHAN2A: impact parameter amplitudes'
11352         WRITE(LO,'(1X,A,1P,2E12.3)') '       AMPEL',AMPEL
11353         WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(1,1-4)',(AMPVM(1,K),K=1,4)
11354         WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(2,1-4)',(AMPVM(2,K),K=1,4)
11355         WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(3,1-4)',(AMPVM(3,K),K=1,4)
11356         WRITE(LO,'(1X,A,1P,8E10.3)') 'AMPVM(4,1-4)',(AMPVM(4,K),K=1,4)
11357         WRITE(LO,'(1X,A,1P,4E12.3)') '  AMPSOF/HAR',AMPSOF,AMPHAR
11358         WRITE(LO,'(1X,A,1P,4E12.3)') '      AMLMSD',AMLMSD
11359         WRITE(LO,'(1X,A,1P,4E12.3)') '      AMHMSD',AMHMSD
11360         WRITE(LO,'(1X,A,1P,2E12.3)') '      AMLMDD',AMLMDD
11361         WRITE(LO,'(1X,A,1P,2E12.3)') '      AMHMDD',AMHMDD
11362         WRITE(LO,'(1X,A,1P,8E10.3)') '  AMPDP(1-4)',AMPDP
11363       ENDIF
11364
11365       END
11366
11367 *$ CREATE PHO_EVENT.FOR
11368 *COPY PHO_EVENT
11369 CDECK  ID>, PHO_EVENT
11370       SUBROUTINE PHO_EVENT(NEV,P1,P2,FAC,IREJ)
11371 C********************************************************************
11372 C
11373 C     main subroutine to manage simulation processes
11374 C
11375 C     input: NEV       -1   initialization
11376 C                       1   generation of events
11377 C                       2   generation of events without rejection
11378 C                           due to energy dependent cross section
11379 C                       3   generation of events without rejection
11380 C                           using initialization energy
11381 C                      -2   output of event generation statistics
11382 C            P1(4)     momentum of particle 1 (internal TARGET)
11383 C            P2(4)     momentum of particle 2 (internal PROJECTILE)
11384 C            FAC       used for initialization:
11385 C                      contains cross section the events corresponds to
11386 C                      during generation: current cross section
11387 C
11388 C     output: IREJ     0: event accepted
11389 C                      1: event rejected
11390 C
11391 C********************************************************************
11392       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11393       SAVE
11394
11395       PARAMETER ( TINY   =  1.D-10 )
11396
11397       DIMENSION P1(4),P2(4)
11398
11399 C  input/output channels
11400       INTEGER LI,LO
11401       COMMON /POINOU/ LI,LO
11402 C  event debugging information
11403       INTEGER NMAXD
11404       PARAMETER (NMAXD=100)
11405       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11406      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11407       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11408      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11409 C  model switches and parameters
11410       CHARACTER*8 MDLNA
11411       INTEGER ISWMDL,IPAMDL
11412       DOUBLE PRECISION PARMDL
11413       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11414 C  general process information
11415       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
11416       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
11417 C  internal rejection counters
11418       INTEGER NMXJ
11419       PARAMETER (NMXJ=60)
11420       CHARACTER*10 REJTIT
11421       INTEGER IFAIL
11422       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
11423 C  gamma-lepton or gamma-hadron vertex information
11424       INTEGER IGHEL,IDPSRC,IDBSRC
11425       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
11426      &                 RADSRC,AMSRC,GAMSRC
11427       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
11428      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
11429      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
11430 C  global event kinematics and particle IDs
11431       INTEGER IFPAP,IFPAB
11432       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
11433       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
11434 C  cross sections
11435       INTEGER IPFIL,IFAFIL,IFBFIL
11436       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
11437      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
11438      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
11439      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
11440      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
11441       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
11442      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
11443      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
11444      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
11445      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
11446      &                IPFIL,IFAFIL,IFBFIL
11447 C  event weights and generated cross section
11448       INTEGER IPOWGC,ISWCUT,IVWGHT
11449       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
11450       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
11451      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
11452 C  names of hard scattering processes
11453       INTEGER Max_pro_1
11454       PARAMETER ( Max_pro_1 = 16 )
11455       CHARACTER*18 PROC
11456       COMMON /POHPRO/ PROC(0:Max_pro_1)
11457 C  hard cross sections and MC selection weights
11458       INTEGER Max_pro_2
11459       PARAMETER ( Max_pro_2 = 16 )
11460       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
11461      &  MH_acc_1,MH_acc_2
11462       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
11463       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
11464      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
11465      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
11466      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
11467      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
11468 C  table of particle indices for recursive PHOJET calls
11469       INTEGER MAXIPX
11470       PARAMETER ( MAXIPX = 100 )
11471       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
11472       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
11473      &                IPOIX1,IPOIX2,IPOIX3
11474
11475       DIMENSION IPRSAM(10),IPRACC(10),IENACC(10),IDNS(4),IDNA(4)
11476
11477       IREJ = 0
11478
11479 C  initializations
11480       IF(NEV.EQ.-1) THEN
11481         WRITE(LO,'(/3(/1X,A))')
11482      &    '=======================================================',
11483      &    '  ------- initialization of event generation --------',
11484      &    '======================================================='
11485         CALL PHO_SETMDL(0,0,-2)
11486 C  amplitude parameters
11487         CALL PHO_FITPAR(1)
11488         CALL PHO_REJSTA(-1)
11489 C  initialize MC package
11490         CALL PHO_EVEINI(1,P1,P2,JM1,JM2)
11491         CALL PHO_MCINI
11492         CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
11493      &    0.D0,-1)
11494         CALL PHO_PARTON(-1,0,0,P1,P2,IREJ)
11495 C  cross section
11496         FAC = SIGGEN(4)
11497         DO 20 I=1,10
11498           IPRSAM(I) = 0
11499           IPRACC(I) = 0
11500           IENACC(I) = 0
11501  20     CONTINUE
11502         ISPS = 0
11503         ISPA = 0
11504         ISRS = 0
11505         ISRA = 0
11506         IHPS = 0
11507         IHPA = 0
11508         ISTS = 0
11509         ISTA = 0
11510         ISLS = 0
11511         ISLA = 0
11512         IDIS = 0
11513         IDIA = 0
11514         IDPS = 0
11515         IDPA = 0
11516         IDNS(1) = 0
11517         IDNS(2) = 0
11518         IDNS(3) = 0
11519         IDNS(4) = 0
11520         IDNA(1) = 0
11521         IDNA(2) = 0
11522         IDNA(3) = 0
11523         IDNA(4) = 0
11524         KACCEP = 0
11525         KEVENT = 0
11526         KEVGEN = 0
11527         ECMSUM = 0.D0
11528       ELSE IF(NEV.GT.0) THEN
11529 C
11530 C  -------------- begin event generation ---------------
11531 C
11532         IPAMDL(13) = 0
11533         IF(NEV.EQ.3) IPAMDL(13) = 1
11534         KEVENT = KEVENT+1
11535 C  enable debugging
11536         CALL PHO_TRACE(0,0,0)
11537         IF(IDEB(68).GE.2) THEN
11538           IF((MOD(KEVENT,50).EQ.0).OR.(IDEB(68).GE.3))
11539      &      WRITE(LO,'(1X,A,2I12)') 'call to PHO_EVENT no',KEVENT,KACCEP
11540         ENDIF
11541         CALL PHO_EVEINI(0,P1,P2,JM1,JM2)
11542 C  cross section calculation
11543         FAC = SIGGEN(3)
11544         IF(NEV.EQ.1) THEN
11545           IF(IVWGHT(1).EQ.1) THEN
11546             WG = EVWGHT(1)*SIGGEN(3)/SIGGEN(4)
11547           ELSE
11548             WG = SIGGEN(3)/SIGGEN(4)
11549           ENDIF
11550           IF(DT_RNDM(FAC).GT.WG) THEN
11551             IREJ = 1
11552             IF(IDEB(68).GE.6) THEN
11553               WRITE(LO,'(1X,2A,/5X,2I10,6X,1P3E10.3)')
11554      &          'PHO_EVENT: rejection due to cross section',
11555      &          ' (CALL/ACC/EVWGHT(1)/SIG/SIGMAX)',
11556      &          KEVENT,KACCEP,EVWGHT(1),SIGGEN(3),SIGGEN(4)
11557               CALL PHO_PREVNT(-1)
11558             ENDIF
11559             RETURN
11560           ENDIF
11561         ENDIF
11562         KEVGEN = KEVGEN+1
11563         SIGGEN(1) = SIGGEN(4)*DBLE(KEVGEN)/DBLE(KEVENT)
11564         HSWGHT(0) = MAX(1.D0,WG)
11565
11566         ITRY1 = 0
11567  50     CONTINUE
11568           ITRY1 = ITRY1+1
11569           IF(ITRY1.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
11570
11571 C  sample process
11572           IPROCE = 0
11573           CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
11574      &      1.D0,IPROCE)
11575           IF(IPROCE.EQ.0) THEN
11576             IF(IDEB(68).GE.4) WRITE(LO,'(1X,A)') 'PHO_EVENT: ',
11577      &        'rejection by PHO_SAMPRO (call,Ecm)',KEVENT,ECM
11578             IREJ = 50
11579             RETURN
11580           ENDIF
11581 C  sampling statistics
11582           IPRSAM(IPROCE) = IPRSAM(IPROCE)+1
11583
11584           ITRY2 = 0
11585  60       CONTINUE
11586             ITRY2 = ITRY2+1
11587             IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
11588 C  sample number of cut graphs according to IPROCE and
11589 C  generate parton configurations+strings
11590             CALL PHO_PARTON(IPROCE,JM1,JM2,P1,P2,IREJ)
11591 C  collect statistics
11592             ISPS = ISPS+KSPOM
11593             IHPS = IHPS+KHPOM
11594             ISRS = ISRS+KSREG
11595             ISTS = ISTS+KSTRG+KHTRG
11596             ISLS = ISLS+KSLOO+KHLOO
11597             IDIS = IDIS+MIN(KHDIR,1)
11598             IDPS = IDPS+KHDPO+KSDPO
11599             IF((IDIFR1+IDIFR2+IDDPOM.EQ.0).AND.(KHDIR.GT.0))
11600      &        IDNS(KHDIR) = IDNS(KHDIR)+1
11601 C  rejection?
11602           IF(IREJ.NE.0) THEN
11603             IF(IDEB(68).GE.4) THEN
11604               WRITE(LO,'(/1X,A,2I5)')
11605      &          'PHO_EVENT: rejection by PHO_PARTON',ITRY2,IREJ
11606               CALL PHO_PREVNT(-1)
11607             ENDIF
11608             IF((IREJ.EQ.50).AND.(NEV.EQ.1)) THEN
11609               RETURN
11610             ENDIF
11611             IFAIL(1) = IFAIL(1)+1
11612             IF(ITRY1.GT.5) RETURN
11613             IF(IREJ.GE.5) THEN
11614               IF(ISWMDL(2).EQ.0) RETURN
11615               GOTO 50
11616             ENDIF
11617             IF(ITRY2.LT.5) GOTO 60
11618             GOTO 50
11619           ENDIF
11620 C  fragmentation of strings
11621 C  FSR and string fragmentation is done separately by DPMJET routines
11622 C         CALL PHO_STRFRA(IREJ)
11623 C  rejection?
11624           IF(IREJ.NE.0) THEN
11625             IFAIL(23) = IFAIL(23)+1
11626             IF(IDEB(68).GE.4)  THEN
11627               WRITE(LO,'(/1X,A,2I5)')
11628      &          'PHO_EVENT: rejection by PHO_STRFRA',ITRY2,IREJ
11629               CALL PHO_PREVNT(-1)
11630             ENDIF
11631             GOTO 50
11632           ENDIF
11633 C  check of conservation of quantum numbers
11634           IF(IDEB(68).GE.-5) THEN
11635             CALL PHO_CHECK(-1,IREJ)
11636             IF(IREJ.NE.0) GOTO 50
11637           ENDIF
11638 C  event now completely processed and accepted
11639 C  acceptance statistics
11640           IPRACC(IPROCE) = IPRACC(IPROCE)+1
11641           ISPA = ISPA+KSPOM
11642           IHPA = IHPA+KHPOM
11643           ISRA = ISRA+KSREG
11644           ISTA = ISTA+(KSTRG+KHTRG)
11645           ISLA = ISLA+(KSLOO+KHLOO)
11646           IDIA = IDIA+MIN(KHDIR,1)
11647           IDPA = IDPA+KHDPO+KSDPO
11648           IF((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GT.0))
11649      &      IDNA(KHDIR) = IDNA(KHDIR)+1
11650           DO 55 I=1,IPOIX2
11651             IENACC(IPORES(I)) = IENACC(IPORES(I))+1
11652  55       CONTINUE
11653           KACCEP = KACCEP+1
11654
11655 C  debug output (partial / full event listing)
11656           if((IDEB(68).eq.1).and.(MOD(KACCEP,50).EQ.0))
11657      &      WRITE(LO,'(1X,A,2I12)') 'call to PHO_EVENT no',KEVENT,KACCEP
11658           IF(IDEB(67).GE.10) THEN
11659             IF(IDEB(67).LE.15) THEN
11660               CALL PHO_PREVNT(-1)
11661             ELSE IF(IDEB(67).LE.20) THEN
11662               CALL PHO_PREVNT(0)
11663             ELSE IF(IDEB(67).LE.25) THEN
11664               CALL PHO_PREVNT(1)
11665             ELSE
11666               CALL PHO_PREVNT(2)
11667             ENDIF
11668           ENDIF
11669 C
11670 C  effective weight
11671           DO 65 I=1,10
11672             IF(IPOWGC(I).GT.0) THEN
11673               HSWGHT(0) = HSWGHT(0)*HSWGHT(I)
11674             ENDIF
11675  65       CONTINUE
11676           IF(IVWGHT(1).EQ.1) THEN
11677             WG = HSWGHT(0)
11678             IF(WG.GT.1.01D0) THEN
11679               IF(EVWGHT(1).LT.1.01D0) THEN
11680                 WRITE(LO,'(1X,A,2I12,1PE12.3)')
11681      &            'PHO_EVENT: cross section weight > 1',
11682      &            KEVENT,KACCEP,WG
11683                 WRITE(LO,'(5X,A,1P3E11.3)') 'SIGCUR,SIGMAX,EVWGHT(1):',
11684      &            SIGGEN(3),SIGGEN(4),EVWGHT(1)
11685               ENDIF
11686               EVWGHT(1) = HSWGHT(0)
11687               HSWGHT(0) = 1.D0
11688             ELSE
11689               EVWGHT(1) = 1.D0
11690             ENDIF
11691           ENDIF
11692
11693 C  effective cross section
11694           SIGGEN(2) = SIGGEN(4)*DBLE(KACCEP)/DBLE(KEVENT)
11695           ECMSUM = ECMSUM+ECM
11696           SIGGEN(3) = SIGGEN(3)*HSWGHT(0)
11697       ELSE IF(NEV.EQ.-2) THEN
11698
11699 C  ---------------- end of event generation ----------------------
11700
11701         WRITE(LO,'(/3(/1X,A),//1X,A,3I12,/1X,A,F12.1)')
11702      &    '====================================================',
11703      &    '  --------- summary of event generation ----------',
11704      &    '====================================================',
11705      &    'called,generated,accepted events:',KEVENT,KEVGEN,KACCEP,
11706      &    'average CMS energy:',ECMSUM/DBLE(MAX(1,KACCEP))
11707
11708 C  write out statistics
11709         IF(KACCEP.GT.0) THEN
11710
11711           FAC1 = SIGGEN(4)/DBLE(KEVENT)
11712           FAC2 = FAC/DBLE(KACCEP)
11713           WRITE(LO,'(/1X,A,/1X,A)')
11714      &      'PHO_EVENT: generated and accepted events',
11715      &      '----------------------------------------'
11716           WRITE(LO,'(3X,A)')
11717      &   'process, sampled, accepted, cross section (internal/external)'
11718           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'non.diff.',IPRSAM(1),
11719      &      IPRACC(1),DBLE(IPRACC(1))*FAC1,DBLE(IPRACC(1))*FAC2
11720           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'elas sca.',IPRSAM(2),
11721      &      IPRACC(2),DBLE(IPRACC(2))*FAC1,DBLE(IPRACC(2))*FAC2
11722           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'qela sca.',IPRSAM(3),
11723      &      IPRACC(3),DBLE(IPRACC(3))*FAC1,DBLE(IPRACC(3))*FAC2
11724           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.pom.',IPRSAM(4),
11725      &      IPRACC(4),DBLE(IPRACC(4))*FAC1,DBLE(IPRACC(4))*FAC2
11726           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'diff.par1',IPRSAM(5),
11727      &      IPRACC(5),DBLE(IPRACC(5))*FAC1,DBLE(IPRACC(5))*FAC2
11728           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'diff.par2',IPRSAM(6),
11729      &      IPRACC(6),DBLE(IPRACC(6))*FAC1,DBLE(IPRACC(6))*FAC2
11730           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.dif.',IPRSAM(7),
11731      &      IPRACC(7),DBLE(IPRACC(7))*FAC1,DBLE(IPRACC(7))*FAC2
11732           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir all  ',IPRSAM(8),
11733      &      IPRACC(8),DBLE(IPRACC(8))*FAC1,DBLE(IPRACC(8))*FAC2
11734           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir X res',IDNS(1),IDNA(1),
11735      &      DBLE(IDNA(1))*FAC1,DBLE(IDNA(1))*FAC2
11736           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'res X dir',IDNS(2),IDNA(2),
11737      &      DBLE(IDNA(2))*FAC1,DBLE(IDNA(2))*FAC2
11738           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'dir X dir',IDNS(3),IDNA(3),
11739      &      DBLE(IDNA(3))*FAC1,DBLE(IDNA(3))*FAC2
11740           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'soft pom.',ISPS,ISPA,
11741      &      DBLE(ISPA)*FAC1,DBLE(ISPA)*FAC2
11742           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'hard pom.',IHPS,IHPA,
11743      &      DBLE(IHPA)*FAC1,DBLE(IHPA)*FAC2
11744           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'soft reg.',ISRS,ISRA,
11745      &      DBLE(ISRA)*FAC1,DBLE(ISRA)*FAC2
11746           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'enh. trg.',ISTS,ISTA,
11747      &      DBLE(ISTA)*FAC1,DBLE(ISTA)*FAC2
11748           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'enh. log.',ISLS,ISLA,
11749      &      DBLE(ISLA)*FAC1,DBLE(ISLA)*FAC2
11750           WRITE(LO,'(3X,A,2I12,1P2E13.3)') 'doub.pom.',IDPS,IDPA,
11751      &      DBLE(IDPA)*FAC1,DBLE(IDPA)*FAC2
11752           IF(ISWMDL(14).GT.0) THEN
11753             WRITE(LO,'(3X,A,I3)') 'recursive pomeron splitting:',
11754      &        ISWMDL(14)
11755             WRITE(LO,'(5X,A,I12)') '1->2pom-cut :',IENACC(8)
11756             WRITE(LO,'(5X,A,I12)') '1->doub-pom :',IENACC(4)
11757             WRITE(LO,'(5X,A,I12)') '1->diff-dis1:',IENACC(5)
11758             WRITE(LO,'(5X,A,I12)') '1->diff-dis2:',IENACC(6)
11759             WRITE(LO,'(5X,A,I12)') '1->doub-diff:',IENACC(7)
11760           ENDIF
11761           WRITE(LO,'(2(/1X,A,1PE12.3)/)') ' sampled cross section (mb)',
11762      &      SIGGEN(1),'accepted cross section (mb)',SIGGEN(2)
11763
11764           CALL PHO_REJSTA(-2)
11765           CALL PHO_SAMPRO(1,IFPAP(1),IFPAP(2),ECM,PVIRT(1),PVIRT(2),
11766      &      0.D0,-2)
11767           CALL PHO_PARTON(-2,0,0,P1,P2,IREJ)
11768 C  statistics of hard scattering processes
11769           WRITE(LO,'(2(/1X,A))')
11770      &      'PHO_EVENT: statistics of hard scattering processes',
11771      &      '--------------------------------------------------'
11772           DO 43 K=1,4
11773             IF(MH_tried(0,K).GT.0) THEN
11774               WRITE(LO,'(/5X,A,I3)')
11775      &      'process (accepted,x-section internal/external) for IP:',K
11776               DO 47 M=0,Max_pro_2
11777                 WRITE(LO,'(1X,I3,1X,A,2X,2I12,1P2E13.3)') M,PROC(M),
11778      &            MH_tried(M,K),MH_acc_1(M,K),DBLE(MH_acc_1(M,K))*FAC1,
11779      &            DBLE(MH_acc_2(M,K))*FAC2
11780  47           CONTINUE
11781             ENDIF
11782  43       CONTINUE
11783
11784         ELSE
11785           WRITE(LO,'(/1X,A,I4,/)') 'no output of statistics',KEVENT
11786         ENDIF
11787         WRITE(LO,'(/3(/1X,A)/)')
11788      &    '======================================================',
11789      &    '   ------- end of event generation summary --------',
11790      &    '======================================================'
11791       ELSE
11792         WRITE(LO,'(/1X,A,I7)') 'PHO_EVENT:ERROR: unsupported NEV',NEV
11793       ENDIF
11794
11795       END
11796
11797 *$ CREATE PHO_PARTON.FOR
11798 *COPY PHO_PARTON
11799 CDECK  ID>, PHO_PARTON
11800       SUBROUTINE PHO_PARTON(IPROC,JM1,JM2,P1,P2,IREJ)
11801 C********************************************************************
11802 C
11803 C     calculation of complete parton configuration
11804 C
11805 C     input:  IPROC   process ID  1 nondiffractive
11806 C                                 2 elastic
11807 C                                 3 quasi-ela. rho,omega,phi prod.
11808 C                                 4 double Pomeron
11809 C                                 5 single diff 1
11810 C                                 6 single diff 2
11811 C                                 7 double diff diss.
11812 C                                 8 single-resolved / direct photon
11813 C             JM1,2   index of mother particles in /POEVT1/
11814 C
11815 C
11816 C     output: complete parton configuration in /POEVT1/
11817 C             IREJ                1 failure
11818 C                                 0 success
11819 C                                50 rejection due to user cutoffs
11820 C
11821 C********************************************************************
11822       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11823       SAVE
11824
11825       DIMENSION P1(4),P2(4)
11826
11827       PARAMETER ( TINY   =  1.D-10 )
11828
11829 C  input/output channels
11830       INTEGER LI,LO
11831       COMMON /POINOU/ LI,LO
11832 C  event debugging information
11833       INTEGER NMAXD
11834       PARAMETER (NMAXD=100)
11835       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
11836      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11837       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
11838      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
11839 C  model switches and parameters
11840       CHARACTER*8 MDLNA
11841       INTEGER ISWMDL,IPAMDL
11842       DOUBLE PRECISION PARMDL
11843       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11844 C  table of particle indices for recursive PHOJET calls
11845       INTEGER MAXIPX
11846       PARAMETER ( MAXIPX = 100 )
11847       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
11848       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
11849      &                IPOIX1,IPOIX2,IPOIX3
11850 C  general process information
11851       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
11852       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
11853 C  global event kinematics and particle IDs
11854       INTEGER IFPAP,IFPAB
11855       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
11856       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
11857 C  cross sections
11858       INTEGER IPFIL,IFAFIL,IFBFIL
11859       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
11860      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
11861      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
11862      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
11863      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
11864       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
11865      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
11866      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
11867      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
11868      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
11869      &                IPFIL,IFAFIL,IFBFIL
11870 C  event weights and generated cross section
11871       INTEGER IPOWGC,ISWCUT,IVWGHT
11872       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
11873       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
11874      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
11875 C  internal rejection counters
11876       INTEGER NMXJ
11877       PARAMETER (NMXJ=60)
11878       CHARACTER*10 REJTIT
11879       INTEGER IFAIL
11880       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
11881
11882       IREJ = 0
11883 C  clear event statistics
11884       KSPOM = 0
11885       KHPOM = 0
11886       KSREG = 0
11887       KHDIR = 0
11888       KSTRG = 0
11889       KHTRG = 0
11890       KSLOO = 0
11891       KHLOO = 0
11892       KHARD = 0
11893       KSOFT = 0
11894       KSDPO = 0
11895       KHDPO = 0
11896
11897 C-------------------------------------------------------------------
11898 C  nondiffractive resolved processes
11899
11900       IF(IPROC.EQ.1) THEN
11901 C  sample number of interactions
11902  555    CONTINUE
11903         IINT = 0
11904         IP   = 1
11905 C  generate only hard events
11906         IF(ISWMDL(2).EQ.0) THEN
11907           MHPOM = 1
11908           MSPOM = 0
11909           MSREG = 0
11910           MHDIR = 0
11911           HSWGHT(1) = 1.D0
11912         ELSE
11913 C  minimum bias events
11914           IPOWGC(1) = 0
11915  10       CONTINUE
11916           CALL PHO_SAMPRB(ECM,IP,IINT,JINT,KINT)
11917           IPOWGC(1) = IPOWGC(1)+1
11918           MINT = 0
11919           MHDIR = 0
11920           MSTRG = 0
11921           MSLOO = 0
11922 C
11923 C  resolved soft processes: pomeron and reggeon
11924           MSPOM = IINT
11925           MSREG = JINT
11926 C  resolved hard process: hard pomeron
11927           MHPOM = KINT
11928 C  resolved absorptive corrections
11929           MPTRI = 0
11930           MPLOO = 0
11931 C  restrictions given by user
11932           IF(MSPOM.LT.ISWCUT(1)) GOTO 10
11933           IF(MSREG.LT.ISWCUT(2)) GOTO 10
11934           IF(MHPOM.LT.ISWCUT(3)) GOTO 10
11935           HSWGHT(1) = 1.D0/DBLE(IPOWGC(1))
11936 C  ----------------------------
11937           IF(ISWMDL(15).EQ.0) THEN
11938             MHPOM = 0
11939             IF(MSREG.GT.0) THEN
11940               MSPOM = 0
11941               MSREG = 1
11942             ELSE
11943               MSPOM = 1
11944               MSREG = 0
11945             ENDIF
11946           ELSE IF(ISWMDL(15).EQ.1) THEN
11947             IF(MHPOM.GT.0) THEN
11948               MHPOM = 1
11949               MSPOM = 0
11950               MSREG = 0
11951             ELSE IF(MSPOM.GT.0) THEN
11952               MSPOM = 1
11953               MSREG = 0
11954             ELSE
11955               MSREG = 1
11956             ENDIF
11957           ELSE IF(ISWMDL(15).EQ.2) THEN
11958             MHPOM = MIN(1,MHPOM)
11959           ELSE IF(ISWMDL(15).EQ.3) THEN
11960             MSPOM = MIN(1,MSPOM)
11961           ENDIF
11962         ENDIF
11963 C  ----------------------------
11964
11965 C  statistics
11966         ISPS = ISPS+MSPOM
11967         IHPS = IHPS+MHPOM
11968         ISRS = ISRS+MSREG
11969         ISTS = ISTS+MSTRG
11970         ISLS = ISLS+MSLOO
11971
11972         IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,I7,6I4)')
11973      &    'PHO_PARTON: EV,SP,SR,HP,HD,ET,EL',
11974      &    KEVENT,MSPOM,MSREG,MHPOM,MHDIR,MPTRI,MPLOO
11975
11976         ITRY2 = 0
11977  50     CONTINUE
11978         ITRY2 = ITRY2+1
11979         IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
11980         KSPOM = MSPOM
11981         KSREG = MSREG
11982         KHPOM = MHPOM
11983         KHDIR = MHDIR
11984         KSTRG = MPTRI
11985         KSLOO = MPLOO
11986
11987         CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
11988         IF(IREJ.NE.0) THEN
11989           IF(IREJ.EQ.50) RETURN
11990           IF(IDEB(3).GE.2) THEN
11991             WRITE(LO,'(/1X,A,I5)')
11992      &        'PHO_PARTON: rejection by PHO_STDPAR ',ITRY2
11993             CALL PHO_PREVNT(-1)
11994           ENDIF
11995           RETURN
11996         ENDIF
11997         IF(MHPOM.GT.0) THEN
11998           IDNODF = 3
11999         ELSE IF(MSPOM.GT.0) THEN
12000           IDNODF = 2
12001         ELSE
12002           IDNODF = 1
12003         ENDIF
12004 C  check of quantum numbers of parton configurations
12005         IF(IDEB(3).GE.0) THEN
12006           CALL PHO_CHECK(1,IREJ)
12007           IF(IREJ.NE.0) GOTO 50
12008         ENDIF
12009 C  sample strings to prepare fragmentation
12010         CALL PHO_STRING(1,IREJ)
12011         IF(IREJ.NE.0) THEN
12012           IF(IREJ.EQ.50) RETURN
12013           IFAIL(30) = IFAIL(30)+1
12014           IF(IDEB(3).GE.2)  THEN
12015             WRITE(LO,'(/1X,A,I5)')
12016      &        'PHO_PARTON: rejection by PHO_STRING',ITRY2
12017             CALL PHO_PREVNT(-1)
12018           ENDIF
12019           IF(ITRY2.LT.20) GOTO 50
12020           IF(IDEB(3).GE.1) THEN
12021             WRITE(LO,'(/1X,A,I5)')
12022      &        'PHO_PARTON: rejection',ITRY2
12023             CALL PHO_PREVNT(-1)
12024           ENDIF
12025           RETURN
12026         ENDIF
12027
12028 C  statistics
12029         ISPA = ISPA+KSPOM
12030         IHPA = IHPA+KHPOM
12031         ISRA = ISRA+KSREG
12032         ISTA = ISTA+KSTRG
12033         ISLA = ISLA+KSLOO
12034
12035 C-------------------------------------------------------------------
12036 C  elastic scattering / quasi-elastic rho/omega/phi production
12037
12038       ELSE IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
12039         IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,I4)')
12040      &    'PHO_PARTON: ela./q-ela.sca:(EV,IPROC)',KEVENT,IPROC
12041
12042 C  DPMJET call with special projectile / target: transform into CMS
12043         IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12044      &    CALL PHO_DFWRAP(1,JM1,JM2)
12045
12046         CALL PHO_QELAST(IPROC,JM1,JM2,IREJ)
12047
12048         IF(IREJ.NE.0) THEN
12049 C  DPMJET call with special projectile / target: clean up
12050           IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12051      &      CALL PHO_DFWRAP(-2,JM1,JM2)
12052           IF(IDEB(3).GE.2) THEN
12053             WRITE(LO,'(/1X,A,I5)')
12054      &        'PHO_PARTON: rejection by PHO_QELAST',IREJ
12055             CALL PHO_PREVNT(-1)
12056           ENDIF
12057           RETURN
12058         ENDIF
12059
12060 C  DPMJET call with special projectile / target: transform back
12061         IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12062      &    CALL PHO_DFWRAP(2,JM1,JM2)
12063
12064 C  prepare possible decays
12065         CALL PHO_STRING(1,IREJ)
12066         IF(IREJ.NE.0) THEN
12067           IF(IREJ.EQ.50) RETURN
12068           IFAIL(30) = IFAIL(30)+1
12069           RETURN
12070         ENDIF
12071
12072 C---------------------------------------------------------------------
12073 C  double Pomeron scattering
12074
12075       ELSE IF(IPROC.EQ.4) THEN
12076         MSOFT = 0
12077         MHARD = 0
12078         IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10)')
12079      &      'PHO_PARTON: EV,double-pomeron scattering',KEVENT
12080         IDPS = IDPS+1
12081         ITRY2 = 0
12082  60     CONTINUE
12083         ITRY2 = ITRY2+1
12084         IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12085 C
12086         CALL PHO_CDIFF(JM1,JM2,MSOFT,MHARD,1,IREJ)
12087         IF(IREJ.NE.0) THEN
12088           IF(IDEB(3).GE.2) THEN
12089             WRITE(LO,'(/1X,A,I5)')
12090      &        'PHO_PARTON: rejection by PHO_CDIFF',IREJ
12091             CALL PHO_PREVNT(-1)
12092           ENDIF
12093           RETURN
12094         ENDIF
12095 C  check of quantum numbers of parton configurations
12096         IF(IDEB(3).GE.0) THEN
12097           CALL PHO_CHECK(1,IREJ)
12098           IF(IREJ.NE.0) GOTO 60
12099         ENDIF
12100 C  sample strings to prepare fragmentation
12101         CALL PHO_STRING(1,IREJ)
12102         IF(IREJ.NE.0) THEN
12103           IF(IREJ.EQ.50) RETURN
12104           IFAIL(30) = IFAIL(30)+1
12105           IF(IDEB(3).GE.2) THEN
12106             WRITE(LO,'(/1X,A,I5)')
12107      &        'PHO_PARTON: rejection by PHO_STRING',ITRY2
12108             CALL PHO_PREVNT(-1)
12109           ENDIF
12110           IF(ITRY2.LT.10) GOTO 60
12111           WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
12112           CALL PHO_PREVNT(-1)
12113           RETURN
12114         ENDIF
12115         IDPA = IDPA+1
12116
12117 C-----------------------------------------------------------------------
12118 C  single / double diffraction dissociation
12119
12120       ELSE IF((IPROC.GE.5).AND.(IPROC.LE.7)) THEN
12121         MSOFT = 0
12122         MHARD = 0
12123         IF(IDEB(3).GE.5) WRITE(LO,'(1X,A,I10,2I4)')
12124      &    'PHO_PARTON: EV,diffraction',KEVENT,IPAR1,IPAR2
12125         IF(IPROC.EQ.5) ID1S = ID1S+1
12126         IF(IPROC.EQ.6) ID2S = ID2S+1
12127         IF(IPROC.EQ.7) ID3S = ID3S+1
12128         ITRY2 = 0
12129  70     CONTINUE
12130         ITRY2 = ITRY2+1
12131         IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12132         IPAR1 = 1
12133         IPAR2 = 1
12134         IF(IPROC.EQ.5) IPAR2 = 0
12135         IF(IPROC.EQ.6) IPAR1 = 0
12136 C  calculate rapidity gap survival probability
12137         SPROB = 1.D0
12138         IF(ECM.GT.10.D0) THEN
12139           IF((IPAR1.GE.1).AND.(IPAR2.EQ.0)) THEN
12140             IF(SIGTR1(1).LT.1.D-10) THEN
12141               SPROB = 1.D0
12142             ELSE
12143               SPROB = SIGHSD(1)/(SIGTR1(1)-2.D0*(SIGDPO(1)+SIGDPO(2)))
12144             ENDIF
12145           ELSE IF((IPAR1.EQ.0).AND.(IPAR2.GE.1)) THEN
12146             IF(SIGTR2(1).LT.1.D-10) THEN
12147               SPROB = 1.D0
12148             ELSE
12149               SPROB = SIGHSD(2)/(SIGTR2(1)-2.D0*(SIGDPO(1)+SIGDPO(3)))
12150             ENDIF
12151           ELSE IF((IPAR1.GE.1).AND.(IPAR2.GE.1)) THEN
12152             IF(SIGLOO.LT.1.D-10) THEN
12153               SPROB = 1.D0
12154             ELSE
12155               SPROB = SIGHDD/SIGLOO
12156             ENDIF
12157           ENDIF
12158         ENDIF
12159 **sr
12160 * temporary patch, r.e. 8.6.99
12161         SPROB = 1.D0
12162 **
12163
12164 C  DPMJET call with special projectile / target: transform into CMS
12165         IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12166      &    CALL PHO_DFWRAP(1,JM1,JM2)
12167
12168         CALL PHO_DIFDIS(IPAR1,IPAR2,JM1,JM2,SPROB,0,MSOFT,MHARD,IREJ)
12169
12170         IF(IREJ.NE.0) THEN
12171 C  DPMJET call with special projectile / target: clean up
12172           IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12173      &      CALL PHO_DFWRAP(-2,JM1,JM2)
12174           IF(IDEB(3).GE.2) THEN
12175             WRITE(LO,'(/1X,A,I5)')
12176      &        'PHO_PARTON: rejection by PHO_DIFDIS',IREJ
12177             CALL PHO_PREVNT(-1)
12178           ENDIF
12179           RETURN
12180         ENDIF
12181
12182 C  DPMJET call with special projectile / target: transform back
12183         IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0))
12184      &    CALL PHO_DFWRAP(2,JM1,JM2)
12185
12186 C  check of quantum numbers of parton configurations
12187         IF(IDEB(3).GE.0) THEN
12188           CALL PHO_CHECK(1,IREJ)
12189           IF(IREJ.NE.0) GOTO 70
12190         ENDIF
12191 C  sample strings to prepare fragmentation
12192         CALL PHO_STRING(1,IREJ)
12193         IF(IREJ.NE.0) THEN
12194           IF(IREJ.EQ.50) RETURN
12195           IFAIL(30) = IFAIL(30)+1
12196           IF(IDEB(3).GE.2) THEN
12197             WRITE(LO,'(/1X,A,I5)')
12198      &        'PHO_PARTON: rejection by PHO_STRING',ITRY2
12199             CALL PHO_PREVNT(-1)
12200           ENDIF
12201           IF(ITRY2.LT.10) GOTO 70
12202           WRITE(LO,'(/1X,A,I5)')
12203      &      'PHO_PARTON: rejection',ITRY2
12204           CALL PHO_PREVNT(-1)
12205           RETURN
12206         ENDIF
12207         IF(IPROC.EQ.5) ID1A = ID1A+1
12208         IF(IPROC.EQ.6) ID2A = ID2A+1
12209         IF(IPROC.EQ.7) ID3A = ID3A+1
12210
12211 C-----------------------------------------------------------------------
12212 C  single / double direct processes
12213
12214       ELSE IF(IPROC.EQ.8) THEN
12215         MSREG = 0
12216         MSPOM = 0
12217         MHPOM = 0
12218         MHDIR = 1
12219         IF(IDEB(3).GE.5) THEN
12220           WRITE(LO,'(1X,A,I10)') 'PHO_PARTON: EV,direct proc',KEVENT
12221         ENDIF
12222         IDIS = IDIS+MHDIR
12223         ITRY2 = 0
12224  80     CONTINUE
12225         ITRY2 = ITRY2+1
12226         IF(ITRY2.GT.1) CALL PHO_EVEINI(2,P1,P2,JM1,JM2)
12227         KSPOM = MSPOM
12228         KSREG = MSREG
12229         KHPOM = MHPOM
12230         KHDIR = 4
12231
12232         CALL PHO_STDPAR(JM1,JM2,1,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
12233         IF(IREJ.NE.0) THEN
12234           IF(IREJ.EQ.50) RETURN
12235           IF(IDEB(3).GE.2) THEN
12236             WRITE(LO,'(/1X,A,I5)')
12237      &        'PHO_PARTON: rejection by PHO_STDPAR',ITRY2
12238             CALL PHO_PREVNT(-1)
12239           ENDIF
12240           RETURN
12241         ENDIF
12242         IDNODF = 4
12243 C  check of quantum numbers of parton configurations
12244         IF(IDEB(3).GE.0) THEN
12245           CALL PHO_CHECK(1,IREJ)
12246           IF(IREJ.NE.0) GOTO 80
12247         ENDIF
12248 C  sample strings to prepare fragmentation
12249         CALL PHO_STRING(1,IREJ)
12250         IF(IREJ.NE.0) THEN
12251           IF(IREJ.EQ.50) RETURN
12252           IFAIL(30) = IFAIL(30)+1
12253           IF(IDEB(3).GE.2) THEN
12254             WRITE(LO,'(/1X,A,I5)')
12255      &        'PHO_PARTON: rejection by PHO_STRING',ITRY2
12256             CALL PHO_PREVNT(-1)
12257           ENDIF
12258           IF(ITRY2.LT.10) GOTO 80
12259           WRITE(LO,'(/1X,A,I5)') 'PHO_PARTON: rejection',ITRY2
12260           CALL PHO_PREVNT(-1)
12261           RETURN
12262         ENDIF
12263         IF(IPROC.EQ.5) ID1A = ID1A+1
12264         IF(IPROC.EQ.6) ID2A = ID2A+1
12265         IF(IPROC.EQ.7) ID3A = ID3A+1
12266         IDIA = IDIA+MHDIR
12267
12268 C-----------------------------------------------------------------------
12269 C  initialize control statistics
12270
12271       ELSE IF(IPROC.EQ.-1) THEN
12272         CALL PHO_SAMPRB(ECM,-1,0,0,0)
12273         CALL PHO_STDPAR(-1,0,0,0,0,0,0,IREJ)
12274         CALL PHO_SEAFLA(-1,0,0,DUM)
12275         IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
12276      &    CALL PHO_QELAST(-1,1,2,0)
12277         ISPS = 0
12278         ISPA = 0
12279         ISRS = 0
12280         ISRA = 0
12281         IHPS = 0
12282         IHPA = 0
12283         ISTS = 0
12284         ISTA = 0
12285         ISLS = 0
12286         ISLA = 0
12287         ID1S = 0
12288         ID1A = 0
12289         ID2S = 0
12290         ID2A = 0
12291         ID3S = 0
12292         ID3A = 0
12293         IDPS = 0
12294         IDPA = 0
12295         IDIS = 0
12296         IDIA = 0
12297         CALL PHO_STRING(-1,IREJ)
12298         CALL PHO_DIFDIS(0,0,0,0,0.D0,-1,0,0,IREJ)
12299         RETURN
12300
12301 C-----------------------------------------------------------------------
12302 C  produce statistics summary
12303
12304       ELSE IF(IPROC.EQ.-2) THEN
12305         IF(ISWMDL(2).NE.0) CALL PHO_SAMPRB(ECM,-2,0,0,0)
12306         IF(IDEB(3).GE.0) THEN
12307           WRITE(LO,'(/1X,A,/1X,A)')
12308      &      'PHO_PARTON: internal statistics on parton configurations',
12309      &      '--------------------------------------------------------'
12310           WRITE(LO,'(5X,A)') 'process          sampled      accepted'
12311           WRITE(LO,'(5X,A,2I12)') 'soft pom.',ISPS,ISPA
12312           WRITE(LO,'(5X,A,2I12)') 'hard pom.',IHPS,IHPA
12313           WRITE(LO,'(5X,A,2I12)') 'soft reg.',ISRS,ISRA
12314           WRITE(LO,'(5X,A,2I12)') 'enh. tri.',ISTS,ISTA
12315           WRITE(LO,'(5X,A,2I12)') 'enh. loo.',ISLS,ISLA
12316           WRITE(LO,'(5X,A,2I12)') 'diff.pa1.',ID1S,ID1A
12317           WRITE(LO,'(5X,A,2I12)') 'diff.pa2.',ID2S,ID2A
12318           WRITE(LO,'(5X,A,2I12)') 'doub.dif.',ID3S,ID3A
12319           WRITE(LO,'(5X,A,2I12)') 'doub.pom.',IDPS,IDPA
12320           WRITE(LO,'(5X,A,2I12/)') 'dir.phot.',IDIS,IDIA
12321         ENDIF
12322         CALL PHO_STDPAR(-2,0,0,0,0,0,0,IREJ)
12323         IF((IFPAP(1).EQ.22).OR.(IFPAP(2).EQ.22))
12324      &    CALL PHO_QELAST(-2,1,2,0)
12325         CALL PHO_STRING(-2,IREJ)
12326         CALL PHO_DIFDIS(0,0,0,0,0.D0,-2,0,0,IREJ)
12327         CALL PHO_SEAFLA(-2,0,0,DUM)
12328         RETURN
12329       ELSE
12330         WRITE(LO,'(1X,A,I2)')
12331      &    'PARTON:ERROR: unknown process ID ',IPROC
12332         STOP
12333       ENDIF
12334
12335       END
12336
12337 *$ CREATE PHO_MCINI.FOR
12338 *COPY PHO_MCINI
12339 CDECK  ID>, PHO_MCINI
12340       SUBROUTINE PHO_MCINI
12341 C********************************************************************
12342 C
12343 C     initialization of MC event generation
12344 C
12345 C********************************************************************
12346       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12347       SAVE
12348
12349       PARAMETER ( PIMASS =  0.13D0,
12350      &            TINY   =  1.D-10 )
12351
12352 C  input/output channels
12353       INTEGER LI,LO
12354       COMMON /POINOU/ LI,LO
12355 C  event debugging information
12356       INTEGER NMAXD
12357       PARAMETER (NMAXD=100)
12358       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12359      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12360       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12361      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12362 C  model switches and parameters
12363       CHARACTER*8 MDLNA
12364       INTEGER ISWMDL,IPAMDL
12365       DOUBLE PRECISION PARMDL
12366       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
12367 C  general process information
12368       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
12369       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
12370 C  cross sections
12371       INTEGER IPFIL,IFAFIL,IFBFIL
12372       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
12373      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
12374      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
12375      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
12376      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
12377       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
12378      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
12379      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
12380      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
12381      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
12382      &                IPFIL,IFAFIL,IFBFIL
12383 C  hard cross sections and MC selection weights
12384       INTEGER Max_pro_2
12385       PARAMETER ( Max_pro_2 = 16 )
12386       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
12387      &  MH_acc_1,MH_acc_2
12388       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
12389       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
12390      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
12391      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
12392      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
12393      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
12394 C  interpolation tables for hard cross section and MC selection weights
12395       INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
12396       PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
12397       INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
12398       DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
12399      &  HQ2a_tab,HQ2b_tab,HEcm_tab
12400       COMMON /POHTAB/
12401      &  Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12402      &  HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12403      &  HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12404      &  Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
12405      &  HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
12406      &  HEcm_tab(1:Max_tab_E,0:4),
12407      &  IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
12408 C  global event kinematics and particle IDs
12409       INTEGER IFPAP,IFPAB
12410       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
12411       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
12412 C  obsolete cut-off information
12413       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
12414       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
12415 C  event weights and generated cross section
12416       INTEGER IPOWGC,ISWCUT,IVWGHT
12417       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
12418       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
12419      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
12420 C  cut probability distribution
12421       INTEGER IEETA1,IIMAX,KKMAX
12422       PARAMETER( IEETA1=20, IIMAX=20, KKMAX=20 )
12423       INTEGER IEEMAX,IMAX,KMAX
12424       REAL PROB
12425       DOUBLE PRECISION EPTAB
12426       COMMON /POPROB/ PROB(4,IEETA1,0:IIMAX,0:KKMAX),EPTAB(4,IEETA1),
12427      &                IEEMAX,IMAX,KMAX
12428 C  energy-interpolation table
12429       INTEGER IEETA2
12430       PARAMETER ( IEETA2 = 20 )
12431       INTEGER ISIMAX
12432       DOUBLE PRECISION SIGTAB,SIGECM
12433       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
12434
12435       CHARACTER*15 PHO_PNAME
12436       DIMENSION ECMF(4)
12437
12438       DATA  XMPOM / 0.766D0 /
12439
12440 C  initialize fragmentation
12441       CALL PHO_FRAINI(ISWMDL(6))
12442
12443 C  reset interpolation tables
12444       DO 50 I=1,4
12445         DO 60 J=1,10
12446           DO 70 K=1,70
12447             SIGTAB(I,K,J) = 0.D0
12448  70       CONTINUE
12449           SIGECM(I,J) = 0.D0
12450  60     CONTINUE
12451  50   CONTINUE
12452
12453 C  max. number of allowed colors (large N expansion)
12454       IC1 = 0
12455       IC2 = 10000
12456       CALL PHO_SELCOL(IC1,IC2,0,0,0,0,-1)
12457
12458 C  lower energy limit of initialization
12459       ETABLO = PARMDL(19)
12460       IF(ECM.LE.5.D0) ETABLO = MIN(2.5D0,ETABLO)
12461
12462       WRITE(LO,'(/,1X,A,2F12.1)')
12463      &  'PHO_MCINI: selected energy range (SQRT(S))',ETABLO,ECM
12464       WRITE(LO,'(5X,A,A,F7.3,E15.4)')
12465      &  'particle 1 (name,mass,virtuality): ',PHO_PNAME(IFPAP(1),1),
12466      &  PMASS(1),PVIRT(1)
12467       WRITE(LO,'(5X,A,A,F7.3,E15.4)')
12468      &  'particle 2 (name,mass,virtuality): ',PHO_PNAME(IFPAP(2),1),
12469      &  PMASS(2),PVIRT(2)
12470
12471 C  cuts on probabilities of multiple interactions
12472       IMAX = MIN(IPAMDL(32),IIMAX)
12473       KMAX = MIN(IPAMDL(33),KKMAX)
12474       AH = 2.D0*PTCUT(1)/ECM
12475       IMAX = MAX(5,MIN(IMAX,INT(ECM/2.0D0)))
12476       KMAX = MIN(KMAX,1+INT(0.9*1.D0/AH))
12477
12478 C  hard interpolation table
12479       ECMF(1) = ECM
12480       ECMF(2) = 0.9D0*ECMF(1)
12481       ECMF(3) = ECMF(2)
12482       ECMF(4) = ECMF(2)
12483       do k=1,4
12484         IH_Ecm_up(k) = MIN(IPAMDL(30),Max_tab_E)
12485         IF(ECMF(k).LT.100.D0) IH_Ecm_up(k) = MIN(IH_Ecm_up(k),15)
12486         IF(ECMF(k).LT.50.D0)  IH_Ecm_up(k) = MIN(IH_Ecm_up(k),10)
12487         IF(ECMF(k).LT.10.D0)  IH_Ecm_up(k) = MIN(IH_Ecm_up(k),5)
12488       enddo
12489
12490 C  initialization of hard scattering for all channels and cutoffs
12491       IF(HSWCUT(5).GT.PARMDL(36))  CALL PHO_HARMCI(-1,ECMF(1))
12492       I0 = 4
12493       IF(ISWMDL(2).EQ.0) I0 = 1
12494       DO 110 I=I0,1,-1
12495         CALL PHO_HARMCI(I,ECMF(I))
12496  110  CONTINUE
12497
12498 C  dimension of interpolation table of cut probabilities
12499       IEEMAX = MIN(IPAMDL(31),IEETA1)
12500       IF(ECM.LT.100.D0) IEEMAX = MIN(IEEMAX,15)
12501       IF(ECM.LT.50.D0)  IEEMAX = MIN(IEEMAX,10)
12502       IF(ECM.LT.10.D0)  IEEMAX = MIN(IEEMAX,5)
12503       ISIMAX = IEEMAX
12504
12505 C  calculate probability distribution
12506       I0 = 4
12507       IFT1 = IFPAP(1)
12508       IFT2 = IFPAP(2)
12509       XMT1 = PMASS(1)
12510       XMT2 = PMASS(2)
12511       XVT1 = PVIRT(1)
12512       XVT2 = PVIRT(2)
12513       IF(ISWMDL(2).EQ.0) I0 = 1
12514       DO 150 IP=I0,1,-1
12515       ECMPRO = ECMF(IP)*1.001D0
12516       IF(IP.EQ.4) THEN
12517         IFPAP(1) = 990
12518         IFPAP(2) = 990
12519         PMASS(1) = XMPOM
12520         PMASS(2) = XMPOM
12521         PVIRT(1) = 0.D0
12522         PVIRT(2) = 0.D0
12523       ELSE IF(IP.EQ.3) THEN
12524         IFPAP(1) = IFT2
12525         IFPAP(2) = 990
12526         PMASS(1) = XMT2
12527         PMASS(2) = XMPOM
12528         PVIRT(1) = XVT2
12529         PVIRT(2) = 0.D0
12530       ELSE IF(IP.EQ.2) THEN
12531         IFPAP(1) = IFT1
12532         IFPAP(2) = 990
12533         PMASS(1) = XMT1
12534         PMASS(2) = XMPOM
12535         PVIRT(1) = XVT1
12536         PVIRT(2) = 0.D0
12537       ELSE
12538         IFPAP(1) = IFT1
12539         IFPAP(2) = IFT2
12540         PMASS(1) = XMT1
12541         PMASS(2) = XMT2
12542         PVIRT(1) = XVT1
12543         PVIRT(2) = XVT2
12544       ENDIF
12545       IF(IEEMAX.GT.1) THEN
12546         IF(IP.EQ.1) THEN
12547           ELMIN = LOG(ETABLO)
12548         ELSE
12549           ELMIN = LOG(2.5D0)
12550         ENDIF
12551         EDELTA = (LOG(ECMPRO)-ELMIN)/DBLE(MAX(1,IEEMAX-1))
12552         DO 100 I=1,IEEMAX
12553           ECMPRO = EXP(ELMIN+DBLE(I-1)*EDELTA)
12554           CALL PHO_PRBDIS(IP,ECMPRO,I)
12555  100    CONTINUE
12556       ELSE
12557         CALL PHO_PRBDIS(IP,ECMPRO,1)
12558       ENDIF
12559
12560 C  debug output of cross section tables
12561       IF(((IDEB(62).GE.0).AND.(IP.EQ.1)).OR.(IDEB(62).GE.3)) THEN
12562       IF((PVIRT(1)+PVIRT(2).GT.0.01D0).AND.(IDEB(62).EQ.0)) GOTO 201
12563       WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12564      &'Table of total cross sections (mb) for particle combination',IP,
12565      &' Ecm    SIGtot  SIGela  SIGine  SIGqel  SIGsd1  SIGsd2  SIGdd',
12566      &'-------------------------------------------------------------'
12567       DO 200 I=1,IEEMAX
12568         WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,1,I),
12569      &    SIGTAB(IP,2,I),SIGTAB(IP,28,I),SIGTAB(IP,3,I),
12570      &    SIGTAB(IP,30,I)+SIGTAB(IP,32,I),
12571      &    SIGTAB(IP,31,I)+SIGTAB(IP,33,I),
12572      &    SIGTAB(IP,34,I)+SIGTAB(IP,35,I)
12573  200  CONTINUE
12574  201  CONTINUE
12575       IF(IDEB(62).GE.2) THEN
12576       WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12577      &'Table of partial x-sections (mb) for particle combination',IP,
12578      &' Ecm    SIGSD1L SIGSD1H SIGSD2L SIGSD2H SIGDDL  SIGDDH  SIGCDF',
12579      &'--------------------------------------------------------------'
12580       DO 205 I=1,IEEMAX
12581         WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,30,I),
12582      &    SIGTAB(IP,32,I),SIGTAB(IP,31,I),SIGTAB(IP,33,I),
12583      &    SIGTAB(IP,34,I),SIGTAB(IP,35,I),SIGTAB(IP,36,I)
12584  205  CONTINUE
12585       ENDIF
12586       IF(IDEB(62).GE.2) THEN
12587       WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12588      &'Table of born graph x-sections (mb) for particle combination',IP,
12589      &' Ecm    SIGSVDM SIGHRES SIGHDIR SIGTR1  SIGTR2  SIGLOO SIGDPO',
12590      &'-------------------------------------------------------------'
12591       DO 210 I=1,IEEMAX
12592         WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),
12593      &    SIGTAB(IP,56,I)+SIGTAB(IP,57,I),SIGTAB(IP,58,I),
12594      &    SIGTAB(IP,59,I),SIGTAB(IP,60,I)+SIGTAB(IP,61,I),
12595      &    SIGTAB(IP,62,I)+SIGTAB(IP,63,I),SIGTAB(IP,64,I),
12596      &    SIGTAB(IP,65,I)+SIGTAB(IP,66,I)+SIGTAB(IP,67,I)
12597      &    +SIGTAB(IP,68,I)
12598  210  CONTINUE
12599       WRITE(LO,'(/1X,A,I3/1X,A,/1X,A)')
12600      &'Table of unitarized x-sections (mb) for particle combination',IP,
12601      &' Ecm    SIGSVDM SIGHVDM  SIGTR1  SIGTR2  SIGLOO SIGDPO  SLOPE',
12602      &'-------------------------------------------------------------'
12603       DO 215 I=1,IEEMAX
12604         WRITE(LO,'(1X,1P,8E9.2)') SIGECM(IP,I),SIGTAB(IP,79,I),
12605      &    SIGTAB(IP,80,I),SIGTAB(IP,32,I),SIGTAB(IP,33,I),
12606      &    SIGTAB(IP,35,I),SIGTAB(IP,36,I),SIGTAB(IP,39,I)
12607  215  CONTINUE
12608       ENDIF
12609       IF(IDEB(62).GE.1) THEN
12610       WRITE(LO,'(/1X,A,/1X,A,2I4,/1X,A,/1X,A)')
12611      &'Table of expected average number of cuts in non-diff events:',
12612      &'       for max. number of cuts soft/hard:',IMAX,KMAX,
12613      &' Ecm   PTCUT   SIGNDF   POM-S   POM-H   REG-S',
12614      &'---------------------------------------------'
12615       DO 220 I=1,IEEMAX
12616         WRITE(LO,'(1X,1P,6E10.3)') SIGECM(IP,I),SIGTAB(IP,77,I),
12617      &    SIGTAB(IP,78,I),SIGTAB(IP,74,I),SIGTAB(IP,75,I),
12618      &    SIGTAB(IP,76,I)
12619  220  CONTINUE
12620       IF(IP.EQ.1) THEN
12621         WRITE(LO,'(/1X,A,/1X,A,/1X,A)')
12622      &  'Table of rapidity gap survival probability (high-mass diff.):',
12623      &  ' Ecm    Spro-sd1     Spro-sd2    Spro-dd    Spro-cd',
12624      &  '---------------------------------------------------'
12625         DO 230 I=1,IEEMAX
12626           IF(SIGECM(IP,I).GT.10.D0) THEN
12627             SPRSD1 = SIGTAB(IP,32,I)/(SIGTAB(IP,60,I)
12628      &               -2.D0*(SIGTAB(IP,65,I)+SIGTAB(IP,66,I)))
12629             SPRSD2 = SIGTAB(IP,33,I)/(SIGTAB(IP,62,I)
12630      &               -2.D0*(SIGTAB(IP,65,I)+SIGTAB(IP,67,I)))
12631             SPRDD  = SIGTAB(IP,35,I)/(SIGTAB(IP,64,I)+SIGTAB(IP,61,I)
12632      &               +SIGTAB(IP,63,I)-2.D0*(SIGTAB(IP,66,I)
12633      &               +SIGTAB(IP,67,I)+2.D0*SIGTAB(IP,68,I)))
12634             SPRCDF = SIGTAB(IP,36,I)/(SIGTAB(IP,65,I)+SIGTAB(IP,66,I)
12635      &               +SIGTAB(IP,67,I)+SIGTAB(IP,68,I))
12636             WRITE(LO,'(1X,1P,5E10.3)') SIGECM(IP,I),
12637      &        SPRSD1,SPRSD2,SPRDD,SPRCDF
12638           ENDIF
12639  230    CONTINUE
12640       ENDIF
12641       ENDIF
12642       ENDIF
12643  150  CONTINUE
12644
12645 C  simulate only hard scatterings
12646       IF(ISWMDL(2).EQ.0) THEN
12647         WRITE(LO,'(2(/1X,A))')
12648      &    'WARNING: generation of hard scatterings only!',
12649      &    '============================================='
12650         DO 151 I=2,7
12651           IPRON(I,1) = 0
12652  151    CONTINUE
12653         DO 152 K=2,4
12654           DO 153 I=1,15
12655             IPRON(I,K) = 0
12656  153      CONTINUE
12657  152    CONTINUE
12658         SIGGEN(4) = 0.D0
12659         DO 160 I=1,IEEMAX
12660           SIGMAX = 0.D0
12661           IF(IPRON(1,1).EQ.1) SIGMAX = SIGTAB(1,58,I)
12662           IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGTAB(1,59,I)
12663           IF(SIGMAX.GT.SIGGEN(4)) THEN
12664             ISIGM = I
12665             SIGGEN(4) = SIGMAX
12666           ENDIF
12667  160    CONTINUE
12668       ELSE
12669         WRITE(LO,'(2(/1X,A))')
12670      &    'activated processes, cross section',
12671      &    '----------------------------------'
12672         WRITE(LO,'(5X,A,I3,2X,3I3)')
12673      &    '  nondiffr. resolved processes',(IPRON(1,K),K=1,4)
12674         WRITE(LO,'(5X,A,I3,2X,3I3)')
12675      &    '            elastic scattering',(IPRON(2,K),K=1,4)
12676         WRITE(LO,'(5X,A,I3,2X,3I3)')
12677      &    'qelast. vectormeson production',(IPRON(3,K),K=1,4)
12678         WRITE(LO,'(5X,A,I3,2X,3I3)')
12679      &    '      double pomeron processes',(IPRON(4,K),K=1,4)
12680         WRITE(LO,'(5X,A,I3,2X,3I3)')
12681      &    ' single diffract. particle (1)',(IPRON(5,K),K=1,4)
12682         WRITE(LO,'(5X,A,I3,2X,3I3)')
12683      &    ' single diffract. particle (2)',(IPRON(6,K),K=1,4)
12684         WRITE(LO,'(5X,A,I3,2X,3I3)')
12685      &    '    double diffract. processes',(IPRON(7,K),K=1,4)
12686         WRITE(LO,'(5X,A,I3,2X,3I3)')
12687      &    '       direct photon processes',(IPRON(8,K),K=1,4)
12688
12689 C  calculate effective cross section
12690         SIGGEN(4) = 0.D0
12691         DO 165 I=1,IEEMAX
12692           CALL PHO_CSINT(1,IFPAP(1),IFPAP(2),-1,-1,SIGECM(1,I),
12693      &                PVIRT(1),PVIRT(2))
12694           SIGMAX = 0.D0
12695           if(iswmdl(2).ge.1) then
12696             IF(IPRON(1,1).EQ.1) SIGMAX = SIGTOT-SIGELA-SIGVM(0,0)
12697      &        -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)
12698      &        -SIGLDD-SIGHDD-SIGDIR
12699             IF(IPRON(2,1).EQ.1) SIGMAX = SIGMAX+SIGELA
12700             IF(IPRON(3,1).EQ.1) SIGMAX = SIGMAX+SIGVM(0,0)
12701             IF(IPRON(4,1).EQ.1) SIGMAX = SIGMAX+SIGCDF(0)
12702             IF(IPRON(5,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(1)+SIGHSD(1)
12703             IF(IPRON(6,1).EQ.1) SIGMAX = SIGMAX+SIGLSD(2)+SIGHSD(2)
12704             IF(IPRON(7,1).EQ.1) SIGMAX = SIGMAX+SIGLDD+SIGHDD
12705             IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
12706           else
12707             IF(IPRON(1,1).EQ.1) SIGMAX = SIGHAR
12708             IF(IPRON(8,1).EQ.1) SIGMAX = SIGMAX+SIGDIR
12709           endif
12710           IF(SIGMAX.GT.SIGGEN(4)) THEN
12711             ISIGM = I
12712             SIGGEN(4) = SIGMAX
12713           ENDIF
12714  165    CONTINUE
12715       ENDIF
12716
12717 C  debug output
12718       IF(SIGGEN(4).LT.1.D-20) THEN
12719         WRITE(LO,'(//1X,A)')
12720      &  'PHO_MCINI:ERROR: selected processes have vanishing x-section'
12721         STOP
12722       ENDIF
12723       WRITE(LO,'(3X,A,1P3E11.4)') 'maximum search (Elow/Eup/Epeak)',
12724      &  SIGECM(1,1),SIGECM(1,IEEMAX),SIGECM(1,ISIGM)
12725       WRITE(LO,'(11X,A,1PE12.4,/)') 'max. cross section (mb)',SIGGEN(4)
12726
12727       END
12728
12729 *$ CREATE PHO_REJSTA.FOR
12730 *COPY PHO_REJSTA
12731 CDECK  ID>, PHO_REJSTA
12732       SUBROUTINE PHO_REJSTA(IMODE)
12733 C********************************************************************
12734 C
12735 C     MC rejection counting
12736 C
12737 C     input IMODE    -1   initialization
12738 C                    -2   output of statistics
12739 C
12740 C********************************************************************
12741       IMPLICIT NONE
12742       SAVE
12743
12744 C  input/output channels
12745       INTEGER LI,LO
12746       COMMON /POINOU/ LI,LO
12747 C  event debugging information
12748       INTEGER NMAXD
12749       PARAMETER (NMAXD=100)
12750       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12751      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12752       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12753      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12754 C  internal rejection counters
12755       INTEGER NMXJ
12756       PARAMETER (NMXJ=60)
12757       CHARACTER*10 REJTIT
12758       INTEGER IFAIL
12759       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
12760
12761       INTEGER IMODE
12762
12763       INTEGER I
12764
12765 C  initialization
12766       IF(IMODE.EQ.-1) THEN
12767         DO 100 I=1,NMXJ
12768           IFAIL(I) = 0
12769  100    CONTINUE
12770 C
12771         REJTIT(1)  = 'PARTON ALL'
12772         REJTIT(2)  = 'STDPAR ALL'
12773         REJTIT(3)  = 'STDPAR DPO'
12774         REJTIT(4)  = 'POMSCA ALL'
12775         REJTIT(5)  = 'POMSCA INT'
12776         REJTIT(6)  = 'POMSCA KIN'
12777         REJTIT(7)  = 'DIFDIS ALL'
12778         REJTIT(8)  = 'POSPOM ALL'
12779         REJTIT(9)  = 'HRES.DIF.1'
12780         REJTIT(10) = 'HDIR.DIF.1'
12781         REJTIT(11) = 'HRES.DIF.2'
12782         REJTIT(12) = 'HDIR.DIF.2'
12783         REJTIT(13) = 'DIFDIS INT'
12784         REJTIT(14) = 'HADRON SP2'
12785         REJTIT(15) = 'HADRON SP3'
12786         REJTIT(16) = 'HARDIR ALL'
12787         REJTIT(17) = 'HARDIR INT'
12788         REJTIT(18) = 'HARDIR KIN'
12789         REJTIT(19) = 'MCHECK BAR'
12790         REJTIT(20) = 'MCHECK MES'
12791         REJTIT(21) = 'DIF.DISS.1'
12792         REJTIT(22) = 'DIF.DISS.2'
12793         REJTIT(23) = 'STRFRA ALL'
12794         REJTIT(24) = 'MSHELL CHA'
12795         REJTIT(25) = 'PARTPT SOF'
12796         REJTIT(26) = 'PARTPT HAR'
12797         REJTIT(27) = 'INTRINS KT'
12798         REJTIT(28) = 'HACHEK DIR'
12799         REJTIT(29) = 'HACHEK RES'
12800         REJTIT(30) = 'STRING ALL'
12801         REJTIT(31) = 'POMSCA INT'
12802         REJTIT(32) = 'DIFF SLOPE'
12803         REJTIT(33) = 'GLU2QU ALL'
12804         REJTIT(34) = 'MASCOR ALL'
12805         REJTIT(35) = 'PARCOR ALL'
12806         REJTIT(36) = 'MSHELL PAR'
12807         REJTIT(37) = 'MSHELL ALL'
12808         REJTIT(38) = 'POMCOR ALL'
12809         REJTIT(39) = 'DB-POM KIN'
12810         REJTIT(40) = 'DB-POM ALL'
12811         REJTIT(41) = 'SOFTXX ALL'
12812         REJTIT(42) = 'SOFTXX PSP'
12813
12814 C  write output
12815       ELSE IF(IMODE.EQ.-2) THEN
12816         WRITE(LO,'(/,1X,A,/,1X,A)') 'PHO_REJSTA: rejection statistics',
12817      &                             '--------------------------------'
12818         DO 300 I=1,NMXJ
12819           IF(IFAIL(I).GT.0)
12820      &      WRITE(LO,'(1X,I3,1X,A,5X,I15)') I,REJTIT(I),IFAIL(I)
12821  300    CONTINUE
12822       ELSE
12823         WRITE(LO,'(1X,A,I3)') 'PHO_REJSTA: invalid mode ',IMODE
12824       ENDIF
12825
12826       END
12827
12828 *$ CREATE PHO_POSPOM.FOR
12829 *COPY PHO_POSPOM
12830 CDECK  ID>, PHO_POSPOM
12831       SUBROUTINE PHO_POSPOM(IP,IND1,IND2,IGEN,IPOM,KCUT,ISWAP,IREJ)
12832 C***********************************************************************
12833 C
12834 C     registration of one cut pomeron (soft/semihard)
12835 C
12836 C     input:   IP      particle combination the pomeron belongs to
12837 C              IND1,2  position of X values in /POSOFT/
12838 C                      1 corresponds to a valence-pomeron
12839 C              IGEN    production process of mother particles
12840 C              IPOM    pomeron number
12841 C              KCUT    total number of cut pomerons and reggeons
12842 C
12843 C     output:  ISWAP   exchange of x values
12844 C              IND1,2  increased by the number of partons belonging
12845 C                      to the generated pomeron cut
12846 C              IREJ    success/failure
12847 C
12848 C**********************************************************************
12849       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12850       SAVE
12851
12852       PARAMETER ( DEPS   =  1.D-8 )
12853
12854 C  input/output channels
12855       INTEGER LI,LO
12856       COMMON /POINOU/ LI,LO
12857 C  event debugging information
12858       INTEGER NMAXD
12859       PARAMETER (NMAXD=100)
12860       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
12861      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12862       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
12863      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
12864 C  internal rejection counters
12865       INTEGER NMXJ
12866       PARAMETER (NMXJ=60)
12867       CHARACTER*10 REJTIT
12868       INTEGER IFAIL
12869       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
12870 C  model switches and parameters
12871       CHARACTER*8 MDLNA
12872       INTEGER ISWMDL,IPAMDL
12873       DOUBLE PRECISION PARMDL
12874       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
12875 C  general process information
12876       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
12877       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
12878 C  global event kinematics and particle IDs
12879       INTEGER IFPAP,IFPAB
12880       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
12881       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
12882 C  data of c.m. system of Pomeron / Reggeon exchange
12883       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
12884       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
12885      &                 SIDP,CODP,SIFP,COFP
12886       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
12887      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
12888      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
12889 C  obsolete cut-off information
12890       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
12891       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
12892 C  energy-interpolation table
12893       INTEGER IEETA2
12894       PARAMETER ( IEETA2 = 20 )
12895       INTEGER ISIMAX
12896       DOUBLE PRECISION SIGTAB,SIGECM
12897       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
12898 C  light-cone x fractions and c.m. momenta of soft cut string ends
12899       INTEGER MAXSOF
12900       PARAMETER ( MAXSOF = 50 )
12901       INTEGER IJSI2,IJSI1
12902       DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
12903       COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
12904      &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
12905      &                IJSI1(MAXSOF),IJSI2(MAXSOF)
12906 C  standard particle data interface
12907       INTEGER NMXHEP
12908       PARAMETER (NMXHEP=4000)
12909       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
12910       DOUBLE PRECISION PHEP,VHEP
12911       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
12912      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
12913      &                VHEP(4,NMXHEP)
12914 C  extension to standard particle data interface (PHOJET specific)
12915       INTEGER IMPART,IPHIST,ICOLOR
12916       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
12917 C  table of particle indices for recursive PHOJET calls
12918       INTEGER MAXIPX
12919       PARAMETER ( MAXIPX = 100 )
12920       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
12921       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
12922      &                IPOIX1,IPOIX2,IPOIX3
12923
12924       DIMENSION P1(4),P2(4),WGXHSD(2),WGX(6)
12925
12926       IREJ = 0
12927       ISWAP = 0
12928       JM1 = NPOSP(1)
12929       JM2 = NPOSP(2)
12930       INDX1 = IND1
12931       INDX2 = IND2
12932       EA1 = XS1(IND1)*ECMP/2.D0
12933       EA2 = XS1(IND1+1)*ECMP/2.D0
12934       EB1 = XS2(IND2)*ECMP/2.D0
12935       EB2 = XS2(IND2+1)*ECMP/2.D0
12936       CMASS1 = MIN(EA1,EA2)
12937       CMASS2 = MIN(EB1,EB2)
12938
12939 C  debug output
12940       IF(IDEB(9).GE.20) THEN
12941         WRITE(LO,'(1X,2A,5I4)') 'PHO_POSPOM: ',
12942      &    'IP,IND1,IND2,KCUT,IPOIX1',IP,IND1,IND2,KCUT,IPOIX1
12943         WRITE(LO,'(1X,A,2I4,1P2E12.4)') 'MOTHER1/2,MASS1/2',JM1,JM2,
12944      &    CMASS1,CMASS2
12945       ENDIF
12946
12947 C  flavours
12948       IF(IND1.EQ.1) THEN
12949         CALL PHO_VALFLA(JM1,IFLA1,IFLA2,EA1,EA2)
12950       ELSE
12951         CALL PHO_SEAFLA(JM1,IFLA1,IFLA2,CMASS1)
12952       ENDIF
12953       IF(IND2.EQ.1) THEN
12954         CALL PHO_VALFLA(JM2,IFLB1,IFLB2,EB1,EB2)
12955       ELSE
12956         CALL PHO_SEAFLA(JM2,IFLB1,IFLB2,CMASS2)
12957       ENDIF
12958       DO 75 I=1,4
12959         P1(I) = PSOFT1(I,IND1)+PSOFT1(I,IND1+1)
12960         P2(I) = PSOFT2(I,IND2)+PSOFT2(I,IND2+1)
12961  75   CONTINUE
12962
12963 C  pomeron resolved?
12964       IF((ISWMDL(14).GT.0).AND.(IPOIX1.GT.0)) THEN
12965 C  find energy for cross section calculation
12966         IF(IPAMDL(16).EQ.2) THEN
12967           ESUB = ECMP
12968         ELSE IF(IPAMDL(16).EQ.3) THEN
12969           IF(IPROCE.EQ.1) THEN
12970             ESUB = ECM
12971           ELSE
12972             ESUB = ECMP
12973           ENDIF
12974         ELSE
12975           ESUB = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2
12976      &                -(P1(2)+P2(2))**2-(P1(3)+P2(3))**2)
12977         ENDIF
12978 C  load cross sections from interpolation table
12979         IF(ESUB.LE.SIGECM(IP,1)) THEN
12980           I1 = 1
12981           I2 = 2
12982         ELSE IF(ESUB.LT.SIGECM(IP,ISIMAX)) THEN
12983           DO 50 I=2,ISIMAX
12984             IF(ESUB.LE.SIGECM(IP,I)) GOTO 200
12985  50       CONTINUE
12986  200      CONTINUE
12987           I1 = I-1
12988           I2 = I
12989         ELSE
12990           WRITE(LO,'(/1X,A,2E12.3)')
12991      &      'PHO_POSPOM: energy too high',ESUB,SIGECM(IP,ISIMAX)
12992           CALL PHO_PREVNT(-1)
12993           I1 = ISIMAX-1
12994           I2 = ISIMAX
12995         ENDIF
12996         FAC2=0.D0
12997         IF(I1.NE.I2) FAC2=LOG(ESUB/SIGECM(IP,I1))
12998      &                    /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
12999         FAC1=1.D0-FAC2
13000 C  calculate weights
13001 *       WGXHSD(1) = FAC2*SIGTAB(IP,32,I2)+FAC1*SIGTAB(IP,32,I1)
13002 *       WGXHSD(2) = FAC2*SIGTAB(IP,33,I2)+FAC1*SIGTAB(IP,33,I1)
13003 *       WGXHDD = FAC2*SIGTAB(IP,35,I2)+FAC1*SIGTAB(IP,35,I1)
13004 *       WGXCDF = FAC2*SIGTAB(IP,36,I2)+FAC1*SIGTAB(IP,36,I1)
13005 *       WGXPOM = FAC2*SIGTAB(IP,37,I2)+FAC1*SIGTAB(IP,37,I1)
13006 *       WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
13007
13008         WGXPOM = FAC2*(SIGTAB(IP,56,I2)+SIGTAB(IP,57,I2))
13009      &          +FAC1*(SIGTAB(IP,56,I1)+SIGTAB(IP,57,I1))
13010         WGXHSD(1) = FAC2*SIGTAB(IP,60,I2)+FAC1*SIGTAB(IP,60,I1)
13011         WGXHSD(2) = FAC2*SIGTAB(IP,62,I2)+FAC1*SIGTAB(IP,62,I1)
13012         WGXHDD = FAC2*(SIGTAB(IP,61,I2)+SIGTAB(IP,63,I2)
13013      &                 +SIGTAB(IP,64,I2))
13014      &          +FAC1*(SIGTAB(IP,61,I1)+SIGTAB(IP,63,I1)
13015      &                 +SIGTAB(IP,64,I1))
13016         WGXCDF = FAC2*(SIGTAB(IP,65,I2)+SIGTAB(IP,66,I2)
13017      &                 +SIGTAB(IP,67,I2)+SIGTAB(IP,68,I2))
13018      &          +FAC1*(SIGTAB(IP,65,I1)+SIGTAB(IP,66,I1)
13019      &                 +SIGTAB(IP,67,I1)+SIGTAB(IP,68,I1))
13020
13021 C  one-pomeron cut
13022         WGX(1) = WGXPOM-3.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)+15.D0*WGXCDF
13023 C  central diff. cut
13024         WGX(2) = WGXCDF
13025 C  diff. diss. of particle 1
13026         WGX(3) = WGXHSD(1)
13027 C  diff. diss. of particle 2
13028         WGX(4) = WGXHSD(2)
13029 C  double diff. dissociation
13030         WGX(5) = WGXHDD
13031 C  two-pomeron cut
13032         WGX(6) = 2.D0*(WGXHSD(1)+WGXHSD(2)+WGXHDD)
13033
13034 *       IF((WGX(1).LT.0.D0).AND.((IP.EQ.1).OR.(IDEB(9).GE.1))) THEN
13035 *         WRITE(LO,'(1X,A,/1X,A,I3,1P,2E11.3)') ' PHO_POSPOM: ',
13036 *    &      ' unitarity bound reached for ',IP,ESUB,WGX(1)
13037 *         WRITE(LO,'(5X,A)') 'WGXHSD(1),WGXHSD(2),WGXHDD,WGXCDF,WGXPOM:'
13038 *         WRITE(LO,'(5X,1P5E11.3)') WGXHSD,WGXHDD,WGXCDF,WGXPOM
13039 *         WRITE(LO,'(5X,A,/,5X,1P,6E11.3)') 'weight factors WG(1-6)',WGX
13040 *       ENDIF
13041
13042         SUM  = WGX(1)+WGX(2)+WGX(3)+WGX(4)+WGX(5)+WGX(6)
13043
13044 C  selection loop
13045  205    CONTINUE
13046         XI = DT_RNDM(SUM)*SUM
13047         I = 0
13048         SUM = 0.D0
13049  210    CONTINUE
13050           I = I+1
13051           SUM = SUM+WGX(I)
13052         IF((XI.GT.SUM).AND.(I.LT.6)) GOTO 210
13053 C  phase space correction
13054         IF(I.NE.1) THEN
13055           ISAM = 4
13056           IF(I.EQ.6) ISAM = 8
13057           PACC = EXP(-PARMDL(8)*DBLE(ISAM*PARMDL(160+IP))/ESUB)
13058 *         IF(DT_RNDM(SUM).GT.PACC) I=1
13059           IF(DT_RNDM(SUM).GT.PACC) GOTO 205
13060         ENDIF
13061
13062 C  do not generate diffraction for events with only one cut pomeron
13063         IF((KCUT.EQ.1).AND.(I.LT.6)) I = 1
13064
13065 C  do not generate recursive calls for remants with
13066 C  diquark-anti-diquark flavour contents
13067         if((abs(IFLA1).gt.1000).and.(IFLA1+IFLA2.eq.0)) I = 1
13068         if((abs(IFLB1).gt.1000).and.(IFLB1+IFLB2.eq.0)) I = 1
13069
13070 C  debug output
13071         IF(IDEB(9).GE.20) WRITE(LO,'(1X,A,/1X,I2,1P7E11.3)')
13072      &    'PHO_POSPOM: IPRO,ESUB,WGX(1-6)',I,ESUB,WGX
13073
13074         IF(I.GT.1) THEN
13075 C  second scattering needed
13076           CALL PHO_HACODE(IFLA1,IFLA2,IDHA1,IDUM)
13077           CALL PHO_HACODE(IFLB1,IFLB2,IDHA2,IDUM)
13078           IDPD1 = IPHO_ID2PDG(IDHA1)
13079           IDPD2 = IPHO_ID2PDG(IDHA2)
13080
13081           if(INDX1.eq.1) then
13082             if((IPHIST(2,JM1).GE.0).and.(IDHEP(JM1).NE.990))
13083      &        IGEN_had = IGEN
13084           else
13085             IGEN_had = -IGEN
13086           endif
13087           CALL PHO_REGPAR(1,IDPD1,IDHA1,JM1,JM2,P1(1),P1(2),P1(3),P1(4),
13088      &      IPOM,IGEN_had,0,0,IPOS1,1)
13089
13090           if(INDX2.eq.1) then
13091             if((IPHIST(2,JM2).GE.0).and.(IDHEP(JM2).NE.990))
13092      &        IGEN_had = IGEN
13093           else
13094             IGEN_had = -IGEN
13095           endif
13096           CALL PHO_REGPAR(1,IDPD2,IDHA2,JM2,JM1,P2(1),P2(2),P2(3),P2(4),
13097      &      IPOM,IGEN_had,0,0,IPOS1,1)
13098
13099           IND1 = IND1+2
13100           IND2 = IND2+2
13101 C  update index
13102           IPOIX2 = IPOIX2+1
13103           IF(IPOIX2.GT.MAXIPX) THEN
13104             WRITE(LO,'(1X,2A,2I5)') 'PHO_POSPOM: no space left in ',
13105      &        '/PORECU/ (IPOIX2,MAXIPX):',IPOIX2,MAXIPX
13106             IREJ = 1
13107             RETURN
13108           ENDIF
13109           IPORES(IPOIX2) = I+2
13110           IPOPOS(1,IPOIX2) = IPOS1-1
13111           IPOPOS(2,IPOIX2) = IPOS1
13112           RETURN
13113         ENDIF
13114       ENDIF
13115
13116  100  CONTINUE
13117       IF(ISWMDL(12).EQ.0) THEN
13118 C  sample colors
13119         CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
13120         CALL PHO_SELCOL(0,0,ICC1,ICC2,ICD1,ICD2,1)
13121
13122 C  purely gluonic pomeron or sea strings formed by gluons
13123
13124         IF(    ((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0))
13125      &     .OR.((IPAMDL(19).EQ.1).AND.(IND1.NE.1))) THEN
13126           IFLA1 = 21
13127           IFLA2 = 21
13128         ENDIF
13129         IF(    ((IDHEP(JM2).EQ.990).AND.(IPAMDL(20).GT.0))
13130      &     .OR.((IPAMDL(19).EQ.1).AND.(IND2.NE.1))) THEN
13131           IFLB1 = 21
13132           IFLB2 = 21
13133         ENDIF
13134
13135 C  color connection
13136         IF(IFLA1.NE.21) THEN
13137           IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
13138      &      .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
13139      &      CALL PHO_SWAPI(ICA1,ICD1)
13140         ENDIF
13141         IF(IFLB1.NE.21) THEN
13142           IF(((ABS(IFLB1).GT.6).AND.(IFLB1.LT.0))
13143      &      .OR.((ABS(IFLB1).LE.6).AND.(IFLB1.GT.0)))
13144      &      CALL PHO_SWAPI(ICB1,ICC1)
13145         ENDIF
13146         ISWAP = 0
13147         IF(ICA1*ICB1.GT.0) THEN
13148           IF((IND1.NE.1).AND.(IND2.NE.1)) THEN
13149             IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
13150               CALL PHO_SWAPI(IFLA1,IFLA2)
13151               CALL PHO_SWAPI(ICA1,ICD1)
13152             ELSE
13153               CALL PHO_SWAPI(IFLB1,IFLB2)
13154               CALL PHO_SWAPI(ICB1,ICC1)
13155             ENDIF
13156           ELSE IF(IND1.NE.1) THEN
13157             CALL PHO_SWAPI(IFLA1,IFLA2)
13158             CALL PHO_SWAPI(ICA1,ICD1)
13159           ELSE IF(IND2.NE.1) THEN
13160             CALL PHO_SWAPI(IFLB1,IFLB2)
13161             CALL PHO_SWAPI(ICB1,ICC1)
13162           ELSE IF((IFLA1.EQ.-IFLA2).AND.(IFLB1.EQ.-IFLB2)) THEN
13163             IF(DT_RNDM(CMASS1).GT.0.5D0) THEN
13164               CALL PHO_SWAPI(IFLA1,IFLA2)
13165               CALL PHO_SWAPI(ICA1,ICD1)
13166             ELSE
13167               CALL PHO_SWAPI(IFLB1,IFLB2)
13168               CALL PHO_SWAPI(ICB1,ICC1)
13169             ENDIF
13170           ELSE IF(IFLA1.EQ.-IFLA2) THEN
13171             CALL PHO_SWAPI(IFLA1,IFLA2)
13172             CALL PHO_SWAPI(ICA1,ICD1)
13173           ELSE IF(IFLB1.EQ.-IFLB2) THEN
13174             CALL PHO_SWAPI(IFLB1,IFLB2)
13175             CALL PHO_SWAPI(ICB1,ICC1)
13176           ELSE
13177             ISWAP = 1
13178             IF(IDEB(9).GE.5) THEN
13179               WRITE(LO,'(1X,A,I12)')
13180      &          'PHO_POSPOM: string end swap (KEVENT)',KEVENT
13181                 WRITE(LO,'(5X,A,4I7)')
13182      &          'flavors:',IFLA1,IFLA2,IFLB1,IFLB2
13183               WRITE(LO,'(5X,A,4I7)') 'colors :',ICA1,ICD1,ICB1,ICC1
13184             ENDIF
13185           ENDIF
13186         ENDIF
13187
13188 C  registration
13189
13190 C  purely gluonic pomeron or sea strings formed by gluons
13191         IF(IFLA1.EQ.21) THEN
13192           CALL PHO_REGPAR(-1,21,0,JM1,JM2,P1(1),P1(2),P1(3),P1(4),
13193      &      IPOM,IGEN,ICA1,ICD1,IPOS1,1)
13194           IND1 = IND1+2
13195
13196 C  strings formed by quarks
13197         ELSE
13198 C  valence quark labels
13199           IF((INDX1.EQ.1).and.(IPHIST(2,JM1).GE.0)
13200      &       .and.(IDHEP(JM1).NE.990)) THEN
13201             ICA2 = 1
13202             ICD2 = 1
13203           ENDIF
13204 C  registration
13205           CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
13206      &      PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICA1,
13207      &      ICA2,IPOS1,1)
13208           IND1 = IND1+1
13209           CALL PHO_REGPAR(-1,IFLA2,0,JM1,JM2,PSOFT1(1,IND1),
13210      &      PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),IPOM,IGEN,ICD1,
13211      &      ICD2,IPOS,1)
13212           IND1 = IND1+1
13213         ENDIF
13214
13215 C  purely gluonic pomeron or sea strings formed by gluons
13216         IF(IFLB1.EQ.21) THEN
13217           CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,P2(1),P2(2),P2(3),P2(4),
13218      &      IPOM,IGEN,ICB1,ICC1,IPOS2,1)
13219           IND2 = IND2+2
13220
13221 C  strings formed by quarks
13222         ELSE
13223 C  valence quark labels
13224           IF((INDX2.EQ.1).and.(IPHIST(2,JM2).GE.0)
13225      &       .and.(IDHEP(JM2).NE.990)) THEN
13226             ICB2 = 1
13227             ICC2 = 1
13228           ENDIF
13229 C  registration
13230           CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
13231      &      PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICB1,
13232      &      ICB2,IPOS,1)
13233           IND2 = IND2+1
13234           CALL PHO_REGPAR(-1,IFLB2,0,JM2,JM1,PSOFT2(1,IND2),
13235      &      PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),IPOM,IGEN,ICC1,
13236      &      ICC2,IPOS2,1)
13237           IND2 = IND2+1
13238         ENDIF
13239
13240 C  soft pt assignment
13241         IF(ISWMDL(18).EQ.0) THEN
13242           CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(IP),IREJ)
13243           IF(IREJ.NE.0) THEN
13244             IFAIL(25) = IFAIL(25)+1
13245             RETURN
13246           ENDIF
13247         ENDIF
13248       ELSE
13249 *       CALL PHO_BFKL(P1,P2,IPART,IREJ)
13250 *       IF(IREJ.NE.0) RETURN
13251       ENDIF
13252
13253       END
13254
13255 *$ CREATE PHO_HADSP2.FOR
13256 *COPY PHO_HADSP2
13257 CDECK  ID>, PHO_HADSP2
13258       SUBROUTINE PHO_HADSP2(IFLB,XS1,XMAX,XSOFT1,IREJ)
13259 C***********************************************************************
13260 C
13261 C     split hadron momentum XMAX into two partons using
13262 C     lower cut-off: AS
13263 C
13264 C     input:   IFLB    compressed particle code of particle to split
13265 C              XS1     sum of x values already selected
13266 C              XMAX    maximal x possible
13267 C
13268 C     output:  XS1     new sum of x values (without first one)
13269 C              XSOFT1  field of selected x values
13270 C
13271 C**********************************************************************
13272       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13273       SAVE
13274
13275       PARAMETER ( DEPS   =  1.D-8 )
13276
13277       DIMENSION XSOFT1(50)
13278
13279 C  input/output channels
13280       INTEGER LI,LO
13281       COMMON /POINOU/ LI,LO
13282 C  event debugging information
13283       INTEGER NMAXD
13284       PARAMETER (NMAXD=100)
13285       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13286      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13287       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13288      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13289 C  internal rejection counters
13290       INTEGER NMXJ
13291       PARAMETER (NMXJ=60)
13292       CHARACTER*10 REJTIT
13293       INTEGER IFAIL
13294       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13295 C  data on most recent hard scattering
13296       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13297       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13298      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13299      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13300       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13301      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13302      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13303      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13304      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13305
13306 C  model exponents
13307       DATA PVMES1 /-0.5D0/
13308       DATA PVMES2 /-0.5D0/
13309       DATA PVBAR1 / 1.5D0/
13310       DATA PVBAR2 /-0.5D0/
13311 C
13312       IREJ = 0
13313       ITMAX = 100
13314 C
13315 C  mesonic particle
13316       IF(ipho_bar3(IFLB,0).EQ.0) THEN
13317         XPOT1 = PVMES1+1.D0
13318         XPOT2 = PVMES2+1.D0
13319 C  baryonic particle
13320       ELSE
13321         XPOT1 = PVBAR1+1.D0
13322         XPOT2 = PVBAR2+1.D0
13323       ENDIF
13324       ITER = 0
13325       XREST= 1.D0-XS1
13326 C  selection loop
13327  100  CONTINUE
13328         ITER = ITER+1
13329         IF(ITER.GE.ITMAX) THEN
13330           IF(IDEB(39).GE.3) THEN
13331             WRITE(LO,'(1X,A,I8)')
13332      &        'PHO_HADSP2: REJECTION (ITER)',ITER
13333             WRITE(LO,'(5X,A,3E12.3)') 'XS1,XMAX,AS:',XS1,XMAX,AS
13334           ENDIF
13335           IFAIL(14) = IFAIL(14)+1
13336           IREJ = 1
13337           RETURN
13338         ENDIF
13339         ZZ = XREST*PHO_RNDBET(XPOT2,XPOT1)
13340       IF((ZZ.GT.XMAX).OR.(ZZ.LT.AS)) GOTO 100
13341       XSS1 = XS1 + ZZ
13342       IF((1.D0-XSS1).LT.AS) GOTO 100
13343 C
13344       XS1 = XSS1
13345       XSOFT1(1) = 1.D0-XSS1
13346       XSOFT1(2) = ZZ
13347 C  debug output
13348       IF(IDEB(39).GE.10) THEN
13349         WRITE(LO,'(1X,A,2I8)') 'PHO_HADSP2: ITMAX,ITER',ITMAX,ITER
13350         WRITE(LO,'(5X,A,3E10.3,5X,2E11.4)') 'XS1,XMAX,AS  X1,X2:',
13351      &    XS1,XMAX,AS,XSOFT1(1),XSOFT1(2)
13352       ENDIF
13353       END
13354
13355 *$ CREATE PHO_HADSP3.FOR
13356 *COPY PHO_HADSP3
13357 CDECK  ID>, PHO_HADSP3
13358       SUBROUTINE PHO_HADSP3(IFLB,XS1,XMAX,XSOFT1,IREJ)
13359 C***********************************************************************
13360 C
13361 C     split hadron momentum XMAX into diquark & quark pair
13362 C     using lower cut-off: AS
13363 C
13364 C     input:   IFLB    compressed particle code of particle to split
13365 C              XS1     sum of x values already selected
13366 C              XMAX    maximal x possible
13367 C
13368 C     output:  XS1     new sum of x values
13369 C              XSOFT1  field of selected x values
13370 C
13371 C
13372 C**********************************************************************
13373       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13374       SAVE
13375       PARAMETER ( DEPS   =  1.D-8 )
13376
13377       DIMENSION XSOFT1(50),XSOFT2(50)
13378
13379 C  input/output channels
13380       INTEGER LI,LO
13381       COMMON /POINOU/ LI,LO
13382 C  event debugging information
13383       INTEGER NMAXD
13384       PARAMETER (NMAXD=100)
13385       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13386      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13387       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13388      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13389 C  internal rejection counters
13390       INTEGER NMXJ
13391       PARAMETER (NMXJ=60)
13392       CHARACTER*10 REJTIT
13393       INTEGER IFAIL
13394       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13395 C  data of c.m. system of Pomeron / Reggeon exchange
13396       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
13397       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
13398      &                 SIDP,CODP,SIFP,COFP
13399       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
13400      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
13401      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
13402
13403       DIMENSION XPOT1(3),XPOT2(3),XMIN(2,3)
13404
13405 C  model exponents
13406       DATA PVMES1 /-0.5D0/
13407       DATA PVMES2 /-0.5D0/
13408       DATA PSMES  /-0.99D0/
13409       DATA PVBAR1 / 1.5D0/
13410       DATA PVBAR2 /-0.5D0/
13411       DATA PSBAR  /-0.99D0/
13412 C
13413       IREJ = 0
13414 C
13415 C  determine exponents
13416 C  particle 1
13417 C
13418       XMMIN = 0.3D0/ECMP
13419       XBMIN = 1.6D0/ECMP
13420 C  mesonic particle
13421       IF(ipho_bar3(IFLB,0).EQ.0) THEN
13422         XPOT1(1) = PVMES1
13423         XMIN(1,1)  = XMMIN
13424         XPOT1(2) = PVMES2
13425         XMIN(1,2)  = XMMIN
13426         XPOT1(3) = PSMES
13427         XMIN(1,3)  = XMMIN
13428 C  baryonic particle
13429       ELSE
13430         XPOT1(1) = PVBAR1
13431         XMIN(1,1)  = XBMIN
13432         XPOT1(2) = PVBAR2
13433         XMIN(1,2)  = XMMIN
13434         XPOT1(3) = PSBAR
13435         XMIN(1,3)  = XMMIN
13436       ENDIF
13437 C  particle 2
13438 C  mesonic particle
13439       XPOT2(1) = PVMES1
13440       XMIN(2,1)  = XMMIN
13441       XPOT2(2) = PVMES2
13442       XMIN(2,2)  = XMMIN
13443       XPOT2(3) = PSMES
13444       XMIN(2,3)  = XMMIN
13445 C
13446       XDUM1 = 0.01D0
13447       XDUM2 = 0.99D0
13448       CALL PHO_SELSXS(3,3,XPOT1,XPOT2,XMIN,XS1,XDUM1,XMAX,XDUM2,
13449      &            XSOFT1,XSOFT2,IREJ)
13450 C  rejection?
13451       IF(IREJ.NE.0) THEN
13452         IF(IDEB(74).GE.3) WRITE(LO,'(1X,A,I6,2E12.4)')
13453      &    'PHO_HADSP3: rejection (IFLB,XS1,XMAX)',IFLB,XS1,XMAX
13454         IFAIL(15) = IFAIL(15)+1
13455         IREJ = 1
13456         RETURN
13457       ENDIF
13458 C  debug output
13459       IF(IDEB(74).GE.10) THEN
13460         WRITE(LO,'(1X,A,I6,2E12.4)')
13461      &    'PHO_HADSP3: IFLB,XS1,XMAX',IFLB,XS1,XMAX
13462         DO 100 I=1,3
13463           WRITE(LO,'(10X,I4,2E12.4)') I,XSOFT1(I),XSOFT2(I)
13464  100    CONTINUE
13465       ENDIF
13466
13467       END
13468
13469 *$ CREATE PHO_SOFTXX.FOR
13470 *COPY PHO_SOFTXX
13471 CDECK  ID>, PHO_SOFTXX
13472       SUBROUTINE PHO_SOFTXX(JM1,JM2,MSPAR1,MSPAR2,IVAL1,IVAL2,MSM1,MSM2,
13473      &                  XSUM1,XSUM2,XMAX1,XMAX2,XS1,XS2,IREJ)
13474 C***********************************************************************
13475 C
13476 C    select soft x values
13477 C
13478 C    input:   JM1,JM2    mother particle index in POEVT1
13479 C                        (0  flavour not known before)
13480 C             MSPAR1,2   number of x values to select
13481 C             IVAL1,2    number valence quarks involved in hard
13482 C                        scattering (0,1,2)
13483 C             MSM1,2     minimum number of soft x to get sampled
13484 C             XSUM1,2    sum of all x values samples up this call
13485 C             XMAX1,2    max. x value
13486 C
13487 C    output   XSUM1,2    new sum of x-values sampled
13488 C             XS1,2      field containing sampled x values
13489 C
13490 C    x values of valence partons are first given
13491 C
13492 C***********************************************************************
13493       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13494       SAVE
13495
13496 C  input/output channels
13497       INTEGER LI,LO
13498       COMMON /POINOU/ LI,LO
13499 C  event debugging information
13500       INTEGER NMAXD
13501       PARAMETER (NMAXD=100)
13502       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13503      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13504       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13505      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13506 C  internal rejection counters
13507       INTEGER NMXJ
13508       PARAMETER (NMXJ=60)
13509       CHARACTER*10 REJTIT
13510       INTEGER IFAIL
13511       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
13512 C  model switches and parameters
13513       CHARACTER*8 MDLNA
13514       INTEGER ISWMDL,IPAMDL
13515       DOUBLE PRECISION PARMDL
13516       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
13517 C  data of c.m. system of Pomeron / Reggeon exchange
13518       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
13519       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
13520      &                 SIDP,CODP,SIFP,COFP
13521       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
13522      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
13523      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
13524 C  standard particle data interface
13525       INTEGER NMXHEP
13526       PARAMETER (NMXHEP=4000)
13527       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
13528       DOUBLE PRECISION PHEP,VHEP
13529       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
13530      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
13531      &                VHEP(4,NMXHEP)
13532 C  extension to standard particle data interface (PHOJET specific)
13533       INTEGER IMPART,IPHIST,ICOLOR
13534       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
13535 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
13536       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
13537       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
13538       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
13539      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
13540 C  obsolete cut-off information
13541       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
13542       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
13543 C  data on most recent hard scattering
13544       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13545       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13546      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13547      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13548       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13549      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13550      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13551      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13552      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13553
13554       DIMENSION XS1(*),XS2(*)
13555
13556       INTEGER MAXPOT
13557       PARAMETER ( MAXPOT = 50 )
13558       DIMENSION XPOT1(MAXPOT),XPOT2(MAXPOT),XMIN(2,MAXPOT)
13559
13560       IREJ = 0
13561
13562       MSMAX = MAX(MSPAR1,MSPAR2)
13563       MSMIN = MAX(MSM1,MSM2)
13564       IF(MSMAX.GT.MAXPOT) THEN
13565         WRITE(LO,'(1X,2A,2I4)') 'PHO_SOFTXX: no space left in ',
13566      &    'local fields XPOT1/2 (MSMAX,MAXPOT):',MSMAX,MAXPOT
13567         IREJ = 1
13568         RETURN
13569       ENDIF
13570 C  determine exponents
13571       IBAR1 = ipho_bar3(JM1,2)
13572       IBAR2 = ipho_bar3(JM2,2)
13573       ISWAP = 0
13574       IF((IBAR1*IBAR2).LT.0) ISWAP = 1
13575 C  meson-baryon scattering (asymmetric sea)
13576       IF((ABS(IBAR1)+ABS(IBAR2)).EQ.1) THEN
13577         PSBAR = PARMDL(53)
13578         PSMES = PARMDL(57)
13579       ELSE
13580         PSBAR = PARMDL(52)
13581         PSMES = PARMDL(56)
13582       ENDIF
13583
13584 C  lower limits for x sampling
13585       XMMINA = 2.D0*PARMDL(157)/ECMP
13586       XBMINA = 2.D0*PARMDL(158)/ECMP
13587       XSMINA = 2.D0*PARMDL(159)/ECMP
13588       XMIN1 = MAX(XSOMIN,AS/XMAX2)
13589       XMIN2 = MAX(XSOMIN,AS/XMAX1)
13590       XMAXP1 = MIN(1.D0-XMIN1*MSMAX,XMAX1)
13591       XMAXP2 = MIN(1.D0-XMIN2*MSMAX,XMAX2)
13592       XMIN1 = MAX(AS/XMAX2,XMIN1)
13593       XMIN2 = MAX(AS/XMAX1,XMIN2)
13594
13595 C  particle 1
13596       XMMIN1 = MAX(XMIN1,XMMINA)
13597       XBMIN1 = MAX(XMIN1,XBMINA)
13598       XSMIN1 = MAX(XMIN1,XSMINA)
13599 C  mesonic particle
13600       IF(IBAR1.EQ.0) THEN
13601         IF(IHFLS(1).EQ.0) THEN
13602           XPOT1(1) = PARMDL(62)
13603           XMIN(1,1)  = XSMIN1
13604           XPOT1(2) = PARMDL(63)
13605           XMIN(1,2)  = XSMIN1
13606         ELSE
13607           XPOT1(1) = PARMDL(54)
13608           XMIN(1,1)  = XMMIN1
13609           XPOT1(2) = PARMDL(55)
13610           XMIN(1,2)  = XMMIN1
13611         ENDIF
13612         DO 100 I=3-IVAL1,MSMAX
13613           XPOT1(I) = PSMES
13614           XMIN(1,I)  = XSMIN1
13615  100    CONTINUE
13616 C  baryonic particle
13617       ELSE
13618         IF(IHFLS(1).EQ.0) THEN
13619           XPOT1(1) = PARMDL(62)
13620           XMIN(1,1)  = XSMIN1
13621           XPOT1(2) = PARMDL(63)
13622           XMIN(1,2)  = XSMIN1
13623         ELSE
13624           XPOT1(1) = PARMDL(50)
13625           XMIN(1,1)  = XBMIN1
13626           XPOT1(2) = PARMDL(51)
13627           XMIN(1,2)  = XMMIN1
13628         ENDIF
13629         DO 200 I=3-IVAL1,MSMAX
13630           XPOT1(I) = PSBAR
13631           XMIN(1,I)  = XSMIN1
13632  200    CONTINUE
13633       ENDIF
13634
13635 C  particle 2
13636       XMMIN2 = MAX(XMIN2,XMMINA)
13637       XBMIN2 = MAX(XMIN2,XBMINA)
13638       XSMIN2 = MAX(XMIN2,XSMINA)
13639 C  mesonic particle
13640       IF(IBAR2.EQ.0) THEN
13641         IF(IHFLS(2).EQ.0) THEN
13642           XPOT2(1) = PARMDL(62)
13643           XMIN(2,1)  = XSMIN2
13644           XPOT2(2) = PARMDL(63)
13645           XMIN(2,2)  = XSMIN2
13646         ELSE
13647           XPOT2(1) = PARMDL(54)
13648           XMIN(2,1)  = XMMIN2
13649           XPOT2(2) = PARMDL(55)
13650           XMIN(2,2)  = XMMIN2
13651         ENDIF
13652         DO 300 I=3-IVAL2,MSMAX
13653           XPOT2(I) = PSMES
13654           XMIN(2,I)  = XSMIN2
13655  300    CONTINUE
13656 C  baryonic particle
13657       ELSE
13658         IF(IHFLS(2).EQ.0) THEN
13659           XPOT2(1) = PARMDL(62)
13660           XMIN(2,1)  = XSMIN2
13661           XPOT2(2) = PARMDL(63)
13662           XMIN(2,2)  = XSMIN2
13663         ELSE
13664           XPOT2(1) = PARMDL(50)
13665           XMIN(2,1)  = XBMIN2
13666           XPOT2(2) = PARMDL(51)
13667           XMIN(2,2)  = XMMIN2
13668         ENDIF
13669         DO 400 I=3-IVAL2,MSMAX
13670           XPOT2(I) = PSBAR
13671           XMIN(2,I)  = XSMIN2
13672  400    CONTINUE
13673       ENDIF
13674
13675       XSS1 = XSUM1
13676       XSS2 = XSUM2
13677       MSOFT = MSMAX
13678
13679 C  check limits (important for valences)
13680       IF((XMIN(1,1).GE.XMAXP1).OR.(XMIN(1,2).GE.XMAXP1)) GOTO 1000
13681       IF((XMIN(2,1).GE.XMAXP2).OR.(XMIN(2,2).GE.XMAXP2)) GOTO 1000
13682
13683       XMINS1 = XSS1
13684       IF(IHFLS(1).NE.0) XMINS1 = XMINS1+(PARMDL(166)/ECMP)**2
13685       XMINS2 = XSS2
13686       IF(IHFLS(2).NE.0) XMINS2 = XMINS2+(PARMDL(166)/ECMP)**2
13687       DO 10 I=1,MSOFT
13688         XMINS1 = XMINS1+XMIN(1,I)
13689         XMINS2 = XMINS2+XMIN(2,I)
13690  10   CONTINUE
13691       IF((XMINS1.GE.1.D0).OR.(XMINS2.GE.1.D0)) GOTO 1000
13692
13693 C  try to sample x values
13694       IF(IPAMDL(14).EQ.0) THEN
13695         IF(MSOFT.EQ.2) THEN
13696           CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13697      &                XS1,XS2,IREJ)
13698         ELSE IF(MSOFT.LT.5) THEN
13699           CALL PHO_SELSXR(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13700      &                XMAXP1,XMAXP2,XS1,XS2,IREJ)
13701         ELSE
13702           CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13703      &                XMAXP1,XMAXP2,XS1,XS2,IREJ)
13704         ENDIF
13705       ELSE IF(IPAMDL(14).EQ.1) THEN
13706         IF(MSOFT.EQ.2) THEN
13707           CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13708      &                XS1,XS2,IREJ)
13709         ELSE
13710           CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13711      &                XMAXP1,XMAXP2,XS1,XS2,IREJ)
13712         ENDIF
13713       ELSE IF(IPAMDL(14).EQ.2) THEN
13714         CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13715      &              XMAXP1,XMAXP2,XS1,XS2,IREJ)
13716       ELSE IF(IPAMDL(14).EQ.3) THEN
13717         IF(MSOFT.EQ.2) THEN
13718           CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSS1,XSS2,XMAXP1,XMAXP2,
13719      &                XS1,XS2,IREJ)
13720         ELSE IF(IVAL1+IVAL2.EQ.0) THEN
13721           CALL PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13722      &                XMAXP1,XMAXP2,XS1,XS2,IREJ)
13723         ELSE
13724           CALL PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XSS1,XSS2,
13725      &                XMAXP1,XMAXP2,XS1,XS2,IREJ)
13726         ENDIF
13727       ELSE
13728         WRITE(LO,'(/,1X,A,I3)')
13729      &    'PHO_SOFTXX:ERROR: unsupported IPAMDL(14)',IPAMDL(14)
13730         STOP
13731       ENDIF
13732       IF(IREJ.NE.0) THEN
13733         IFAIL(41) = IFAIL(41)+1
13734         IF(IDEB(60).GE.2) THEN
13735           WRITE(LO,'(1X,A,I12,4I3)')
13736      &      'PHO_SOFTXX: rejection: EVE,MSP1/2,MSM1/2',
13737      &      KEVENT,MSPAR1,MSPAR2,MSM1,MSM2
13738           WRITE(LO,'(1X,A,1P4E11.3)') 'XSUM1/2,XMAX1/2',
13739      &      XSUM1,XSUM2,XMAX1,XMAX2
13740         ENDIF
13741         RETURN
13742       ENDIF
13743       IF(MSOFT.NE.MSMAX) THEN
13744         MSDIFF = MSMAX-MSOFT
13745         MSPAR1 = MSPAR1-MSDIFF
13746         MSPAR2 = MSPAR2-MSDIFF
13747       ENDIF
13748
13749 C  correct for different MSPAR numbers
13750       IF(MSOFT.NE.MSPAR1) THEN
13751         IF(MSPAR1.GT.1) THEN
13752           XDEL = 0.D0
13753           DO 500 I=MSPAR1+1,MSOFT
13754             XDEL = XDEL+XS1(I)
13755  500      CONTINUE
13756           XFAC = (1.D0-XSUM1)/(1.D0-XDEL-XSUM1)
13757           DO 550 I=2,MSPAR1
13758             XS1(I) = XS1(I)*XFAC
13759  550      CONTINUE
13760           XSS1 = (XSS1-XDEL-XSUM1)*XFAC+XSUM1
13761         ELSE
13762           XSS1 = XSUM1
13763         ENDIF
13764       ENDIF
13765       IF(MSOFT.NE.MSPAR2) THEN
13766         IF(MSPAR2.GT.1) THEN
13767           XDEL = 0.D0
13768           DO 600 I=MSPAR2+1,MSOFT
13769             XDEL = XDEL+XS2(I)
13770  600      CONTINUE
13771           XFAC = (1.D0-XSUM2)/(1.D0-XDEL-XSUM2)
13772           DO 650 I=2,MSPAR2
13773             XS2(I) = XS2(I)*XFAC
13774  650      CONTINUE
13775           XSS2 = (XSS2-XDEL-XSUM2)*XFAC+XSUM2
13776         ELSE
13777           XSS2 = XSUM2
13778         ENDIF
13779       ENDIF
13780
13781 C  first x entry
13782       XS1(1) = 1.D0 - XSS1
13783       XS2(1) = 1.D0 - XSS2
13784       XSUM1 = XSS1
13785       XSUM2 = XSS2
13786
13787 C  debug output
13788       IF(IDEB(60).GE.10) THEN
13789         WRITE(LO,'(1X,A,I8,2I4,2E12.4)')
13790      &    'PHO_SOFTXX: EVE,MSPAR1/2,XSUM1/2:',
13791      &    KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
13792         WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I  XS1/2   XPOT1/2  XMIN1/2'
13793         DO 30 I=1,MSOFT
13794           WRITE(LO,'(5X,I3,6E12.4)') I,XS1(I),XS2(I),XPOT1(I),XPOT2(I),
13795      &      XMIN(1,I),XMIN(2,I)
13796  30     CONTINUE
13797       ENDIF
13798
13799       RETURN
13800
13801 C  not enough phase space
13802  1000 CONTINUE
13803
13804       IFAIL(42) = IFAIL(42)+1
13805       IREJ = 1
13806
13807 C  warning message
13808       IF(IDEB(60).GE.1) THEN
13809         WRITE (6,'(1X,A,1P,2E11.3,/1X,A,/5X,6E11.3)')
13810      &    'PHO_SOFTXX: Xmin>Xmax or sum(Xmin)>1 (ECM,AS)',
13811      &    ECMP,AS,'PHO_SOFTXX: Xmin1/2,Xmaxp1/2,sum(Xmin1/2)',
13812      &    XMIN1,XMIN2,XMAXP1,XMAXP2,XMINS1,XMINS2
13813         WRITE(LO,'(1X,A,1P,3E11.3)')
13814      &    'PHO_SOFTXX: Xmmina,Xbmina,Xsmina:',XMMINA,XBMINA,XSMINA
13815         WRITE(LO,'(1X,A,1P,3E11.3)')
13816      &    'PHO_SOFTXX: Xmmin1,Xbmin1,Xsmin1:',XMMIN1,XBMIN1,XSMIN1
13817         WRITE(LO,'(1X,A,1P,3E11.3)')
13818      &    'PHO_SOFTXX: Xmmin2,Xbmin2,Xsmin2:',XMMIN2,XBMIN2,XSMIN2
13819         WRITE(LO,'(1X,A)')
13820      &    'PHO_SOFTXX: Table of lower x limits (I,Xmin(1,I),Xmin(2,I))'
13821         DO 27 I=1,MSOFT
13822           WRITE(LO,'(5X,I3,1P,2E11.3)') I,XMIN(1,I),XMIN(2,I)
13823  27     CONTINUE
13824         WRITE(LO,'(1X,A,I10,2I4,2E11.3)')
13825      &    'PHO_SOFTXX: KEVENT,MSPAR1/2,XSUM1/2:',
13826      &    KEVENT,MSPAR1,MSPAR2,XSUM1,XSUM2
13827         WRITE(LO,'(1X,A)') 'PHO_SOFTXX: I   XPOT1/2   XMIN1/2'
13828         DO 25 I=1,MSOFT
13829           WRITE(LO,'(5X,I3,4E12.4)') I,XPOT1(I),XPOT2(I),
13830      &    XMIN(1,I),XMIN(2,I)
13831  25     CONTINUE
13832       ENDIF
13833
13834       END
13835
13836 *$ CREATE PHO_SELSXR.FOR
13837 *COPY PHO_SELSXR
13838 CDECK  ID>, PHO_SELSXR
13839       SUBROUTINE PHO_SELSXR(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
13840      &                  XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
13841 C***********************************************************************
13842 C
13843 C    select x values of soft string ends (rejection method)
13844 C
13845 C***********************************************************************
13846       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13847       SAVE
13848
13849       DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
13850
13851 C  input/output channels
13852       INTEGER LI,LO
13853       COMMON /POINOU/ LI,LO
13854 C  event debugging information
13855       INTEGER NMAXD
13856       PARAMETER (NMAXD=100)
13857       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
13858      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13859       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
13860      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
13861 C  model switches and parameters
13862       CHARACTER*8 MDLNA
13863       INTEGER ISWMDL,IPAMDL
13864       DOUBLE PRECISION PARMDL
13865       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
13866 C  data on most recent hard scattering
13867       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13868       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13869      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
13870      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
13871       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
13872      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
13873      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
13874      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
13875      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
13876 C  global event kinematics and particle IDs
13877       INTEGER IFPAP,IFPAB
13878       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
13879       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
13880 C  obsolete cut-off information
13881       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
13882       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
13883
13884       DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
13885
13886       IF(IDEB(13).GE.10) THEN
13887         WRITE(LO,'(1X,A)') 'PHO_SELSXR:'
13888         WRITE(LO,'(5X,A,I4,5E11.3)') 'MSOFT,XS1,XS2,XMAX1,2',
13889      &    MSOFT,XS1,XS2,XMAX1,XMAX2
13890         DO 40 I=1,MSOFT
13891           WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
13892  40     CONTINUE
13893       ENDIF
13894 C
13895       IREJ = 0
13896 C
13897       XMINK = MAX(PSOMIN/ECM*2.D0,XSOMIN)
13898       XMIN1 = MAX(AS/XMAX1,XMINK)
13899       XMIN2 = MAX(AS/XMAX2,XMINK)
13900 C
13901       IF(MSOFT.EQ.1) THEN
13902         XSOFT1(2) = 0.D0
13903         XSOFT2(2) = 0.D0
13904         RETURN
13905       ENDIF
13906       XWMAX = MAX(XMAX1**XPOT1(1),XMIN1**XPOT1(1))
13907      &        *MAX(XMAX2**XPOT2(1),XMIN2**XPOT2(1))
13908 C
13909  10   CONTINUE
13910 C
13911       DO 50 I=2,MSOFT
13912         POT(1,I) = XPOT1(I)+1.D0
13913         POT(2,I) = XPOT2(I)+1.D0
13914         REVP(1,I) = 1.D0/POT(1,I)
13915         REVP(2,I) = 1.D0/POT(2,I)
13916         XLMIN(1,I) = XMIN(1,I)**POT(1,I)
13917         XLMAX = XMAX1**POT(1,I)
13918         XLDIF(1,I) = XLMAX-XLMIN(1,I)
13919         XLMIN(2,I) = XMIN(2,I)**POT(2,I)
13920         XLMAX = XMAX2**POT(2,I)
13921         XLDIF(2,I) = XLMAX-XLMIN(2,I)
13922  50   CONTINUE
13923 C
13924       ITRY0 = 0
13925  5    CONTINUE
13926       ITRY0 = ITRY0 + 1
13927       IF(ITRY0.GE.IPAMDL(181)) THEN
13928         IF(MSOFT-MSMIN.GE.2) THEN
13929           MSOFT = MSMIN
13930           GOTO 10
13931         ENDIF
13932         GOTO 1000
13933       ENDIF
13934       XREST1 = 1.D0-XS1
13935       XREST2 = 1.D0-XS2
13936       DO 100 I=2,MSOFT
13937         ITRY1 = 0
13938
13939  20     CONTINUE
13940         Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
13941         Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
13942         XSOFT1(I) = Z1**REVP(1,I)
13943         XSOFT2(I) = Z2**REVP(2,I)
13944         ITRY1 = ITRY1+1
13945         IF(ITRY1.GE.50) GOTO 1000
13946         IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
13947
13948         XREST1 = XREST1-XSOFT1(I)
13949         IF(XREST1.LT.XMIN1) GOTO 5
13950         IF(XREST1.LT.XMIN(1,1)) GOTO 5
13951         XREST2 = XREST2-XSOFT2(I)
13952         IF(XREST2.LT.XMIN2) GOTO 5
13953         IF(XREST2.LT.XMIN(2,1)) GOTO 5
13954         IF(XREST1*XREST2.LT.AS) GOTO 5
13955
13956  100  CONTINUE
13957       XSOFT1(1) = XREST1
13958       XSOFT2(1) = XREST2
13959       IREJ=0
13960 *     XX = 1.D0
13961 *     DO 200 I=2,MSOFT
13962 *       XX = XX*XSOFT1(I)**XPOT1(I)*XSOFT2(I)**XPOT2(I)
13963 *200  CONTINUE
13964       XX = XSOFT1(1)**XPOT1(1)*XSOFT2(1)**XPOT2(1)
13965       IF((XX-DT_RNDM(XX)*XWMAX).LT.0.D0) GOTO 5
13966
13967       XS1 = 1.D0-XREST1
13968       XS2 = 1.D0-XREST2
13969       RETURN
13970
13971  1000 CONTINUE
13972       IREJ = 1
13973       IF(IDEB(13).GE.2) THEN
13974         WRITE(LO,'(1X,A,2I4)')
13975      &    'PHO_SELSXR: REJECTION(ITRY0/1)',ITRY0,ITRY1
13976         WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
13977       ENDIF
13978
13979       END
13980
13981 *$ CREATE PHO_SELSX2.FOR
13982 *COPY PHO_SELSX2
13983 CDECK  ID>, PHO_SELSX2
13984       SUBROUTINE PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
13985      &                  XS1,XS2,IREJ)
13986 C***********************************************************************
13987 C
13988 C    select x values of soft string ends using PHO_RNDBET
13989 C
13990 C***********************************************************************
13991       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13992       SAVE
13993
13994       DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XS1(*),XS2(*)
13995
13996 C  input/output channels
13997       INTEGER LI,LO
13998       COMMON /POINOU/ LI,LO
13999 C  event debugging information
14000       INTEGER NMAXD
14001       PARAMETER (NMAXD=100)
14002       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14003      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14004       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14005      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14006 C  model switches and parameters
14007       CHARACTER*8 MDLNA
14008       INTEGER ISWMDL,IPAMDL
14009       DOUBLE PRECISION PARMDL
14010       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14011 C  data on most recent hard scattering
14012       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14013       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14014      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14015      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14016       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14017      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14018      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14019      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14020      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14021 C  obsolete cut-off information
14022       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14023       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14024
14025       IREJ = 0
14026
14027       IF(IDEB(32).GE.10) THEN
14028         WRITE(LO,'(1X,A)') 'PHO_SELSX2:'
14029         WRITE(LO,'(5X,A,5E11.3)') 'AS,XSUM1,2,XMAX1,2',
14030      &    AS,XSUM1,XSUM2,XMAX1,XMAX2
14031         DO 30 I=1,2
14032           WRITE(LO,'(5X,A,I4,2E12.3)') 'EXPONENTS',I,XPOT1(I),XPOT2(I)
14033  30     CONTINUE
14034       ENDIF
14035
14036       FAC1 = 1.D0-XSUM1
14037       FAC2 = 1.D0-XSUM2
14038       FAC = FAC1*FAC2
14039       GAM1 = XPOT1(1)+1.D0
14040       GAM2 = XPOT2(1)+1.D0
14041       BET1 = XPOT1(2)+1.D0
14042       BET2 = XPOT2(2)+1.D0
14043
14044       ITRY0 = 0
14045       DO 100 I=1,IPAMDL(182)
14046
14047         ITRY1 = 0
14048  10     CONTINUE
14049           X1 = PHO_RNDBET(GAM1,BET1)
14050           ITRY1 = ITRY1+1
14051           IF(ITRY1.GE.50) GOTO 1000
14052         IF((X1.LE.XMIN(1,1)).OR.((1.D0-X1).LE.XMIN(1,2))) GOTO 10
14053
14054         ITRY2 = 0
14055  11     CONTINUE
14056           X2 = PHO_RNDBET(GAM2,BET2)
14057           ITRY2 = ITRY2+1
14058           IF(ITRY2.GE.50) GOTO 1000
14059         IF((X2.LE.XMIN(2,1)).OR.((1.D0-X2).LE.XMIN(2,2))) GOTO 11
14060
14061         X3 = 1.D0 - X1
14062         X4 = 1.D0 - X2
14063         IF(X1*X2*FAC.GT.AS) THEN
14064           IF(X3*X4*FAC.GT.AS) THEN
14065             XS1(1) = X1*FAC1
14066             XS1(2) = X3*FAC1
14067             XS2(1) = X2*FAC2
14068             XS2(2) = X4*FAC2
14069             IF(XS1(1).GT.XMIN(1,1)) THEN
14070               IF(XS2(1).GT.XMIN(2,1)) THEN
14071                 IF(XS1(2).GT.XMIN(1,2)) THEN
14072                   IF(XS2(2).GT.XMIN(2,2)) THEN
14073                     XSUM1 = XSUM1+XS1(2)
14074                     XSUM2 = XSUM2+XS2(2)
14075                     GOTO 300
14076                   ENDIF
14077                 ENDIF
14078               ENDIF
14079             ENDIF
14080           ENDIF
14081         ENDIF
14082         ITRY0 = ITRY0+1
14083
14084  100  CONTINUE
14085
14086  1000 CONTINUE
14087       IREJ = 1
14088       IF(IDEB(32).GE.2) THEN
14089         WRITE(LO,'(1X,A,3I4)')
14090      &    'PHO_SELSX2: REJECTION(ITRY0/1/2)',ITRY0,ITRY1,ITRY2
14091         WRITE(LO,'(5X,A,3E12.3)') 'XMAX1,2,AS:',XMAX1,XMAX2,AS
14092       ENDIF
14093       RETURN
14094  300  CONTINUE
14095
14096       END
14097
14098 *$ CREATE PHO_SELSXS.FOR
14099 *COPY PHO_SELSXS
14100 CDECK  ID>, PHO_SELSXS
14101       SUBROUTINE PHO_SELSXS(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
14102      &                  XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
14103 C***********************************************************************
14104 C
14105 C    select x values of soft string ends (rescaling method)
14106 C
14107 C***********************************************************************
14108       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14109       SAVE
14110
14111       DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
14112
14113 C  input/output channels
14114       INTEGER LI,LO
14115       COMMON /POINOU/ LI,LO
14116 C  event debugging information
14117       INTEGER NMAXD
14118       PARAMETER (NMAXD=100)
14119       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14120      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14121       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14122      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14123 C  model switches and parameters
14124       CHARACTER*8 MDLNA
14125       INTEGER ISWMDL,IPAMDL
14126       DOUBLE PRECISION PARMDL
14127       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14128 C  data on most recent hard scattering
14129       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14130       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14131      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14132      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14133       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14134      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14135      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14136      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14137      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14138 C  obsolete cut-off information
14139       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14140       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14141
14142       DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
14143
14144       IREJ = 0
14145
14146  10   CONTINUE
14147
14148       IF(MSOFT.EQ.1) THEN
14149         XSOFT1(1) = 1.D0-XS1
14150         XSOFT1(2) = 0.D0
14151         XSOFT2(1) = 1.D0-XS2
14152         XSOFT2(2) = 0.D0
14153         RETURN
14154       ENDIF
14155
14156       DO 50 I=1,MSOFT
14157         POT(1,I) = XPOT1(I)+1.D0
14158         POT(2,I) = XPOT2(I)+1.D0
14159         REVP(1,I) = 1.D0/POT(1,I)
14160         REVP(2,I) = 1.D0/POT(2,I)
14161         XLMIN(1,I) = XMIN(1,I)**POT(1,I)
14162         XLMAX = XMAX1**POT(1,I)
14163         XLDIF(1,I) = XLMAX-XLMIN(1,I)
14164         XLMIN(2,I) = XMIN(2,I)**POT(2,I)
14165         XLMAX = XMAX2**POT(2,I)
14166         XLDIF(2,I) = XLMAX-XLMIN(2,I)
14167  50   CONTINUE
14168
14169       ITRY0 = 0
14170  5    CONTINUE
14171       ITRY0 = ITRY0 + 1
14172       IF(ITRY0.GE.IPAMDL(180)) THEN
14173         IF(MSOFT-MSMIN.GE.2) THEN
14174           MSOFT= MSMIN
14175           GOTO 10
14176         ENDIF
14177         GOTO 1000
14178       ENDIF
14179       XSUM1 = 0.D0
14180       XSUM2 = 0.D0
14181       DO 100 I=1,MSOFT
14182         ITRY1 = 0
14183  20     CONTINUE
14184         Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
14185         Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
14186         XSOFT1(I) = Z1**REVP(1,I)
14187         XSOFT2(I) = Z2**REVP(2,I)
14188         ITRY1 = ITRY1+1
14189         IF(ITRY1.GE.50) GOTO 1000
14190         IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
14191         XSUM1 = XSUM1+XSOFT1(I)
14192         XSUM2 = XSUM2+XSOFT2(I)
14193  100  CONTINUE
14194       FAC1 = (1.D0-XS1)/XSUM1
14195       FAC2 = (1.D0-XS2)/XSUM2
14196       DO 200 I=1,MSOFT
14197         XSOFT1(I) = XSOFT1(I)*FAC1
14198         XSOFT2(I) = XSOFT2(I)*FAC2
14199         IF(XSOFT1(I).LT.XMIN(1,I)) GOTO 5
14200         IF(XSOFT2(I).LT.XMIN(2,I)) GOTO 5
14201         IF(XSOFT1(I)*XSOFT2(I).LT.AS) GOTO 5
14202  200  CONTINUE
14203
14204       XS1 = 1.D0-XSOFT1(1)
14205       XS2 = 1.D0-XSOFT2(1)
14206       RETURN
14207
14208  1000 CONTINUE
14209       IREJ = 1
14210       IF(IDEB(14).GE.2) THEN
14211         WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXS: ',
14212      &    'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
14213         DO 300 I=1,MSOFT
14214           WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
14215  300    CONTINUE
14216       ENDIF
14217
14218       END
14219
14220 *$ CREATE PHO_SELSXI.FOR
14221 *COPY PHO_SELSXI
14222 CDECK  ID>, PHO_SELSXI
14223       SUBROUTINE PHO_SELSXI(MSOFT,MSMIN,XPOT1,XPOT2,XMIN,XS1,XS2,
14224      &                  XMAX1,XMAX2,XSOFT1,XSOFT2,IREJ)
14225 C***********************************************************************
14226 C
14227 C    select x values of soft string ends (sea independent from valence)
14228 C
14229 C***********************************************************************
14230       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14231       SAVE
14232
14233       DIMENSION XPOT1(*),XPOT2(*),XMIN(2,*),XSOFT1(*),XSOFT2(*)
14234
14235 C  input/output channels
14236       INTEGER LI,LO
14237       COMMON /POINOU/ LI,LO
14238 C  event debugging information
14239       INTEGER NMAXD
14240       PARAMETER (NMAXD=100)
14241       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14242      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14243       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14244      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14245 C  model switches and parameters
14246       CHARACTER*8 MDLNA
14247       INTEGER ISWMDL,IPAMDL
14248       DOUBLE PRECISION PARMDL
14249       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14250 C  data on most recent hard scattering
14251       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14252       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14253      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
14254      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
14255       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
14256      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
14257      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
14258      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
14259      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
14260 C  obsolete cut-off information
14261       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
14262       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
14263
14264       DIMENSION XLDIF(2,50),XLMIN(2,50),REVP(2,50),POT(2,50)
14265
14266       IREJ = 0
14267
14268  10   CONTINUE
14269
14270       DO 50 I=1,MSOFT
14271         POT(1,I) = XPOT1(I)+1.D0
14272         POT(2,I) = XPOT2(I)+1.D0
14273         REVP(1,I) = 1.D0/POT(1,I)
14274         REVP(2,I) = 1.D0/POT(2,I)
14275         XLMIN(1,I) = XMIN(1,I)**POT(1,I)
14276         XLMAX = XMAX1**POT(1,I)
14277         XLDIF(1,I) = XLMAX-XLMIN(1,I)
14278         XLMIN(2,I) = XMIN(2,I)**POT(2,I)
14279         XLMAX = XMAX2**POT(2,I)
14280         XLDIF(2,I) = XLMAX-XLMIN(2,I)
14281  50   CONTINUE
14282
14283 C  selection of sea
14284       ITRY0 = 0
14285  5    CONTINUE
14286
14287       ITRY0 = ITRY0 + 1
14288       IF(ITRY0.GE.IPAMDL(183)) THEN
14289         IF(MSOFT-MSMIN.GE.2) THEN
14290           MSOFT = MSMIN
14291           GOTO 10
14292         ENDIF
14293         GOTO 1000
14294       ENDIF
14295       XSUM1 = XS1
14296       XSUM2 = XS2
14297       DO 100 I=3,MSOFT
14298         ITRY1 = 0
14299  20     CONTINUE
14300         Z1 = XLDIF(1,I)*DT_RNDM(XS1)+XLMIN(1,I)
14301         Z2 = XLDIF(2,I)*DT_RNDM(XS2)+XLMIN(2,I)
14302         XSOFT1(I) = Z1**REVP(1,I)
14303         XSOFT2(I) = Z2**REVP(2,I)
14304         ITRY1 = ITRY1+1
14305         IF(ITRY1.GE.50) GOTO 1000
14306         IF( (XSOFT1(I)*XSOFT2(I)).LT.AS ) GOTO 20
14307         XSUM1 = XSUM1+XSOFT1(I)
14308         XSUM2 = XSUM2+XSOFT2(I)
14309  100  CONTINUE
14310
14311       IF(XSUM1.GT.1.D0-XMIN(1,1)-XMIN(1,2)) GOTO 5
14312       IF(XSUM2.GT.1.D0-XMIN(2,1)-XMIN(2,2)) GOTO 5
14313
14314 C  selection of valence
14315       CALL PHO_SELSX2(XPOT1,XPOT2,XMIN,XSUM1,XSUM2,XMAX1,XMAX2,
14316      &  XSOFT1,XSOFT2,IREJ)
14317       IF(IREJ.NE.0) THEN
14318         IF(MSOFT-MSMIN.GE.2) THEN
14319           MSOFT = MSMIN
14320           GOTO 10
14321         ENDIF
14322         IF(IDEB(31).GE.2) WRITE(LO,'(1X,A,1P,4E11.4)')
14323      &    'PHO_SELSXI: rejection by PHO_SELSX2 (XSUM1/2,XMAX1/2)',
14324      &    XSUM1,XSUM2,XMAX1,XMAX2
14325         RETURN
14326       ENDIF
14327
14328       XS1 = 1.D0-XSOFT1(1)
14329       XS2 = 1.D0-XSOFT2(1)
14330       RETURN
14331
14332  1000 CONTINUE
14333       IREJ = 1
14334       IF(IDEB(14).GE.2) THEN
14335         WRITE(LO,'(1X,2A,3I4)') 'PHO_SELSXI: ',
14336      &    'rejection (MSOFT,ITRY0/1)',MSOFT,ITRY0,ITRY1
14337         DO 300 I=1,MSOFT
14338           WRITE(LO,'(5X,I4,1P4E11.3)') I,XMIN(1,I),XMIN(2,I),XMAX1,XMAX2
14339  300    CONTINUE
14340       ENDIF
14341
14342       END
14343
14344 *$ CREATE PHO_SELCOL.FOR
14345 *COPY PHO_SELCOL
14346 CDECK  ID>, PHO_SELCOL
14347       SUBROUTINE PHO_SELCOL(ICO1,ICO2,ICOA1,ICOA2,ICOB1,ICOB2,IMODE)
14348 C********************************************************************
14349 C
14350 C    color combinatorics
14351 C
14352 C    input:         ICO1,2   colors of incoming particle
14353 C                   IMODE    -2  output of initialization status
14354 C                            -1  initialization
14355 C                                   ICINP(1) selection mode
14356 C                                            0   QCD
14357 C                                            1   large N_c expansion
14358 C                                   ICINP(2) max. allowed color
14359 C                            0   clear internal color counter
14360 C                            1   hadron into two colored objects
14361 C                            2   quark into quark gluon
14362 C                            3   gluon into gluon gluon
14363 C                            4   gluon into quark antiquark
14364 C
14365 C    output:        ICOA1,2  colors of first outgoing particle
14366 C                   ICOB1,2  colors of second outgoing particle
14367 C
14368 C********************************************************************
14369       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14370       SAVE
14371
14372 C  input/output channels
14373       INTEGER LI,LO
14374       COMMON /POINOU/ LI,LO
14375 C  event debugging information
14376       INTEGER NMAXD
14377       PARAMETER (NMAXD=100)
14378       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14379      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14380       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14381      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14382
14383       DATA METHOD /0/, II /0/
14384
14385       ICI1 = ICO1
14386       ICI2 = ICO2
14387       IF(METHOD.EQ.0) THEN
14388
14389         IF(IMODE.EQ.1) THEN
14390           II = II+1
14391           IF(II.GT.MAXCOL)
14392      &      II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14393           ICOA1 = II
14394           ICOA2 = 0
14395           ICOB1 = -II
14396           ICOB2 = 0
14397         ELSE IF(IMODE.EQ.2) THEN
14398           II = II+1
14399           IF(II.GT.MAXCOL)
14400      &      II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14401           ICOA2 = 0
14402           IF(ICI1.GT.0) THEN
14403             ICOA1 = II
14404             ICOB1 = ICI1
14405             ICOB2 = -II
14406           ELSE
14407             ICOA1 = -II
14408             ICOB1 = II
14409             ICOB2 = ICI1
14410           ENDIF
14411         ELSE IF(IMODE.EQ.3) THEN
14412           II = II+1
14413           IF(II.GT.MAXCOL)
14414      &      II = MIN(DT_RNDM(DUM)*MAXCOL+1.00001,DBLE(MAXCOL))
14415           IF(DT_RNDM(DUM).GT.0.5D0) THEN
14416             ICOA1 = ICI1
14417             ICOA2 = -II
14418             ICOB1 = II
14419             ICOB2 = ICI2
14420           ELSE
14421             ICOB1 = ICI1
14422             ICOB2 = -II
14423             ICOA1 = II
14424             ICOA2 = ICI2
14425           ENDIF
14426         ELSE IF(IMODE.EQ.4) THEN
14427           ICOA1 = ICI1
14428           ICOA2 = 0
14429           ICOB1 = ICI2
14430           ICOB2 = 0
14431         ELSE IF(IMODE.EQ.0) THEN
14432           II = 0
14433         ELSE IF(IMODE.EQ.-1) THEN
14434           METHOD = ICI1
14435           MAXCOL = ICI2
14436         ELSE IF(IMODE.EQ.-2) THEN
14437           WRITE(LO,'(1X,A,2I5)') 'PHO_SELCOL: METHOD,MAXCOL',
14438      &      METHOD,MAXCOL
14439         ELSE
14440           WRITE(LO,'(1X,A,I5)')
14441      &      'PHO_SELCOL:ERROR: unsupported mode',IMODE
14442           CALL PHO_ABORT
14443         ENDIF
14444
14445       ELSE
14446         WRITE(LO,'(1X,A,I5)')
14447      &    'PHO_SELCOL:ERROR:unsupported method selected',METHOD
14448         CALL PHO_ABORT
14449       ENDIF
14450
14451       II = ABS(II)
14452       IF(IDEB(75).GE.10) THEN
14453         WRITE(LO,'(1X,A,I5,I12,I5)') 'PHO_SELCOL: IMODE,MAXCOL,II',
14454      &    IMODE,MAXCOL,II
14455         WRITE(LO,'(10X,A,2I5)') 'input  colors',ICI1,ICI2
14456         WRITE(LO,'(10X,A,4I5)') 'output colors',ICOA1,ICOA2,ICOB1,ICOB2
14457       ENDIF
14458
14459       END
14460
14461 *$ CREATE ipho_diqu.FOR
14462 *COPY ipho_diqu
14463 CDECK  ID>, ipho_diqu
14464       INTEGER FUNCTION ipho_diqu(iq1,iq2)
14465 C***********************************************************************
14466 C
14467 C     selection of diquark number (PDG convention)
14468 C
14469 C***********************************************************************
14470       IMPLICIT NONE
14471       SAVE
14472
14473       integer iq1,iq2
14474
14475 C  input/output channels
14476       INTEGER LI,LO
14477       COMMON /POINOU/ LI,LO
14478 C  event debugging information
14479       INTEGER NMAXD
14480       PARAMETER (NMAXD=100)
14481       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14482      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14483       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14484      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14485 C  model switches and parameters
14486       CHARACTER*8 MDLNA
14487       INTEGER ISWMDL,IPAMDL
14488       DOUBLE PRECISION PARMDL
14489       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14490
14491 C  external functions
14492       double precision DT_RNDM
14493
14494 C  local variables
14495       integer i0,i1,i2
14496       double precision dum
14497
14498       i1 = abs(iq1)
14499       i2 = abs(iq2)
14500
14501       if(i1.eq.i2) then
14502         i0 = i1*1100+3
14503       else
14504         i0 = max(i1,i2)*1000+min(i1,i2)*100
14505         if(DT_RNDM(dum).gt.PARMDL(135)) then
14506           i0 = i0+1
14507         else
14508           i0 = i0+3
14509         endif
14510       endif
14511
14512       ipho_diqu = sign(i0,iq1)
14513
14514       END
14515
14516 *$ CREATE PHO_PARREM.FOR
14517 *COPY PHO_PARREM
14518 CDECK  ID>, PHO_PARREM
14519       SUBROUTINE PHO_PARREM(INDX,IOUT,IREM,IREJ)
14520 C**********************************************************************
14521 C
14522 C     selection of particle remnant flavour(s) (quark or diquark)
14523 C
14524 C     input:    INDX   index of particle in /POEVT1/
14525 C               IOUT   parton which was taken out
14526 C
14527 C     output:   IREM   remnant according to valence flavours
14528 C               IREJ   0  flavour combination possible
14529 C                      1  flavour combination impossible
14530 C
14531 C     all particle ID are given according to PDG conventions
14532 C
14533 C**********************************************************************
14534       IMPLICIT NONE
14535       SAVE
14536
14537       integer INDX,IOUT,IREM,IREJ
14538
14539 C  input/output channels
14540       INTEGER LI,LO
14541       COMMON /POINOU/ LI,LO
14542 C  event debugging information
14543       INTEGER NMAXD
14544       PARAMETER (NMAXD=100)
14545       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14546      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14547       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14548      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14549 C  standard particle data interface
14550       INTEGER NMXHEP
14551       PARAMETER (NMXHEP=4000)
14552       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14553       DOUBLE PRECISION PHEP,VHEP
14554       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14555      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14556      &                VHEP(4,NMXHEP)
14557 C  extension to standard particle data interface (PHOJET specific)
14558       INTEGER IMPART,IPHIST,ICOLOR
14559       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14560 C  general particle data
14561       double precision xm_list,tau_list,gam_list,
14562      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
14563      &  xm_bb82_list,xm_bb102_list
14564       integer          ich3_list,iba3_list,iq_list,
14565      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
14566       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
14567      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
14568      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
14569      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
14570      &  ich3_list(300),iba3_list(300),iq_list(3,300),
14571      &  id_psm_list(6,6),id_vem_list(6,6),
14572      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
14573
14574 C  external functions
14575       integer ipho_diqu
14576
14577 C  local variables
14578       integer ID,IS,ID1,ID2,i,k,K1,K2,IQUA,IDQ
14579       dimension IQUA(3),IDQ(2)
14580
14581       ID1 = IDHEP(INDX)
14582       ID2 = IMPART(INDX)
14583       IREJ = 0
14584
14585       IF(ID2.EQ.0) THEN
14586         WRITE(LO,'(1X,A,I6)') 'PHO_PARREM: no CPC ID available for',INDX
14587         CALL PHO_ABORT
14588       ENDIF
14589
14590 C  particle with flavour mixing
14591       if(ID1.eq.22) then
14592 C  photon
14593         IREM = -IOUT
14594         GOTO 100
14595       else if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
14596 C  pi0, rho0, and omega
14597         IF(ABS(IOUT).LE.2) THEN
14598           IREM = -IOUT
14599           GOTO 100
14600         ELSE
14601           GOTO 150
14602         ENDIF
14603       else if((abs(ID1).eq.311).or.(ID1.eq.310).or.(ID1.eq.130)) then
14604 C  neutral kaons (K0,K0-bar)
14605         if(abs(IOUT).eq.1) then
14606           IREM = sign(3,-IOUT)
14607           goto 100
14608         else if(abs(IOUT).eq.3) then
14609           IREM = sign(1,-IOUT)
14610           goto 100
14611         else
14612           goto 150
14613         endif
14614       else if((ID1.eq.990).or.(ID1.eq.110)) then
14615 C  pomeron and reggeon
14616         IREM = -IOUT
14617         GOTO 100
14618       endif
14619
14620 C  ordinary hadron
14621       ID = abs(ID2)
14622       IS = sign(1,ID2)
14623       IQUA(1) = iq_list(1,ID)*IS
14624       IQUA(2) = iq_list(2,ID)*IS
14625       IQUA(3) = iq_list(3,ID)*IS
14626
14627 C  compare to flavour content
14628       IF(ABS(IOUT).LT.1000) THEN
14629 C  single quark requested
14630         IF(IQUA(1).EQ.IOUT) THEN
14631           K1 = 2
14632           K2 = 3
14633         ELSE IF(IQUA(2).EQ.IOUT) THEN
14634           K1 = 1
14635           K2 = 3
14636         ELSE IF(IQUA(3).EQ.IOUT) THEN
14637           K1 = 1
14638           K2 = 2
14639         ELSE
14640           GOTO 150
14641         ENDIF
14642         IF(IQUA(3).EQ.0) THEN
14643           IREM = IQUA(K1)
14644         ELSE
14645           IREM = ipho_diqu(IQUA(K1),IQUA(K2))
14646         ENDIF
14647       ELSE IF(IQUA(3).NE.0) THEN
14648 C  diquark requested from baryon
14649         IDQ(1) = IOUT/1000
14650         IDQ(2) = (IOUT-IDQ(1)*1000)/100
14651         do i=1,2
14652           do k=1,3
14653             if(IDQ(i).eq.IQUA(k)) then
14654               IQUA(k) = 0
14655               goto 110
14656             endif
14657           enddo
14658           goto 150
14659  110      continue
14660         enddo
14661         IREM = IQUA(1)+IQUA(2)+IQUA(3)
14662       ENDIF
14663
14664  100  CONTINUE
14665 C  debug output
14666       IF(IDEB(72).GE.10) WRITE(LO,'(1X,A,5I6)')
14667      &  'PHO_PARREM: INDX,ID-PDG,ID-BAM,IOUT,IREM',
14668      &  INDX,ID1,ID2,IOUT,IREM
14669       RETURN
14670
14671 C  rejection
14672  150  CONTINUE
14673       IREJ = 1
14674       IF(IDEB(72).GE.2) WRITE(LO,'(1X,A,5I7)')
14675      &  'PHO_PARREM: rejection IDPDG,Q1-3,IOUT',IDHEP(INDX),IQUA,IOUT
14676
14677       END
14678
14679 *$ CREATE PHO_VALFLA.FOR
14680 *COPY PHO_VALFLA
14681 CDECK  ID>, PHO_VALFLA
14682       SUBROUTINE PHO_VALFLA(IPAR,IFL1,IFL2,E1,E2)
14683 C***********************************************************************
14684 C
14685 C     selection of valence flavour decomposition of particle IPAR
14686 C
14687 C     input:    IPAR   particle index in /POEVT1/
14688 C                      -1   initialization
14689 C                      -2   output of statistics
14690 C               XMASS  mass of particle
14691 C                      (important for pomeron:
14692 C                       mass dependent flavour sampling)
14693 C
14694 C     output:   IFL1,IFL2
14695 C               baryon: IFL1  diquark flavour
14696 C               (valence flavours according to PDG conventions)
14697 C
14698 C***********************************************************************
14699       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14700       SAVE
14701
14702       PARAMETER ( EPS    =  0.1D0,
14703      &            DEPS   =  1.D-15)
14704
14705 C  input/output channels
14706       INTEGER LI,LO
14707       COMMON /POINOU/ LI,LO
14708 C  event debugging information
14709       INTEGER NMAXD
14710       PARAMETER (NMAXD=100)
14711       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14712      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14713       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14714      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14715 C  model switches and parameters
14716       CHARACTER*8 MDLNA
14717       INTEGER ISWMDL,IPAMDL
14718       DOUBLE PRECISION PARMDL
14719       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14720 C  standard particle data interface
14721       INTEGER NMXHEP
14722       PARAMETER (NMXHEP=4000)
14723       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14724       DOUBLE PRECISION PHEP,VHEP
14725       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14726      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14727      &                VHEP(4,NMXHEP)
14728 C  extension to standard particle data interface (PHOJET specific)
14729       INTEGER IMPART,IPHIST,ICOLOR
14730       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14731 C  general particle data
14732       double precision xm_list,tau_list,gam_list,
14733      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
14734      &  xm_bb82_list,xm_bb102_list
14735       integer          ich3_list,iba3_list,iq_list,
14736      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
14737       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
14738      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
14739      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
14740      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
14741      &  ich3_list(300),iba3_list(300),iq_list(3,300),
14742      &  id_psm_list(6,6),id_vem_list(6,6),
14743      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
14744
14745       data ITMX / 5 /
14746
14747       IF(IPAR.GT.0) THEN
14748         K = IPAR
14749 C  select particle code
14750         ID1 = IDHEP(K)
14751         ID  = abs(IMPART(K))
14752         IBAR = IPHO_BAR3(K,2)
14753         ITER = 0
14754
14755  10     CONTINUE
14756
14757         ifl1 = 0
14758         ifl2 = 0
14759         ITER = ITER+1
14760         if(ITER.GT.ITMX) then
14761           WRITE(LO,'(1x,2a,i10,1p,2e11.3)') 'PHO_VALFLA: ',
14762      &      'no valences found for (IPAR,E1,E2)',IPAR,E1,E2
14763           return
14764         endif
14765
14766 C  not baryon
14767         IF(IBAR.EQ.0) THEN
14768
14769 C  photon
14770           IF(ID1.EQ.22) THEN
14771 C  charge dependent flavour sampling
14772  15         CONTINUE
14773             K = INT(DT_RNDM(E1)*6.D0)+1
14774             IF(K.LE.4) THEN
14775               IFL1 = 2
14776               IFL2 = -2
14777             ELSE IF(K.EQ.5) THEN
14778               IFL1 = 1
14779               IFL2 = -1
14780             ELSE
14781               IFL1 = 3
14782               IFL2 = -3
14783             ENDIF
14784 C  optional strangeness suppression
14785             IF((IFL1.EQ.3).AND.(DT_RNDM(E2).GT.PARMDL(160))) GOTO 15
14786             IF(DT_RNDM(DUM).LT.0.5D0) THEN
14787               K = IFL1
14788               IFL1 = IFL2
14789               IFL2 = K
14790             ENDIF
14791
14792 C  pomeron, reggeon
14793           ELSE IF((ID1.EQ.990).or.(ID1.eq.110)) THEN
14794             IF(ISWMDL(19).EQ.0) THEN
14795 C  SU(3) symmetric valences
14796               K = INT(DT_RNDM(E1)*3.D0)+1
14797               IF(DT_RNDM(DUM).LT.0.5D0) THEN
14798                 IFL1 = K
14799               ELSE
14800                 IFL1 = -K
14801               ENDIF
14802               IFL2 = -IFL1
14803             ELSE IF(ISWMDL(19).EQ.1) THEN
14804 C  mass dependent flavour sampling
14805               EMIN = MIN(E1,E2)
14806               CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
14807             ELSE
14808               WRITE(LO,'(/1X,2A,I5)') 'PHO_VALFLA: ',
14809      &          'invalid flavour selection mode ISWMDL(19)',ISWMDL(19)
14810               CALL PHO_ABORT
14811             ENDIF
14812
14813 C  meson with flavour mixing
14814           ELSE if((ID1.eq.111).or.(ID1.eq.113).or.(ID1.eq.223)) then
14815             K = INT(2.D0*DT_RNDM(E1))+1
14816             IFL1 = K
14817             IFL2 = -K
14818 C  meson (standard)
14819           ELSE
14820             K = INT(2.D0*DT_RNDM(E1))+1
14821             IFL1 = iq_list(K,ID)
14822             K = MOD(K,2) + 1
14823             IFL2 = iq_list(K,ID)
14824             if(IFL1.EQ.0) then
14825               EMIN = MIN(E1,E2)
14826               CALL PHO_SEAFLA(IPAR,IFL1,IFL2,EMIN)
14827             endif
14828           ENDIF
14829
14830 C  baryon
14831         ELSE
14832           K = INT(2.999999D0*DT_RNDM(E2))+1
14833           K1 = MOD(K,3)+1
14834           K2 = MOD(K1,3)+1
14835           IFL1 = ipho_diqu(iq_list(K1,ID),iq_list(K2,ID))
14836           IFL2 = iq_list(K,ID)
14837         ENDIF
14838
14839 C  change sign for antiparticles
14840         if(ID1.lt.0) then
14841           IFL1 = -IFL1
14842           IFL2 = -IFL2
14843         endif
14844
14845 ************************************************************************
14846 C  check kinematic constraints
14847 *       IF((PHO_PMASS(IFL1,3).GT.E1)
14848 *    &     .OR.(PHO_PMASS(IFL2,3).GT.E2)) GOTO 10
14849 ************************************************************************
14850
14851 C  debug output
14852         IF(IDEB(46).GE.10) WRITE(LO,'(1X,A,I5,2E12.4,2I7)')
14853      &    'PHO_VALFLA: IPAR,MASS1/2,FL1/2',IPAR,E1,E2,IFL1,IFL2
14854
14855       ELSE IF(IPAR.EQ.-1) THEN
14856 C  initialization
14857
14858       ELSE IF(IPAR.EQ.-2) THEN
14859 C  output of final statistics
14860
14861       ELSE
14862         WRITE(LO,'(1X,A,I10)')
14863      &    'PHO_VALFLA:ERROR: invalid input particle (IPAR)',IPAR
14864         CALL PHO_ABORT
14865       ENDIF
14866
14867       END
14868
14869 *$ CREATE PHO_REGFLA.FOR
14870 *COPY PHO_REGFLA
14871 CDECK  ID>, PHO_REGFLA
14872       SUBROUTINE PHO_REGFLA(JM1,JM2,IFLR1,IFLR2,IREJ)
14873 C**********************************************************************
14874 C
14875 C     selection of reggeon flavours
14876 C
14877 C     input:    JM1,JM2      position index of mother hadrons
14878 C
14879 C     output:   IFLR1,IFLR2  valence flavours according to
14880 C                            PDG conventions and JM1,JM2
14881 C               IREJ         0  reggeon possible
14882 C                            1  reggeon impossible
14883 C
14884 C**********************************************************************
14885       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14886       SAVE
14887
14888       PARAMETER ( EPS    =  0.1D0,
14889      &            DEPS   =  1.D-15)
14890
14891 C  input/output channels
14892       INTEGER LI,LO
14893       COMMON /POINOU/ LI,LO
14894 C  event debugging information
14895       INTEGER NMAXD
14896       PARAMETER (NMAXD=100)
14897       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
14898      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14899       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
14900      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
14901 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
14902       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
14903       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
14904       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
14905      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
14906 C  standard particle data interface
14907       INTEGER NMXHEP
14908       PARAMETER (NMXHEP=4000)
14909       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
14910       DOUBLE PRECISION PHEP,VHEP
14911       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
14912      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
14913      &                VHEP(4,NMXHEP)
14914 C  extension to standard particle data interface (PHOJET specific)
14915       INTEGER IMPART,IPHIST,ICOLOR
14916       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
14917
14918       IF(JM1.GT.0) THEN
14919         IREJ = 0
14920         ITER = 0
14921 C  available energy
14922         E1   = SQRT((PHEP(4,JM1)+PHEP(4,JM2))**2
14923      &             -(PHEP(1,JM1)+PHEP(1,JM2))**2
14924      &             -(PHEP(2,JM1)+PHEP(2,JM2))**2
14925      &             -(PHEP(3,JM1)+PHEP(3,JM2))**2)/2.D0
14926  50     CONTINUE
14927         ITER = ITER+1
14928         IF(ITER.GT.50) THEN
14929           IREJ = 1
14930 C  debug output
14931           IF(IDEB(41).GE.2) WRITE(LO,'(/1X,A,2I7,1P,E12.4)')
14932      &      'PHO_REGFLA: rejection, no reggeon found for',
14933      &      IDHEP(JM1),IDHEP(JM2),E1
14934           RETURN
14935         ENDIF
14936
14937         CALL PHO_VALFLA(JM1,IFLA1,IFLA2,E1,E1)
14938         CALL PHO_VALFLA(JM2,IFLB1,IFLB2,E1,E1)
14939         IF(IFLA1.EQ.-IFLB1) THEN
14940           IFLR1 = IFLA2
14941           IFLR2 = IFLB2
14942         ELSE IF(IFLA1.EQ.-IFLB2) THEN
14943           IFLR1 = IFLA2
14944           IFLR2 = IFLB1
14945         ELSE IF(IFLA2.EQ.-IFLB1) THEN
14946           IFLR1 = IFLA1
14947           IFLR2 = IFLB2
14948         ELSE IF(IFLA2.EQ.-IFLB2) THEN
14949           IFLR1 = IFLA1
14950           IFLR2 = IFLB1
14951         ELSE
14952 C  debug output
14953           IF(IDEB(41).GE.25) WRITE(LO,'(/1X,A,3I4)')
14954      &      'PHO_REGFLA: int.rejection JM1,JM2,ITRY',JM1,JM2,ITER
14955           GOTO 50
14956         ENDIF
14957 C  debug output
14958         IF(IDEB(41).GE.10) WRITE(LO,'(1X,A,/5X,2I4,2I6,2I5,1PE10.3)')
14959      &    'PHO_REGFLA: JM1/2,PDG-ID1/2,IFLR1/2,MASS',
14960      &    JM1,JM2,IDHEP(JM1),IDHEP(JM2),IFLR1,IFLR2,E1
14961       ELSE IF(JM1.EQ.-1) THEN
14962 C  initialization
14963       ELSE IF(JM1.EQ.-2) THEN
14964 C  output of statistics
14965       ELSE
14966         WRITE(LO,'(1X,A,I10)')
14967      &    'PHO_REGFLA: invalid mother particle (JM1)',JM1
14968         CALL PHO_ABORT
14969       ENDIF
14970
14971       END
14972
14973 *$ CREATE PHO_SEAFLA.FOR
14974 *COPY PHO_SEAFLA
14975 CDECK  ID>, PHO_SEAFLA
14976       SUBROUTINE PHO_SEAFLA(IPAR,IFL1,IFL2,CHMASS)
14977 C**********************************************************************
14978 C
14979 C     selection of sea flavour content of particle IPAR
14980 C
14981 C     input:    IPAR    particle index in /POEVT1/
14982 C               CHMASS  available invariant string mass
14983 C                       positive mass --> use BAMJET method
14984 C                       negative mass --> SU(3) symmetric sea according
14985 C                       to values given in PARMDL(1-6)
14986 C               IPAR    -1 initialization
14987 C                       -2 output of statistics
14988 C
14989 C     output:   sea flavours according to PDG conventions
14990 C
14991 C**********************************************************************
14992       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14993       SAVE
14994
14995       PARAMETER ( EPS    =  0.1D0,
14996      &            DEPS   =  1.D-15)
14997
14998 C  input/output channels
14999       INTEGER LI,LO
15000       COMMON /POINOU/ LI,LO
15001 C  event debugging information
15002       INTEGER NMAXD
15003       PARAMETER (NMAXD=100)
15004       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15005      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15006       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15007      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15008 C  model switches and parameters
15009       CHARACTER*8 MDLNA
15010       INTEGER ISWMDL,IPAMDL
15011       DOUBLE PRECISION PARMDL
15012       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15013 C  some hadron information, will be deleted in future versions
15014       INTEGER NFS
15015       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
15016       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
15017
15018       IF(IPAR.GT.0) THEN
15019         IF((ISWMDL(20).EQ.1).OR.(CHMASS.LT.0.D0)) THEN
15020 C  constant weights for sea
15021  15       CONTINUE
15022             SUM = 0.D0
15023             DO 40 K=1,NFSEA
15024               SUM = SUM + PARMDL(K)
15025  40         CONTINUE
15026             XI = DT_RNDM(SUM)*SUM
15027             SUM = 0.D0
15028             DO 50 K=1,NFSEA
15029               SUM = SUM + PARMDL(K)
15030               IF(XI.LE.SUM) GOTO 55
15031  50         CONTINUE
15032  55         CONTINUE
15033           IF(K.GT.NFSEA) GOTO 15
15034         ELSE
15035 C  mass dependent flavour sampling
15036  10       CONTINUE
15037             CALL PHO_FLAUX(CHMASS,K)
15038           IF(K.GT.NFSEA) GOTO 10
15039         ENDIF
15040         IF(DT_RNDM(CHMASS).GT.0.5D0) K = -K
15041         IFL1 = K
15042         IFL2 = -K
15043         IF(IDEB(46).GE.10) THEN
15044           WRITE(LO,'(1X,A,3I5,E12.4)') 'PHO_SEAFLA:IPAR,IFL1,IFL2,MASS',
15045      &      IPAR,IFL1,IFL2,CHMASS
15046         ENDIF
15047       ELSE IF(IPAR.EQ.-1) THEN
15048 C  initialization
15049         NFSEA = NFS
15050       ELSE IF(IPAR.EQ.-2) THEN
15051 C  output of statistics
15052       ELSE
15053         WRITE(LO,'(1X,A,I10)') 'PHO_SEAFLA:ERROR:INVALID IPAR',IPAR
15054         CALL PHO_ABORT
15055       ENDIF
15056
15057       END
15058
15059 *$ CREATE PHO_FLAUX.FOR
15060 *COPY PHO_FLAUX
15061 CDECK  ID>, PHO_FLAUX
15062       SUBROUTINE PHO_FLAUX(EQUARK,K)
15063 C***********************************************************************
15064 C
15065 C    auxiliary subroutine to select flavours
15066 C
15067 C********************************************************************
15068       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15069       SAVE
15070
15071       PARAMETER ( DEPS   =  1.D-14 )
15072
15073 C  input/output channels
15074       INTEGER LI,LO
15075       COMMON /POINOU/ LI,LO
15076 C  event debugging information
15077       INTEGER NMAXD
15078       PARAMETER (NMAXD=100)
15079       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15080      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15081       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15082      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15083 C  some hadron information, will be deleted in future versions
15084       INTEGER NFS
15085       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
15086       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
15087
15088       DIMENSION WGHT(9)
15089
15090 C  calculate weights for given energy
15091       IF(EQUARK.LT.QMASS(1)) THEN
15092         IF(IDEB(16).GE.5)
15093      &    WRITE(LO,'(1X,A,E12.3)') 'PHO_FLAUX: VERY SMALL MASS',
15094      &      EQUARK
15095         WGHT(1) = 0.5D0
15096         WGHT(2) = 0.5D0
15097         WGHT(3) = 0.D0
15098         WGHT(4) = 0.D0
15099         SUM = 1.D0
15100       ELSE
15101         SUM = 0.D0
15102         DO 305 K=1,NFS
15103           IF(EQUARK.GT.QMASS(K)) THEN
15104             WGHT(K) = PHO_BETAF(EQUARK,QMASS(K),BET)
15105           ELSE
15106             WGHT(K) = 0.D0
15107           ENDIF
15108           SUM = SUM + WGHT(K)
15109  305    CONTINUE
15110       ENDIF
15111 C  sample flavours
15112       XI = SUM*(DT_RNDM(SUM)-DEPS)
15113       K = 0
15114       SUM = 0.D0
15115  400  CONTINUE
15116         K = K+1
15117         SUM = SUM + WGHT(K)
15118       IF(XI.GT.SUM) GOTO 400
15119 C  debug output
15120       IF(IDEB(16).GE.20) THEN
15121         WRITE(LO,'(1X,A,I5)') 'PHO_FLAUX: selected flavour',K
15122       ENDIF
15123       END
15124
15125 *$ CREATE PHO_BETAF.FOR
15126 *COPY PHO_BETAF
15127 CDECK  ID>, PHO_BETAF
15128       DOUBLE PRECISION FUNCTION PHO_BETAF(X1,X2,BET)
15129 C********************************************************************
15130 C
15131 C     weights of different quark flavours
15132 C
15133 C********************************************************************
15134       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15135       SAVE
15136
15137       AX=0.D0
15138       BETX1=BET*X1
15139       IF(BETX1.LT.70.D0) AX=-1.D0/BET**2*(BETX1+1.D0)*EXP(-BETX1)
15140       AY=1.D0/BET**2*(BET*X2+1.D0)*EXP(-BET*X2)
15141
15142       PHO_BETAF=AX+AY
15143
15144       END
15145
15146 *$ CREATE PHO_MCHECK.FOR
15147 *COPY PHO_MCHECK
15148 CDECK  ID>, PHO_MCHECK
15149       SUBROUTINE PHO_MCHECK(J1,IREJ)
15150 C********************************************************************
15151 C
15152 C    check parton momenta for fragmentation
15153 C
15154 C    input:      J1      first  string number
15155 C                        /POEVT1/
15156 C                        /POSTRG/
15157 C
15158 C    output:             /POEVT1/
15159 C                        /POSTRG/
15160 C                IREJ    0  successful
15161 C                        1  failure
15162 C
15163 C    in case of very small string mass:
15164 C                NNCH    mass label of string
15165 C                        0  string
15166 C                       -1  octett baryon / pseudo scalar meson
15167 C                        1  decuplett baryon / vector meson
15168 C                IBHAD   hadron number according to CPC,
15169 C                        string will be treated as resonance
15170 C                        (sometimes far off mass shell)
15171 C
15172 C    constant WIDTH ( 0.01GeV ) determines range of acceptance
15173 C
15174 C********************************************************************
15175       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15176       SAVE
15177
15178       PARAMETER ( WIDTH  =  0.01D0,
15179      &            DEPS   =  1.D-15 )
15180
15181 C  input/output channels
15182       INTEGER LI,LO
15183       COMMON /POINOU/ LI,LO
15184 C  event debugging information
15185       INTEGER NMAXD
15186       PARAMETER (NMAXD=100)
15187       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15188      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15189       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15190      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15191 C  model switches and parameters
15192       CHARACTER*8 MDLNA
15193       INTEGER ISWMDL,IPAMDL
15194       DOUBLE PRECISION PARMDL
15195       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15196 C  standard particle data interface
15197       INTEGER NMXHEP
15198       PARAMETER (NMXHEP=4000)
15199       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15200       DOUBLE PRECISION PHEP,VHEP
15201       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15202      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15203      &                VHEP(4,NMXHEP)
15204 C  extension to standard particle data interface (PHOJET specific)
15205       INTEGER IMPART,IPHIST,ICOLOR
15206       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15207 C  color string configurations including collapsed strings and hadrons
15208       INTEGER MSTR
15209       PARAMETER (MSTR=500)
15210       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15211       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15212      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15213      &                NNCH(MSTR),IBHAD(MSTR),ISTR
15214 C  internal rejection counters
15215       INTEGER NMXJ
15216       PARAMETER (NMXJ=60)
15217       CHARACTER*10 REJTIT
15218       INTEGER IFAIL
15219       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
15220
15221       IREJ = 0
15222 C  quark antiquark jet
15223       STRM = PHEP(5,NPOS(1,J1))
15224       IF(NCODE(J1).EQ.3) THEN
15225         CALL PHO_MEMASS(IPAR1(J1),IPAR2(J1),
15226      &    AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
15227         IF(IDEB(18).GE.5)
15228      &    WRITE(LO,'(1X,A,/3X,I3,5E12.3)')
15229      &      'PHO_MCHECK:1.STRING NO, CHMASS,AMPS,AMPS2,AMVE,AMVE2 ',
15230      &      J1,STRM,AMPS,AMPS2,AMVE,AMVE2
15231         IF(STRM.LT.AMPS) THEN
15232           IREJ = 1
15233           IFAIL(20) = IFAIL(20) + 1
15234           RETURN
15235         ELSE IF(STRM.LT.AMPS2) THEN
15236           IF(STRM.LT.(AMVE-WIDTH)) THEN
15237             NNCH(J1) = -1
15238             IBHAD(J1) = IPS
15239           ELSE
15240             NNCH(J1) = 1
15241             IBHAD(J1) = IVE
15242           ENDIF
15243         ELSE
15244           NNCH(J1) = 0
15245           IBHAD(J1) = 0
15246         ENDIF
15247 C  quark diquark or v.s. jet
15248       ELSE IF((NCODE(J1).EQ.4).OR.(NCODE(J1).EQ.6)) THEN
15249         CALL PHO_BAMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),
15250      &              AM8,AM82,AM10,AM102,I8,I10)
15251         IF(IDEB(18).GE.5)
15252      &    WRITE(LO,'(1X,A,/5X,I3,5E12.3)')
15253      &            'PHO_MCHECK:1.STRING NO, CHMASS,AM8,AM82,AM10,AM102 ',
15254      &            J1,STRM,AM8,AM82,AM10,AM102
15255         IF(STRM.LT.AM8) THEN
15256           IREJ = 1
15257           IFAIL(19) = IFAIL(19) + 1
15258           RETURN
15259         ELSE IF(STRM.LT.AM82) THEN
15260           IF(STRM.LT.(AM10-WIDTH)) THEN
15261             NNCH(J1) = -1
15262             IBHAD(J1) = I8
15263           ELSE
15264             NNCH(J1) = 1
15265             IBHAD(J1) = I10
15266           ENDIF
15267         ELSE
15268           NNCH(J1) = 0
15269           IBHAD(J1) = 0
15270         ENDIF
15271 C  diquark a-diquark string
15272       ELSE IF(NCODE(J1).EQ.5) THEN
15273         CALL PHO_DQMASS(IPAR1(J1),IPAR2(J1),IPAR3(J1),IPAR4(J1),
15274      &              AM82,AM102)
15275         IF(IDEB(18).GE.5)
15276      &    WRITE(LO,'(1X,A,/5X,I3,3E12.3)')
15277      &            'PHO_MCHECK:1.STRING NO, CHMASS,AM82,AM102 ',
15278      &            J1,STRM,AM82,AM102
15279         IF(STRM.LT.AM82) THEN
15280           IREJ = 1
15281           IFAIL(19) = IFAIL(19) + 1
15282           RETURN
15283         ELSE
15284           NNCH(J1) = 0
15285           IBHAD(J1) = 0
15286         ENDIF
15287       ELSE IF(NCODE(J1).LT.0) THEN
15288         RETURN
15289       ELSE
15290         WRITE(LO,'(/,1X,2A,2I8)')  'PHO_MCHECK: ',
15291      &    'inconsistent flavours for string (NO,NCODE)',J1,NCODE(J1)
15292         CALL PHO_ABORT
15293       ENDIF
15294       END
15295
15296 *$ CREATE PHO_POMCOR.FOR
15297 *COPY PHO_POMCOR
15298 CDECK  ID>, PHO_POMCOR
15299       SUBROUTINE PHO_POMCOR(IREJ)
15300 C********************************************************************
15301 C
15302 C    join quarks to gluons in case of too small masses
15303 C
15304 C    input:              /POEVT1/
15305 C                        /POSTRG/
15306 C                IREJ    -1          initialization
15307 C                        -2          output of statistics
15308 C
15309 C    output:             /POEVT1/
15310 C                        /POSTRG/
15311 C                IREJ    0  successful
15312 C                        1  failure
15313 C
15314 C
15315 C********************************************************************
15316       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15317       SAVE
15318
15319       PARAMETER ( EPS    =  1.D-10 )
15320
15321 C  input/output channels
15322       INTEGER LI,LO
15323       COMMON /POINOU/ LI,LO
15324 C  event debugging information
15325       INTEGER NMAXD
15326       PARAMETER (NMAXD=100)
15327       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15328      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15329       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15330      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15331 C  model switches and parameters
15332       CHARACTER*8 MDLNA
15333       INTEGER ISWMDL,IPAMDL
15334       DOUBLE PRECISION PARMDL
15335       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15336 C  standard particle data interface
15337       INTEGER NMXHEP
15338       PARAMETER (NMXHEP=4000)
15339       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15340       DOUBLE PRECISION PHEP,VHEP
15341       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15342      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15343      &                VHEP(4,NMXHEP)
15344 C  extension to standard particle data interface (PHOJET specific)
15345       INTEGER IMPART,IPHIST,ICOLOR
15346       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15347 C  color string configurations including collapsed strings and hadrons
15348       INTEGER MSTR
15349       PARAMETER (MSTR=500)
15350       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15351       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15352      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15353      &                NNCH(MSTR),IBHAD(MSTR),ISTR
15354
15355       DIMENSION PJ(4)
15356
15357       IF(IREJ.EQ.-1) THEN
15358         ICTOT = 0
15359         ICCOR = 0
15360         RETURN
15361       ELSE IF(IREJ.EQ.-2) THEN
15362         WRITE(LO,'(/1X,A,2I8)')
15363      &    'PHO_POMCOR: total/joined strings',ICTOT,ICCOR
15364         RETURN
15365       ENDIF
15366 C
15367       IREJ = 0
15368 C
15369       NITER = 100
15370       ITER = 0
15371       ICTOT = ICTOT+ISTR
15372       IF(ISWMDL(25).LE.0) RETURN
15373 C  debug string entries
15374       IF(IDEB(83).GE.25) CALL PHO_PRSTRG
15375 C
15376  50   CONTINUE
15377       ITER = ITER+1
15378       IF(ITER.GE.NITER) THEN
15379         IREJ = 1
15380         IF(IDEB(83).GE.2) THEN
15381           WRITE(LO,'(1X,A,2I5)') 'PHO_POMCOR: rejection',ITER,NITER
15382           IF(IDEB(83).GE.10) CALL PHO_PREVNT(0)
15383         ENDIF
15384         RETURN
15385       ENDIF
15386 C
15387 C  check mass limits
15388       ISTRO = ISTR
15389       DO 100 I=1,ISTRO
15390         IF(NCODE(I).LT.0) GOTO 99
15391         J1 = NPOS(1,I)
15392         NRPOM = IPHIST(2,J1)
15393         IF(NRPOM.GE.100) GOTO 99
15394         CMASS0 = PHEP(5,J1)
15395 C  get masses
15396         IF(NCODE(I).EQ.3) THEN
15397           CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
15398         ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
15399           CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
15400      &                AM1,AM2,AM3,AM4,IP1,IP2)
15401         ELSE IF(NCODE(I).EQ.5) THEN
15402           CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
15403      &                AM1,AM2)
15404           AM3 = 0.D0
15405           AM4 = 0.D0
15406           IP1 = 0
15407           IP2 = 0
15408         ELSE IF(NCODE(I).EQ.7) THEN
15409           GOTO 99
15410         ELSE IF(NCODE(I).LT.0) THEN
15411           GOTO 99
15412         ELSE
15413           WRITE(LO,'(/,1X,A,2I5)') 'ERROR:PHO_POMCOR:STRING NO,NCODE ',
15414      &                            J1,NCODE(I)
15415           CALL PHO_ABORT
15416         ENDIF
15417         IF(IDEB(83).GE.5)
15418      &    WRITE(LO,'(1X,A,/3X,2I4,5E11.3,2I5)')
15419      &      'PHO_POMCOR: STRING,POM,CHMASS,AM1,AM2,AM3,AM4,IP1,IP2',
15420      &      I,NRPOM,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
15421 C  select masses to correct
15422         IF(CMASS0.LT.MAX(AM2,AM4)) THEN
15423           DO 200 K=1,ISTRO
15424             IF((K.NE.I).AND.(NCODE(K).GE.0)) THEN
15425               J2 = NPOS(1,K)
15426 C  join quarks to gluon
15427               IF(NRPOM.EQ.IPHIST(2,J2)) THEN
15428 C  flavour check
15429                 IFL1 = 0
15430                 IFL2 = 0
15431                 PROB1 = 0.D0
15432                 PROB2 = 0.D0
15433                 KK1 = NPOS(2,I)
15434                 KK2 = NPOS(2,K)
15435                 IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
15436                   CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
15437      &                   -(PHEP(1,KK1)+PHEP(1,KK2))**2
15438      &                   -(PHEP(2,KK1)+PHEP(2,KK2))**2
15439      &                   -(PHEP(2,KK1)+PHEP(2,KK2))**2
15440                   IFL1 = ABS(IDHEP(KK1))
15441                   IF(IFL1.GT.2) THEN
15442                     PROB1 = 0.1D0/MAX(CMASS,EPS)
15443                   ELSE
15444                     PROB1 = 0.9D0/MAX(CMASS,EPS)
15445                   ENDIF
15446                 ENDIF
15447                 KK1 = ABS(NPOS(3,I))
15448                 KK2 = ABS(NPOS(3,K))
15449                 IF(IDHEP(KK1)+IDHEP(KK2).EQ.0) THEN
15450                   CMASS = (PHEP(4,KK1)+PHEP(4,KK2))**2
15451      &                   -(PHEP(1,KK1)+PHEP(1,KK2))**2
15452      &                   -(PHEP(2,KK1)+PHEP(2,KK2))**2
15453      &                   -(PHEP(2,KK1)+PHEP(2,KK2))**2
15454                   IFL2 = ABS(IDHEP(KK1))
15455                   IF(IFL2.GT.2) THEN
15456                     PROB2 = 0.1D0/MAX(CMASS,EPS)
15457                   ELSE
15458                     PROB2 = 0.9D0/MAX(CMASS,EPS)
15459                   ENDIF
15460                 ENDIF
15461                 IF(IFL1+IFL2.EQ.0) GOTO 99
15462 C  fusion possible
15463                 ICCOR = ICCOR+1
15464                 IF((DT_RNDM(CMASS)*(PROB1+PROB2)).LT.PROB1) THEN
15465                   JJ = 2
15466                   JE = 3
15467                 ELSE
15468                   JJ = 3
15469                   JE = 2
15470                 ENDIF
15471                 KK1 = ABS(NPOS(JJ,I))
15472                 KK2 = ABS(NPOS(JJ,K))
15473                 I1 = ABS(NPOS(JE,I))
15474                 I2 = KK1
15475                 IS = SIGN(1,I2-I1)
15476                 I2 = I2 - IS
15477                 K1 = KK2
15478                 K2 = ABS(NPOS(JE,K))
15479                 KS = SIGN(1,K2-K1)
15480                 K1 = K1 + KS
15481                 IP1 = NHEP+1
15482 C  copy mother partons of string I
15483                 DO 300 II=I1,I2,IS
15484                   CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
15485      &              PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
15486      &              ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
15487  300            CONTINUE
15488 C  register gluon
15489                 DO 350 II=1,4
15490                   PJ(II) = PHEP(II,KK1)+PHEP(II,KK2)
15491  350            CONTINUE
15492                 CALL PHO_REGPAR(-1,21,0,J1,J2,PJ(1),PJ(2),PJ(3),PJ(4),
15493      &            I,IPHIST(2,KK2),ICOLOR(1,KK1),ICOLOR(1,KK2),IPOS,1)
15494 C  copy mother partons of string K
15495                 DO 400 II=K1,K2,KS
15496                   CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,PHEP(1,II),
15497      &              PHEP(2,II),PHEP(3,II),PHEP(4,II),I,IPHIST(2,II),
15498      &              ICOLOR(1,II),ICOLOR(2,II),IPOS,1)
15499  400            CONTINUE
15500 C  create new string entry
15501                 DO 450 II=1,4
15502                   PJ(II) = PHEP(II,J1)+PHEP(II,J2)
15503  450            CONTINUE
15504                 IP2 = IPOS
15505                 CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PJ(1),PJ(2),PJ(3),
15506      &            PJ(4),I,IPHIST(2,J1),ICOLOR(1,J1)+ICOLOR(1,J2),
15507      &            ICOLOR(2,J1)+ICOLOR(2,J2),IPOS,1)
15508 C  delete string K in /POSTRG/
15509                 NCODE(K) = -999
15510 C  update string I in /POSTRG/
15511                 NPOS(1,I) = IPOS
15512                 NPOS(2,I) = IP1
15513                 NPOS(3,I) = -IP2
15514 C  calculate new CPC string codes
15515                 CALL PHO_ID2STR(IDHEP(IP1),IDHEP(IP2),NCODE(I),IPAR1(I),
15516      &            IPAR2(I),IPAR3(I),IPAR4(I))
15517                 GOTO 99
15518               ENDIF
15519             ENDIF
15520  200      CONTINUE
15521         ENDIF
15522  99     CONTINUE
15523  100  CONTINUE
15524       IF(IDEB(83).GE.20) THEN
15525         WRITE(LO,'(1X,A)') 'PHO_POMCOR: after string recombination'
15526         IF(IDEB(83).GE.22) THEN
15527           CALL PHO_PRSTRG
15528           CALL PHO_PREVNT(0)
15529         ENDIF
15530       ENDIF
15531
15532       END
15533
15534 *$ CREATE PHO_MASCOR.FOR
15535 *COPY PHO_MASCOR
15536 CDECK  ID>, PHO_MASCOR
15537       SUBROUTINE PHO_MASCOR(IREJ)
15538 C********************************************************************
15539 C
15540 C    check and adjust parton momenta for fragmentation
15541 C
15542 C    input:      /POEVT1/
15543 C                /POSTRG/
15544 C                IREJ    -1          initialization
15545 C                        -2          output of statistics
15546 C
15547 C    output:     /POEVT1/
15548 C                /POSTRG/
15549 C                IREJ    0  successful
15550 C                        1  failure
15551 C
15552 C    in case of very small string mass:
15553 C       - direct manipulation of /POEVT1/ and /POEVT2/
15554 C       - string will be deleted from /POSTRG/ (label -99)
15555 C
15556 C********************************************************************
15557       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15558       SAVE
15559
15560       PARAMETER ( EPS    =  1.D-10,
15561      &            EMIN   =  0.3D0,
15562      &            DEPS   =  1.D-15)
15563
15564 C  input/output channels
15565       INTEGER LI,LO
15566       COMMON /POINOU/ LI,LO
15567 C  event debugging information
15568       INTEGER NMAXD
15569       PARAMETER (NMAXD=100)
15570       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15571      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15572       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15573      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15574 C  internal rejection counters
15575       INTEGER NMXJ
15576       PARAMETER (NMXJ=60)
15577       CHARACTER*10 REJTIT
15578       INTEGER IFAIL
15579       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
15580 C  model switches and parameters
15581       CHARACTER*8 MDLNA
15582       INTEGER ISWMDL,IPAMDL
15583       DOUBLE PRECISION PARMDL
15584       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15585 C  standard particle data interface
15586       INTEGER NMXHEP
15587       PARAMETER (NMXHEP=4000)
15588       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15589       DOUBLE PRECISION PHEP,VHEP
15590       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15591      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15592      &                VHEP(4,NMXHEP)
15593 C  extension to standard particle data interface (PHOJET specific)
15594       INTEGER IMPART,IPHIST,ICOLOR
15595       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
15596 C  color string configurations including collapsed strings and hadrons
15597       INTEGER MSTR
15598       PARAMETER (MSTR=500)
15599       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
15600       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
15601      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
15602      &                NNCH(MSTR),IBHAD(MSTR),ISTR
15603
15604       DIMENSION PC1(4),PC2(4),P1(4),PTR(4),GAM(3),GAMB(3)
15605
15606       IF(IREJ.EQ.-1) THEN
15607         ICTOT = 0
15608         ICCOR = 0
15609         RETURN
15610       ELSE IF(IREJ.EQ.-2) THEN
15611         WRITE(LO,'(/1X,A,2I8/)')
15612      &    'PHO_MASCOR: total/converted strings',ICTOT,ICCOR
15613         RETURN
15614       ENDIF
15615
15616       IREJ = 0
15617       NITER = 100
15618       ITER = 0
15619       ICTOT = ICTOT+ISTR
15620       IF(ISWMDL(7).EQ.-1) RETURN
15621 C  debug /POSTRG/
15622       IF(IDEB(42).GE.25) CALL PHO_PRSTRG
15623
15624       ITOUCH = 0
15625  50   CONTINUE
15626       ITER = ITER+1
15627       IF(ITER.GE.NITER) THEN
15628         IREJ = 1
15629         IF(IDEB(42).GE.2) THEN
15630           WRITE(LO,'(1X,A,2I5)') 'PHO_MASCOR: rejection',ITER,NITER
15631           IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
15632         ENDIF
15633         RETURN
15634       ENDIF
15635
15636 C  check mass limits
15637       IF(DT_RNDM(CMASS0).LT.0.5D0) THEN
15638         IM1 = 1
15639         IM2 = ISTR
15640         IST = 1
15641       ELSE
15642         IM1 = ISTR
15643         IM2 = 1
15644         IST = -1
15645       ENDIF
15646       DO 100 I=IM1,IM2,IST
15647         J1 = NPOS(1,I)
15648         CMASS0 = PHEP(5,J1)
15649 C  get masses
15650         IF(NCODE(I).EQ.3) THEN
15651           CALL PHO_MEMASS(IPAR1(I),IPAR2(I),AM1,AM2,AM3,AM4,IP1,IP2)
15652         ELSE IF((NCODE(I).EQ.4).OR.(NCODE(I).EQ.6)) THEN
15653           CALL PHO_BAMASS(IPAR1(I),IPAR2(I),IPAR3(I),
15654      &                AM1,AM2,AM3,AM4,IP1,IP2)
15655         ELSE IF(NCODE(I).EQ.5) THEN
15656           CALL PHO_DQMASS(IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),
15657      &              AM1,AM2)
15658           AM3 = 0.D0
15659           AM4 = 0.D0
15660           IP1 = 0
15661           IP2 = 0
15662         ELSE IF(NCODE(I).EQ.7) THEN
15663           AM1 = 0.15D0
15664           AM2 = 0.3D0
15665           AM3 = 0.765D0
15666           AM4 = 1.5D0
15667 *??????????????????????????????????
15668           IP1 = 23
15669           IP2 = 33
15670 *??????????????????????????????????
15671         ELSE IF(NCODE(I).LT.0) THEN
15672           GOTO 90
15673         ELSE
15674           WRITE(LO,'(/,1X,A,2I5)') 'PHO_MASCOR:ERROR: string no,NCODE ',
15675      &                            J1,NCODE(I)
15676           CALL PHO_ABORT
15677         ENDIF
15678         IF(IDEB(42).GE.20) WRITE(LO,'(1X,A,/3X,I3,5E11.3,2I5)')
15679      &    'PHO_MASCOR: string no CHMASS,AM1,AM2,AM3,AM4,IP1,IP2:',
15680      &    I,CMASS0,AM1,AM2,AM3,AM4,IP1,IP2
15681 C  select masses to correct
15682         IBHAD(I) = 0
15683         NNCH(I) = 0
15684 C  correction needed?
15685 C  no resonances for diquark-antidiquark and gluon-gluon strings
15686         IF(NCODE(I).EQ.5) THEN
15687           IF(CMASS0.LT.1.3D0*AM1) THEN
15688             IF(ISWMDL(7).LE.2) THEN
15689               IBHAD(I) = 90
15690               NNCH(I)  = -1
15691               CHMASS   = AM1*1.3D0
15692             ELSE
15693               IREJ = 1
15694               RETURN
15695             ENDIF
15696           ENDIF
15697         ELSE
15698           INEED = 0
15699 C  resonances possible
15700           IF(ISWMDL(7).EQ.0) THEN
15701             IF(CMASS0.LT.AM1*0.99D0) THEN
15702               IBHAD(I) = IP1
15703               NNCH(I)  = -1
15704               CHMASS   = AM1
15705               INEED = 1
15706             ELSE IF(CMASS0.LT.MIN(AM2,AM4)*1.2D0) THEN
15707               DELM1 = 1.D0/((CMASS0-AM1)**2+EPS)
15708               DELM2 = 1.D0/((CMASS0-AM3)**2+EPS)
15709               IF(DT_RNDM(DELM1).LT.DELM1/(DELM1+DELM2)) THEN
15710                 IBHAD(I) = IP1
15711                 NNCH(I)  = -1
15712                 CHMASS   = AM1
15713               ELSE
15714                 IBHAD(I) = IP2
15715                 NNCH(I)  = 1
15716                 CHMASS   = AM3
15717               ENDIF
15718             ENDIF
15719           ELSE IF((ISWMDL(7).EQ.1).OR.(ISWMDL(7).EQ.2)) THEN
15720             IF(CMASS0.LT.AM1*0.99) THEN
15721               IBHAD(I) = IP1
15722               NNCH(I) = -1
15723               CHMASS = AM1
15724               INEED = 1
15725             ENDIF
15726           ELSE IF(ISWMDL(7).EQ.3) THEN
15727             IF(CMASS0.LT.AM1) THEN
15728               IREJ = 1
15729               RETURN
15730             ENDIF
15731           ELSE
15732             WRITE(LO,'(/1X,A,I5)')
15733      &        'PHO_MASCOR:ERROR:UNSUPPORTED ISWMDL(7)',ISWMDL(7)
15734             CALL PHO_ABORT
15735           ENDIF
15736         ENDIF
15737 C
15738 C  correction necessary?
15739         IF(IBHAD(I).NE.0) THEN
15740 C  find largest invar. mass
15741           IPOS = 0
15742           CMASS1 = -1.D0
15743           DO 200 J2=NHEP,3,-1
15744             IF(ABS(ISTHEP(J2)).EQ.1) THEN
15745               IF((IPHIST(1,J2).LE.0).OR.(IPHIST(1,J2).GT.ISTR)) THEN
15746                 WRITE(LO,'(1X,2A,I7,I12)') 'PHO_MASCOR: ',
15747      &            'inconsistent IPHIST(1,J2) entry (J2,KEV):',J2,KEVENT
15748                 CALL PHO_PREVNT(0)
15749               ELSE IF(NCODE(IPHIST(1,J2)).GT.0) THEN
15750                 CMASS2= (PHEP(4,J1)+PHEP(4,J2))**2
15751      &                 -(PHEP(1,J1)+PHEP(1,J2))**2
15752      &                 -(PHEP(2,J1)+PHEP(2,J2))**2
15753      &                 -(PHEP(3,J1)+PHEP(3,J2))**2
15754                 IF(CMASS2.GT.CMASS1) THEN
15755                   IPOS=J2
15756                   CMASS1=CMASS2
15757                 ENDIF
15758               ENDIF
15759             ENDIF
15760  200      CONTINUE
15761           J2 = IPOS
15762           IF((J1.EQ.J2).OR.(CMASS1.LE.EMIN)) THEN
15763             IF(INEED.EQ.1) THEN
15764               IREJ = 1
15765               RETURN
15766             ELSE
15767               IBHAD(I) = 0
15768               NNCH(I) = 0
15769               GOTO 90
15770             ENDIF
15771           ENDIF
15772           ISTA = ISTHEP(J1)
15773           ISTB = ISTHEP(J2)
15774           CMASS1 = SQRT(CMASS1)
15775           CMASS2 = PHEP(5,J2)
15776           IF(CMASS1.LT.(CMASS2+CHMASS)) CMASS2 = CMASS1-1.1D0*CHMASS
15777           IREJ = 1
15778           IF(CMASS2.GT.0.D0) CALL PHO_MSHELL(PHEP(1,J1),PHEP(1,J2),
15779      &      CHMASS,CMASS2,PC1,PC2,IREJ)
15780           IF(IREJ.NE.0) THEN
15781             IFAIL(24) = IFAIL(24)+1
15782             IF(IDEB(42).GE.2) THEN
15783               WRITE(LO,'(1X,A,2I4)')
15784      &          'PHO_MASCOR: rejection by PHO_MSHELL (J1,J2):',J1,J2
15785               IF(IDEB(42).GE.10) CALL PHO_PREVNT(0)
15786             ENDIF
15787             IREJ = 1
15788             RETURN
15789           ENDIF
15790 C  momentum transfer
15791           DO 210 II=1,4
15792             PTR(II) = PHEP(II,J2)-PC2(II)
15793  210      CONTINUE
15794           IF(IDEB(42).GE.10) WRITE(LO,'(1X,A,/5X,2I3,4E12.3)')
15795      &      'PHO_MASCOR: J1,J2,transfer',J1,J2,PTR
15796 C  copy parents of strings
15797 C  register partons belonging to first string
15798           IF(IDHEP(J1).EQ.90) THEN
15799             K1 = JMOHEP(1,J1)
15800             K2 = MAX(JMOHEP(1,J1),-JMOHEP(2,J1))
15801             ESUM = 0.D0
15802             DO 500 II=K1,K2
15803               ESUM = ESUM+PHEP(4,II)
15804  500        CONTINUE
15805             IF(JMOHEP(2,J1).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J1))
15806             DO 600 II=K1,K2
15807               FAC = PHEP(4,II)/ESUM
15808               DO 650 K=1,4
15809                 P1(K) = PHEP(K,II)+FAC*PTR(K)
15810  650          CONTINUE
15811               CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15812      &          P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15813      &          ICOLOR(2,II),IPOS,1)
15814  600        CONTINUE
15815             K1A = IPOS+K1-K2
15816             IF(JMOHEP(2,J1).GT.0) THEN
15817               II = JMOHEP(2,J1)
15818               FAC = PHEP(4,II)/ESUM
15819               DO 675 K=1,4
15820                 P1(K) = PHEP(K,II)+FAC*PTR(K)
15821  675          CONTINUE
15822               CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15823      &          P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15824      &          ICOLOR(2,II),IPOS,1)
15825             ENDIF
15826             K2A = -IPOS
15827           ELSE
15828             K1A = J1
15829             K2A = J2
15830           ENDIF
15831 C  register partons belonging to second string
15832           IF(IDHEP(J2).EQ.90) THEN
15833             CALL PHO_GETLTR(PHEP(1,J2),PC2,GAM,GAMB,DELE,IREJL)
15834             K1 = JMOHEP(1,J2)
15835             K2 = MAX(JMOHEP(1,J2),-JMOHEP(2,J2))
15836             ESUM = 0.D0
15837             DO 300 II=K1,K2
15838               ESUM = ESUM+PHEP(4,II)
15839  300        CONTINUE
15840             IF(JMOHEP(2,J2).GT.0) ESUM = ESUM+PHEP(4,JMOHEP(2,J2))
15841             DO 400 II=K1,K2
15842 **sr 28.12.2006 fix adopted from FLUKA
15843 C             FAC = PHEP(4,II)/ESUM
15844               IF (ABS(ESUM).GT.0.D0) THEN
15845                  FAC = PHEP(4,II)/ESUM
15846               ELSE
15847                  FAC = 1.0D0
15848               ENDIF
15849 **
15850               IF(IREJL.EQ.0) THEN
15851                 CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
15852                 P1(4) = P1(4)+FAC*DELE
15853               ELSE
15854                 DO 450 K=1,4
15855                   P1(K) = PHEP(K,II)-FAC*PTR(K)
15856  450            CONTINUE
15857               ENDIF
15858               CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15859      &          P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15860      &          ICOLOR(2,II),IPOS,1)
15861  400        CONTINUE
15862             K1B = IPOS+K1-K2
15863             IF(JMOHEP(2,J2).GT.0) THEN
15864               II = JMOHEP(2,J2)
15865               FAC = PHEP(4,II)/ESUM
15866               IF(IREJL.EQ.0) THEN
15867                 CALL PHO_MKSLTR(PHEP(1,II),P1,GAM,GAMB)
15868                 P1(4) = P1(4)+FAC*DELE
15869               ELSE
15870                 DO 475 K=1,4
15871                   P1(K) = PHEP(K,II)-FAC*PTR(K)
15872  475            CONTINUE
15873               ENDIF
15874               CALL PHO_REGPAR(-1,IDHEP(II),0,J1,J2,P1(1),P1(2),P1(3),
15875      &          P1(4),IPHIST(1,II),IPHIST(2,II),ICOLOR(1,II),
15876      &          ICOLOR(2,II),IPOS,1)
15877             ENDIF
15878             K2B = -IPOS
15879           ELSE
15880             K1B = J1
15881             K2B = J2
15882           ENDIF
15883 C  register first string/collapsed to hadron
15884           IF((ISWMDL(7).EQ.0).OR.(ISWMDL(7).EQ.1)) THEN
15885             IF(NCODE(I).NE.5) THEN
15886               CALL PHO_REGPAR(1,0,IBHAD(I),K1A,K2A,PC1(1),PC1(2),PC1(3),
15887      &          PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
15888 C  label string as collapsed to hadron/resonance
15889               NCODE(I)  = -99
15890               IDHEP(J1) = 92
15891             ELSE
15892               CALL PHO_REGPAR(-1,90,0,K1A,K2A,PC1(1),PC1(2),PC1(3),
15893      &          PC1(4),IPHIST(1,J1),IPHIST(2,J1),0,0,IPOS,1)
15894               IDHEP(J1) = 91
15895             ENDIF
15896             NPOS(1,I) = IPOS
15897             NPOS(2,I) = K1A
15898             NPOS(3,I) = K2A
15899           ELSE
15900             CALL PHO_REGPAR(ISTA,IDHEP(J1),IMPART(J1),K1A,K2A,PC1(1),
15901      &        PC1(2),PC1(3),PC1(4),IPHIST(1,J1),IPHIST(2,J1),
15902      &        ICOLOR(1,J1),ICOLOR(2,J1),IPOS,1)
15903             IF(IDHEP(J1).EQ.90) THEN
15904               NPOS(1,IPHIST(1,J1)) = IPOS
15905               NPOS(2,IPHIST(1,J1)) = K1A
15906               NPOS(3,IPHIST(1,J1)) = K2A
15907 C  label string as collapsed to resonance-string
15908               IDHEP(J1) = 91
15909             ELSE IF((IPHIST(1,J1).GE.1).AND.(IPHIST(1,J1).LE.ISTR)) THEN
15910               IF(NPOS(1,IPHIST(1,J1)).EQ.J1) NPOS(1,IPHIST(1,J1))=IPOS
15911             ENDIF
15912           ENDIF
15913 C  register second string/hadron/parton
15914           CALL PHO_REGPAR(ISTB,IDHEP(J2),IMPART(J2),K1B,K2B,PC2(1),
15915      &      PC2(2),PC2(3),PC2(4),IPHIST(1,J2),IPHIST(2,J2),ICOLOR(1,J2),
15916      &      ICOLOR(2,J2),IPOS,1)
15917           IF(IDHEP(J2).EQ.90) THEN
15918             NPOS(1,IPHIST(1,J2))=IPOS
15919             NPOS(2,IPHIST(1,J2))=K1B
15920             NPOS(3,IPHIST(1,J2))=K2B
15921 C  label string touched by momentum transfer
15922             IDHEP(J2) = 91
15923           ELSE IF((IPHIST(1,J2).GE.1).AND.(IPHIST(1,J2).LE.ISTR)) THEN
15924             IF(NPOS(1,IPHIST(1,J2)).EQ.J2) NPOS(1,IPHIST(1,J2))=IPOS
15925           ENDIF
15926           ICCOR = ICCOR+1
15927           ITOUCH = ITOUCH+1
15928 C  consistency checks
15929           IF(IDEB(42).GE.5) THEN
15930             CALL PHO_CHECK(-1,IDEV)
15931             IF(IDEB(42).GE.25) CALL PHO_PREVNT(0)
15932           ENDIF
15933 C  jump to next iteration
15934           GOTO 50
15935         ENDIF
15936  90     CONTINUE
15937  100  CONTINUE
15938 C  debug output
15939       IF(IDEB(42).GE.15) THEN
15940         IF((ITOUCH.GT.0).OR.(IDEB(42).GE.25)) THEN
15941           WRITE(LO,'(1X,A,I5)') 'PHO_MASCOR: iterations:',ITER
15942           CALL PHO_PREVNT(1)
15943         ENDIF
15944       ENDIF
15945       END
15946
15947 *$ CREATE PHO_PARCOR.FOR
15948 *COPY PHO_PARCOR
15949 CDECK  ID>, PHO_PARCOR
15950       SUBROUTINE PHO_PARCOR(MODE,IREJ)
15951 C********************************************************************
15952 C
15953 C    conversion of string partons (using JETSET masses)
15954 C
15955 C    input:      MODE    >0 position index of corresponding string
15956 C                        -1 initialization
15957 C                        -2 output of statistics
15958 C
15959 C    output:     /POSTRG/
15960 C                IREJ    1 combination of strings impossible
15961 C                        0 successful combination
15962 C
15963 C********************************************************************
15964       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15965       SAVE
15966
15967       PARAMETER ( DELM   =  0.005D0,
15968      &            DEPS   =  1.D-15,
15969      &            EPS    =  1.D-5)
15970
15971 C  input/output channels
15972       INTEGER LI,LO
15973       COMMON /POINOU/ LI,LO
15974 C  event debugging information
15975       INTEGER NMAXD
15976       PARAMETER (NMAXD=100)
15977       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
15978      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15979       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
15980      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
15981 C  internal rejection counters
15982       INTEGER NMXJ
15983       PARAMETER (NMXJ=60)
15984       CHARACTER*10 REJTIT
15985       INTEGER IFAIL
15986       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
15987 C  model switches and parameters
15988       CHARACTER*8 MDLNA
15989       INTEGER ISWMDL,IPAMDL
15990       DOUBLE PRECISION PARMDL
15991       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15992 C  standard particle data interface
15993       INTEGER NMXHEP
15994       PARAMETER (NMXHEP=4000)
15995       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
15996       DOUBLE PRECISION PHEP,VHEP
15997       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15998      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
15999      &                VHEP(4,NMXHEP)
16000 C  extension to standard particle data interface (PHOJET specific)
16001       INTEGER IMPART,IPHIST,ICOLOR
16002       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16003 C  color string configurations including collapsed strings and hadrons
16004       INTEGER MSTR
16005       PARAMETER (MSTR=500)
16006       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16007       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16008      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16009      &                NNCH(MSTR),IBHAD(MSTR),ISTR
16010
16011       DIMENSION PP1(4),PP2(4),PB1(4),PB2(4),GAM(3),GAMB(3),
16012      &          PL(4,100),XMP(100),XML(100)
16013
16014       DOUBLE PRECISION PYMASS
16015
16016       IREJ = 0
16017       IMODE = MODE
16018 C
16019       IF(IMODE.GT.0) THEN
16020         ICH = 0
16021         I1 = JMOHEP(1,IMODE)
16022         I2 = ABS(JMOHEP(2,IMODE))
16023 C  copy to local field
16024         L = 0
16025         DO 100 I=I1,I2
16026           L = L+1
16027           DO 200 K=1,4
16028             PL(K,L) = PHEP(K,I)
16029  200      CONTINUE
16030           XMP(L) = PHEP(5,I)
16031           XML(L) = PYMASS(IDHEP(I))
16032  100    CONTINUE
16033         IPAR = L
16034         XMC = PHEP(5,IMODE)
16035         IF(IDEB(82).GE.20) THEN
16036           WRITE(LO,'(1X,A,I7,2I4)')
16037      &      'PHO_PARCOR: ini.momenta,masses(C/L),EV,ICH,L',
16038      &      KEVENT,IMODE,L
16039           DO 150 I=1,L
16040             WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16041      &       XMP(I),XML(I)
16042  150      CONTINUE
16043         ENDIF
16044 C
16045 C  two parton configurations
16046 C  -----------------------------------------
16047         IF(IPAR.EQ.2) THEN
16048           XM1 = XML(1)
16049           XM2 = XML(2)
16050           IF((XM1+XM2).GE.XMC) THEN
16051             IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,/,5X,I3,3E12.4)')
16052      &        'PHO_PARCOR: REJECTION I,XM1,XM2,XMC',
16053      &        IMODE,XM1,XM2,XMC
16054             GOTO 990
16055           ENDIF
16056 C  conversion possible
16057           CALL PHO_MSHELL(PL(1,1),PL(1,2),XM1,XM2,PP1,PP2,IREJ)
16058           IF(IREJ.NE.0) THEN
16059             IFAIL(36) = IFAIL(36)+1
16060             IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,I4,E12.4)')
16061      &      'PHO_PARCOR: rejection by PHO_MSHELL EV,STRING,MASS',
16062      &        KEVENT,IMODE,XMC
16063             GOTO 990
16064           ENDIF
16065           ICH = 1
16066           DO 115 K=1,4
16067             PL(K,1) = PP1(K)
16068             PL(K,2) = PP2(K)
16069             XMP(1) = XM1
16070             XMP(2) = XM2
16071  115      CONTINUE
16072 C
16073 C  multi parton configurations
16074 C  ---------------------------------
16075         ELSE
16076 C
16077 C  random selection of string side to start with
16078           IF(DT_RNDM(XMC).LT.0.5D0) THEN
16079             K1 = 1
16080             K2 = IPAR
16081             KS = 1
16082           ELSE
16083             K1 = IPAR
16084             K2 = 1
16085             KS = -1
16086           ENDIF
16087           ITER = 0
16088 C
16089  300      CONTINUE
16090           IF(ITER.LT.4) THEN
16091             KK = K1
16092             K1 = K2
16093             K2 = KK
16094             KS = -KS
16095           ELSE
16096             GOTO 990
16097           ENDIF
16098           ITER = ITER+1
16099 C  select method
16100           IF(ITER.GT.2) GOTO 230
16101
16102 C  conversion according to color flow method
16103           IFAI = 0
16104           DO 210 II=K1,K2-KS,KS
16105             DO 215 IK=II+KS,K2,KS
16106               XM1 = XML(II)
16107               XM2 = XML(IK)
16108 *             IF(IDEB(82).GE.10) WRITE(LO,'(1X,A,2I3,4E12.4)')
16109 *    &          'PHO_PARCOR:I,K,XM(1-4)',II,IK,XM1,XMP(II),XM2,XMP(IK)
16110               IF((ABS(XM1-XMP(II)).GT.DELM)
16111      &           .OR.(ABS(XM2-XMP(IK)).GT.DELM)) THEN
16112                 CALL PHO_MSHELL(PL(1,II),PL(1,IK),XM1,XM2,PP1,PP2,IREJ)
16113                 IF(IREJ.NE.0) THEN
16114                   IFAIL(36) = IFAIL(36)+1
16115                   IF(IDEB(82).GE.6) WRITE(LO,'(1X,2A,I8,3I4)')
16116      &              'PHO_PARCOR: ',
16117      &              'int.rej. by PHO_MSHELL EV,IC,I1,I2',
16118      &              KEVENT,IMODE,II,IK
16119                   IREJ = 0
16120                 ELSE
16121                   ICH = ICH+1
16122                   DO 220 KK=1,4
16123                     PL(KK,II) = PP1(KK)
16124                     PL(KK,IK) = PP2(KK)
16125  220              CONTINUE
16126                   XMP(II) = XM1
16127                   XMP(IK) = XM2
16128                   GOTO 219
16129                 ENDIF
16130               ELSE
16131                 GOTO 219
16132               ENDIF
16133  215        CONTINUE
16134             IFAI = II
16135  219        CONTINUE
16136  210      CONTINUE
16137           IF(IFAI.NE.0) GOTO 300
16138           GOTO 950
16139 C
16140  230      CONTINUE
16141 C
16142 C  conversion according to remainder method
16143           DO 350 I=K1,K2,KS
16144             XM1 = XML(I)
16145             IF(ABS(XM1-XMP(I)).GT.DELM) THEN
16146               ICH = ICH+1
16147               IFAI = I
16148 C  conversion necessary
16149               DO 400 K=1,4
16150                 PB1(K) = PL(K,I)
16151                 PB2(K) = PHEP(K,IMODE)-PB1(K)
16152  400          CONTINUE
16153               XM2 = PB2(4)**2-PB2(1)**2-PB2(2)**2-PB2(3)**2
16154               IF(XM2.LT.0.D0) THEN
16155                 IF(IDEB(82).GE.10) WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
16156      &            'PHO_PARCOR: ',
16157      &            'int.rej. I,IPA,ICH,XML,XMP,XM2**2,MCHAIN',
16158      &            I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
16159                 GOTO 300
16160               ENDIF
16161               XM2 = SQRT(XM2)
16162               IF((XM1+XM2).GE.XMC) THEN
16163                 IF(IDEB(82).GE.10) WRITE(LO,'(1X,2A,/,5X,3I3,4E12.4)')
16164      &            'PHO_PARCOR: ',
16165      &            'int.rej. I,IPA,ICH,XML,XMP,XM2,XMC',
16166      &            I,IPAR,IMODE,XM1,XMP(I),XM2,XMC
16167                 GOTO 300
16168               ENDIF
16169 C  conversion possible
16170               CALL PHO_MSHELL(PB1,PB2,XM1,XM2,PP1,PP2,IREJ)
16171               IF(IREJ.NE.0) THEN
16172                 IFAIL(36) = IFAIL(36)+1
16173                 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,3I4)')
16174      &            'PHO_PARCOR: PHO_MSHELL rej. ITER,STRING,PARTON',
16175      &            ITER,IMODE,I
16176                 GOTO 300
16177               ENDIF
16178 C  calculate Lorentz transformation
16179               CALL PHO_GETLTR(PB2,PP2,GAM,GAMB,DELE,IREJ)
16180               IF(IREJ.NE.0) THEN
16181                 IF(IDEB(82).GE.6) WRITE(LO,'(1X,A,I8,3I4)')
16182      &            'PHO_PARCOR: PHO_GETLTR rej. ITER,STRING,PARTON',
16183      &            ITER,IMODE,I
16184                 GOTO 300
16185               ENDIF
16186               IFAI = 0
16187 C  transform remaining partons
16188               DO 450 L=K1,K2,KS
16189                 IF(L.NE.I) THEN
16190                   CALL PHO_MKSLTR(PL(1,L),PP2,GAM,GAMB)
16191                   DO 500 K=1,4
16192                     PL(K,L) = PP2(K)
16193  500              CONTINUE
16194                 ELSE
16195                   DO 550 K=1,4
16196                     PL(K,L) = PP1(K)
16197  550              CONTINUE
16198                 ENDIF
16199  450          CONTINUE
16200               XMP(I) = XM1
16201             ENDIF
16202  350      CONTINUE
16203         ENDIF
16204
16205 C  register transformed partons
16206  950      CONTINUE
16207           IREJ = 0
16208           IF(ICH.NE.0) THEN
16209             IP1 = NHEP+1
16210             L = 0
16211             DO 700 I=I1,I2
16212               L= L+1
16213               CALL PHO_REGPAR(-1,IDHEP(I),0,IMODE,0,PL(1,L),PL(2,L),
16214      &          PL(3,L),PL(4,L),IPHIST(1,I),IPHIST(2,I),ICOLOR(1,I),
16215      &          ICOLOR(2,I),IPOS,1)
16216  700        CONTINUE
16217             IP2 = IPOS
16218 C  register string
16219             CALL PHO_REGPAR(-1,90,0,IP1,-IP2,PHEP(1,IMODE),
16220      &        PHEP(2,IMODE),PHEP(3,IMODE),PHEP(4,IMODE),IPHIST(1,IMODE),
16221      &        IPHIST(2,IMODE),ICOLOR(1,IMODE),ICOLOR(2,IMODE),IPOS,1)
16222 C  update /POSTRG/
16223             I = IPHIST(1,IMODE)
16224             NPOS(1,I) = IPOS
16225             NPOS(2,I) = IP1
16226             NPOS(3,I) = -IP2
16227           ENDIF
16228 C  debug output
16229           IF(IDEB(82).GE.20) THEN
16230             WRITE(LO,'(1X,A,I7,2I4)')
16231      &        'PHO_PARCOR: fin.momenta,masses(C/L),(EV,ICH,L)',
16232      &        KEVENT,IMODE,L
16233             DO 850 I=1,L
16234               WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16235      &         XMP(I),XML(I)
16236  850        CONTINUE
16237             WRITE(LO,'(1X,A,2I5)')
16238      &        'PHO_PARCOR: conversion done (old/new ICH)',IMODE,IPOS
16239           ENDIF
16240           RETURN
16241 C  rejection
16242  990      CONTINUE
16243           IREJ = 1
16244           IF(IDEB(82).GE.3) THEN
16245             WRITE(LO,'(/1X,A,/,5X,3I5,E12.4)')
16246      &        'PHO_PARCOR: rejection I,IPAR,ICHAIN,MCHAIN',
16247      &         IFAI,IPAR,IMODE,XMC
16248             IF(IDEB(82).GE.5) THEN
16249               WRITE(LO,'(1X,A,I7,2I4)')
16250      &          'PHO_PARCOR: momenta,masses(C/L),(EV,ICH,L)',
16251      &          KEVENT,IMODE,IPAR
16252               DO 155 I=1,IPAR
16253                 WRITE(LO,'(1X,4E12.4,2X,2E12.4)') (PL(K,I),K=1,4),
16254      &           XMP(I),XML(I)
16255  155          CONTINUE
16256             ENDIF
16257           ENDIF
16258           RETURN
16259
16260       ELSE IF(IMODE.EQ.-1) THEN
16261 C  initialization
16262         RETURN
16263
16264       ELSE IF(IMODE.EQ.-2) THEN
16265 C  final output
16266         RETURN
16267       ENDIF
16268       END
16269
16270 *$ CREATE PHO_STRING.FOR
16271 *COPY PHO_STRING
16272 CDECK  ID>, PHO_STRING
16273       SUBROUTINE PHO_STRING(IMODE,IREJ)
16274 C********************************************************************
16275 C
16276 C    calculation of string combinatorics, Lorentz boosts and
16277 C                   particle codes
16278 C
16279 C                - splitting of gluons
16280 C                - strings will be built up from pairs of partons
16281 C                  according to their color labels
16282 C                  with IDHEP(..) = -1
16283 C                - there can be other particles between to string partons
16284 C                  (these will be unchanged by string construction)
16285 C                - string mass fine correction
16286 C
16287 C    input:      IMODE    1  complete string processing
16288 C                        -1 initialization
16289 C                        -2 output of statistics
16290 C
16291 C    output:     /POSTRG/
16292 C                IREJ    1 combination of strings impossible
16293 C                        0 successful combination
16294 C                       50 rejection due to user cutoffs
16295 C
16296 C********************************************************************
16297       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16298       SAVE
16299
16300       PARAMETER ( DEPS   =  1.D-15,
16301      &            EPS    =  1.D-5 )
16302
16303 C  input/output channels
16304       INTEGER LI,LO
16305       COMMON /POINOU/ LI,LO
16306 C  event debugging information
16307       INTEGER NMAXD
16308       PARAMETER (NMAXD=100)
16309       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16310      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16311       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16312      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16313 C  general process information
16314       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
16315       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
16316 C  internal rejection counters
16317       INTEGER NMXJ
16318       PARAMETER (NMXJ=60)
16319       CHARACTER*10 REJTIT
16320       INTEGER IFAIL
16321       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
16322 C  model switches and parameters
16323       CHARACTER*8 MDLNA
16324       INTEGER ISWMDL,IPAMDL
16325       DOUBLE PRECISION PARMDL
16326       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16327 C  hard cross sections and MC selection weights
16328       INTEGER Max_pro_2
16329       PARAMETER ( Max_pro_2 = 16 )
16330       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
16331      &  MH_acc_1,MH_acc_2
16332       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
16333       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
16334      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
16335      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
16336      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
16337      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
16338 C  standard particle data interface
16339       INTEGER NMXHEP
16340       PARAMETER (NMXHEP=4000)
16341       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16342       DOUBLE PRECISION PHEP,VHEP
16343       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16344      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16345      &                VHEP(4,NMXHEP)
16346 C  extension to standard particle data interface (PHOJET specific)
16347       INTEGER IMPART,IPHIST,ICOLOR
16348       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16349 C  color string configurations including collapsed strings and hadrons
16350       INTEGER MSTR
16351       PARAMETER (MSTR=500)
16352       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16353       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16354      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16355      &                NNCH(MSTR),IBHAD(MSTR),ISTR
16356 C  table of particle indices for recursive PHOJET calls
16357       INTEGER MAXIPX
16358       PARAMETER ( MAXIPX = 100 )
16359       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
16360       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
16361      &                IPOIX1,IPOIX2,IPOIX3
16362 C  some constants
16363       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
16364       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
16365      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
16366
16367       IREJ = 0
16368       IF(IMODE.EQ.-1) THEN
16369         CALL PHO_POMCOR(-1)
16370         CALL PHO_MASCOR(-1)
16371         CALL PHO_PARCOR(-1,IREJ)
16372         RETURN
16373       ELSE IF(IMODE.EQ.-2) THEN
16374         CALL PHO_POMCOR(-2)
16375         CALL PHO_MASCOR(-2)
16376         CALL PHO_PARCOR(-2,IREJ)
16377         RETURN
16378       ENDIF
16379
16380 C  generate enhanced graphs
16381       IF(IPOIX2.GT.0) THEN
16382  200    CONTINUE
16383         I1 = MAX(1,IPOIX1)
16384         I2 = IPOIX2
16385         IF(ISWMDL(14).EQ.1) IPOIX1 = 0
16386         KSPOMS = KSPOM-1
16387         KSREGS = KSREG
16388         KHPOMS = KHPOM
16389         KHDIRS = KHDIR
16390         IDDFS1 = IDIFR1
16391         IDDFS2 = IDIFR2
16392         IDDPOS = IDDPOM
16393         DO 110 I=I1,I2
16394           IPOIX3 = I
16395           KSPOM = 0
16396           KSREG = 0
16397           KHPOM = 0
16398           KHDIR = 0
16399           IF(IPORES(I).EQ.8) THEN
16400             KSPOM = 2
16401             LSPOM = 2
16402             LHPOM = 0
16403             LSREG = 0
16404             LHDIR = 0
16405             IGEN = abs(IPHIST(2,IPOPOS(1,I)))
16406             CALL PHO_STDPAR(IPOPOS(1,I),IPOPOS(2,I),IGEN,
16407      &                      LSPOM,LSREG,LHPOM,LHDIR,IREJ)
16408             IF(IREJ.NE.0) THEN
16409               IF(IDEB(4).GE.2) THEN
16410                 WRITE(LO,'(/1X,A,I5)')
16411      &            'PHO_STRING: sec.rejection by PHO_STDPAR',IREJ
16412                 CALL PHO_PREVNT(-1)
16413               ENDIF
16414               RETURN
16415             ENDIF
16416             KSPOM = KSPOMS+LSPOM
16417             KSREG = KSREGS+LSREG
16418             KHPOM = KHPOMS+LHPOM
16419             KHDIR = KHDIRS+LHDIR
16420           ELSE IF(IPORES(I).EQ.4) THEN
16421             ITEMP = ISWMDL(17)
16422             ISWMDL(17) = 0
16423             CALL PHO_CDIFF(IPOPOS(1,I),IPOPOS(2,I),MSOFT,MHARD,1,IREJ)
16424             ISWMDL(17) = ITEMP
16425             IF(IREJ.NE.0) THEN
16426               IF(IDEB(4).GE.2) THEN
16427                 WRITE(LO,'(/1X,A,I5)')
16428      &            'PHO_STRING: sec.rejection by PHO_CDIFF',IREJ
16429                 CALL PHO_PREVNT(-1)
16430               ENDIF
16431               RETURN
16432             ENDIF
16433             KSDPO = KSDPO+1
16434             KSPOM = KSPOMS+KSPOM
16435             KSREG = KSREGS+KSREG
16436             KHPOM = KHPOMS+KHPOM
16437             KHDIR = KHDIRS+KHDIR
16438           ELSE
16439             IDIF1 = 1
16440             IDIF2 = 1
16441             IF(IPORES(I).EQ.5) THEN
16442               IDIF2 = 0
16443               KSTRG = KSTRG+1
16444             ELSE IF(IPORES(I).EQ.6) THEN
16445               IDIF1 = 0
16446               KSTRG = KSTRG+1
16447             ELSE
16448               KSLOO = KSLOO+1
16449             ENDIF
16450             ITEMP = ISWMDL(16)
16451             ISWMDL(16) = 0
16452             SPROB = 1.D0
16453             CALL PHO_DIFDIS(IDIF1,IDIF2,IPOPOS(1,I),IPOPOS(2,I),SPROB,
16454      &        0,MSOFT,MHARD,IREJ)
16455             ISWMDL(16) = ITEMP
16456             IF(IREJ.NE.0) THEN
16457               IF(IDEB(4).GE.2) THEN
16458                 WRITE(LO,'(/1X,A,I5)')
16459      &            'PHO_STRING: sec.rejection by PHO_DIFDIS',IREJ
16460                 CALL PHO_PREVNT(-1)
16461               ENDIF
16462               RETURN
16463             ENDIF
16464             KSPOM = KSPOMS+KSPOM
16465             KSREG = KSREGS+KSREG
16466             KHPOM = KHPOMS+KHPOM
16467             KHDIR = KHDIRS+KHDIR
16468           ENDIF
16469           IDIFR1 = IDDFS1
16470           IDIFR2 = IDDFS2
16471           IDDPOM = IDDPOS
16472  110    CONTINUE
16473         IF(IPOIX2.GT.I2) THEN
16474           IPOIX1 = I2+1
16475           GOTO 200
16476         ENDIF
16477       ENDIF
16478
16479 C  optional: split gluons to q-qbar pairs
16480       IF(ISWMDL(9).GT.0) THEN
16481         NHEPO = NHEP
16482         DO 30 I=3,NHEPO
16483           IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).EQ.21)) THEN
16484             ICG1=ICOLOR(1,I)
16485             ICG2=ICOLOR(2,I)
16486             IQ1 = 0
16487             IQ2 = 0
16488             DO 40 K=3,NHEPO
16489               IF(ICOLOR(1,K).EQ.-ICG1) THEN
16490                 IQ1 = K
16491                 IF(IQ1*IQ2.NE.0) GOTO 45
16492               ELSE IF(ICOLOR(1,K).EQ.-ICG2) THEN
16493                 IQ2 = K
16494                 IF(IQ1*IQ2.NE.0) GOTO 45
16495               ENDIF
16496  40         CONTINUE
16497             WRITE(LO,'(/1X,2A,3I6)') 'PHO_STRING:ERROR:(1) ',
16498      &        'no matching color found (IG,ICG1,ICG2)',I,ICG1,ICG2
16499             CALL PHO_ABORT
16500  45         CONTINUE
16501             CALL PHO_GLU2QU(I,IQ1,IQ2,IREJ)
16502             IF(IREJ.NE.0) THEN
16503               IF(IDEB(19).GE.5) THEN
16504                 WRITE(LO,'(/,1X,A)')
16505      &            'PHO_STRING: no gluon splitting possible'
16506                 CALL PHO_PREVNT(0)
16507               ENDIF
16508               RETURN
16509             ENDIF
16510           ENDIF
16511  30     CONTINUE
16512       ENDIF
16513
16514 C  construct strings and write entries sorted by strings
16515
16516       ISTR = ISTR+1
16517       NHEPO = NHEP
16518       DO 50 I=3,NHEPO
16519         IF(ISTR.GT.MSTR) THEN
16520           WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
16521      &      'event has too many strings (ISTR,MSTR):',ISTR,MSTR
16522           CALL PHO_PREVNT(0)
16523           IREJ = 1
16524           RETURN
16525         ENDIF
16526         IF(ISTHEP(I).EQ.1) THEN
16527 C  hadrons / resonances / clusters
16528           NPOS(1,ISTR) = I
16529           NPOS(2,ISTR) = 0
16530           NPOS(3,ISTR) = 0
16531           NPOS(4,ISTR) = abs(IPHIST(2,I))
16532           NCODE(ISTR) = -99
16533           IPHIST(1,I) = ISTR
16534           ISTR = ISTR+1
16535         ELSE IF((ISTHEP(I).EQ.-1).AND.(IDHEP(I).NE.21)) THEN
16536 C  quark /diquark terminated strings
16537           ICOL1 = -ICOLOR(1,I)
16538           P1 = PHEP(1,I)
16539           P2 = PHEP(2,I)
16540           P3 = PHEP(3,I)
16541           P4 = PHEP(4,I)
16542           ICH1 = IPHO_CHR3(I,2)
16543           IBA1 = IPHO_BAR3(I,2)
16544           CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
16545      &                P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
16546      &                ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
16547           JM1 = IPOS
16548
16549           NRPOM = 0
16550  65       CONTINUE
16551           DO 55 K=3,NHEPO
16552             IF(ISTHEP(K).EQ.-1)THEN
16553               IF(IDHEP(K).EQ.21) THEN
16554                 IF(ICOLOR(1,K).EQ.ICOL1) THEN
16555                   ICOL1 = -ICOLOR(2,K)
16556                   GOTO 60
16557                 ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
16558                   ICOL1 = -ICOLOR(1,K)
16559                   GOTO 60
16560                 ENDIF
16561               ELSE IF(ICOLOR(1,K).EQ.ICOL1) THEN
16562                 ICOL1 = 0
16563                 GOTO 60
16564               ENDIF
16565             ENDIF
16566  55       CONTINUE
16567           WRITE(LO,'(/1X,A,I5)')
16568      &      'PHO_STRING:ERROR:(2) no matching color found for',-ICOL1
16569           CALL PHO_ABORT
16570  60       CONTINUE
16571           P1 = P1+PHEP(1,K)
16572           P2 = P2+PHEP(2,K)
16573           P3 = P3+PHEP(3,K)
16574           P4 = P4+PHEP(4,K)
16575           NRPOM = MAX(NRPOM,IPHIST(1,K))
16576           ICH1 = ICH1+IPHO_CHR3(K,2)
16577           IBA1 = IBA1+IPHO_BAR3(K,2)
16578           CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
16579      &      PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
16580      &      IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
16581 C  further parton involved?
16582           IF(ICOL1.NE.0) GOTO 65
16583           JM2 = IPOS
16584 C  register string
16585           IGEN = IPHIST(2,K)
16586           CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
16587      &                ISTR,IGEN,ICH1,IBA1,IPOS,1)
16588 C  store additional string information
16589           NPOS(1,ISTR) = IPOS
16590           NPOS(2,ISTR) = JM1
16591           NPOS(3,ISTR) = -JM2
16592           NPOS(4,ISTR) = abs(IPHIST(2,K))
16593 C  calculate CPC string codes
16594           CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
16595      &                IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
16596           ISTR = ISTR+1
16597         ENDIF
16598  50   CONTINUE
16599
16600       DO 150 I=3,NHEPO
16601         IF(ISTR.GT.MSTR) THEN
16602           WRITE(LO,'(1X,2A,2I4)') 'PHO_STRING: ',
16603      &      'event has too many strings (ISTR,MSTR):',ISTR,MSTR
16604           CALL PHO_PREVNT(0)
16605           IREJ = 1
16606           RETURN
16607         ENDIF
16608         IF(ISTHEP(I).EQ.-1) THEN
16609 C  gluon loop-strings
16610           ICOL1 = -ICOLOR(1,I)
16611           P1 = PHEP(1,I)
16612           P2 = PHEP(2,I)
16613           P3 = PHEP(3,I)
16614           P4 = PHEP(4,I)
16615           IBA1 = 0
16616           ICH1 = 0
16617           CALL PHO_REGPAR(-1,IDHEP(I),IMPART(I),I,0,
16618      &                P1,P2,P3,P4,IPHIST(1,I),IPHIST(2,I),
16619      &                ICOLOR(1,I),ICOLOR(2,I),IPOS,1)
16620           JM1 = IPOS
16621 C
16622           NRPOM = 0
16623  165      CONTINUE
16624           IF(ICOLOR(2,I).EQ.ICOL1) GOTO 170
16625           DO 155 K=I,NHEPO
16626             IF(ISTHEP(K).EQ.-1)THEN
16627               IF(ICOLOR(1,K).EQ.ICOL1) THEN
16628                 ICOL1 = -ICOLOR(2,K)
16629                 GOTO 160
16630               ELSE IF(ICOLOR(2,K).EQ.ICOL1) THEN
16631                 ICOL1 = -ICOLOR(1,K)
16632                 GOTO 160
16633               ENDIF
16634             ENDIF
16635  155      CONTINUE
16636           WRITE(LO,'(/1X,A,I5)')
16637      &      'PHO_STRING:ERROR:(3) no matching color found for',-ICOL1
16638           CALL PHO_ABORT
16639  160      CONTINUE
16640           P1 = P1+PHEP(1,K)
16641           P2 = P2+PHEP(2,K)
16642           P3 = P3+PHEP(3,K)
16643           P4 = P4+PHEP(4,K)
16644           NRPOM = MAX(NRPOM,IPHIST(1,K))
16645           CALL PHO_REGPAR(-1,IDHEP(K),IMPART(K),K,0,
16646      &      PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K),
16647      &      IPHIST(1,K),IPHIST(2,K),ICOLOR(1,K),ICOLOR(2,K),IPOS,1)
16648 C  further parton involved?
16649           IF(ICOL1.NE.0) GOTO 165
16650  170      CONTINUE
16651           JM2 = IPOS
16652 C  register string
16653           IGEN = IPHIST(2,K)
16654           CALL PHO_REGPAR(-1,90,0,JM1,-JM2,P1,P2,P3,P4,
16655      &                ISTR,IGEN,ICH1,IBA1,IPOS,1)
16656 C  store additional string information
16657           NPOS(1,ISTR) = IPOS
16658           NPOS(2,ISTR) = JM1
16659           NPOS(3,ISTR) = -JM2
16660           NPOS(4,ISTR) = abs(IPHIST(2,K))
16661 C  calculate CPC string codes
16662           CALL PHO_ID2STR(IDHEP(JM1),IDHEP(JM2),NCODE(ISTR),
16663      &                IPAR1(ISTR),IPAR2(ISTR),IPAR3(ISTR),IPAR4(ISTR))
16664           ISTR = ISTR+1
16665         ENDIF
16666  150  CONTINUE
16667
16668       ISTR = ISTR-1
16669
16670       IF(IDEB(19).GE.17) THEN
16671         WRITE(LO,'(1X,A)') 'PHO_STRING: after string construction'
16672         CALL PHO_PREVNT(0)
16673       ENDIF
16674
16675 C  pomeron corrections
16676       CALL PHO_POMCOR(IREJ)
16677       IF(IREJ.NE.0) THEN
16678         IFAIL(38) = IFAIL(38)+1
16679         IF(IDEB(19).GE.3) THEN
16680           WRITE(LO,'(1X,A,I6)')
16681      &      'PHO_STRING: rejection by PHO_POMCOR (IREJ)',IREJ
16682           CALL PHO_PREVNT(-1)
16683         ENDIF
16684         RETURN
16685       ENDIF
16686
16687 C  string mass corrections
16688       CALL PHO_MASCOR(IREJ)
16689       IF(IREJ.NE.0) THEN
16690         IFAIL(34) = IFAIL(34)+1
16691         IF(IDEB(19).GE.3) THEN
16692           WRITE(LO,'(1X,A,I6)')
16693      &      'PHO_STRING: rejection by PHO_MASCOR (IREJ)',IREJ
16694           CALL PHO_PREVNT(-1)
16695         ENDIF
16696         RETURN
16697       ENDIF
16698
16699 C  parton mass corrections
16700       DO 100 I=1,ISTR
16701         IF(NCODE(I).GE.0) THEN
16702           CALL PHO_PARCOR(NPOS(1,I),IREJ)
16703           IF(IREJ.NE.0) THEN
16704             IFAIL(35) = IFAIL(35)+1
16705             IF(IDEB(19).GE.3) THEN
16706               WRITE(LO,'(1X,A,I6)')
16707      &          'PHO_STRING: rejection by PHO_PARCOR (IREJ)',IREJ
16708               CALL PHO_PREVNT(-1)
16709             ENDIF
16710             RETURN
16711           ENDIF
16712         ENDIF
16713  100  CONTINUE
16714
16715 C  statistics of hard processes
16716       DO 550 I=3,NHEP
16717         IF(ISTHEP(I).EQ.25) THEN
16718           K  = IMPART(I)
16719           II = IDHEP(I)
16720           MH_acc_2(K,II) = MH_acc_2(K,II)+1
16721         ENDIF
16722  550  CONTINUE
16723
16724 C  debug: write out strings
16725       IF(IDEB(19).GE.5) THEN
16726         IF(IDEB(19).GE.10)
16727      &    CALL PHO_CHECK(1,IDEV)
16728         IF(IDEB(19).GE.15) THEN
16729           CALL PHO_PREVNT(0)
16730         ELSE
16731           CALL PHO_PRSTRG
16732         ENDIF
16733       ENDIF
16734
16735       END
16736
16737 *$ CREATE PHO_STRFRA.FOR
16738 *COPY PHO_STRFRA
16739 CDECK  ID>, PHO_STRFRA
16740       SUBROUTINE PHO_STRFRA(IREJ)
16741 C********************************************************************
16742 C
16743 C     do all fragmentation of strings
16744 C
16745 C     output:  IREJ    0   successful
16746 C                      1   rejection
16747 C                     50   rejection due to user cutoffs
16748 C
16749 C********************************************************************
16750       IMPLICIT NONE
16751       SAVE
16752
16753 C  input/output channels
16754       INTEGER LI,LO
16755       COMMON /POINOU/ LI,LO
16756 C  some constants
16757       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
16758       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
16759      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
16760 C  event debugging information
16761       INTEGER NMAXD
16762       PARAMETER (NMAXD=100)
16763       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
16764      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16765       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
16766      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
16767 C  general process information
16768       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
16769       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
16770 C  model switches and parameters
16771       CHARACTER*8 MDLNA
16772       INTEGER ISWMDL,IPAMDL
16773       DOUBLE PRECISION PARMDL
16774       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
16775 C  global event kinematics and particle IDs
16776       INTEGER IFPAP,IFPAB
16777       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
16778       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
16779 C  standard particle data interface
16780       INTEGER NMXHEP
16781       PARAMETER (NMXHEP=4000)
16782       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
16783       DOUBLE PRECISION PHEP,VHEP
16784       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16785      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
16786      &                VHEP(4,NMXHEP)
16787 C  extension to standard particle data interface (PHOJET specific)
16788       INTEGER IMPART,IPHIST,ICOLOR
16789       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
16790 C  color string configurations including collapsed strings and hadrons
16791       INTEGER MSTR
16792       PARAMETER (MSTR=500)
16793       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
16794       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
16795      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
16796      &                NNCH(MSTR),IBHAD(MSTR),ISTR
16797
16798       INTEGER IREJ
16799
16800       DOUBLE PRECISION PX,PY,PZ,HE,XMB,PT1,PT2,DUM
16801       INTEGER I,II,IJ,IFOUND,IP,IP_old,IPMOTH,IPOS,IBAM,IJOIN,
16802      &        IGEN,IS,ISH,ISTR,J,K1,K2,NHEP1,NLINES
16803
16804       integer indx(500),indx_max
16805
16806       DOUBLE PRECISION DT_RNDM
16807       INTEGER ipho_pdg2id
16808       EXTERNAL DT_RNDM,ipho_pdg2id
16809
16810       DOUBLE PRECISION PYP,RQLUN
16811       INTEGER PYK
16812
16813       INTEGER MSTU,MSTJ
16814       DOUBLE PRECISION PARU,PARJ
16815       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16816       INTEGER N,NPAD,K
16817       DOUBLE PRECISION P,V
16818       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16819
16820       DIMENSION IJOIN(100)
16821
16822       IREJ = 0
16823       IF(ABS(ISWMDL(6)).GT.3) THEN
16824         WRITE(LO,'(/1X,2A,I3)') 'PHO_STRFRA:ERROR: ',
16825      &    'invalid value of ISWMDL(6)',ISWMDL(6)
16826         CALL PHO_ABORT
16827       ENDIF
16828
16829 C  popcorn suppression
16830         IF(PARMDL(134).GT.0.D0) THEN
16831           IF(DT_RNDM(DUM).LT.PARMDL(134)) THEN
16832             MSTJ(12) = 2
16833           ELSE
16834             MSTJ(12) = 1
16835           ENDIF
16836         ENDIF
16837
16838 C  copy partons to fragmentation code JETSET
16839         IP = 0
16840         IP_old = 1
16841
16842         DO 300 J=1,ISTR
16843
16844 C  select partons with common production process
16845           IGEN = NPOS(4,J)
16846           if(IGEN.lt.0) goto 299
16847
16848           indx_max = 0
16849           DO 400 I=J,ISTR
16850             if((IGEN.eq.NPOS(4,I)).or.(IPAMDL(17).eq.0)) then
16851
16852 C  write final particles/resonances to JETSET
16853               IF(NCODE(I).EQ.-99) THEN
16854                 II = NPOS(1,I)
16855                 IP = IP+1
16856                 P(IP,1) = PHEP(1,II)
16857                 P(IP,2) = PHEP(2,II)
16858                 P(IP,3) = PHEP(3,II)
16859                 P(IP,4) = PHEP(4,II)
16860                 P(IP,5) = PHEP(5,II)
16861                 K(IP,1) = 1
16862                 K(IP,2) = IDHEP(II)
16863                 K(IP,3) = 0
16864                 K(IP,4) = 0
16865                 K(IP,5) = 0
16866                 IPHIST(2,II) = IP
16867                 if(indx_max.eq.500) then
16868                   WRITE(LO,'(1x,2a,i8,I12)') 'PHO_STRFRA: ',
16869      &              'no space left in index vector (indx,Kevent)',
16870      &              indx_max,KEVENT
16871                   IREJ = 1
16872                   return
16873                 endif
16874                 indx_max = indx_max+1
16875                 indx(indx_max) = II
16876 C  write partons to JETSET
16877               ELSE IF(NCODE(I).GE.0) THEN
16878                 K1 = JMOHEP(1,NPOS(1,I))
16879                 K2 = MAX(JMOHEP(1,NPOS(1,I)),-JMOHEP(2,NPOS(1,I)))
16880                 IJ = 0
16881                 DO II=K1,K2
16882                   IP = IP+1
16883                   P(IP,1) = PHEP(1,II)
16884                   P(IP,2) = PHEP(2,II)
16885                   P(IP,3) = PHEP(3,II)
16886                   P(IP,4) = PHEP(4,II)
16887                   P(IP,5) = PHEP(5,II)
16888                   K(IP,1) = 1
16889                   K(IP,2) = IDHEP(II)
16890                   K(IP,3) = 0
16891                   K(IP,4) = 0
16892                   K(IP,5) = 0
16893                   IPHIST(2,II) = IP
16894                   IJ = IJ+1
16895                   IJOIN(IJ) = IP
16896                   indx_max = indx_max+1
16897                   indx(indx_max) = II
16898                 ENDDO
16899                 II = JMOHEP(2,NPOS(1,I))
16900                 IF((II.GT.0).AND.(II.NE.K1)) THEN
16901                   IP = IP+1
16902                   P(IP,1) = PHEP(1,II)
16903                   P(IP,2) = PHEP(2,II)
16904                   P(IP,3) = PHEP(3,II)
16905                   P(IP,4) = PHEP(4,II)
16906                   P(IP,5) = PHEP(5,II)
16907                   K(IP,1) = 1
16908                   K(IP,2) = IDHEP(II)
16909                   K(IP,3) = 0
16910                   K(IP,4) = 0
16911                   K(IP,5) = 0
16912                   IPHIST(2,II) = IP
16913                   IJ = IJ+1
16914                   IJOIN(IJ) = IP
16915                   indx_max = indx_max+1
16916                   indx(indx_max) = II
16917                 ENDIF
16918                 N = IP
16919 C  connect partons to strings
16920                 CALL PYJOIN(IJ,IJOIN)
16921               ENDIF
16922
16923               NPOS(4,I) = -NPOS(4,I)
16924             endif
16925  400      continue
16926
16927 C  set Lund counter
16928           N = IP
16929           if(IP.eq.0) goto 299
16930
16931 C  hard final state evolution
16932           IF((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
16933             ISH = 0
16934             do 125 k1=1,indx_max
16935               I = indx(k1)
16936               IF(IPHIST(1,I).LE.-100) THEN
16937                 ISH = ISH+1
16938                 IJOIN(ISH) = I
16939               ENDIF
16940  125        continue
16941             IF(ISH.GE.2) THEN
16942               DO 130 K1=1,ISH
16943                 IF(IJOIN(K1).EQ.0) GOTO 130
16944                 I = IJOIN(K1)
16945                 IF((IPAMDL(102).EQ.1)
16946      &             .AND.(IPHIST(1,I).NE.-100)) GOTO 130
16947                 DO 135 K2=K1+1,ISH
16948                   IF(IJOIN(K2).EQ.0) GOTO 135
16949                   II = IJOIN(K2)
16950                   IF(IPHIST(1,I).EQ.IPHIST(1,II)) THEN
16951                     PT1 = SQRT(PHEP(1,II)**2+PHEP(2,II)**2)
16952                     PT2 = SQRT(PHEP(1,I)**2+PHEP(2,I)**2)
16953                     RQLUN = MIN(PT1,PT2)
16954                     IF(IDEB(22).GE.10) WRITE(LO,'(1X,A,2I5,E12.4)')
16955      &                'PHO_STRFRA: PYSHOW called',I,II,RQLUN
16956                     CALL PYSHOW(IPHIST(2,I),IPHIST(2,II),RQLUN)
16957                     IJOIN(K1) = 0
16958                     IJOIN(K2) = 0
16959                     GOTO 130
16960                   ENDIF
16961  135            CONTINUE
16962  130          CONTINUE
16963             ENDIF
16964           ENDIF
16965
16966 C  fragment parton / hadron configuration (hadronization & decay)
16967
16968           IF(ISWMDL(6).NE.0) THEN
16969             II = MSTU(21)
16970             MSTU(21) = 1
16971             CALL PYEXEC
16972             MSTU(21) = II
16973 C  Lund warning?
16974             if(MSTU(28).ne.0) then
16975               IF(IDEB(22).GE.10) THEN
16976                 WRITE(LO,'(1X,A,I12,I3)')
16977      &            'PHO_STRFRA:(1) Lund code warning (EV/code)',
16978      &            KEVENT,MSTU(28)
16979                 CALL PHO_PREVNT(2)
16980               ENDIF
16981             endif
16982 C  event accepted?
16983             IF(MSTU(24).NE.0) THEN
16984               IF(IDEB(22).GE.2) THEN
16985                 WRITE(LO,'(1X,A,I12,I3)')
16986      &            'PHO_STRFRA:(1) rejection by Lund code (EV/code)',
16987      &            KEVENT,MSTU(24)
16988                 CALL PHO_PREVNT(2)
16989               ENDIF
16990               IREJ = 1
16991               RETURN
16992             ENDIF
16993           ENDIF
16994
16995           IP = N
16996 C  change particle status in JETSET to avoid internal adjustments
16997           do k1=IP_old,IP
16998             K(k1,1) = K(k1,1)+1000
16999           enddo
17000           IP_old = IP+1
17001
17002  299      continue
17003  300    CONTINUE
17004
17005 C  restore original JETSET particle status codes
17006         do i=1,N
17007           K(i,1) = K(i,1)-1000
17008         enddo
17009
17010 *       IF(IDEB(22).GE.25) THEN
17011 *         WRITE(LO,'(//1X,2A)') 'PHO_STRFRA: ',
17012 *    &      'particle/string system before fragmentation'
17013 *         CALL PHO_PREVNT(2)
17014 *       ENDIF
17015
17016 C  copy hadrons back to POEVT1 / POEVT2
17017
17018         IF(IP.GT.0) THEN
17019           NHEP1 = NHEP+1
17020           NLINES = PYK(0,1)
17021 C  copy hadrons back with full history information
17022           IF(IPAMDL(178).EQ.1) THEN
17023             DO 155 II=1,ISTR
17024               IF(NCODE(II).GE.0) THEN
17025                 K1 = IPHIST(2,NPOS(2,II))
17026                 K2 = IPHIST(2,-NPOS(3,II))
17027               ELSE IF(NCODE(II).EQ.-99) THEN
17028                 K1 = IPHIST(2,NPOS(1,II))
17029                 K2 = K1
17030               ELSE
17031                 GOTO 149
17032               ENDIF
17033               IFOUND = 0
17034               DO 160 J=1,NLINES
17035                 IF(PYK(J,7).EQ.1) THEN
17036                   IPMOTH = PYK(J,15)
17037                   IF((IPMOTH.GE.K1).AND.(IPMOTH.LE.K2)) THEN
17038                     IBAM = ipho_pdg2id(PYK(J,8))
17039                     IF((IBAM.EQ.0).AND.(ISWMDL(6).NE.0)) THEN
17040                       IF(IDEB(22).GE.2) THEN
17041                         WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
17042      &                    'LUND interface (1) rejection'
17043                         CALL PHO_PREVNT(2)
17044                       ENDIF
17045                       IREJ = 1
17046                       RETURN
17047                     ENDIF
17048                     IFOUND = IFOUND+1
17049                     PX = PYP(J,1)
17050                     PY = PYP(J,2)
17051                     PZ = PYP(J,3)
17052                     HE = PYP(J,4)
17053                     XMB = PYP(J,5)**2
17054 C  register parton/hadron
17055                     IS = 1
17056                     IF(IBAM.EQ.0) THEN
17057                       IF(ISWMDL(6).EQ.0) THEN
17058                         IS = -1
17059                       ELSE
17060                         IF(IDEB(22).GE.2) THEN
17061                           WRITE(LO,'(/1X,2A)') 'PHO_STRFRA: ',
17062      &                      'LUND interface (2) rejection'
17063                           CALL PHO_PREVNT(2)
17064                         ENDIF
17065                         IREJ = 1
17066                         RETURN
17067                       ENDIF
17068                     ENDIF
17069                     CALL PHO_REGPAR(IS,PYK(J,8),IBAM,NPOS(1,II),0,
17070      &                PX,PY,PZ,HE,J,0,0,0,IPOS,1)
17071                     ISTHEP(IPOS) = 1
17072                   ENDIF
17073                 ENDIF
17074  160          CONTINUE
17075               IF(IFOUND.EQ.0) THEN
17076                 IF(IDEB(2).GE.2) THEN
17077                   WRITE(LO,'(2A,I12,I3)') 'PHO_STRFRA: ',
17078      &            'no particles found for string (EVE,ISTR):',KEVENT,II
17079                 ENDIF
17080                 ISTHEP(NPOS(1,II)) = 2
17081               ENDIF
17082  149          CONTINUE
17083  155        CONTINUE
17084           ELSE
17085 C  copy hadrons back without history information
17086             JDAHEP(1,1) = NHEP1
17087             JDAHEP(1,2) = NHEP1
17088             DO 170 J=1,NLINES
17089               IF(PYK(J,7).EQ.1) THEN
17090                 IBAM = ipho_pdg2id(PYK(J,8))
17091                 IF((IBAM.EQ.99999).AND.(ISWMDL(6).NE.0)) THEN
17092                   IF(IDEB(22).GE.2) THEN
17093                     WRITE(LO,'(/1X,A)')
17094      &                'PHO_STRFRA: LUND interface (3) rejection'
17095                     CALL PHO_PREVNT(2)
17096                   ENDIF
17097                   IREJ = 1
17098                   RETURN
17099                 ENDIF
17100                 PX = PYP(J,1)
17101                 PY = PYP(J,2)
17102                 PZ = PYP(J,3)
17103                 HE = PYP(J,4)
17104                 XMB = PYP(J,5)**2
17105 C  register parton/hadron
17106                 IS = 1
17107                 IF(IBAM.EQ.0) THEN
17108                   IF(ISWMDL(6).EQ.0) THEN
17109                     IS = -1
17110                   ELSE
17111                     IF(IDEB(22).GE.2) THEN
17112                       WRITE(LO,'(/1X,A)')
17113      &                  'PHO_STRFRA: LUND interface (4) rejection'
17114                       CALL PHO_PREVNT(2)
17115                     ENDIF
17116                     IREJ = 1
17117                     RETURN
17118                   ENDIF
17119                 ENDIF
17120                 CALL PHO_REGPAR(IS,PYK(J,8),IBAM,1,2,PX,PY,PZ,
17121      &            HE,J,0,0,0,IPOS,1)
17122                 ISTHEP(IPOS) = 1
17123               ENDIF
17124  170        CONTINUE
17125             DO 180 II=1,ISTR
17126               IF((NCODE(II).GE.0).OR.(NCODE(II).EQ.-99))
17127      &          ISTHEP(NPOS(1,II)) = 2
17128  180        CONTINUE
17129           ENDIF
17130         ENDIF
17131
17132 C  debug event status
17133       IF(IDEB(22).GE.15) THEN
17134         WRITE(LO,'(//1X,A)')
17135      &    'PHO_STRFRA: particle system after fragmentation'
17136         CALL PHO_PREVNT(2)
17137       ENDIF
17138
17139       END
17140
17141 *$ CREATE PHO_EVEINI.FOR
17142 *COPY PHO_EVEINI
17143 CDECK  ID>, PHO_EVEINI
17144       SUBROUTINE PHO_EVEINI(IMODE,P1,P2,IP1,IP2)
17145 C********************************************************************
17146 C
17147 C     prepare /POEVT1/ for new event
17148 C
17149 C     first subroutine called for each event
17150 C
17151 C     input:   P1(4)  particle 1
17152 C              P2(4)  particle 2
17153 C              IMODE  0    general initialization
17154 C                     1    initialization of particles and kinematics
17155 C                     2    initialization after internal rejection
17156 C
17157 C     output:  IP1,IP2  index of interacting particles
17158 C
17159 C********************************************************************
17160       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17161       SAVE
17162
17163       DIMENSION P1(4),P2(4)
17164
17165       PARAMETER ( EPS    =  1.D-5,
17166      &            DEPS   =  1.D-15 )
17167
17168 C  input/output channels
17169       INTEGER LI,LO
17170       COMMON /POINOU/ LI,LO
17171 C  event debugging information
17172       INTEGER NMAXD
17173       PARAMETER (NMAXD=100)
17174       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17175      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17176       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17177      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17178 C  model switches and parameters
17179       CHARACTER*8 MDLNA
17180       INTEGER ISWMDL,IPAMDL
17181       DOUBLE PRECISION PARMDL
17182       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17183 C  general process information
17184       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
17185       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
17186 C  gamma-lepton or gamma-hadron vertex information
17187       INTEGER IGHEL,IDPSRC,IDBSRC
17188       DOUBLE PRECISION PINI,PFIN,PGAM,GYY,GQ2,GGECM,GAIMP,PFTHE,PFPHI,
17189      &                 RADSRC,AMSRC,GAMSRC
17190       COMMON /POFSRC/ PINI(5,2),PFIN(5,2),PGAM(5,2),IGHEL(2),
17191      &                GYY(2),GQ2(2),GGECM,GAIMP(2),PFTHE(2),PFPHI(2),
17192      &                IDPSRC(2),IDBSRC(2),RADSRC(2),AMSRC(2),GAMSRC(2)
17193 C  global event kinematics and particle IDs
17194       INTEGER IFPAP,IFPAB
17195       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
17196       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
17197 C  energy-interpolation table
17198       INTEGER IEETA2
17199       PARAMETER ( IEETA2 = 20 )
17200       INTEGER ISIMAX
17201       DOUBLE PRECISION SIGTAB,SIGECM
17202       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
17203 C  cross sections
17204       INTEGER IPFIL,IFAFIL,IFBFIL
17205       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
17206      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
17207      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
17208      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
17209      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
17210       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
17211      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
17212      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
17213      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
17214      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
17215      &                IPFIL,IFAFIL,IFBFIL
17216 C  color string configurations including collapsed strings and hadrons
17217       INTEGER MSTR
17218       PARAMETER (MSTR=500)
17219       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
17220       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
17221      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
17222      &                NNCH(MSTR),IBHAD(MSTR),ISTR
17223 C  standard particle data interface
17224       INTEGER NMXHEP
17225       PARAMETER (NMXHEP=4000)
17226       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
17227       DOUBLE PRECISION PHEP,VHEP
17228       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
17229      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
17230      &                VHEP(4,NMXHEP)
17231 C  extension to standard particle data interface (PHOJET specific)
17232       INTEGER IMPART,IPHIST,ICOLOR
17233       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
17234 C  table of particle indices for recursive PHOJET calls
17235       INTEGER MAXIPX
17236       PARAMETER ( MAXIPX = 100 )
17237       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
17238       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
17239      &                IPOIX1,IPOIX2,IPOIX3
17240 C  event weights and generated cross section
17241       INTEGER IPOWGC,ISWCUT,IVWGHT
17242       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
17243       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
17244      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
17245
17246       DIMENSION IM(2)
17247
17248 C  reset debug variables
17249       KSPOM  = 0
17250       KHPOM  = 0
17251       KSREG  = 0
17252       KHDIR  = 0
17253       KSTRG  = 0
17254       KHTRG  = 0
17255       KSLOO  = 0
17256       KHLOO  = 0
17257       KSDPO  = 0
17258       KSOFT  = 0
17259       KHARD  = 0
17260 C
17261       IDNODF = 0
17262       IDIFR1 = 0
17263       IDIFR2 = 0
17264       IDDPOM = 0
17265       ISTR   = 0
17266       IPOIX1 = 0
17267       IF(ISWMDL(14).GT.0) IPOIX1 = 1
17268       IPOIX2 = 0
17269       IPOIX3 = 0
17270 C  reset /POEVT1/ and /POEVT2/
17271       CALL PHO_REGPAR(0,0,0,0,0,0.D0,0.D0,0.D0,0.D0,
17272      &            0,0,0,0,IPOS,0)
17273       CALL PHO_SELCOL(0,0,0,0,0,0,0)
17274       DO 15 I=0,10
17275         IPOWGC(I) = 0
17276  15   CONTINUE
17277
17278 C  initialization of particle kinematics
17279
17280 C  lepton-photon/hadron-photon vertex and initial particles
17281         IM(1) = 0
17282         IM(2) = 0
17283         IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
17284           CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),0,0,PINI(1,1),PINI(2,1),
17285      &      PINI(3,1),PINI(4,1),0,0,0,0,IM(1),1)
17286         ELSE
17287           CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
17288      &      P1(4),0,0,0,0,IP1,1)
17289         ENDIF
17290         IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
17291           CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),0,0,PINI(1,2),PINI(2,2),
17292      &      PINI(3,2),PINI(4,2),0,0,0,0,IM(2),1)
17293         ELSE
17294           CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
17295      &      P2(4),0,0,0,0,IP2,1)
17296         ENDIF
17297         IF((IPAMDL(11).GT.0).AND.(IDPSRC(1).NE.0)) THEN
17298           CALL PHO_REGPAR(1,IDPSRC(1),IDBSRC(1),IM(1),0,PFIN(1,1),
17299      &      PFIN(2,1),PFIN(3,1),PFIN(4,1),0,10,0,0,IPOS,1)
17300           CALL PHO_REGPAR(1,IFPAP(1),IFPAB(1),IM(1),0,P1(1),P1(2),P1(3),
17301      &      P1(4),0,0,0,0,IP1,1)
17302         ENDIF
17303         IF((IPAMDL(12).GT.0).AND.(IDPSRC(2).NE.0)) THEN
17304           CALL PHO_REGPAR(1,IDPSRC(2),IDBSRC(2),IM(2),0,PFIN(1,2),
17305      &      PFIN(2,2),PFIN(3,2),PFIN(4,2),0,10,0,0,IPOS,1)
17306           CALL PHO_REGPAR(1,IFPAP(2),IFPAB(2),IM(2),0,P2(1),P2(2),P2(3),
17307      &      P2(4),0,0,0,0,IP2,1)
17308         ENDIF
17309         NEVHEP = KACCEP
17310
17311       IF(IMODE.LE.1) THEN
17312 C  CMS energy
17313         ECM = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
17314      &           -(P1(3)+P2(3))**2)
17315 *       CALL PHO_PECMS(1,PMASS(1),PMASS(2),ECM,PCM,EE)
17316         PMASS(1) = PHEP(5,IP1)
17317         PVIRT(1) = 0.D0
17318         IF(IFPAP(1).EQ.22) PVIRT(1) = PMASS(1)**2
17319         PMASS(2) = PHEP(5,IP2)
17320         PVIRT(2) = 0.D0
17321         IF(IFPAP(2).EQ.22) PVIRT(2) = PMASS(2)**2
17322       ENDIF
17323
17324 C  cross section calculations
17325
17326       IF(IMODE.NE.1) THEN
17327         IP = 1
17328         CALL PHO_CSINT(IP,IFPAP(1),IFPAP(2),IGHEL(1),IGHEL(2),
17329      &              ECM,PVIRT(1),PVIRT(2))
17330       ENDIF
17331
17332       IF(IMODE.LE.0) THEN
17333 C  effective cross section
17334         SIGGEN(3) = 0.D0
17335         IF(ISWMDL(2).ge.1) THEN
17336           IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGTOT-SIGELA-SIGVM(0,0)
17337      &      -SIGCDF(0)-SIGLSD(1)-SIGHSD(1)-SIGLSD(2)-SIGHSD(2)-SIGLDD
17338      &      -SIGHDD-SIGDIR
17339           IF(IPRON(2,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGELA
17340           IF(IPRON(3,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGVM(0,0)
17341           IF(IPRON(4,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGCDF(0)
17342           IF(IPRON(5,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(1)+SIGHSD(1)
17343           IF(IPRON(6,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLSD(2)+SIGHSD(2)
17344           IF(IPRON(7,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGLDD+SIGHDD
17345           IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
17346 C  simulate only hard scatterings
17347         ELSE
17348           IF(IPRON(1,1).EQ.1) SIGGEN(3) = SIGHAR
17349           IF(IPRON(8,1).EQ.1) SIGGEN(3) = SIGGEN(3)+SIGDIR
17350         ENDIF
17351
17352       ENDIF
17353
17354 C  reset of mother/daughter relations only (IMODE = 2)
17355
17356 C  debug output
17357       IF(IDEB(63).GE.15) THEN
17358         WRITE(LO,'(/1X,2A,I12,I3)') 'PHO_EVEINI: ',
17359      &    '/POEVT1/ initialized (event/mode)',KEVENT,IMODE
17360         IF(IMODE.LE.0) THEN
17361           WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)') 'PHO_EVEINI: ',
17362      &      'current suppression factors total-1/2 hard-1/2 diff-1/2:',
17363      &      FSUP,FSUH,FSUD
17364           ONEM = -1.D0
17365           ITMP = IDEB(57)
17366           IDEB(57) = MAX(5,ITMP)
17367           CALL PHO_XSECT(1,0,ONEM)
17368           IDEB(57) = ITMP
17369         ENDIF
17370         CALL PHO_PREVNT(0)
17371       ENDIF
17372
17373       END
17374
17375 *$ CREATE PHO_CSINT.FOR
17376 *COPY PHO_CSINT
17377 CDECK  ID>, PHO_CSINT
17378       SUBROUTINE PHO_CSINT(IP,IFPA,IFPB,IHLA,IHLB,ECM,PVIR2A,PVIR2B)
17379 C********************************************************************
17380 C
17381 C     calculate cross sections by interpolation
17382 C
17383 C     input:   IP          particle combination
17384 C              IFPA/B      particle PDG number
17385 C              IHLA/B      particle helicity (photons only)
17386 C              ECM         c.m. energy (GeV)
17387 C              PVIR2A      virtuality of particle A (GeV**2, positive)
17388 C              PVIR2B      virtuality of particle B (GeV**2, positive)
17389 C
17390 C     output:  cross sections stored in /POCSEC/
17391 C
17392 C********************************************************************
17393       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17394       SAVE
17395
17396       PARAMETER ( EPS    =  1.D-5,
17397      &            DEPS   =  1.D-15 )
17398
17399 C  input/output channels
17400       INTEGER LI,LO
17401       COMMON /POINOU/ LI,LO
17402 C  some constants
17403       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
17404       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
17405      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
17406 C  event debugging information
17407       INTEGER NMAXD
17408       PARAMETER (NMAXD=100)
17409       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17410      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17411       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17412      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17413 C  model switches and parameters
17414       CHARACTER*8 MDLNA
17415       INTEGER ISWMDL,IPAMDL
17416       DOUBLE PRECISION PARMDL
17417       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17418 C  energy-interpolation table
17419       INTEGER IEETA2
17420       PARAMETER ( IEETA2 = 20 )
17421       INTEGER ISIMAX
17422       DOUBLE PRECISION SIGTAB,SIGECM
17423       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
17424 C  cross sections
17425       INTEGER IPFIL,IFAFIL,IFBFIL
17426       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
17427      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
17428      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
17429      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
17430      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
17431       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
17432      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
17433      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
17434      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
17435      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
17436      &                IPFIL,IFAFIL,IFBFIL
17437 C  hard cross sections and MC selection weights
17438       INTEGER Max_pro_2
17439       PARAMETER ( Max_pro_2 = 16 )
17440       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
17441      &  MH_acc_1,MH_acc_2
17442       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
17443       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
17444      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
17445      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
17446      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
17447      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
17448
17449       DIMENSION PVIRT(2),SIGSRH(2),FSUT(2),FSUL(2),IFPAP(2),IHEL(2)
17450
17451       dimension PD(-6:6),FH_T(2),FH_L(2)
17452
17453 C  debug
17454       IF(IDEB(15).GE.10) WRITE(LO,'(1X,A,/10X,I3,2I6,1P3E12.4)')
17455      &  'PHO_CSINT: called with IP, IFP1, IFP2, ECM, PVIR1, PVIR2',
17456      &  IP,IFPA,IFPB,ECM,PVIR2A,PVIR2B
17457
17458 C  check currently stored cross sections
17459       IF((IP.EQ.IPFIL).AND.(ECM.EQ.ECMFIL)
17460      &   .AND.(PVIR2A.EQ.P2AFIL).AND.(PVIR2B.EQ.P2BFIL)
17461      &   .AND.(IFPA.EQ.IFAFIL).AND.(IFPB.EQ.IFBFIL)) THEN
17462 C  nothing to calculate
17463         IF(IDEB(15).GE.20)
17464      &    WRITE(LO,'(1X,A)') 'PHO_CSINT: nothing done'
17465         RETURN
17466       ELSE
17467
17468 C  copy to local fields
17469         IFPAP(1) = IFPA
17470         IFPAP(2) = IFPB
17471         IHEL(1)  = IHLA
17472         IHEL(2)  = IHLB
17473         PVIRT(1) = PVIR2A
17474         PVIRT(2) = PVIR2B
17475
17476 C  load cross sections from interpolation table
17477         IF(ECM.LE.SIGECM(IP,1)) THEN
17478           I1 = 1
17479           I2 = 2
17480         ELSE IF(ECM.LE.SIGECM(IP,ISIMAX)) THEN
17481           DO 50 I=2,ISIMAX
17482             IF(ECM.LE.SIGECM(IP,I)) GOTO 200
17483  50       CONTINUE
17484  200      CONTINUE
17485           I1 = I-1
17486           I2 = I
17487         ELSE
17488           WRITE(LO,'(/1X,A,2E12.3)')
17489      &      'PHO_CSINT: too high energy',ECM,SIGECM(IP,ISIMAX)
17490           CALL PHO_PREVNT(-1)
17491           I1 = ISIMAX-1
17492           I2 = ISIMAX
17493         ENDIF
17494         FAC2=0.D0
17495         IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
17496      &                    /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
17497         FAC1=1.D0-FAC2
17498
17499 C  cross section dependence on photon virtualities
17500         DO 140 K=1,2
17501           FSUP(K) = 1.D0
17502           FSUD(K) = 1.D0
17503           FSUH(K) = 1.D0
17504           IF(IFPAP(K).EQ.22) THEN
17505             IF(ISWMDL(10).GE.1) THEN
17506               FSUP(K) = 0.D0
17507               FSUT(K) = 0.D0
17508               FSUL(K) = 0.D0
17509               FSUH(K) = 0.D0
17510 C  GVDM factors for transverse/longitudinal photons
17511               DO 150 I=1,3
17512                 FSUT(K) = FSUT(K)+PARMDL(26+I)
17513      &                   /(1.D0+PVIRT(K)/PARMDL(30+I))**2
17514                 FSUL(K) = FSUL(K)
17515      &                   +PARMDL(26+I)*PVIRT(K)/(4.D0*PARMDL(30+I))
17516      &                   /(1.D0+PVIRT(K)/PARMDL(30+I))**2
17517  150          CONTINUE
17518               FSUT(K) = FSUT(K)+PARMDL(30)/(1.D0+PVIRT(K)/PARMDL(34))
17519 C  transverse part
17520               IF((ABS(IHEL(K)).EQ.1).OR.(ISWMDL(10).EQ.1)) THEN
17521                 FSUP(K) = FSUT(K)
17522                 FSUH(K) = FSUT(K)/(FSUT(K)+FSUL(K))
17523 C  diffraction of trans. photons corresponds mainly to leading twist
17524                 FSUD(K) = 1.D0
17525               ENDIF
17526 C  longitudinal (scalar) part
17527               IF((IHEL(K).LE.0).OR.(ISWMDL(10).EQ.1)) THEN
17528                 FSUP(K) = FSUP(K)+FSUL(K)
17529                 FSUH(K) = FSUH(K)+FSUL(K)/(FSUT(K)+FSUL(K))
17530 C  diffraction of long. photons corresponds mainly to higher twist
17531                 FSUD(K) = 0.5D0*LOG(((ECM*PARMDL(45))**2+PVIRT(K))
17532      &                   /((0.765D0+PARMDL(46))**2+PVIRT(K)))
17533      &                   /LOG(ECM*PARMDL(45)/(0.765D0+PARMDL(46)))
17534               ENDIF
17535 C  debug output
17536               if(ideb(15).ge.10) then
17537                 WRITE(LO,'(1x,2a,2i3,/,5x,1p5e12.4)') 'PHO_CSINT: ',
17538      &            'side,helicity,F_tran,F_long,F_eff,F_hard,F_diff',
17539      &            K,IHEL(K),FSUT(K),FSUL(K),FSUP(K),FSUH(K),FSUD(K)
17540               endif
17541             ENDIF
17542           ENDIF
17543  140    CONTINUE
17544
17545         FACP = FSUP(1)*FSUP(2)
17546         FACH = FSUH(1)*FSUH(2)
17547         FACD = FSUD(1)*FSUD(2)
17548
17549 C  matching of model cross section to F2(x,Q2,P2) in limit of Q2 >> P2
17550
17551         if((IFPAP(1).eq.22).and.(IFPAP(2).eq.22)
17552      &     .and.(IPAMDL(117).gt.0)) then
17553 C  check kinematic limit
17554           Q2_max = max(PVIRT(1),PVIRT(2))
17555           Q2_min = min(PVIRT(1),PVIRT(2))
17556           if((Q2_max.gt.1.D0).and.(Q2_min.lt.1.D0)) then
17557
17558 C  calculate F2 from current parton density
17559             if(PVIRT(1).gt.PVIRT(2)) then
17560               K = 2
17561             else
17562               K = 1
17563             endif
17564             Q2 = Q2_max
17565             P2 = Q2_min
17566             X = Q2/(ECM**2+Q2+P2)
17567             call pho_actpdf(IFPAP(K),K)
17568             call pho_pdf(K,X,Q2,P2,PD)
17569 C  light quark contribution
17570             F2_light = 0.D0
17571             do j=1,3
17572               F2_light = F2_light+Q_ch2(j)*(PD(j)+PD(-j))
17573             enddo
17574 C  heavy quark contribution
17575             call pho_qpmpdf(4,X,Q2,0.D0,P2,xpdf_c)
17576             F2_c = 2.D0*4.D0/9.D0*xpdf_c
17577             F2 = (F2_light+F2_c)
17578
17579 C  calculate model prediction
17580             SIGTOT = FAC2*SIGTAB(IP,1,I2)+FAC1*SIGTAB(IP,1,I1)
17581             SIGINE = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
17582             CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17583
17584             if(ISWMDL(10).ge.2) then
17585
17586 C  calculate all helicity combinations
17587               if(IPAMDL(115).eq.0) then
17588                 SIGDIH    = HSig(14)
17589                 SIGSRH(1) = HSig(10)+HSig(11)
17590                 SIGSRH(2) = HSig(12)+HSig(13)
17591                 SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
17592 C  photon helicity factors
17593                 FH_T(1) = FSUT(1)/(FSUT(1)+FSUL(1))
17594                 FH_L(1) = 1.D0-FH_T(1)
17595                 FH_T(2) = FSUT(2)/(FSUT(2)+FSUL(2))
17596                 FH_L(2) = 1.D0-FH_T(2)
17597                 SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
17598      &                  + SIGDIH*FH_T(1)*FH_T(2)
17599      &                  + SIGSRH(1)*FH_T(1)*FSUT(2)
17600      &                  + SIGSRH(2)*FSUT(1)*FH_T(2)
17601                 SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
17602      &                  + SIGDIH*FH_T(1)*FH_L(2)
17603      &                  + SIGSRH(1)*FH_T(1)*FSUL(2)
17604      &                  + SIGSRH(2)*FSUT(1)*FH_L(2)
17605                 SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
17606      &                  + SIGDIH*FH_L(1)*FH_T(2)
17607      &                  + SIGSRH(1)*FH_L(1)*FSUT(2)
17608      &                  + SIGSRH(2)*FSUL(1)*FH_T(2)
17609                 SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
17610      &                  + SIGDIH*FH_L(1)*FH_L(2)
17611      &                  + SIGSRH(1)*FH_L(1)*FSUL(2)
17612      &                  + SIGSRH(2)*FSUL(1)*FH_L(2)
17613               else
17614 C  use explicit PDF virtuality dependence (pre-tabulated)
17615                 SIGDIH    = HSig(14)
17616                 SIGSRH(1) = HSig(10)+HSig(11)
17617                 SIGSRH(2) = HSig(12)+HSig(13)
17618                 SIGtmp = SIGTOT-SIGDIH-SIGSRH(1)-SIGSRH(2)
17619                 WRITE(LO,*) ' PHO_CSINT: invalid option for F2 matching'
17620                 stop
17621 *               CALL PHO_HARINT(IP,ECM,PVIRT(1),PVIRT(2),0,
17622 *    &                          Max_pro_2,3,4,1)
17623 *               SIG_TT = SIGtmp*FSUT(1)*FSUT(2)
17624 *    &                  + HSig(10)+HSig(12)+HSig(14)+HSig(16)+HSig(18)
17625 *               SIG_TL = SIGtmp*FSUT(1)*FSUL(2)
17626 *    &                  + HSig(10)+HSig(12)+HSig(14)+HSig(16)+HSig(19)
17627 *               SIG_LT = SIGtmp*FSUL(1)*FSUT(2)
17628 *    &                  + HSig(11)+HSig(13)+HSig(15)+HSig(17)+HSig(20)
17629 *               SIG_LL = SIGtmp*FSUL(1)*FSUL(2)
17630 *    &                  + HSig(11)+HSig(13)+HSig(15)+HSig(17)+HSig(21)
17631               endif
17632               Xnu = Ecm*Ecm+Q2+P2
17633               F2_fac = Q2*Xnu/sqrt(Xnu*Xnu-Q2*P2)/(4.D0*Pi*Pi)
17634      &             *137.D0/GeV2mb
17635               if(K.eq.2) then
17636                 F2m = F2_fac*(SIG_TT+SIG_LT-0.5D0*SIG_TL-0.5D0*SIG_LL)
17637                 F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUL(1)*FSUT(2)
17638      &               -0.5D0*FSUT(1)*FSUL(2)-0.5D0*FSUL(1)*FSUL(2))
17639               else
17640                 F2m = F2_fac*(SIG_TT+SIG_TL-0.5D0*SIG_LT-0.5D0*SIG_LL)
17641                 F2s = F2_fac*SIGtmp*(FSUT(1)*FSUT(2)+FSUT(1)*FSUL(2)
17642      &               -0.5D0*FSUL(1)*FSUT(2)-0.5D0*FSUL(1)*FSUL(2))
17643               endif
17644
17645             else
17646
17647 C  assume sig_eff = sigtot
17648               SIGDIH    = HSig(14)
17649               SIGSRH(1) = HSig(10)+HSig(11)
17650               SIGSRH(2) = HSig(12)+HSig(13)
17651               SIGtmp = SIGTOT-SIGSRH(1)-SIGSRH(2)-SIGDIH
17652               SIGeff = SIGtmp*FSUP(1)*FSUP(2)
17653      &                +SIGSRH(1)*FSUP(2)+SIGSRH(2)*FSUP(1)+SIGDIH
17654               Xnu = Ecm*Ecm+Q2+P2
17655               F2_fac = Q2*Xnu/sqrt(Xnu*Xnu-Q2*P2)/(4.D0*Pi*Pi)
17656      &             *137.D0/GeV2mb
17657               F2m = F2_fac*SIGeff
17658               F2s = F2_fac*SIGtmp*FSUP(1)*FSUP(2)
17659             endif
17660 *           WRITE(LO,*) ' PHO_CSINT: Q2_1,Q2_2,W ',PVIRT(1),PVIRT(2),Ecm
17661 *           WRITE(LO,*) ' PHO_CSINT: F2_mod,F2_pdf,mod/pdf ',F2m,F2,F2m/F2
17662
17663 C  global factor to re-scale suppression of soft contributions
17664             Fcorr = (F2-F2m+F2s)/F2s
17665 *           WRITE(LO,*) ' PHO_CSINT: re-scaling factor: ',Fcorr,FACP*Fcorr
17666             FACP = FACP*Fcorr
17667
17668           endif
17669         endif
17670
17671         SIGTOT = (FAC2*SIGTAB(IP,1,I2)+FAC1*SIGTAB(IP,1,I1))*FACP
17672         SIGINE = (FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1))*FACP
17673         SIGELA = (FAC2*SIGTAB(IP,2,I2)+FAC1*SIGTAB(IP,2,I1))*FACP
17674         J = 2
17675         DO 5 I=0,4
17676           DO 6 K=0,4
17677             J = J+1
17678             SIGVM(I,K) = (FAC2*SIGTAB(IP,J,I2)+FAC1*SIGTAB(IP,J,I1))
17679      &                  *FACP**2
17680  6        CONTINUE
17681  5      CONTINUE
17682
17683         SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
17684         SIGHAR = FAC2*SIGTAB(IP,58,I2)+FAC1*SIGTAB(IP,58,I1)
17685 C  suppression of multi-pomeron graphs (diffraction)
17686         SIGLSD(1) = (FAC2*SIGTAB(IP,30,I2)+FAC1*SIGTAB(IP,30,I1))
17687      &             *FACP*FSUP(2)*FSUD(1)
17688         SIGLSD(2) = (FAC2*SIGTAB(IP,31,I2)+FAC1*SIGTAB(IP,31,I1))
17689      &             *FACP*FSUP(1)*FSUD(2)
17690         SIGHSD(1) = (FAC2*SIGTAB(IP,32,I2)+FAC1*SIGTAB(IP,32,I1))
17691      &             *FACP*FSUP(2)*FSUD(1)
17692         SIGHSD(2) = (FAC2*SIGTAB(IP,33,I2)+FAC1*SIGTAB(IP,33,I1))
17693      &             *FACP*FSUP(1)*FSUD(2)
17694         SIGLDD    = (FAC2*SIGTAB(IP,34,I2)+FAC1*SIGTAB(IP,34,I1))
17695      &             *FACP**2*FACD
17696         SIGHDD    = (FAC2*SIGTAB(IP,35,I2)+FAC1*SIGTAB(IP,35,I1))*FACP
17697         SIGCDF(0) = (FAC2*SIGTAB(IP,36,I2)+FAC1*SIGTAB(IP,36,I1))
17698      &             *FACP**2
17699         SIGTR1(1) = (FAC2*SIGTAB(IP,60,I2)+FAC1*SIGTAB(IP,60,I1))
17700      &             *FACP*FSUP(2)*FSUD(1)
17701         SIGTR1(2) = (FAC2*SIGTAB(IP,61,I2)+FAC1*SIGTAB(IP,61,I1))
17702      &             *FACP*FSUP(2)*FSUD(1)
17703         SIGTR2(1) = (FAC2*SIGTAB(IP,62,I2)+FAC1*SIGTAB(IP,62,I1))
17704      &             *FACP*FSUP(1)*FSUD(2)
17705         SIGTR2(2) = (FAC2*SIGTAB(IP,63,I2)+FAC1*SIGTAB(IP,63,I1))
17706      &             *FACP*FSUP(1)*FSUD(2)
17707         SIGLOO    = (FAC2*SIGTAB(IP,64,I2)+FAC1*SIGTAB(IP,64,I1))*FACP
17708         SIGDPO(1) = (FAC2*SIGTAB(IP,65,I2)+FAC1*SIGTAB(IP,65,I1))
17709      &             *FACP**2
17710         SIGDPO(2) = (FAC2*SIGTAB(IP,66,I2)+FAC1*SIGTAB(IP,66,I1))
17711      &             *FACP**2
17712         SIGDPO(3) = (FAC2*SIGTAB(IP,67,I2)+FAC1*SIGTAB(IP,67,I1))
17713      &             *FACP**2
17714         SIGDPO(4) = (FAC2*SIGTAB(IP,68,I2)+FAC1*SIGTAB(IP,68,I1))
17715      &             *FACP**2
17716
17717 C  corrections due to photon virtuality dependence of PDFs
17718         if(iswmdl(2).eq.1) then
17719           CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17720 C  minimum bias event generation
17721           IF(IPAMDL(115).GE.1) THEN
17722 C  all the virtuality dependence is given by PDF parametrization
17723             SIGHIN = FAC2*SIGTAB(IP,80,I2)+FAC1*SIGTAB(IP,80,I1)
17724             IF(IPAMDL(116).GE.2) THEN
17725 C  direct interaction according to full QPM calculation
17726               SIGDIH = HSig(14)
17727               SIGSRH(1) = HSig(10)+HSig(11)
17728               SIGSRH(2) = HSig(12)+HSig(13)
17729             ELSE
17730 C  direct interaction suppressed according to helicity factor
17731               SIGDIH = HSig(14)*FACH
17732               SIGSRH(1) = (HSig(10)+HSig(11))*FSUH(1)
17733               SIGSRH(2) = (HSig(12)+HSig(13))*FSUH(2)
17734             ENDIF
17735             WRITE(LO,*) ' PHO_CSINT: option not supported yet'
17736             stop
17737           ELSE
17738 C  rescale relevant hard processes
17739             SIGDIH    = HSig(14)
17740             SIGSRH(1) = HSig(10)+HSig(11)
17741             SIGSRH(2) = HSig(12)+HSig(13)
17742             SIGtmp = SIGINE-(SIGDIH+SIGSRH(1)+SIGSRH(2))*FACP
17743             SIGDIR = HSig(14)*FACH+SIGSRH(1)*FSUH(1)*FSUP(2)
17744      &              +SIGSRH(2)*FSUP(1)*FSUH(2)
17745             SIGINE = SIGtmp+SIGDIR
17746             SIGTOT = SIGINE+SIGELA
17747           ENDIF
17748         else
17749 C  only hard interactions
17750           CALL PHO_HARINT(IP,ECM,0.D0,0.D0,0,Max_pro_2,3,4,1)
17751           SIGSRH(1) = (HSig(10)+HSig(11))*FSUH(1)
17752           SIGSRH(2) = (HSig(12)+HSig(13))*FSUH(2)
17753           SIGDIR = HSig(14)+SIGSRH(1)+SIGSRH(2)
17754           SIGHAR = HSig(9)*FACH
17755         endif
17756
17757         SIG1SO = (FAC2*SIGTAB(IP,37,I2)+FAC1*SIGTAB(IP,37,I1))*FACP
17758         SIG1HA = (FAC2*SIGTAB(IP,38,I2)+FAC1*SIGTAB(IP,38,I1))*FACH
17759         SLOEL = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
17760         J = 39
17761         DO 9 I=1,4
17762           DO 10 K=1,4
17763             J = J+1
17764             SLOVM(I,K) = FAC2*SIGTAB(IP,J,I2)+FAC1*SIGTAB(IP,J,I1)
17765  10       CONTINUE
17766  9      CONTINUE
17767         SIGPOM = (FAC2*SIGTAB(IP,56,I2)+FAC1*SIGTAB(IP,56,I1))*FACP
17768         SIGREG = (FAC2*SIGTAB(IP,57,I2)+FAC1*SIGTAB(IP,57,I1))*FACP
17769
17770         IPFIL  = IP
17771         IFAFIL = IFPA
17772         IFBFIL = IFPB
17773         ECMFIL = ECM
17774         P2AFIL = PVIR2A
17775         P2BFIL = PVIR2B
17776
17777         IF(IDEB(15).GE.20)
17778      &    WRITE(LO,'(1X,A)') 'PHO_CSINT: cross sections calculated'
17779
17780       ENDIF
17781
17782       END
17783
17784 *$ CREATE PHO_PRIMKT.FOR
17785 *COPY PHO_PRIMKT
17786 CDECK  ID>, PHO_PRIMKT
17787       SUBROUTINE PHO_PRIMKT(IMODE,IF,IL,PTCUT,IREJ)
17788 C***********************************************************************
17789 C
17790 C    give primordial kt to partons entering hard scatterings and
17791 C    remants connected to hard parton-parton interactions by color flow
17792 C
17793 C    input:  IMODE   -2   output of statistics
17794 C                    -1   initialization
17795 C                     1   sampling of primordial kt
17796 C            IF           first entry in /POEVT1/ to check
17797 C            IL           last entry in /POEVT1/ to check
17798 C            PTCUT        current value of PTCUT to distinguish
17799 C                         between soft and hard
17800 C
17801 C    output: IREJ     0   success
17802 C                     1   failure
17803 C
17804 C***********************************************************************
17805       IMPLICIT NONE
17806       SAVE
17807
17808       DOUBLE PRECISION DEPS
17809       PARAMETER ( DEPS = 1.D-15 )
17810
17811       INTEGER IMODE,IF,IL,IREJ
17812       DOUBLE PRECISION PTCUT
17813
17814 C  input/output channels
17815       INTEGER LI,LO
17816       COMMON /POINOU/ LI,LO
17817 C  event debugging information
17818       INTEGER NMAXD
17819       PARAMETER (NMAXD=100)
17820       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
17821      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17822       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
17823      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
17824 C  model switches and parameters
17825       CHARACTER*8 MDLNA
17826       INTEGER ISWMDL,IPAMDL
17827       DOUBLE PRECISION PARMDL
17828       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
17829 C  some constants
17830       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
17831       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
17832      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
17833 C  data of c.m. system of Pomeron / Reggeon exchange
17834       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
17835       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
17836      &                 SIDP,CODP,SIFP,COFP
17837       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
17838      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
17839      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
17840 C  hard scattering data
17841       INTEGER MSCAHD
17842       PARAMETER ( MSCAHD = 50 )
17843       INTEGER LSCAHD,LSC1HD,LSIDX,
17844      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
17845       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
17846       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
17847      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
17848      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
17849      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
17850      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
17851      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
17852      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
17853 C  standard particle data interface
17854       INTEGER NMXHEP
17855       PARAMETER (NMXHEP=4000)
17856       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
17857       DOUBLE PRECISION PHEP,VHEP
17858       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
17859      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
17860      &                VHEP(4,NMXHEP)
17861 C  extension to standard particle data interface (PHOJET specific)
17862       INTEGER IMPART,IPHIST,ICOLOR
17863       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
17864
17865       DOUBLE PRECISION PTS,XP,XP2,POLD,PNEW,GA,PP
17866       DIMENSION PTS(0:2,5),XP(5),
17867      &  XP2(5,2),POLD(2,2),PNEW(4,2),GA(4),PP(4)
17868
17869       INTEGER IROTT,IBALT,IBAL,IV,IV2,IRMAX
17870
17871       PARAMETER (IRMAX=200)
17872       DIMENSION IROTT(IRMAX),IBALT(5,2),IBAL(2),IV(5),IV2(5,2)
17873
17874       DOUBLE PRECISION SI,EI,SF,EF,PTOT,EE,XX,YY,ZZ,ANORF,FAC,DEL,PT2,
17875      &                 DEL2,GAE,GAZ,SID,COD,SIF,COF,ESUM
17876       INTEGER IROT,I,J,K,NHD,ISTART,INEXT,ICOM
17877
17878 C  debug output
17879       IF(IDEB(10).GE.10) WRITE(LO,'(1X,A,3I4,1P,E11.3)')
17880      &  'PHO_PRIMKT: called with IMODE,IF,IL,PTCUT',
17881      &  IMODE,IF,IL,PTCUT
17882
17883 C  give primordial kt to partons engaged in a hard scattering
17884
17885       IF(IMODE.EQ.1) THEN
17886
17887         ISTART = IF
17888
17889  100    CONTINUE
17890
17891         NHD = 0
17892         IBAL(1) = 0
17893         IBAL(2) = 0
17894         IROT = 0
17895         ICOM = 0
17896         DO 110 I=ISTART,IL
17897           IF(ISTHEP(I).EQ.25) THEN
17898 C  hard scattering number
17899             NHD = IPHIST(1,I+1)
17900             ICOM = I
17901             K = LSIDX(NHD/100)
17902 C  calculate momenta of incoming partons
17903             POLD(1,1) = XHD(K,1)*ECMP/2.D0
17904             POLD(2,1) = POLD(1,1)
17905             POLD(1,2) = -XHD(K,2)*ECMP/2.D0
17906             POLD(2,2) = -POLD(1,2)
17907             ISTART = I+3
17908             GOTO 150
17909           ENDIF
17910  110    CONTINUE
17911         RETURN
17912
17913  150    CONTINUE
17914
17915 C  search for partons involved in hard interaction
17916         INEXT = 0
17917         IROT = 0
17918         DO 500 I=ISTART,IL
17919           IF(ABS(ISTHEP(I)).EQ.1) THEN
17920 C  hard scatterd partons (including ISR)
17921             IF((IPHIST(1,I).EQ.-NHD)
17922      &         .OR.(IPHIST(1,I).EQ.NHD+1)
17923      &         .OR.(IPHIST(1,I).EQ.NHD+2)) THEN
17924               IROT = IROT+1
17925               IF(IROT.GT.IRMAX) THEN
17926                 WRITE(LO,'(1X,/,2A,2I5)') 'PHO_PRIMKT: ',
17927      &            'no memory left in IROTT, event rejected (max/IROT)',
17928      &            IRMAX,IROT
17929                 CALL PHO_PREVNT(0)
17930                 IREJ = 1
17931                 RETURN
17932               ENDIF
17933               IROTT(IROT) = I
17934 C  hard remnant
17935             ELSE IF(IPHIST(1,I).EQ.NHD) THEN
17936               IF(PHEP(3,I).GT.0.D0) THEN
17937                 J = 1
17938               ELSE
17939                 J = 2
17940               ENDIF
17941               IBAL(J) = IBAL(J)+1
17942               IBALT(IBAL(J),J) = I
17943               XP2(IBAL(J),J) = PHEP(3,I)/ECMP
17944               IF(ISWMDL(24).EQ.0) THEN
17945                 IV2(IBAL(J),J) = 0
17946                 IF(IDHEP(I).NE.21) IV2(IBAL(J),J) = ICOLOR(2,I)
17947               ELSE IF(ISWMDL(24).EQ.1) THEN
17948                 IV2(IBAL(J),J) = -1
17949               ELSE
17950                 IV2(IBAL(J),J) = 1
17951               ENDIF
17952             ENDIF
17953 C  possibly further hard scattering
17954           ELSE IF(ISTHEP(I).EQ.25) THEN
17955             INEXT = 1
17956             ISTART = I
17957             GOTO 550
17958           ENDIF
17959  500    CONTINUE
17960  550    CONTINUE
17961
17962 C debug output
17963         if(IDEB(10).ge.15) then
17964           WRITE(LO,'(1X,2A,I4)') 'PHO_PRIMKT: ',
17965      &      'hard scattering number: ',NHD/100
17966           WRITE(LO,'(1X,2A,I5)') 'PHO_PRIMKT: ',
17967      &      'number of entries to rotate: ',IROT
17968           DO I=1,IROT
17969             WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
17970      &        'entries to rotate: ',I,IROTT(I)
17971           ENDDO
17972           WRITE(LO,'(1X,2A,2I5)') 'PHO_PRIMKT: ',
17973      &      'number of entries to balance: ',IBAL
17974           DO J=1,2
17975             DO I=1,IBAL(J)
17976               WRITE(LO,'(1X,2A,I2,2I5)')
17977      &          'PHO_PRIMKT: entries to balance (side,no,line)',
17978      &          J,I,IBALT(I,J)
17979             ENDDO
17980           ENDDO
17981         endif
17982
17983 C  incoming partons (comment lines), skip direct interacting particles
17984         DO 120 K=1,2
17985           IF((IDHEP(ICOM+K).NE.22).AND.(IDHEP(ICOM+K).NE.990)) THEN
17986             IF(PHEP(3,ICOM+K).GT.0.D0) THEN
17987               J = 1
17988             ELSE
17989               J = 2
17990             ENDIF
17991             IBAL(J) = IBAL(J)+1
17992             IBALT(IBAL(J),J) = -ICOM-K
17993             XP2(IBAL(J),J) = POLD(1,J)/ECMP
17994             IV2(IBAL(J),J) = -1
17995           ENDIF
17996  120    CONTINUE
17997
17998 C  check consistency
17999         IF((IBAL(1).GT.4).OR.(IBAL(2).GT.4)) THEN
18000           WRITE(LO,'(1X,2A,I10)') 'PHO_PRIMKT: ',
18001      &      'inconsistent hard scattering remnant for event: ',KEVENT
18002           WRITE(LO,'(1X,A,3I4,1P,E11.3)')
18003      &      'PHO_PRIMKT called with IMODE,IF,IL,PTCUT',
18004      &      IMODE,IF,IL,PTCUT
18005           WRITE(LO,'(1X,A,I4)') 'hard scattering number: ',NHD/100
18006           DO 390 I=1,IROT
18007             WRITE(LO,'(1X,A,2I5)') 'entries to rotate',I,IROTT(I)
18008  390      CONTINUE
18009           DO 392 J=1,2
18010             DO 395 I=1,IBAL(J)
18011               WRITE(LO,'(1X,A,I2,2I5)')
18012      &          'entries to balance (side,no,line)',J,I,IBALT(I,J)
18013  395        CONTINUE
18014  392      CONTINUE
18015           IF(IBAL(1)+IBAL(2).GT.0) CALL PHO_PREVNT(0)
18016         ENDIF
18017
18018 C  calculate primordial kt
18019
18020 C  something to do?
18021         IF((IBAL(1).GT.1).OR.(IBAL(2).GT.1)) THEN
18022
18023 C  add transverse momentum (overwrite /POEVT1/ entries)
18024         DO 200 J=1,2
18025           IF(IBAL(J).GT.1) THEN
18026 C  sample from truncated distribution
18027             K = IBAL(J)
18028             DO 180 I=1,K
18029               IV(I) = IV2(I,J)
18030               XP(I) = XP2(I,J)
18031  180        CONTINUE
18032  190        CONTINUE
18033               CALL PHO_SOFTPT(K,PTCUT,PTCUT,XP,IV,PTS)
18034             IF(PTS(0,K).GE.PARMDL(100)) GOTO 190
18035 C  transform incoming partons of hard scattering
18036             DEL = ABS(POLD(1,J))+POLD(2,J)
18037             PT2 = PTS(0,K)**2
18038             DEL2 = DEL*DEL
18039             PNEW(1,J) = PTS(1,K)
18040             PNEW(2,J) = PTS(2,K)
18041             PNEW(3,J) = (-1)**J*(PT2 - DEL2)/(2.D0*DEL)
18042             PNEW(4,J) = (DEL2 + PT2)/(2.D0*DEL)
18043 C  spectator partons
18044             ESUM = 0.D0
18045             DO 220 I=1,IBAL(J)-1
18046               K = IBALT(I,J)
18047               PHEP(1,K) = PHEP(1,K)+PTS(1,I)
18048               PHEP(2,K) = PHEP(2,K)+PTS(2,I)
18049               ESUM = ESUM+PHEP(4,K)
18050  220        CONTINUE
18051 C  long. momentum transfer
18052             PP(3) = PNEW(3,J) - POLD(1,J)
18053             PP(4) = PNEW(4,J) - POLD(2,J)
18054             DO 230 I=1,IBAL(J)-1
18055               K = IBALT(I,J)
18056               FAC = PHEP(4,K)/ESUM
18057               PHEP(3,K) = PHEP(3,K) - FAC*PP(3)
18058               PHEP(4,K) = PHEP(4,K) - FAC*PP(4)
18059  230        CONTINUE
18060
18061 C  debug output
18062             IF(IDEB(10).GE.15) THEN
18063               WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
18064      &          'old incoming:',J,0.D0,0.D0,(POLD(I,J),I=1,2)
18065               WRITE(LO,'(1X,2A,I3,1P,4E11.3)') 'PHO_PRIMKT: ',
18066      &          'new incoming:',J,(PNEW(I,J),I=1,4)
18067             ENDIF
18068
18069           ELSE
18070             PNEW(1,J) = 0.D0
18071             PNEW(2,J) = 0.D0
18072             PNEW(3,J) = POLD(1,J)
18073             PNEW(4,J) = POLD(2,J)
18074           ENDIF
18075  200    CONTINUE
18076
18077 C  transformation of hard scattering final states (including ISR)
18078
18079 C  old parton c.m. energy
18080         SI = (POLD(2,1)+POLD(2,2))**2-(POLD(1,1)+POLD(1,2))**2
18081         EI = SQRT(SI)
18082 C  new parton c.m. energy
18083         SF = (PNEW(4,1)+PNEW(4,2))**2-(PNEW(1,1)+PNEW(1,2))**2
18084      &       -(PNEW(2,1)+PNEW(2,2))**2-(PNEW(3,1)+PNEW(3,2))**2
18085         EF = SQRT(SF)
18086         FAC = EF/EI
18087 C  debug output
18088         IF(IDEB(10).GE.25) WRITE(LO,'(1X,A,1P,E12.4)')
18089      &    'PHO_PRIMKT: scaling factor (E-final/E-initial): ',FAC
18090
18091 C  calculate Lorentz transformation
18092         GAZ = -(POLD(1,1)+POLD(1,2))/EI
18093         GAE = (POLD(2,1)+POLD(2,2))/EI
18094         DO 240 I=1,4
18095           GA(I) = (PNEW(I,1)+PNEW(I,2))/EF
18096  240    CONTINUE
18097         CALL PHO_ALTRA(GA(4),-GA(1),-GA(2),-GA(3),PNEW(1,1),PNEW(2,1),
18098      &    PNEW(3,1),PNEW(4,1),PTOT,PP(1),PP(2),PP(3),PP(4))
18099         PTOT = MAX(DEPS,PTOT)
18100         COD= PP(3)/PTOT
18101         SID= SQRT(PP(1)**2+PP(2)**2)/PTOT
18102         COF= 1.D0
18103         SIF= 0.D0
18104         IF(PTOT*SID.GT.1.D-5) THEN
18105           COF=PP(1)/(SID*PTOT)
18106           SIF=PP(2)/(SID*PTOT)
18107           ANORF=SQRT(COF*COF+SIF*SIF)
18108           COF=COF/ANORF
18109           SIF=SIF/ANORF
18110         ENDIF
18111
18112 C  debug output
18113 C  check consistency initial/final configuration before rotation
18114         IF(IDEB(10).GE.25) THEN
18115           WRITE(LO,'(1X,A,1P,4E11.3)') 'PHO_PRIMKT: ini. momentum (1):',
18116      &      0.D0,0.D0,(POLD(I,1)+POLD(I,2),I=1,2)
18117           DO I=1,4
18118             PP(I) = 0.D0
18119           ENDDO
18120           DO I=1,IROT
18121             K = IROTT(I)
18122             DO J=1,4
18123               PP(J) = PP(J)+PHEP(J,K)
18124             ENDDO
18125           ENDDO
18126           WRITE(LO,'(1X,A,1P,4E11.3)')
18127      &      'PHO_PRIMKT: fin. momentum (1):',PP
18128         ENDIF
18129
18130 C  apply rotation/boost to scattered particles
18131         DO 400 I=1,IROT
18132           K = IROTT(I)
18133           DO 350 J=1,4
18134             PP(J) = FAC*PHEP(J,K)
18135  350      CONTINUE
18136           CALL PHO_ALTRA(GAE,0.D0,0.D0,GAZ,PP(1),PP(2),PP(3),
18137      &      PP(4),PTOT,PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
18138           CALL PHO_TRANS(PHEP(1,K),PHEP(2,K),PHEP(3,K),
18139      &      COD,SID,COF,SIF,XX,YY,ZZ)
18140           EE = PHEP(4,K)
18141           CALL PHO_ALTRA(GA(4),GA(1),GA(2),GA(3),XX,YY,ZZ,EE,PTOT,
18142      &      PHEP(1,K),PHEP(2,K),PHEP(3,K),PHEP(4,K))
18143  400    CONTINUE
18144
18145 C  debug output
18146 C  check consistency initial/final configuration after rotation
18147         IF(IDEB(10).GE.25) THEN
18148           DO I=1,4
18149             PP(I) = PNEW(I,1)+PNEW(I,2)
18150           ENDDO
18151           WRITE(LO,'(1X,A,1P,4E11.3)')
18152      &      'PHO_PRIMKT: ini. momentum (2):',PP
18153           DO I=1,4
18154             PP(I) = 0.D0
18155           ENDDO
18156           DO I=1,IROT
18157             K = IROTT(I)
18158             DO J=1,4
18159               PP(J) = PP(J)+PHEP(J,K)
18160             ENDDO
18161           ENDDO
18162           WRITE(LO,'(1X,A,1P,4E11.3)')
18163      &      'PHO_PRIMKT: fin. momentum (2):',PP
18164         ENDIF
18165
18166         ENDIF
18167
18168         IF(INEXT.EQ.1) GOTO 100
18169
18170 C  initialization
18171
18172       ELSE IF(IMODE.EQ.-1) THEN
18173
18174 C  output of statistics etc.
18175
18176       ELSE IF(IMODE.EQ.-2) THEN
18177
18178 C  something wrong
18179
18180       ELSE
18181         WRITE(LO,'(/1X,A,I4)')
18182      &    'PHO_PRIMKT:ERROR: invalid value of IMODE:',IMODE
18183         CALL PHO_ABORT
18184       ENDIF
18185
18186       END
18187
18188 *$ CREATE PHO_PARTPT.FOR
18189 *COPY PHO_PARTPT
18190 CDECK  ID>, PHO_PARTPT
18191       SUBROUTINE PHO_PARTPT(IMODE,IF,IL,PTCUT,IREJ)
18192 C********************************************************************
18193 C
18194 C    assign to soft partons
18195 C
18196 C    input:  IMODE   -2   output of statistics
18197 C                    -1   initialization
18198 C                     0   sampling of pt for soft partons belonging to
18199 C                         soft Pomerons
18200 C                     1   sampling of pt for soft partons belonging to
18201 C                         hard Pomerons
18202 C            IF           first entry in /POEVT1/ to check
18203 C            IL           last entry in /POEVT1/ to check
18204 C            PTCUT        current value of PTCUT to distinguish
18205 C                         between soft and hard
18206 C
18207 C    output: IREJ     0   success
18208 C                     1   failure
18209 C
18210 C    (soft pt is sampled by call to PHO_SOFTPT)
18211 C
18212 C********************************************************************
18213       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18214       SAVE
18215
18216       PARAMETER ( DEPS = 1.D-15 )
18217
18218       INTEGER IMODE,IF,IL,IREJ
18219       DOUBLE PRECISION PTCUT
18220
18221 C  input/output channels
18222       INTEGER LI,LO
18223       COMMON /POINOU/ LI,LO
18224 C  event debugging information
18225       INTEGER NMAXD
18226       PARAMETER (NMAXD=100)
18227       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18228      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18229       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18230      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18231 C  model switches and parameters
18232       CHARACTER*8 MDLNA
18233       INTEGER ISWMDL,IPAMDL
18234       DOUBLE PRECISION PARMDL
18235       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18236 C  some constants
18237       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
18238       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
18239      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
18240 C  data of c.m. system of Pomeron / Reggeon exchange
18241       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18242       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18243      &                 SIDP,CODP,SIFP,COFP
18244       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18245      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
18246      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
18247 C  standard particle data interface
18248       INTEGER NMXHEP
18249       PARAMETER (NMXHEP=4000)
18250       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
18251       DOUBLE PRECISION PHEP,VHEP
18252       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
18253      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
18254      &                VHEP(4,NMXHEP)
18255 C  extension to standard particle data interface (PHOJET specific)
18256       INTEGER IMPART,IPHIST,ICOLOR
18257       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
18258
18259       DOUBLE PRECISION PTS,PB,XP,XPB,PC
18260       DIMENSION PTS(0:2,50),PB(0:2,2),XP(50),XPB(2),PC(4)
18261
18262       INTEGER MODIFY,IV,IVB
18263       DIMENSION MODIFY(50),IV(50),IVB(2)
18264
18265 C  debug output
18266       IF(IDEB(6).GE.10) WRITE(LO,'(1X,A,3I4,1P,E11.3)')
18267      &  'PHO_PARTPT: called with IMODE,IF,IL,PTCUT',
18268      &  IMODE,IF,IL,PTCUT
18269
18270       IF(IMODE.LT.0) GOTO 1000
18271
18272       IREJ = 0
18273       IF((ISWMDL(3).EQ.10).AND.(ISWMDL(4).EQ.10)) RETURN
18274
18275 C  count entries to modify
18276       IENTRY = 0
18277       PTCUT2 = PTCUT**2
18278       EMIN = 1.D20
18279       IPEAK = 1
18280       ISTART = IF
18281
18282 C  soft Pomerons
18283
18284       IF(IMODE.EQ.0) THEN
18285         DO 300 I=ISTART,IL
18286           IF((ISTHEP(I).EQ.-1).AND.(ABS(IPHIST(1,I)).LT.100)) THEN
18287             IENTRY = IENTRY+1
18288             MODIFY(IENTRY) = I
18289             XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
18290             IV(IENTRY) = 0
18291             IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
18292             IF(PHEP(4,I).LT.EMIN) THEN
18293               EMIN = PHEP(4,I)
18294               IPEAK = IENTRY
18295             ENDIF
18296           ENDIF
18297  300    CONTINUE
18298
18299 C  hard Pomeron associated remnants (IPHIST(1,)=100,200,...)
18300
18301       ELSE IF(IMODE.EQ.1) THEN
18302
18303         DO 350 I=ISTART,IL
18304           IF((ISTHEP(I).EQ.-1).AND.(IPHIST(1,I).GE.100)) THEN
18305             IF(MOD(IPHIST(1,I),100).EQ.0) THEN
18306               IENTRY = IENTRY+1
18307               MODIFY(IENTRY) = I
18308               XP(IENTRY) = SIGN(PHEP(4,I)/ECMP,PHEP(3,I))
18309               IF(ISWMDL(24).EQ.0) THEN
18310                 IV(IENTRY) = 0
18311                 IF(IDHEP(I).NE.21) IV(IENTRY) = ICOLOR(2,I)
18312               ELSE IF(ISWMDL(24).EQ.1) THEN
18313                 IV(IENTRY) = -1
18314               ELSE
18315                 IV(IENTRY) = 1
18316               ENDIF
18317               IF(PHEP(4,I).LT.EMIN) THEN
18318                 EMIN = PHEP(4,I)
18319                 IPEAK = IENTRY
18320               ENDIF
18321             ENDIF
18322           ENDIF
18323  350    CONTINUE
18324
18325 C  something wrong
18326
18327       ELSE
18328         WRITE(LO,'(/1X,A,I5)') 'PHO_PARTPT:ERROR: invalid mode',IMODE
18329         CALL PHO_ABORT
18330       ENDIF
18331
18332 C  debug output
18333       IF(IDEB(6).GE.5) THEN
18334         WRITE(LO,'(1X,2A,3I4)') 'PHO_PARTPT: ',
18335      &    'number of partons, IPEAK,MODE',IENTRY,IPEAK,IMODE
18336         IF(IDEB(6).GE.20) CALL PHO_PREVNT(0)
18337       ENDIF
18338
18339 C  nothing to do
18340       IF(IENTRY.LE.1) RETURN
18341
18342 C  sample pt of soft partons
18343
18344       IF(ISWMDL(5).LE.1) THEN
18345         ITER = 0
18346         IPEAK = DT_RNDM(DUM)*IENTRY+1
18347         CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
18348         CALL PHO_SWAPD(XP(IPEAK),XP(1))
18349         CALL PHO_SWAPI(IV(IPEAK),IV(1))
18350  400    CONTINUE
18351 C  energy limited sampling
18352           PSUMX = 0.D0
18353           PSUMY = 0.D0
18354           ITER = ITER+1
18355           IF(ITER.GE.1000) THEN
18356             IF(IDEB(6).GE.3) THEN
18357               WRITE(LO,'(1X,A,3I5)')
18358      &          'PHO_PARTPT: rejection for MODE,ENTRY,ITER',
18359      &          IMODE,IENTRY,ITER
18360               WRITE(LO,'(8X,A,I5)') 'I  II  IV       XP         EP',
18361      &          IPEAK
18362               DO 405 I=1,IENTRY
18363                 II = MODIFY(I)
18364                 WRITE(LO,'(5X,3I5,1P,2E13.4)')
18365      &            I,II,IV(I),XP(I),PHEP(4,II)
18366  405          CONTINUE
18367               IF(IDEB(6).GE.5) CALL PHO_PREVNT(0)
18368             ENDIF
18369             IREJ = 1
18370             RETURN
18371           ENDIF
18372           DO 410 I=2,IENTRY
18373             II = MODIFY(I)
18374             PTMX = MIN(PHEP(4,II),PTCUT)
18375             XPB(1) = XP(I)
18376             IVB(1) = IV(I)
18377             IF(ISWMDL(5).EQ.0) THEN
18378               CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
18379             ELSE
18380               CALL PHO_SOFTPT(1,PTMX,PTMX,XPB,IVB,PB)
18381             ENDIF
18382             PTS(0,I) = PB(0,1)
18383             PTS(1,I) = PB(1,1)
18384             PTS(2,I) = PB(2,1)
18385             PSUMX = PSUMX+PB(1,1)
18386             PSUMY = PSUMY+PB(2,1)
18387  410      CONTINUE
18388           PTREM = SQRT(PSUMX**2+PSUMY**2)
18389         IF(PTREM.GT.MIN(PHEP(4,MODIFY(1)),PTCUT)) GOTO 400
18390         PTS(1,1) = -PSUMX
18391         PTS(2,1) = -PSUMY
18392       ELSE IF((ISWMDL(5).EQ.2)
18393      &        .OR.((IMODE.EQ.1).AND.(ISWMDL(5).EQ.3))) THEN
18394 C  unlimited sampling
18395         IPEAK = DT_RNDM(PSUMX)*IENTRY+1
18396         CALL PHO_SWAPI(MODIFY(IPEAK),MODIFY(1))
18397         CALL PHO_SWAPD(XP(IPEAK),XP(1))
18398         CALL PHO_SWAPI(IV(IPEAK),IV(1))
18399         CALL PHO_SOFTPT(IENTRY,PTCUT,PTCUT,XP,IV,PTS)
18400       ELSE IF(ISWMDL(5).EQ.3) THEN
18401 C  each string has balanced pt
18402         DO 500 K=1,IENTRY
18403           IF(IV(K).LE.-90) GOTO 499
18404           I1 = MODIFY(K)
18405           IC1 = -ICOLOR(1,I1)
18406           DO 510 L=K+1,IENTRY
18407             IF(ICOLOR(1,MODIFY(L)).EQ.IC1) GOTO 511
18408  510      CONTINUE
18409           WRITE(LO,'(//1X,A,I5)')
18410      &      'PHO_PARTPT:ERROR: no color found for (line,color)',I1,-IC1
18411           CALL PHO_ABORT
18412  511      CONTINUE
18413           I2 = MODIFY(L)
18414           AMSQR = (PHEP(4,I1)+PHEP(4,I2))**2-(PHEP(1,I1)+PHEP(1,I2))**2
18415      &           -(PHEP(2,I1)+PHEP(2,I2))**2-(PHEP(3,I1)+PHEP(3,I2))**2
18416           AM   = SQRT(AMSQR)
18417           PTMX = AM/2.D0
18418           IVB(1) = MAX(IV(K),IV(L))
18419           XPB(1) = XP(K)
18420           CALL PHO_SOFTPT(1,PTCUT,PTMX,XPB,IVB,PB)
18421           PTS(1,K) = PB(1,1)
18422           PTS(2,K) = PB(2,1)
18423           PTS(1,L) = -PB(1,1)
18424           PTS(2,L) = -PB(2,1)
18425           GAM    = (PHEP(4,I1)+PHEP(4,I2))/AM
18426           GAMBEZ = (PHEP(3,I1)+PHEP(3,I2))/AM
18427           PC(1) = PB(1,1)
18428           PC(2) = PB(2,1)
18429           PLONG = SQRT(PTMX**2-PB(0,1)**2+1.D-12)
18430           PC(3) = SIGN(PLONG,PHEP(3,I1))
18431           PC(4) = PTMX
18432           CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
18433      &               PTOT,PHEP(1,I1),PHEP(2,I1),PHEP(3,I1),PHEP(4,I1))
18434           PC(1) = -PC(1)
18435           PC(2) = -PC(2)
18436           PC(3) = -PC(3)
18437           CALL PHO_ALTRA(GAM,0.D0,0.D0,GAMBEZ,PC(1),PC(2),PC(3),PC(4),
18438      &               PTOT,PHEP(1,I2),PHEP(2,I2),PHEP(3,I2),PHEP(4,I2))
18439           IV(K) = IV(K)-100
18440           IV(L) = IV(L)-100
18441  499      CONTINUE
18442  500    CONTINUE
18443       ELSE
18444         WRITE(LO,'(/1X,A,I4)')
18445      &    'PHO_PARTPT:ERROR: invalid value of ISWMDL(5):',ISWMDL(5)
18446         CALL PHO_ABORT
18447       ENDIF
18448
18449 C  change partons in /POEVT1/
18450       DO 900 II=1,IENTRY
18451         IF(IV(II).GT.-90) THEN
18452           I = MODIFY(II)
18453           PHEP(1,I) = PHEP(1,I)+PTS(1,II)
18454           PHEP(2,I) = PHEP(2,I)+PTS(2,II)
18455           AMSQR = PHEP(4,I)**2
18456      &             -PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
18457           PHEP(5,I) = SIGN(SQRT(ABS(AMSQR)),AMSQR)
18458         ENDIF
18459  900  CONTINUE
18460
18461 C  debug output
18462       IF(IDEB(6).GE.15) THEN
18463         WRITE(LO,'(1X,A,/,8X,A,I5)') 'PHO_PARTPT: table of momenta',
18464      &    'I  II  IV    XP    EP    PTS   PTX   PTY',IPEAK
18465         DO 505 I=1,IENTRY
18466           II = MODIFY(I)
18467           WRITE(LO,'(2X,3I5,1P,5E12.4)')
18468      &      I,II,IV(I),XP(I),PHEP(4,II),PTS(0,I),PTS(1,I),PTS(2,I)
18469  505    CONTINUE
18470         CALL PHO_PREVNT(0)
18471       ENDIF
18472       RETURN
18473
18474 C  initialization / output of statistics
18475  1000 CONTINUE
18476       CALL PHO_SOFTPT(IMODE,PTM,PTM,XP,IV,PTS)
18477
18478       END
18479
18480 *$ CREATE PHO_SOFTPT.FOR
18481 *COPY PHO_SOFTPT
18482 CDECK  ID>, PHO_SOFTPT
18483       SUBROUTINE PHO_SOFTPT(ISOFT,PTCUT,PTMAX,XV,IV,PTSOF)
18484 C***********************************************************************
18485 C
18486 C    select pt of soft string ends
18487 C
18488 C    input:    ISOFT          number of soft partons
18489 C                    -1       initialization
18490 C                    >=0      sampling of p_t
18491 C                    -2       output of statistics
18492 C              PTCUT          cutoff for soft strings
18493 C              PTMAX          maximal allowed PT
18494 C              XV             field of x values
18495 C              IV             0    sea quark
18496 C                             1    valence quark
18497 C
18498 C    output:   /POINT3/       containing parameters AAS,BETAS
18499 C              PTSOF          filed with soft pt values
18500 C
18501 C    note:     ISWMDL(3/4) = 0  dNs/dP_t = P_t ASS * exp(-BETA*P_t**2)
18502 C              ISWMDL(3/4) = 1  dNs/dP_t = P_t ASS * exp(-BETA*P_t)
18503 C              ISWMDL(3/4) = 2  photon wave function
18504 C              ISWMDL(3/4) = 10 no soft P_t assignment
18505 C
18506 C***********************************************************************
18507       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18508       SAVE
18509
18510       PARAMETER ( DEPS   =  1.D-15)
18511
18512       DIMENSION PTSOF(0:2,*),XV(*)
18513       DIMENSION IV(*)
18514
18515 C  input/output channels
18516       INTEGER LI,LO
18517       COMMON /POINOU/ LI,LO
18518 C  event debugging information
18519       INTEGER NMAXD
18520       PARAMETER (NMAXD=100)
18521       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18522      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18523       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18524      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18525 C  model switches and parameters
18526       CHARACTER*8 MDLNA
18527       INTEGER ISWMDL,IPAMDL
18528       DOUBLE PRECISION PARMDL
18529       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18530 C  data of c.m. system of Pomeron / Reggeon exchange
18531       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18532       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18533      &                 SIDP,CODP,SIFP,COFP
18534       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18535      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
18536      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
18537 C  data on most recent hard scattering
18538       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
18539       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
18540      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
18541      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
18542       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
18543      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
18544      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
18545      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
18546      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
18547 C  data needed for soft-pt calculation
18548       DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18549       COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18550
18551       DIMENSION BETAB(100)
18552
18553 C  selection of pt
18554       IF(ISOFT.GE.0) THEN
18555         CALLS = CALLS + 1.D0
18556 C  sample according to model ISWMDL(3-6)
18557         IF(ISOFT.GT.1) THEN
18558  210      CONTINUE
18559           PTXS = 0.D0
18560           PTYS = 0.D0
18561           DO 300 I=2,ISOFT
18562             IMODE = ISWMDL(3)
18563 C  valence partons
18564             IF(IV(I).EQ.1) THEN
18565               BETA = BETAS(1)
18566 C  photon/pomeron valence part
18567               IF(IPAMDL(5).EQ.1) THEN
18568                 IF(XV(I).GE.0.D0) THEN
18569                   IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
18570                     IMODE = ISWMDL(4)
18571                     BETA = BETAS(3)
18572                   ENDIF
18573                 ELSE
18574                   IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
18575                     IMODE = ISWMDL(4)
18576                     BETA = BETAS(3)
18577                   ENDIF
18578                 ENDIF
18579               ELSE IF(IPAMDL(5).EQ.2) THEN
18580                 BETA = PARMDL(20)
18581               ELSE IF(IPAMDL(5).EQ.3) THEN
18582                 BETA = BETAS(3)
18583               ENDIF
18584 C  sea partons
18585             ELSE IF(IV(I).EQ.0) THEN
18586               BETA = BETAS(3)
18587 C  hard scattering remnant
18588             ELSE
18589               IF(IPAMDL(6).EQ.0) THEN
18590                 BETA = BETAS(1)
18591               ELSE IF(IPAMDL(6).EQ.1) THEN
18592                 BETA = BETAS(3)
18593               ELSE
18594                 BETA = PARMDL(20)
18595               ENDIF
18596             ENDIF
18597             BETA = MAX(BETA,0.01D0)
18598             CALL PHO_SELPT(XV(I),0.D0,PTCUT,PTS,BETA,IMODE)
18599             PTS = MIN(PTMAX,PTS)
18600             CALL PHO_SFECFE(SIG,COG)
18601             PTSOF(0,I) = PTS
18602             PTSOF(1,I) = COG*PTS
18603             PTSOF(2,I) = SIG*PTS
18604             PTXS = PTXS+PTSOF(1,I)
18605             PTYS = PTYS+PTSOF(2,I)
18606             BETAB(I) = BETA
18607  300      CONTINUE
18608 C  balancing of momenta
18609           PTS = SQRT(PTXS**2+PTYS**2)
18610           IF(PTS.GE.PTMAX) GOTO 210
18611           PTSOF(0,1) = PTS
18612           PTSOF(1,1) = -PTXS
18613           PTSOF(2,1) = -PTYS
18614           BETAB(1) = 0.D0
18615 C
18616 *400      CONTINUE
18617 C
18618 C  single parton only
18619         ELSE
18620           IMODE = ISWMDL(3)
18621 C  valence partons
18622           IF(IV(1).EQ.1) THEN
18623             BETA = BETAS(1)
18624 C  photon/Pomeron valence part
18625             IF(IPAMDL(5).EQ.1) THEN
18626               IF(XV(1).GE.0.D0) THEN
18627                 IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
18628                   IMODE = ISWMDL(4)
18629                   BETA = BETAS(3)
18630                 ENDIF
18631               ELSE
18632                 IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
18633                   IMODE = ISWMDL(4)
18634                   BETA = BETAS(3)
18635                 ENDIF
18636               ENDIF
18637             ELSE IF(IPAMDL(5).EQ.2) THEN
18638               BETA = PARMDL(20)
18639             ELSE IF(IPAMDL(5).EQ.3) THEN
18640               BETA = BETAS(3)
18641             ENDIF
18642 C  sea partons
18643           ELSE IF(IV(1).EQ.0) THEN
18644             BETA = BETAS(3)
18645 C  hard scattering remnant
18646           ELSE
18647             IF(IPAMDL(6).EQ.1) THEN
18648               BETA = BETAS(3)
18649             ELSE
18650               BETA = PARMDL(20)
18651             ENDIF
18652           ENDIF
18653           BETA = MAX(BETA,0.01D0)
18654           CALL PHO_SELPT(XV(1),0.D0,PTCUT,PTS,BETA,IMODE)
18655           PTS = MIN(PTMAX,PTS)
18656           CALL PHO_SFECFE(SIG,COG)
18657           PTSOF(0,1) = PTS
18658           PTSOF(1,1) = COG*PTS
18659           PTSOF(2,1) = SIG*PTS
18660           BETAB(1) = BETA
18661         ENDIF
18662 C  debug output
18663         IF(IDEB(29).GE.10) THEN
18664           WRITE(LO,'(1X,A,I4)') 'PHO_SOFTPT: ISOFT',ISOFT
18665           WRITE(LO,'(6X,A)') 'TABLE OF  I, IV, XV, PT, PT-X, PT-Y, BETA'
18666           DO 105 I=1,ISOFT
18667             WRITE(LO,'(10X,2I3,1P,5E12.3)') I,IV(I),XV(I),PTSOF(0,I),
18668      &        PTSOF(1,I),PTSOF(2,I),BETAB(I)
18669  105      CONTINUE
18670         ENDIF
18671
18672 C  initialization of statistics and parameters
18673
18674       ELSE IF(ISOFT.EQ.-1) THEN
18675         PTSMIN = 0.D0
18676         PTSMAX = PTCUT
18677         IMODE = -100+ISWMDL(3)
18678         CALL PHO_SELPT(ECMP,PTSMIN,PTSMAX,PTS,BETAS(3),IMODE)
18679
18680 C  output of statistics
18681
18682       ELSE IF(ISOFT.EQ.-2) THEN
18683       ELSE
18684         WRITE(LO,'(1X,2A,I2)') 'PHO_SOFTPT:ERROR: ',
18685      &    'unsupported ISOFT ',ISOFT
18686         STOP
18687       ENDIF
18688       END
18689
18690 *$ CREATE PHO_SELPT.FOR
18691 *COPY PHO_SELPT
18692 CDECK  ID>, PHO_SELPT
18693       SUBROUTINE PHO_SELPT(EE,PTLOW,PTHIGH,PTS,BETA,IMODE)
18694 C***********************************************************************
18695 C
18696 C    select pt from different distributions
18697 C
18698 C    input:    EE            energy (for initialization only)
18699 C                            otherwise x value of corresponding parton
18700 C              PTLOW         lower pt limit
18701 C              PTHIGH        upper pt limit
18702 C                            (PTHIGH > 20 will cause DEXP underflows)
18703 C
18704 C              IMODE = 0     dNs/dP_t = P_t * ASS * exp(-BETA*P_t**2)
18705 C              IMODE = 1     dNs/dP_t = P_t * ASS * exp(-BETA*P_t)
18706 C              IMODE = 2     dNs/dP_t according photon wave function
18707 C              IMODE = 10    no sampling
18708 C
18709 C              IMODE = -100+IMODE    initialization according to
18710 C                                    given limitations
18711 C
18712 C    output:   PTS           sampled pt value
18713 C    initialization:
18714 C              BETA          soft pt slope in central region
18715 C
18716 C***********************************************************************
18717       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18718       SAVE
18719
18720       PARAMETER ( PI2    =  6.28318530718D0,
18721      &            AMIN   =  1.D-2,
18722      &            EPS    =  1.D-7,
18723      &            DEPS   =  1.D-30)
18724
18725 C  input/output channels
18726       INTEGER LI,LO
18727       COMMON /POINOU/ LI,LO
18728 C  event debugging information
18729       INTEGER NMAXD
18730       PARAMETER (NMAXD=100)
18731       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
18732      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18733       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
18734      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
18735 C  model switches and parameters
18736       CHARACTER*8 MDLNA
18737       INTEGER ISWMDL,IPAMDL
18738       DOUBLE PRECISION PARMDL
18739       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
18740 C  data of c.m. system of Pomeron / Reggeon exchange
18741       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
18742       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
18743      &                 SIDP,CODP,SIFP,COFP
18744       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
18745      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
18746      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
18747 C  average number of cut soft and hard ladders (obsolete)
18748       DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
18749       COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
18750 C  data needed for soft-pt calculation
18751       DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18752       COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18753
18754       DOUBLE PRECISION PHO_CONN0,PHO_CONN1
18755       EXTERNAL PHO_CONN0,PHO_CONN1
18756
18757 C  initialization
18758
18759       IF(IMODE.LT.0) GOTO 100
18760
18761       PX = PTHIGH
18762       PTS = 0.D0
18763
18764 C  initial checks
18765
18766       IF(PX.LT.AMIN) RETURN
18767
18768       IF((PX-PTLOW).LT.0.01) THEN
18769         IF(IDEB(5).GE.3) WRITE(LO,'(1X,A,2E12.3,I3)')
18770      &    'PHO_SELPT: PTLOW,PTHIGH,IMODE ',PTLOW,PTHIGH,IMODE
18771         RETURN
18772       ENDIF
18773
18774 C  sampling of pt values according to IMODE
18775
18776       IF(IMODE.EQ.0) THEN
18777
18778         FAC1 = EXP(-BETA*PX**2)
18779         FAC2 = (1.D0-FAC1)
18780  25     CONTINUE
18781           XI1 = DT_RNDM(PX)*FAC2 + FAC1
18782           PTS = SQRT(-1.D0/BETA*LOG(XI1))
18783         IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 25
18784
18785       ELSE IF(IMODE.EQ.1) THEN
18786
18787         XIMIN = EXP(-BETA*PTHIGH)
18788         XIDEL = 1.D0-XIMIN
18789  50     CONTINUE
18790           PTS = -LOG((XIDEL*DT_RNDM(XIDEL)+XIMIN)
18791      &              *(XIDEL*DT_RNDM(XIMIN)+XIMIN)+DEPS)/BETA
18792         IF(PTS.LT.XMT) GOTO 50
18793         PTS = SQRT(PTS**2-XMT2)
18794         IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 50
18795
18796       ELSE IF(IMODE.EQ.2) THEN
18797
18798         IF(EE.GE.0.D0) THEN
18799           P2 = PVIRTP(1)
18800         ELSE
18801           P2 = PVIRTP(2)
18802         ENDIF
18803         XV = ABS(EE)
18804         AA = (1.D0-XV)*XV*P2+PARMDL(25)
18805  75     CONTINUE
18806           PTS = SQRT(AA/(DT_RNDM(PX)+EPS)-AA)
18807         IF((PTS.GT.PTHIGH).OR.(PTS.LT.PTLOW)) GOTO 75
18808
18809 C  something wrong
18810
18811       ELSE IF(IMODE.NE.10) THEN
18812         WRITE(LO,'(/1X,A,I4)') 'PHO_SELPT:ERROR: invalid IMODE',IMODE
18813         CALL PHO_ABORT
18814       ENDIF
18815
18816 C  debug output
18817       IF(IDEB(5).GE.20) THEN
18818         WRITE(LO,'(1X,A,I3,4E10.3)')
18819      &    'PHO_SELPT: MODE,BET,PTMI,PTMA,PT',
18820      &    IMODE,BETA,PTLOW,PTHIGH,PTS
18821       ENDIF
18822       RETURN
18823
18824 C  initialization
18825  100  CONTINUE
18826         PTSMIN = PTLOW
18827         PTSMAX = PTHIGH
18828         PTCON = PTHIGH
18829 C  calculation of parameters
18830         INIT = IMODE+100
18831         AAS = 0.D0
18832
18833 C  initialization for model 0 (gaussian pt distribution)
18834
18835         IF(INIT.EQ.0) THEN
18836           BETAS(1) = PARMDL(23)+0.15D0*LOG(EE)*(PARMDL(24)-PARMDL(23))
18837           BETUP = BETAS(1)
18838           BETLO = -2.D0
18839           XTOL = PHO_CONN0(BETLO)*PHO_CONN0(BETUP)
18840           IF(XTOL.LT.0.D0) THEN
18841             XTOL = 1.D-4
18842             METHOD = 1
18843             MAXF = 500
18844             BETA = 0.D0
18845             BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN0,METHOD)
18846 *           IF(BETA.LT.-1.D+10) THEN
18847 *             WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
18848 *    &          '(model 0: Ecm,PTcut)',EE,PTCON
18849 *             WRITE(LO,'(1X,A,1P,3E10.3)')
18850 *    &          'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
18851 *             CALL PHO_PREVNT(-1)
18852 *             BETA = 0.01
18853 *           ELSE
18854               AAS = DSIGHP/PTCON*EXP(-BETA*PTCON**2)
18855 *           ENDIF
18856           ELSE
18857             AAS = 0.D0
18858             BETA = BETAS(1)
18859           ENDIF
18860
18861 C  initialization for model 1 (exponential pt distribution)
18862
18863         ELSE IF(INIT.EQ.1) THEN
18864           XMT = PARMDL(43)
18865           XMT2 = XMT*XMT
18866           BETAS(1) = PARMDL(21)+0.15D0*LOG(EE)*(PARMDL(22)-PARMDL(21))
18867           BETUP = BETAS(1)
18868           BETLO = -3.D0
18869           XTOL = PHO_CONN1(BETLO)*PHO_CONN1(BETUP)
18870           IF(XTOL.LT.0.D0) THEN
18871             XTOL = 1.D-4
18872             METHOD = 1
18873             MAXF = 500
18874             BETA = 0.D0
18875             BETA = PHO_DZEROX(BETLO,BETUP,XTOL,MAXF,PHO_CONN1,METHOD)
18876 *           IF(BETA.LT.-1.D+10) THEN
18877 *             WRITE(LO,'(1X,2A,1P,2E11.3)') 'PHO_SELPT: no Beta found ',
18878 *    &          '(model 1: Ecm,PTcut)',EE,PTCON
18879 *             WRITE(LO,'(1X,A,1P,3E10.3)')
18880 *    &          'PHO_SELPT: SIGS,SIGH,DSIGHP',SIGS,SIGH,DSIGHP
18881 *             CALL PHO_PREVNT(-1)
18882 *             BETA = 0.01
18883 *           ELSE
18884               AAS = DSIGHP/PTCON*EXP(-BETA*PTCON)
18885 *           ENDIF
18886           ELSE
18887             AAS = 0.D0
18888             BETA = BETAS(1)
18889           ENDIF
18890         ELSE IF(INIT.EQ.10) THEN
18891           IF(IDEB(5).GT.10)
18892      &      WRITE(LO,'(/1X,A)') 'PHO_SELPT: no soft pt sampling'
18893           RETURN
18894         ELSE
18895           WRITE(LO,'(1X,A,I4)') 'PHO_SELPT:ERROR: invalid distribution',
18896      &      INIT
18897           CALL PHO_ABORT
18898         ENDIF
18899         BETA = MIN(BETA,BETAS(1))
18900
18901 C  hard cross section is too big: neg. beta parameter
18902         IF(BETA.LE.0.D0) THEN
18903           WRITE(LO,'(1X,A,1P,2E12.3)')
18904      &      'PHO_SELPT: parameter BETA negative (BETA,AAS)',BETA,AAS
18905           WRITE(LO,'(1X,A,1P,4E11.3)') 'SIGS,DSIGHP,SIGH,PTCON:',
18906      &      SIGS,DSIGHP,SIGH,PTCON
18907           CALL PHO_PREVNT(-1)
18908         ENDIF
18909
18910 C  output of initialization parameters
18911         IF(IDEB(5).GE.10) THEN
18912           WRITE(LO,'(1X,A,I3)') 'PHO_SELPT: initialization for model',
18913      &      INIT
18914           WRITE(LO,'(5X,A,1P,2E13.3)')
18915      &      'BETA,AAS        ',BETA,AAS
18916           WRITE(LO,'(5X,A,1P,3E13.3)')
18917      &      'ECM,PTMIN,PTMAX ',EE,PTSMIN,PTSMAX
18918           WRITE(LO,'(5X,A,1P,3E13.3)')
18919      &      'SIGS,DSIGHP,SIGH',SIGS,DSIGHP,SIGH
18920         ENDIF
18921
18922       END
18923
18924 *$ CREATE PHO_CONN0.FOR
18925 *COPY PHO_CONN0
18926 CDECK  ID>, PHO_CONN0
18927       DOUBLE PRECISION FUNCTION PHO_CONN0(BETA)
18928 C***********************************************************************
18929 C
18930 C    auxiliary function to determine parameters of soft
18931 C    pt distribution  dNs/dP_t = P_t * AAS * EXP(-BETA*P_t**2)
18932 C
18933 C    internal factors: FS  number of soft partons in soft Pomeron
18934 C                      FH  number of soft partons in hard Pomeron
18935 C
18936 C***********************************************************************
18937       IMPLICIT NONE
18938       SAVE
18939
18940 C  input/output channels
18941       INTEGER LI,LO
18942       COMMON /POINOU/ LI,LO
18943 C  average number of cut soft and hard ladders (obsolete)
18944       DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
18945       COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
18946 C  data needed for soft-pt calculation
18947       DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18948       COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18949
18950       DOUBLE PRECISION BETA,XX,FF
18951
18952       XX = BETA*PTCON**2
18953       IF(ABS(XX).LT.1.D-3) THEN
18954         FF = FS*SIGS+FH*SIGH
18955      &       - DSIGHP*(PTCON/2.D0+PTCON**3*BETA/4.D0)
18956       ELSE
18957         FF = FS*SIGS+FH*SIGH
18958      &       - DSIGHP/(2.D0*PTCON*BETA)*(EXP(XX)-1.D0)
18959       ENDIF
18960       PHO_CONN0 = FF
18961
18962 *     WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:BETA,AAS,FF',BETA,AAS,FF
18963 *     WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN0:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP
18964
18965       END
18966
18967 *$ CREATE PHO_CONN1.FOR
18968 *COPY PHO_CONN1
18969 CDECK  ID>, PHO_CONN1
18970       DOUBLE PRECISION FUNCTION PHO_CONN1(BETA)
18971 C***********************************************************************
18972 C
18973 C    auxiliary function to determine parameters of soft
18974 C    pt distribution  dNs/dP_t = P_t * AAS * EXP(-BETA*P_t)
18975 C
18976 C    internal factors: FS  number of soft partons in soft Pomeron
18977 C                      FH  number of soft partons in hard Pomeron
18978 C
18979 C***********************************************************************
18980       IMPLICIT NONE
18981       SAVE
18982
18983 C  input/output channels
18984       INTEGER LI,LO
18985       COMMON /POINOU/ LI,LO
18986 C  average number of cut soft and hard ladders (obsolete)
18987       DOUBLE PRECISION AVERI,AVERK,AVERL,AVERM,AVERN
18988       COMMON /POINT2/ AVERI,AVERK,AVERL,AVERM,AVERN
18989 C  data needed for soft-pt calculation
18990       DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
18991       COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
18992
18993       DOUBLE PRECISION BETA,XX,FF
18994
18995       XX = BETA*PTCON
18996       IF(ABS(XX).LT.1.D-3) THEN
18997         FF = FS*SIGS+FH*SIGH
18998      &       - DSIGHP*(PTCON/2.D0+PTCON**2*BETA/6.D0)
18999       ELSE
19000         FF = FS*SIGS+FH*SIGH
19001      &       - DSIGHP/(PTCON*BETA**2)*(EXP(XX)-1.D0-BETA*PTCON)
19002       ENDIF
19003       PHO_CONN1 = FF
19004
19005 *     WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:BETA,AAS,FF',BETA,AAS,FF
19006 *     WRITE(LO,'(1X,A,3E12.3)') 'PHO_CONN1:SIGS,SIGH,DSIGH',SIGS,SIGH,DSIGHP
19007
19008       END
19009
19010 *$ CREATE PHO_MSHELL.FOR
19011 *COPY PHO_MSHELL
19012 CDECK  ID>, PHO_MSHELL
19013       SUBROUTINE PHO_MSHELL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
19014 C********************************************************************
19015 C
19016 C    rescaling of momenta of two partons to put both
19017 C                                       on mass shell
19018 C
19019 C    input:       PA1,PA2   input momentum vectors
19020 C                 XM1,2     desired masses of particles afterwards
19021 C                 P1,P2     changed momentum vectors
19022 C
19023 C********************************************************************
19024       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19025       SAVE
19026
19027       PARAMETER ( DEPS   =  1.D-20 )
19028
19029       DIMENSION PA1(*),PA2(*),P1(*),P2(*)
19030
19031 C  input/output channels
19032       INTEGER LI,LO
19033       COMMON /POINOU/ LI,LO
19034 C  event debugging information
19035       INTEGER NMAXD
19036       PARAMETER (NMAXD=100)
19037       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19038      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19039       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19040      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19041 C  internal rejection counters
19042       INTEGER NMXJ
19043       PARAMETER (NMXJ=60)
19044       CHARACTER*10 REJTIT
19045       INTEGER IFAIL
19046       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19047
19048       IREJ = 0
19049       IDEV = 0
19050 C  debug output
19051       IF(IDEB(40).GE.10) THEN
19052         WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
19053         WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
19054         WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
19055         WRITE(LO,'(5X,A,2E12.3)') 'new masses:',XM1,XM2
19056       ENDIF
19057
19058 C  Lorentz transformation into system CMS
19059       PX = PA1(1)+PA2(1)
19060       PY = PA1(2)+PA2(2)
19061       PZ = PA1(3)+PA2(3)
19062       EE = PA1(4)+PA2(4)
19063       XMS = EE**2-PX**2-PY**2-PZ**2
19064       IF(XMS.LT.(XM1+XM2)**2) THEN
19065         IREJ = 1
19066         IFAIL(37) = IFAIL(37)+1
19067
19068         if((xm1.gt.1.D4).or.(xm2.gt.1.D4)) irej = irej/idev
19069
19070         IF(IDEB(40).GE.3) THEN
19071           WRITE(LO,'(/1X,A,I12)')
19072      &      'PHO_MSHELL:reject: too small string mass (KEVENT)',KEVENT
19073           WRITE(LO,'(5X,A,3E12.4)') 'two-part.mass, part.masses:',
19074      &      SIGN(SQRT(ABS(XMS)),XMS),XM1,XM2
19075           WRITE(LO,'(5X,A,4E11.4)') 'PX,PY,PZ,EE:',PX,PY,PZ,EE
19076           IDEV = 5
19077           IF(IDEB(40).GE.3) GOTO 55
19078         ENDIF
19079         RETURN
19080       ENDIF
19081       XMS = SQRT(XMS)
19082       BGX = PX/XMS
19083       BGY = PY/XMS
19084       BGZ = PZ/XMS
19085       GAM = EE/XMS
19086       CALL PHO_ALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
19087      &           PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
19088 C  rotation angles
19089       PTOT1 = MAX(DEPS,PTOT1)
19090       COD = P1(3)/PTOT1
19091       SID = SQRT(P1(1)**2+P1(2)**2)/PTOT1
19092       COF = 1.D0
19093       SIF = 0.D0
19094       IF(PTOT1*SID.GT.1.D-5) THEN
19095         COF = P1(1)/(SID*PTOT1)
19096         SIF = P1(2)/(SID*PTOT1)
19097         ANORF = SQRT(COF*COF+SIF*SIF)
19098         COF = COF/ANORF
19099         SIF = SIF/ANORF
19100       ENDIF
19101
19102 C  new CM momentum and energies (for masses XM1,XM2)
19103       XM12 = XM1**2
19104       XM22 = XM2**2
19105       SS   = XMS**2
19106       PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*XMS)
19107       EE1  = SQRT(XM12+PCMP**2)
19108       EE2  = XMS-EE1
19109 C  back rotation
19110       CALL PHO_TRANS(0.D0,0.D0,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
19111       CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
19112      &           PTOT1,P1(1),P1(2),P1(3),P1(4))
19113       CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
19114      &           PTOT2,P2(1),P2(2),P2(3),P2(4))
19115
19116 C  check consistency
19117       DEL = XMS*0.0001
19118       IF(ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
19119         IDEV = 1
19120       ELSE IF(ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
19121         IDEV = 2
19122       ELSE IF(ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
19123         IDEV = 3
19124       ELSE IF(ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
19125         IDEV = 4
19126       ENDIF
19127  55   CONTINUE
19128 C  debug output
19129       IF(IDEV.NE.0) THEN
19130         WRITE(LO,'(1X,A,I3)')
19131      &    'PHO_MSHELL: inconsistent transformation (IDEV)',IDEV
19132         WRITE(LO,'(1X,A)') 'PHO_MSHELL: input momenta:'
19133         WRITE(LO,'(5X,4E12.5)') (PA1(K),K=1,4)
19134         WRITE(LO,'(5X,4E12.5)') (PA2(K),K=1,4)
19135         WRITE(LO,'(5X,A,3E12.3)') 'ava.mass,masses:',XMS,XM1,XM2
19136         WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
19137         WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
19138         WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
19139       ELSE IF(IDEB(40).GE.10) THEN
19140         WRITE(LO,'(1X,A)') 'PHO_MSHELL: output momenta:'
19141         WRITE(LO,'(5X,4E12.5)') (P1(K),K=1,4)
19142         WRITE(LO,'(5X,4E12.5)') (P2(K),K=1,4)
19143       ENDIF
19144       END
19145
19146 *$ CREATE PHO_GLU2QU.FOR
19147 *COPY PHO_GLU2QU
19148 CDECK  ID>, PHO_GLU2QU
19149       SUBROUTINE PHO_GLU2QU(IG,IQ1,IQ2,IREJ)
19150 C********************************************************************
19151 C
19152 C    split gluon with index I in POEVT1
19153 C          (massless gluon assumed)
19154 C
19155 C    input:      /POEVT1/
19156 C                IG      gluon index
19157 C                IQ1     first quark index
19158 C                IQ2     second quark index
19159 C
19160 C    output:     new quarks in /POEVT1/
19161 C                IREJ    1 splitting impossible
19162 C                        0 splitting successful
19163 C
19164 C********************************************************************
19165       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19166       SAVE
19167
19168       PARAMETER ( DEPS   =  1.D-15,
19169      &            EPS    =  1.D-5 )
19170
19171 C  input/output channels
19172       INTEGER LI,LO
19173       COMMON /POINOU/ LI,LO
19174 C  event debugging information
19175       INTEGER NMAXD
19176       PARAMETER (NMAXD=100)
19177       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19178      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19179       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19180      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19181 C  model switches and parameters
19182       CHARACTER*8 MDLNA
19183       INTEGER ISWMDL,IPAMDL
19184       DOUBLE PRECISION PARMDL
19185       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
19186 C  standard particle data interface
19187       INTEGER NMXHEP
19188       PARAMETER (NMXHEP=4000)
19189       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
19190       DOUBLE PRECISION PHEP,VHEP
19191       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
19192      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
19193      &                VHEP(4,NMXHEP)
19194 C  extension to standard particle data interface (PHOJET specific)
19195       INTEGER IMPART,IPHIST,ICOLOR
19196       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
19197 C  internal rejection counters
19198       INTEGER NMXJ
19199       PARAMETER (NMXJ=60)
19200       CHARACTER*10 REJTIT
19201       INTEGER IFAIL
19202       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19203
19204       DIMENSION P1(4),P2(4)
19205       DATA CUTM  /0.02D0/
19206
19207       IREJ = 0
19208
19209 C  calculate string masses max possible
19210       IF(ISWMDL(9).EQ.1) THEN
19211         CMASS1=2.D0*(PHEP(4,IG)*PHEP(4,IQ1)-PHEP(1,IG)*PHEP(1,IQ1)
19212      &     -PHEP(2,IG)*PHEP(2,IQ1)-PHEP(3,IG)*PHEP(3,IQ1))
19213         IF(CMASS1.LT.CUTM) THEN
19214           IF(IDEB(73).GE.5) THEN
19215             WRITE(LO,'(1X,A,3I4,4E10.3)')
19216      &        'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS1',IG,IQ1,IQ2,CMASS1
19217           ENDIF
19218           IFAIL(33) = IFAIL(33) + 1
19219           IREJ = 1
19220           RETURN
19221         ENDIF
19222         CMASS2=2.D0*(PHEP(4,IG)*PHEP(4,IQ2)-PHEP(1,IG)*PHEP(1,IQ2)
19223      &     -PHEP(2,IG)*PHEP(2,IQ2)-PHEP(3,IG)*PHEP(3,IQ2))
19224         IF(CMASS2.LT.CUTM) THEN
19225           IF(IDEB(73).GE.5) THEN
19226             WRITE(LO,'(1X,A,3I4,4E10.3)')
19227      &        'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,CMASS2',IG,IQ1,IQ2,CMASS2
19228           ENDIF
19229           IFAIL(33) = IFAIL(33) + 1
19230           IREJ = 1
19231           RETURN
19232         ENDIF
19233 C
19234 C  calculate minimal z
19235         ZMIN1 = (CUTM-SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))/CMASS1+EPS
19236         ZMIN2 = (CUTM-SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))/CMASS2+EPS
19237         ZMIN = MIN(ZMIN1,ZMIN2)
19238         IF(MAX(ZMIN1,ZMIN2).GE.0.45D0) THEN
19239           IF(IDEB(73).GE.5) THEN
19240             WRITE(LO,'(1X,A,3I3,4E10.3)')
19241      &        'PHO_GLU2QU:REJECTION:IG,IQ1,IQ2,ZMIN1,ZMIN2,P1*PG,P2*PG',
19242      &        IG,IQ1,IQ2,ZMIN1,ZMIN2,CMASS1,CMASS2
19243           ENDIF
19244           IFAIL(33) = IFAIL(33) + 1
19245           IREJ = 1
19246           RETURN
19247         ENDIF
19248       ELSE
19249         ZMIN = MIN(0.1D0,0.5D0/PHEP(4,IG))
19250       ENDIF
19251 C
19252       ZFRAC = PHO_GLUSPL(ZMIN)
19253       IF((ZFRAC.LT.ZMIN1).OR.((1.D0-ZFRAC).LT.ZMIN2)) THEN
19254         ZFRAC = 1.D0-ZFRAC
19255       ENDIF
19256       DO 200 I=1,4
19257         P1(I) = PHEP(I,IG)*ZFRAC
19258         P2(I) = PHEP(I,IG)*(1.D0-ZFRAC)
19259  200  CONTINUE
19260 C  quark flavours
19261       CMASS1 = SQRT(ZFRAC*CMASS1+SIGN(PHEP(5,IQ1)**2,PHEP(5,IQ1)))
19262       CMASS2 = SQRT((1.D0-ZFRAC)*CMASS2
19263      &              +SIGN(PHEP(5,IQ2)**2,PHEP(5,IQ2)))
19264       CALL PHO_SEAFLA(IG,K,I,MIN(CMASS1,CMASS2))
19265       IF(ABS(IDHEP(IQ1)).GT.6) THEN
19266         K = SIGN(ABS(K),IDHEP(IQ1))
19267       ELSE
19268         K = -SIGN(ABS(K),IDHEP(IQ1))
19269       ENDIF
19270 C  colors
19271       IF(K.GT.0) THEN
19272         IC1 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
19273         IC2 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
19274       ELSE
19275         IC1 = MIN(ICOLOR(1,IG),ICOLOR(2,IG))
19276         IC2 = MAX(ICOLOR(1,IG),ICOLOR(2,IG))
19277       ENDIF
19278 C  register new partons
19279       CALL PHO_REGPAR(-1,K,0,IG,0,P1(1),P1(2),P1(3),P1(4),
19280      &            IPHIST(1,IG),0,IC1,0,IPOS,1)
19281       CALL PHO_REGPAR(-1,-K,0,IG,0,P2(1),P2(2),P2(3),P2(4),
19282      &            IPHIST(1,IG),0,IC2,0,IPOS,1)
19283 C  debug output
19284       IF(IDEB(73).GE.20) THEN
19285           WRITE(LO,'(1X,A,/1X,A,3I3,5E10.3)')
19286      &      'PHO_GLU2QU:','   IG,IQ1,IQ2,ZMIN1,2,Z,P1*PG,P2*PG',
19287      &      IG,IQ1,IQ2,ZMIN1,ZMIN2,ZFRAC,CMASS1,CMASS2
19288         WRITE(LO,'(1X,A,4I5)') '   flavours, colors  ',
19289      &    K,-K,IC1,IC2
19290       ENDIF
19291       END
19292
19293 *$ CREATE PHO_GLUSPL.FOR
19294 *COPY PHO_GLUSPL
19295 CDECK  ID>, PHO_GLUSPL
19296       DOUBLE PRECISION FUNCTION PHO_GLUSPL(ZMIN)
19297 C*********************************************************************
19298 C
19299 C     calculate quark - antiquark light cone momentum fractions
19300 C     according to Altarelli-Parisi g->q aq splitting function
19301 C     (symmetric z interval assumed)
19302 C
19303 C     input: ZMIN    minimal Z value allowed,
19304 C                    1-ZMIN maximal Z value allowed
19305 C
19306 C********************************************************************
19307       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19308       SAVE
19309
19310       PARAMETER ( ALEXP= 0.3333333333D0,
19311      &            DEPS = 1.D-10 )
19312
19313 C  input/output channels
19314       INTEGER LI,LO
19315       COMMON /POINOU/ LI,LO
19316 C  event debugging information
19317       INTEGER NMAXD
19318       PARAMETER (NMAXD=100)
19319       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19320      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19321       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19322      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19323
19324       IF(ZMIN.GE.0.5D0) THEN
19325         IF(IDEB(69).GT.2) THEN
19326           WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN>=0.5',ZMIN
19327         ENDIF
19328         ZZ=0.D0
19329         GOTO 1000
19330       ELSE IF(ZMIN.LE.0.D0) THEN
19331         IF(IDEB(69).GT.2) THEN
19332           WRITE(LO,'(1X,A,E12.4)') 'PHO_GLUSPL: ZMIN<=0',ZMIN
19333         ENDIF
19334         ZMINL = DEPS
19335       ELSE
19336         ZMINL = ZMIN
19337       ENDIF
19338
19339       ZMAX = 1.D0-ZMINL
19340       XI   = DT_RNDM(ZMAX)
19341       ZZ   = ((1.D0-XI)*ZMINL**3+XI*ZMAX**3)**ALEXP
19342       IF(DT_RNDM(ZZ).LT.0.5D0) ZZ = 1.D0-ZZ
19343
19344  1000 CONTINUE
19345       IF(IDEB(69).GE.10) THEN
19346         WRITE(LO,'(1X,A,2E12.4)') 'PHO_GLUSPL: ZMIN,Z ',ZMIN,ZZ
19347       ENDIF
19348       PHO_GLUSPL = ZZ
19349       END
19350
19351 *$ CREATE PHO_STDPAR.FOR
19352 *COPY PHO_STDPAR
19353 CDECK  ID>, PHO_STDPAR
19354       SUBROUTINE PHO_STDPAR(IJM1,IJM2,IGEN,MSPOM,MSREG,MHPOM,MHDIR,IREJ)
19355 C***********************************************************************
19356 C
19357 C     select the initial parton x-fractions and flavors and
19358 C     the final parton momenta and flavours
19359 C     for standard Pomeron/Reggeon cuts
19360 C
19361 C     input:   IJM1   index of mother particle 1 in /POEVT1/
19362 C              IJM2   index of mother particle 2 in /POEVT1/
19363 C              IGEN   production process of mother particles
19364 C              MSPOM  soft cut Pomerons
19365 C              MHPOM  hard or semihard cut Pomerons
19366 C              MSREG  soft cut Reggeons
19367 C              MHDIR  direct hard processes
19368 C
19369 C              IJM1   -1    initialization of statistics
19370 C                     -2    output of statistics
19371 C
19372 C     output:  partons are directly written to /POEVT1/,/POEVT2/
19373 C
19374 C          structure of /POSOFT/
19375 C               XS1(I),XS2(I):     x-values of initial partons
19376 C               IJSI1(I),IJSI2(I): flavor of initial parton
19377 C                                  0            gluon
19378 C                                  1,2,3,4      quarks
19379 C                                  negative     antiquarks
19380 C               IJSF1(I),IJSF2(I): flavor of final state partons
19381 C               PSOFT1(I,J),PSOFT2(I,J): final part. momentum and energy
19382 C                                J=1   PX
19383 C                                 =2   PY
19384 C                                 =3   PZ
19385 C                                 =4   ENERGY
19386 C
19387 C***********************************************************************
19388       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19389       SAVE
19390
19391       PARAMETER (RHOMAS =  0.766D0,
19392      &           DEPS   =  1.D-10,
19393      &           TINY   =  1.D-10)
19394
19395 C  input/output channels
19396       INTEGER LI,LO
19397       COMMON /POINOU/ LI,LO
19398 C  event debugging information
19399       INTEGER NMAXD
19400       PARAMETER (NMAXD=100)
19401       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
19402      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19403       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
19404      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
19405 C  model switches and parameters
19406       CHARACTER*8 MDLNA
19407       INTEGER ISWMDL,IPAMDL
19408       DOUBLE PRECISION PARMDL
19409       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
19410 C  some constants
19411       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
19412       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
19413      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
19414 C  general process information
19415       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
19416       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
19417 C  global event kinematics and particle IDs
19418       INTEGER IFPAP,IFPAB
19419       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
19420       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
19421 C  data of c.m. system of Pomeron / Reggeon exchange
19422       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
19423       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
19424      &                 SIDP,CODP,SIFP,COFP
19425       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
19426      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
19427      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
19428 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
19429       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
19430       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
19431       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
19432      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
19433 C  obsolete cut-off information
19434       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
19435       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
19436 C  currently activated parton density parametrizations
19437       CHARACTER*8 PDFNAM
19438       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
19439       DOUBLE PRECISION PDFLAM,PDFQ2M
19440       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
19441      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
19442 C  hard scattering parameters used for most recent hard interaction
19443       INTEGER NFbeta,NF
19444       DOUBLE PRECISION ALQCD2,BQCD
19445       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
19446 C  particles created by initial state evolution
19447       INTEGER MXISR1,MXISR2
19448       PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
19449       INTEGER IFLISR,IPOISR,IMXISR
19450       DOUBLE PRECISION PHISR
19451       COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
19452      &                IPOISR(2,2,MXISR2),IMXISR(2)
19453 C  light-cone x fractions and c.m. momenta of soft cut string ends
19454       INTEGER MAXSOF
19455       PARAMETER ( MAXSOF = 50 )
19456       INTEGER IJSI2,IJSI1
19457       DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
19458       COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
19459      &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
19460      &                IJSI1(MAXSOF),IJSI2(MAXSOF)
19461 C  table of particle indices for recursive PHOJET calls
19462       INTEGER MAXIPX
19463       PARAMETER ( MAXIPX = 100 )
19464       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
19465       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
19466      &                IPOIX1,IPOIX2,IPOIX3
19467 C  hard scattering data
19468       INTEGER MSCAHD
19469       PARAMETER ( MSCAHD = 50 )
19470       INTEGER LSCAHD,LSC1HD,LSIDX,
19471      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
19472       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
19473       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
19474      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
19475      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
19476      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
19477      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
19478      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
19479      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
19480 C  standard particle data interface
19481       INTEGER NMXHEP
19482       PARAMETER (NMXHEP=4000)
19483       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
19484       DOUBLE PRECISION PHEP,VHEP
19485       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
19486      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
19487      &                VHEP(4,NMXHEP)
19488 C  extension to standard particle data interface (PHOJET specific)
19489       INTEGER IMPART,IPHIST,ICOLOR
19490       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
19491 C  internal rejection counters
19492       INTEGER NMXJ
19493       PARAMETER (NMXJ=60)
19494       CHARACTER*10 REJTIT
19495       INTEGER IFAIL
19496       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
19497 C  internal cross check information on hard scattering limits
19498       DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
19499       COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)
19500 C  hard cross sections and MC selection weights
19501       INTEGER Max_pro_2
19502       PARAMETER ( Max_pro_2 = 16 )
19503       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
19504      &  MH_acc_1,MH_acc_2
19505       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
19506       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
19507      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
19508      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
19509      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
19510      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
19511
19512       double precision pho_alphas
19513
19514       DIMENSION PC(4),IFLA(2),ICI(2,2)
19515
19516       IF(IJM1.EQ.-1) THEN
19517         DO 116 I=1,15
19518           ETAMI(1,I) = 1.D10
19519           ETAMA(1,I) = -1.D10
19520           ETAMI(2,I) = 1.D10
19521           ETAMA(2,I) = -1.D10
19522           XXMI(1,I) = 1.D0
19523           XXMA(1,I) = 0.D0
19524           XXMI(2,I) = 1.D0
19525           XXMA(2,I) = 0.D0
19526  116    CONTINUE
19527         CALL PHO_HARSCA(IJM1,1)
19528         CALL PHO_HARCOL(IJM1,0.D0,0,0,0,0,0,0,0,0,0,0,0,0)
19529
19530         RETURN
19531
19532       ELSE IF(IJM1.EQ.-2) THEN
19533
19534 C  output internal statistics
19535         IF(IDEB(23).GE.1) THEN
19536           WRITE(LO,'(/1X,A)')
19537      &      'kinematic limits particle c (ETAMIN,ETAMAX,XMIN,XMAX)'
19538           DO 117 I=1,15
19539             WRITE(LO,'(5X,I3,4E13.5)')
19540      &        I,ETAMI(1,I),ETAMA(1,I),XXMI(1,I),XXMA(1,I)
19541  117      CONTINUE
19542           WRITE(LO,'(1X,A)')
19543      &      'kinematic limits particle d (ETAMIN,ETAMAX,XMIN,XMAX)'
19544           DO 118 I=1,15
19545             WRITE(LO,'(5X,I3,4E13.5)')
19546      &        I,ETAMI(2,I),ETAMA(2,I),XXMI(2,I),XXMA(2,I)
19547  118      CONTINUE
19548         ENDIF
19549         CALL PHO_HARSCA(IJM1,1)
19550         CALL PHO_HARCOL(IJM1,0.D0,0,0,0,0,0,0,0,0,0,0,0,0)
19551
19552         RETURN
19553       ENDIF
19554
19555       IREJ   = 0
19556 C  debug output
19557       IF(IDEB(23).GT.5) WRITE(LO,221) IJM1,IJM2,MSPOM,MHPOM,MSREG,MHDIR
19558   221 FORMAT (' PHO_STDPAR: JM1/2,MSPOM,MHPOM,MSREG,MHDIR ',6I5)
19559
19560 C  get mother data (exchange if first particle is a pomeron)
19561       IF((IDHEP(IJM1).EQ.990).AND.(IFPAP(1).NE.990)) THEN
19562         JM1 = IJM2
19563         JM2 = IJM1
19564       ELSE
19565         JM1 = IJM1
19566         JM2 = IJM2
19567       ENDIF
19568
19569       NPOSP(1) = JM1
19570       NPOSP(2) = JM2
19571       IDPDG1 = IDHEP(JM1)
19572       IDBAM1 = IMPART(JM1)
19573       IDPDG2 = IDHEP(JM2)
19574       IDBAM2 = IMPART(JM2)
19575
19576 C  store current status of /POEVT1/
19577       KHPOMS = KHPOM
19578       KSPOMS = KSPOM
19579       KSREGS = KSREG
19580       KHDIRS = KHDIR
19581       NHEPS  = NHEP
19582       IPOIS1 = IPOIX1
19583       IPOIS2 = IPOIX2
19584
19585 C  get nominal masses (photons: VDM assumption)
19586       DELMAS = 0.D0
19587       IF(IDHEP(JM1).EQ.22) THEN
19588         PMASSP(1) = RHOMAS+DELMAS
19589         PVIRTP(1) = PHEP(5,JM1)**2
19590       ELSE
19591         PMASSP(1) = PHO_PMASS(IDBAM1,0)+DELMAS
19592         PVIRTP(1) = 0.D0
19593       ENDIF
19594       IF(IDHEP(JM2).EQ.22) THEN
19595         PMASSP(2) = RHOMAS+DELMAS
19596         PVIRTP(2) = PHEP(5,JM2)**2
19597       ELSE
19598         PMASSP(2) = PHO_PMASS(IDBAM2,0)+DELMAS
19599         PVIRTP(2) = 0.D0
19600       ENDIF
19601
19602 C  calculate c.m. energy and check kinematics
19603       PC(1) = PHEP(1,JM1)+PHEP(1,JM2)
19604       PC(2) = PHEP(2,JM1)+PHEP(2,JM2)
19605       PC(3) = PHEP(3,JM1)+PHEP(3,JM2)
19606       PC(4) = PHEP(4,JM1)+PHEP(4,JM2)
19607       SS = (PC(4)+PC(3))*(PC(4)-PC(3))-PC(1)**2-PC(2)**2
19608
19609       IF(SS.LE.(PMASSP(1)+PMASSP(2)+DEPS)**2) THEN
19610         WRITE(LO,'(/,1X,2A)') 'PHO_STDPAR: ',
19611      &    'energy smaller than two-particle threshold (event rejected)'
19612         CALL PHO_PREVNT(1)
19613         IREJ = 5
19614         GOTO 150
19615       ENDIF
19616       ECMP = SQRT(SS)
19617
19618       IF(IDEB(23).GE.5) THEN
19619         WRITE(LO,'(1X,2A,2I7,E12.4)') 'PHO_STDPAR: ',
19620      &    'particles, available energy:',IDHEP(JM1),IDHEP(JM2),ECMP
19621         IF(IDEB(23).GE.25) CALL PHO_PREVNT(0)
19622       ENDIF
19623
19624 C  Lorentz transformation into c.m. system
19625       DO 10 I=1,4
19626         GAMBEP(I) = PC(I)/ECMP
19627  10   CONTINUE
19628       CALL PHO_ALTRA(GAMBEP(4),-GAMBEP(1),-GAMBEP(2),-GAMBEP(3),
19629      &           PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
19630      &           PHEP(4,JM1),PTOT1,PC(1),PC(2),PC(3),PC(4))
19631 C  rotation angle: particle 1 moves along +z
19632       CODP = PC(3)/PTOT1
19633       SIDP = SQRT(PC(1)**2+PC(2)**2)/PTOT1
19634       COFP = 1.D0
19635       SIFP = 0.D0
19636       IF(PTOT1*SIDP.GT.1.D-5) THEN
19637         COFP = PC(1)/(SIDP*PTOT1)
19638         SIFP = PC(2)/(SIDP*PTOT1)
19639         ANORF = SQRT(COFP*COFP+SIFP*SIFP)
19640         COFP = COFP/ANORF
19641         SIFP = SIFP/ANORF
19642       ENDIF
19643 C  get CM momentum
19644       XM12 = PMASSP(1)**2
19645       XM22 = PMASSP(2)**2
19646       PCMP = PHO_XLAM(SS,XM12,XM22)/(2.D0*ECMP)
19647
19648 C  find particle combination
19649       II = 0
19650       IF(IDPDG2.EQ.IFPAP(2)) THEN
19651         IF(IDPDG1.EQ.IFPAP(1)) II = 1
19652       ELSE IF(IDPDG2.EQ.990) THEN
19653         IF(IDPDG1.EQ.IFPAP(1)) THEN
19654           II = 2
19655         ELSE IF(IDPDG1.EQ.IFPAP(2)) THEN
19656           II = 3
19657         ELSE IF(IDPDG1.EQ.990) THEN
19658           II = 4
19659         ENDIF
19660       ENDIF
19661       IF(II.EQ.0) THEN
19662         IF(ISWMDL(14).GT.0) THEN
19663           II = 1
19664         ELSE
19665           WRITE(LO,'(/1X,2A,2I8)') 'PHO_STDPAR:ERROR: ',
19666      &      'invalid particle combination:',IDPDG1,IDPDG2
19667           CALL PHO_ABORT
19668         ENDIF
19669       ENDIF
19670
19671 C  select parton distribution functions from tables
19672       IF((MHPOM+MHDIR).GT.0) THEN
19673         CALL PHO_ACTPDF(IDPDG1,1)
19674         CALL PHO_ACTPDF(IDPDG2,2)
19675 C  initialize alpha_s calculation
19676         DUMMY = PHO_ALPHAS(0.D0,-4)
19677       ENDIF
19678
19679 C  interpolate hard cross sections and rejection weights
19680       CALL PHO_HARINT(II,ECMP,PVIRTP(1),PVIRTP(2),
19681      &            -1,Max_pro_2,1,4,MSPOM+MHPOM+MHDIR)
19682
19683       NTRY   = 10
19684
19685 C  position of first particle added to /POEVT2/
19686       NLOR1 = NHEP+1
19687
19688 C  ---------------- direct processes -----------------
19689
19690       IF(MHDIR.EQ.1) THEN
19691         CALL PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
19692         IF(IREJ.EQ.50) RETURN
19693         IF(IREJ.NE.0) GOTO 150
19694 C  write comments to /POEVT1/
19695         CALL PHO_REGPAR(25,II,NPROHD(1),IDPDG1,IDPDG2,X0HD(1,1),
19696      &    X0HD(1,2),PTHD(1),VHD(1),N0INHD(1,1),N0INHD(1,2),
19697      &    IPHO_CNV1(NOUTHD(1,1)),IPHO_CNV1(NOUTHD(1,2)),IPOS,1)
19698         CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,1)),IPDF1,JM1,JM2,
19699      &    PPH(1,1),PPH(2,1),PPH(3,1),Q2SCA(1,1),100,NBRAHD(1,1),
19700      &    ICA1,ICA2,IPOS,1)
19701         CALL PHO_REGPAR(20,IPHO_CNV1(N0INHD(1,2)),IPDF2,JM2,JM1,
19702      &    PPH(1,2),PPH(2,2),PPH(3,2),Q2SCA(1,2),100,NBRAHD(1,2),
19703      &    ICA1,ICA2,IPOS,1)
19704         CALL PHO_REGPAR(21,NOUTHD(1,1),IPDF1,JM1,JM2,PPH(5,1),
19705      &    PPH(6,1),PPH(7,1),PPH(8,1),100,NBRAHD(1,1),ICA1,ICA2,
19706      &    IPOS1,1)
19707         CALL PHO_REGPAR(21,NOUTHD(1,2),IPDF2,JM2,JM1,PPH(5,2),
19708      &    PPH(6,2),PPH(7,2),PPH(8,2),100,NBRAHD(1,2),ICA1,ICA2,
19709      &    IPOS2,1)
19710
19711 C  soft spectator partons
19712         ICA1  = 0
19713         ICA2  = 0
19714         ICB1  = 0
19715         ICB2  = 0
19716         IPDF1 = 0
19717         IPDF2 = 0
19718
19719 C  single resolved: QCD compton scattering
19720 C ------------------------------
19721         IF(NPROHD(1).EQ.10) THEN
19722 C  register hadron remnant
19723           CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
19724           IPDF2 = 1000*IGRP(2)+ISET(2)
19725         ELSE IF(NPROHD(1).EQ.12) THEN
19726 C  register hadron remnant
19727           CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
19728           IPDF1 = 1000*IGRP(1)+ISET(1)
19729
19730 C  single resolved: photon gluon fusion
19731 C ---------------------------
19732         ELSE IF(NPROHD(1).EQ.11) THEN
19733 C  register hadron remnant
19734           CALL PHO_HARREM(JM2,JM1,IGEN,-1,IVAL2,1,ICB1,ICB2,IUSED,IREJ)
19735           IPDF2 = 1000*IGRP(2)+ISET(2)
19736         ELSE IF(NPROHD(1).EQ.13) THEN
19737 C  register hadron remnant
19738           CALL PHO_HARREM(JM1,JM2,IGEN,1,IVAL1,1,ICA1,ICA2,IUSED,IREJ)
19739           IPDF1 = 1000*IGRP(1)+ISET(1)
19740
19741 C  direct process (no remnant)
19742 C ----------------------------
19743         ELSE IF(NPROHD(1).EQ.14) THEN
19744
19745         ENDIF
19746
19747 C  write final high-pt partons to POEVT1
19748         IF((ISWMDL(8).GE.2).AND.(NPROHD(1).NE.14)) THEN
19749           ICI(1,1) = ICA1
19750           ICI(1,2) = ICA2
19751           ICI(2,1) = ICB1
19752           ICI(2,2) = ICB2
19753           I = 1
19754           IFLA(1) = NINHD(I,1)
19755           IFLA(2) = NINHD(I,2)
19756 C  initial state radiation
19757           DO 130 K=1,2
19758             DO 135 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
19759               KK = 1
19760  137          CONTINUE
19761               IFLB = IFLISR(K,IPA)
19762               IF(ABS(IFLB).LE.6) THEN
19763 C  partons
19764                 IF(ICI(K,1)*ICI(K,2).NE.0) THEN
19765                   IF(IFLB.EQ.0) THEN
19766                     CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19767      &                ICI(K,1),ICI(K,2),3)
19768                   ELSE IF(IFLB.GT.0) THEN
19769                     CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19770      &                ICI(K,1),ICI(K,2),4)
19771                   ELSE
19772                     CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
19773      &                IC1,IC2,4)
19774                   ENDIF
19775                 ELSE
19776                   IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
19777                     IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
19778                       CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
19779                       KK = KK+1
19780                       GOTO 137
19781                     ENDIF
19782                   ENDIF
19783                   IF(IFLB.EQ.0) THEN
19784                     CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),ICI(K,2),
19785      &                IC1,IC2,2)
19786                   ELSE
19787                     CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
19788      &                ICI(K,1),ICI(K,2),2)
19789                   ENDIF
19790                 ENDIF
19791                 IIFL = IPHO_CNV1(IFLB)
19792                 IFLA(K) = IFLA(K)-IFLB
19793                 IST = -1
19794               ELSE
19795 C  other particle
19796                 IIFL = IFLB
19797                 IC1 = 0
19798                 IC2 = 0
19799                 IST = 1
19800               ENDIF
19801               CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
19802      &          PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),I*100+K,
19803      &          IGEN,IC1,IC2,IPOS,1)
19804  135        CONTINUE
19805  130      CONTINUE
19806           ICOLOR(1,IPOS1-2) = ICI(1,1)
19807           ICOLOR(2,IPOS1-2) = ICI(1,2)
19808           ICOLOR(1,IPOS1-1) = ICI(2,1)
19809           ICOLOR(2,IPOS1-1) = ICI(2,2)
19810           CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
19811      &      IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
19812      &      NOUTHD(I,2),ICI(2,1),ICI(2,2))
19813           ICOLOR(1,IPOS1) = ICI(1,1)
19814           ICOLOR(2,IPOS1) = ICI(1,2)
19815           ICOLOR(1,IPOS2) = ICI(2,1)
19816           ICOLOR(2,IPOS2) = ICI(2,2)
19817           DO 140 K=1,2
19818             IPA = IPOISR(K,1,I)
19819             CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
19820      &        PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
19821      &        PHISR(K,4,IPA),-I*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
19822  140      CONTINUE
19823         ELSE
19824           ICOLOR(1,IPOS1-2) = ICA1
19825           ICOLOR(2,IPOS1-2) = ICA2
19826           ICOLOR(1,IPOS1-1) = ICB1
19827           ICOLOR(2,IPOS1-1) = ICB2
19828           CALL PHO_HARCOL(NPROHD(1),VHD(1),NINHD(1,1),ICA1,ICA2,
19829      &      NINHD(1,2),ICB1,ICB2,NOUTHD(1,1),ICA1,ICA2,
19830      &      NOUTHD(1,2),ICB1,ICB2)
19831           ICOLOR(1,IPOS1) = ICA1
19832           ICOLOR(2,IPOS1) = ICA2
19833           ICOLOR(1,IPOS2) = ICB1
19834           ICOLOR(2,IPOS2) = ICB2
19835           I = -1
19836           IF(ABS(NOUTHD(1,1)).GT.12) I = 1
19837           CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,1)),0,JM1,JM2,PPH(5,1),
19838      &      PPH(6,1),PPH(7,1),PPH(8,1),-100,IGEN,ICA1,ICA2,IPOS,1)
19839           CALL PHO_REGPAR(I,IPHO_CNV1(NOUTHD(1,2)),0,JM1,JM2,PPH(5,2),
19840      &      PPH(6,2),PPH(7,2),PPH(8,2),-100,IGEN,ICB1,ICB2,IPOS,1)
19841         ENDIF
19842
19843 C  assign soft pt to spectators
19844         IF(ISWMDL(18).EQ.0) THEN
19845           IPOS2 = IPOS2-1
19846           CALL PHO_PARTPT(0,NLOR1,IPOS2,PTCUT(II),IREJ)
19847           IF(IREJ.NE.0) THEN
19848             IFAIL(26) = IFAIL(26) + 1
19849             GOTO 150
19850           ENDIF
19851
19852         ENDIF
19853
19854 C  ----------------- resolved processes -------------------
19855
19856 C  single Reggeon exchange
19857 C ----------------------------
19858       ELSE IF((MSREG.EQ.1).AND.(MHPOM+MSPOM.EQ.0)) THEN
19859 C  flavours
19860         CALL PHO_REGFLA(JM1,JM2,IFL1,IFL2,IREJ)
19861         IF(IREJ.NE.0) THEN
19862           IFAIL(24) = IFAIL(24)+1
19863           GOTO 150
19864         ENDIF
19865 C  colors
19866         CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
19867         IF(((ABS(IFL1).GT.6).AND.(IFL1.GT.0))
19868      &     .OR.((ABS(IFL1).LE.6).AND.(IFL1.LT.0))) THEN
19869           CALL PHO_SWAPI(ICA1,ICB1)
19870         ENDIF
19871         ECMH = ECMP/2.D0
19872
19873 C  registration
19874
19875 C  DPMJET call with special projectile / target
19876         IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
19877           CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH*XPSUB,
19878      &               ECMH*XPSUB,-1,IGEN,ICA1,0,IPOS1,1)
19879           CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH*XTSUB,
19880      &               ECMH*XTSUB,-1,IGEN,ICB1,0,IPOS2,1)
19881 C  default treatment
19882         ELSE
19883           CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,0.D0,0.D0,ECMH,ECMH,
19884      &      -1,IGEN,ICA1,0,IPOS1,1)
19885           CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,0.D0,0.D0,-ECMH,ECMH,
19886      &      -1,IGEN,ICB1,0,IPOS2,1)
19887         ENDIF
19888
19889 C  soft pt assignment
19890         IF(ISWMDL(18).EQ.0) THEN
19891           CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
19892           IF(IREJ.NE.0) THEN
19893             IFAIL(25) = IFAIL(25) + 1
19894             GOTO 150
19895           ENDIF
19896         ENDIF
19897 C
19898 C  multi Reggeon / Pomeron exchange
19899 C----------------------------------------
19900       ELSE
19901 C  parton configuration
19902
19903         CALL PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,MSPAR1,MSPAR2,
19904      &              MHPAR1,MHPAR2,IREJ)
19905
19906         IF(IREJ.EQ.50) RETURN
19907         IF(IREJ.NE.0) GOTO 150
19908
19909 C  register particles
19910         IF(IDEB(23).GE.15) WRITE(LO,'(1X,A,/15X,7I5)')
19911      &    'PHO_STDPAR: MSPOM,MHPOM,MSREG,MSPAR1/2,IVAL1/2',
19912      &    MSPOM,MHPOM,MSREG,MSPAR1,MSPAR2,IVAL1,IVAL2
19913
19914 C  register soft partons
19915         IF(IVAL1.NE.0) THEN
19916           IF(IVAL1.LT.0) THEN
19917             IND1 = 3
19918             IVAL1=-IVAL1
19919           ELSE
19920             IND1 = 2
19921           ENDIF
19922         ELSE IF(MSPOM.EQ.0) THEN
19923           IND1 = 4
19924         ELSE
19925           IND1 = 1
19926         ENDIF
19927         IF(IVAL2.NE.0) THEN
19928           IF(IVAL2.LT.0) THEN
19929             IND2 = 3
19930             IVAL2=-IVAL2
19931           ELSE
19932             IND2 = 2
19933           ENDIF
19934         ELSE IF(MSPOM.EQ.0) THEN
19935           IND2 = 4
19936         ELSE
19937           IND2 = 1
19938         ENDIF
19939
19940         IF(IDEB(23).GE.20) WRITE(LO,'(1X,A,2I3,2X,2I3)')
19941      &    'PHO_STDPAR: IND1/2,IVAL1/2',IND1,IND2,IVAL1,IVAL2
19942
19943 C  soft Pomeron final states
19944 C -----------------------------------
19945         K = MSPOM+MHPOM+MSREG
19946         DO 50 I=1,MSPOM
19947
19948           CALL PHO_POSPOM(II,IND1,IND2,IGEN,I,K,ISWAP,IREJ)
19949           IF(IREJ.NE.0) THEN
19950             IFAIL(8) = IFAIL(8) + 1
19951             GOTO 150
19952           ENDIF
19953 C
19954  50     CONTINUE
19955
19956 C  soft Reggeon final states
19957 C -----------------------------------------
19958         DO 75 I=1,MSREG
19959 C  flavours
19960           CMASS1 = MIN(PSOFT1(4,IND1),PSOFT2(4,IND2))
19961           IF(DT_RNDM(CMASS1).LT.0.5D0) THEN
19962             CALL PHO_SEAFLA(JM1,IFLA1,IFLB1,CMASS1)
19963           ELSE
19964             CALL PHO_SEAFLA(JM2,IFLA1,IFLB1,CMASS1)
19965           ENDIF
19966 C  colors
19967           CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
19968           IF(((ABS(IFLA1).GT.6).AND.(IFLA1.GT.0))
19969      &      .OR.((ABS(IFLA1).LE.6).AND.(IFLA1.LT.0)))
19970      &      CALL PHO_SWAPI(ICA1,ICB1)
19971 C  registration
19972           CALL PHO_REGPAR(-1,IFLA1,0,JM1,JM2,PSOFT1(1,IND1),
19973      &      PSOFT1(2,IND1),PSOFT1(3,IND1),PSOFT1(4,IND1),
19974      &      I,IGEN,ICA1,ICA2,IPOS1,1)
19975           IND1 = IND1+1
19976           CALL PHO_REGPAR(-1,IFLB1,0,JM2,JM1,PSOFT2(1,IND2),
19977      &      PSOFT2(2,IND2),PSOFT2(3,IND2),PSOFT2(4,IND2),
19978      &      I,IGEN,ICB1,ICB2,IPOS2,1)
19979           IND2 = IND2+1
19980
19981           IF(IDEB(23).GE.20) WRITE(LO,'(1X,A,/15X,6I4)')
19982      &      'PHO_STDPAR: reg.cut: IND1,IND2,IFLA,IFLB,IPOS1,IPOS2',
19983      &      IND1-1,IND2-1,IFLA1,IFLB1,IPOS1,IPOS2
19984
19985 C  soft pt assignment
19986           IF(ISWMDL(18).EQ.0) THEN
19987             CALL PHO_PARTPT(0,IPOS1,IPOS2,PTCUT(II),IREJ)
19988             IF(IREJ.NE.0) THEN
19989               IFAIL(25) = IFAIL(25) + 1
19990               GOTO 150
19991             ENDIF
19992           ENDIF
19993
19994  75     CONTINUE
19995
19996 C  hard Pomeron final states
19997 C ------------------------------------
19998         IND1 = MSPAR1
19999         IND2 = MSPAR2
20000
20001         DO 100 L=1,MHPOM
20002           I = LSIDX(L)
20003
20004           IFLI1 = IPHO_CNV1(N0INHD(I,1))
20005           IFLI2 = IPHO_CNV1(N0INHD(I,2))
20006           IFLO1 = IPHO_CNV1(NOUTHD(I,1))
20007           IFLO2 = IPHO_CNV1(NOUTHD(I,2))
20008 C  write comments to /POEVT1/
20009           CALL PHO_REGPAR(25,II,NPROHD(I),IDPDG1,IDPDG2,X0HD(I,1),
20010      &      X0HD(I,2),PTHD(I),VHD(I),N0INHD(I,1),N0INHD(I,2),
20011      &      IFLO1,IFLO2,IPOS,1)
20012           I1 = 8*I-7
20013           IPDF = 1000*IGRP(1)+ISET(1)
20014           CALL PHO_REGPAR(20,IFLI1,IPDF,JM1,JM2,PPH(I1,1),
20015      &      PPH(I1+1,1),PPH(I1+2,1),Q2SCA(I,1),L*100,NBRAHD(I,1),
20016      &      ICA1,ICA2,IPOS,1)
20017           IPDF = 1000*IGRP(2)+ISET(2)
20018           CALL PHO_REGPAR(20,IFLI2,IPDF,JM2,JM1,PPH(I1,2),
20019      &      PPH(I1+1,2),PPH(I1+2,2),Q2SCA(I,2),L*100,NBRAHD(I,2),
20020      &      ICB1,ICB2,IPOS,1)
20021           I1 = 8*I-3
20022           IPDF = 1000*IGRP(1)+ISET(1)
20023           CALL PHO_REGPAR(21,IFLO1,IPDF,JM1,JM2,PPH(I1,1),
20024      &      PPH(I1+1,1),PPH(I1+2,1),PPH(I,1),L*100,NBRAHD(I,1),
20025      &      ICA1,ICA2,IPOS1,1)
20026           IPDF = 1000*IGRP(2)+ISET(2)
20027           CALL PHO_REGPAR(21,IFLO2,IPDF,JM2,JM1,PPH(I1,2),
20028      &      PPH(I1+1,2),PPH(I1+2,2),PPH(I,2),L*100,NBRAHD(I,2),
20029      &      ICB1,ICB2,IPOS2,1)
20030
20031 C  spectator partons belonging to hard interaction
20032           IF(IVAL1.EQ.I) THEN
20033             IVQ = 1
20034             IND = 1
20035           ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL1.EQ.0)) THEN
20036             IVQ = 0
20037             IND = 1
20038           ELSE
20039             IVQ = -1
20040             IND = IND1
20041           ENDIF
20042           CALL PHO_HARREM(JM1,JM2,IGEN,L,IVQ,IND,ICA1,ICA2,IUSED,IREJ)
20043           IF(IVQ.LT.0) IND1 = IND1-IUSED
20044           IF(IVAL2.EQ.I) THEN
20045             IVQ = 1
20046             IND = 1
20047           ELSE IF((MSPOM.EQ.0).AND.(L.EQ.1).AND.(IVAL2.EQ.0)) THEN
20048             IVQ = 0
20049             IND = 1
20050           ELSE
20051             IVQ = -1
20052             IND = IND2
20053           ENDIF
20054           CALL PHO_HARREM(JM2,JM1,IGEN,-L,IVQ,IND,ICB1,ICB2,IUSED,IREJ)
20055           IF(IVQ.LT.0) IND2 = IND2-IUSED
20056 C
20057 C  register hard scattered partons
20058           IF((ISWMDL(8).GE.2)
20059      &       .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
20060             ICI(1,1) = ICA1
20061             ICI(1,2) = ICA2
20062             ICI(2,1) = ICB1
20063             ICI(2,2) = ICB2
20064             IFLA(1) = NINHD(I,1)
20065             IFLA(2) = NINHD(I,2)
20066 C  initial state radiation
20067             DO 230 K=1,2
20068               DO 235 IPA=IPOISR(K,2,I),IPOISR(K,1,I)+1,-1
20069                 KK = 1
20070  237            CONTINUE
20071                 IFLB = IFLISR(K,IPA)
20072                 IF(ABS(IFLB).LE.6) THEN
20073 C  partons
20074                   IF(ICI(K,1)*ICI(K,2).NE.0) THEN
20075                     IF(IFLB.EQ.0) THEN
20076                       CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20077      &                  ICI(K,1),ICI(K,2),3)
20078                     ELSE IF(IFLB.GT.0) THEN
20079                       CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20080      &                  ICI(K,1),ICI(K,2),4)
20081                     ELSE
20082                       CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
20083      &                  ICI(K,2),IC1,IC2,4)
20084                     ENDIF
20085                   ELSE
20086                     IF((ICI(K,1)+ICI(K,2))*IFLB.LT.0) THEN
20087                       IF(IPA-KK.GT.IPOISR(K,1,I)) THEN
20088                         CALL PHO_SWAPI(IFLISR(K,IPA),IFLISR(K,IPA-KK))
20089                         KK = KK+1
20090                         GOTO 237
20091                       ENDIF
20092                     ENDIF
20093                     IF(IFLB.EQ.0) THEN
20094                       CALL PHO_SELCOL(ICI(K,1),ICI(K,2),ICI(K,1),
20095      &                  ICI(K,2),IC1,IC2,2)
20096                     ELSE
20097                       CALL PHO_SELCOL(ICI(K,1),ICI(K,2),IC1,IC2,
20098      &                  ICI(K,1),ICI(K,2),2)
20099                     ENDIF
20100                   ENDIF
20101                   IIFL = IPHO_CNV1(IFLB)
20102                   IFLA(K)  = IFLA(K)-IFLB
20103                   IST = -1
20104                 ELSE
20105 C  other particles
20106                   IIFL = IFLB
20107                   IC1 = 0
20108                   IC2 = 0
20109                   IST = 1
20110                 ENDIF
20111                 CALL PHO_REGPAR(IST,IIFL,0,JM1,JM2,PHISR(K,1,IPA),
20112      &            PHISR(K,2,IPA),PHISR(K,3,IPA),PHISR(K,4,IPA),
20113      &            L*100+K,IGEN,IC1,IC2,IPOS,1)
20114  235          CONTINUE
20115  230        CONTINUE
20116             ICOLOR(1,IPOS1-2) = ICI(1,1)
20117             ICOLOR(2,IPOS1-2) = ICI(1,2)
20118             ICOLOR(1,IPOS1-1) = ICI(2,1)
20119             ICOLOR(2,IPOS1-1) = ICI(2,2)
20120             CALL PHO_HARCOL(NPROHD(I),VHD(I),IFLA(1),ICI(1,1),ICI(1,2),
20121      &        IFLA(2),ICI(2,1),ICI(2,2),NOUTHD(I,1),ICI(1,1),ICI(1,2),
20122      &        NOUTHD(I,2),ICI(2,1),ICI(2,2))
20123             ICOLOR(1,IPOS1) = ICI(1,1)
20124             ICOLOR(2,IPOS1) = ICI(1,2)
20125             ICOLOR(1,IPOS2) = ICI(2,1)
20126             ICOLOR(2,IPOS2) = ICI(2,2)
20127             DO 240 K=1,2
20128               IPA = IPOISR(K,1,I)
20129               CALL PHO_REGPAR(-1,IPHO_CNV1(IFLISR(K,IPA)),0,JM1,JM2,
20130      &          PHISR(K,1,IPA),PHISR(K,2,IPA),PHISR(K,3,IPA),
20131      &          PHISR(K,4,IPA),-L*100,IGEN,ICI(K,1),ICI(K,2),IPOS,1)
20132  240        CONTINUE
20133           ELSE
20134             ICOLOR(1,IPOS1-2) = ICA1
20135             ICOLOR(2,IPOS1-2) = ICA2
20136             ICOLOR(1,IPOS1-1) = ICB1
20137             ICOLOR(2,IPOS1-1) = ICB2
20138             CALL PHO_HARCOL(NPROHD(I),VHD(I),NINHD(I,1),ICA1,ICA2,
20139      &        NINHD(I,2),ICB1,ICB2,NOUTHD(I,1),ICA1,ICA2,
20140      &        NOUTHD(I,2),ICB1,ICB2)
20141             ICOLOR(1,IPOS1) = ICA1
20142             ICOLOR(2,IPOS1) = ICA2
20143             ICOLOR(1,IPOS2) = ICB1
20144             ICOLOR(2,IPOS2) = ICB2
20145             I1 = 8*I-3
20146             CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,1)),0,JM1,JM2,
20147      &        PPH(I1,1),PPH(I1+1,1),PPH(I1+2,1),PPH(I1+3,1),-L*100,IGEN,
20148      &        ICA1,ICA2,IPOS,1)
20149             CALL PHO_REGPAR(-1,IPHO_CNV1(NOUTHD(I,2)),0,JM1,JM2,
20150      &        PPH(I1,2),PPH(I1+1,2),PPH(I1+2,2),PPH(I1+3,2),-L*100,IGEN,
20151      &        ICB1,ICB2,IPOS,1)
20152           ENDIF
20153  100    CONTINUE
20154 C  end of resolved parton registration
20155       ENDIF
20156
20157       IF(MHDIR+MHPOM.GT.0) THEN
20158
20159         IF(ISWMDL(29).GE.1) THEN
20160 C  primordial kt of hard scattering
20161           CALL PHO_PRIMKT(1,NLOR1,NHEP,PTCUT(II),IREJ)
20162           IF(IREJ.NE.0) THEN
20163             IFAIL(27) = IFAIL(27)+1
20164             GOTO 150
20165           ENDIF
20166         ELSE IF(ISWMDL(24).GE.0) THEN
20167 C  give "soft" pt only to soft (spectator) partons in hard processes
20168           CALL PHO_PARTPT(1,NLOR1,NHEP,PTCUT(II),IREJ)
20169           IF(IREJ.NE.0) THEN
20170             IFAIL(26) = IFAIL(26)+1
20171             GOTO 150
20172           ENDIF
20173         ENDIF
20174
20175       ENDIF
20176
20177 C  give "soft" pt to partons in soft Pomerons
20178       IF((MHDIR.EQ.0).AND.(ISWMDL(18).EQ.1)) THEN
20179         CALL PHO_PARTPT(0,NLOR1,NHEP,PTCUT(II),IREJ)
20180         IF(IREJ.NE.0) THEN
20181           IFAIL(25) = IFAIL(25) + 1
20182           GOTO 150
20183         ENDIF
20184       ENDIF
20185
20186 C  boost back to lab frame
20187       CALL PHO_LTRHEP(NLOR1,NHEP,CODP,SIDP,COFP,SIFP,GAMBEP(4),
20188      &  GAMBEP(1),GAMBEP(2),GAMBEP(3))
20189       RETURN
20190
20191 C  rejection treatment
20192  150  CONTINUE
20193       IFAIL(2) = IFAIL(2)+1
20194 C  reset counters
20195       KSPOM = KSPOMS
20196       KHPOM = KHPOMS
20197       KHDIR = KHDIRS
20198       KSREG = KSREGS
20199 C  reset mother-daugther relations
20200       JDAHEP(1,JM1) = 0
20201       JDAHEP(2,JM1) = 0
20202       JDAHEP(1,JM2) = 0
20203       JDAHEP(2,JM2) = 0
20204       ISTHEP(JM1) = 1
20205       ISTHEP(JM2) = 1
20206       IPOIX1 = IPOIS1
20207       IPOIX2 = IPOIS2
20208       NHEP   = NHEPS
20209 C  debug
20210       IF(IDEB(23).GT.2) WRITE(LO,'(/1X,A,4I6)')
20211      &  'PHO_STDPAR: rejection (MSPOM,MHPOM,MSREG,MHDIR)',
20212      &  MSPOM,MHPOM,MSREG,MHDIR
20213       RETURN
20214
20215       END
20216
20217 *$ CREATE PHO_HARCOL.FOR
20218 *COPY PHO_HARCOL
20219 CDECK  ID>, PHO_HARCOL
20220       SUBROUTINE PHO_HARCOL(MSPR,V,IP1,ICA1,ICA2,IP2,ICB1,ICB2,
20221      &                  IP3,ICC1,ICC2,IP4,ICD1,ICD2)
20222 C*********************************************************************
20223 C
20224 C     calculate color flow for hard resolved process
20225 C
20226 C     input:    IP1..4  flavour of partons (PDG convention)
20227 C               V       parton subprocess Mandelstam variable  V = t/s
20228 C                       (lightcone momenta assumed)
20229 C               ICA,ICB color labels
20230 C               MSPR    process number
20231 C                       -1   initialization of statistics
20232 C                       -2   output of statistics
20233 C
20234 C     output:   ICC,ICD color label of final partons
20235 C
20236 C     (it is possible to use the same variables for in and output)
20237 C
20238 C**********************************************************************
20239       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20240       SAVE
20241
20242 C  input/output channels
20243       INTEGER LI,LO
20244       COMMON /POINOU/ LI,LO
20245 C  event debugging information
20246       INTEGER NMAXD
20247       PARAMETER (NMAXD=100)
20248       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
20249      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20250       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
20251      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20252 C  model switches and parameters
20253       CHARACTER*8 MDLNA
20254       INTEGER ISWMDL,IPAMDL
20255       DOUBLE PRECISION PARMDL
20256       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
20257 C  names of hard scattering processes
20258       INTEGER Max_pro_1
20259       PARAMETER ( Max_pro_1 = 16 )
20260       CHARACTER*18 PROC
20261       COMMON /POHPRO/ PROC(0:Max_pro_1)
20262
20263       DIMENSION PC(3),ICONF(8,5),IRECN(8,2)
20264
20265 C  initialization
20266       IF(MSPR.EQ.-1) THEN
20267         DO 200 I=1,8
20268           DO 210 K=1,5
20269             ICONF(I,K) = 0
20270  210      CONTINUE
20271           IRECN(I,1) = 0
20272           IRECN(I,2) = 0
20273  200    CONTINUE
20274         RETURN
20275 C  output of statistics
20276       ELSE IF(MSPR.EQ.-2) THEN
20277         IF(IDEB(26).LT.1) RETURN
20278         WRITE(LO,'(/1X,A,/1X,A)')
20279      &    'PHO_HARCOL: sampled color configurations',
20280      &    '----------------------------------------'
20281         WRITE(LO,'(6X,A,15X,A)')
20282      &    'diagram                  color configurations (1-4)','sum'
20283         DO 300 I=1,8
20284           DO 310 K=1,4
20285             ICONF(I,5) = ICONF(I,5) + ICONF(I,K)
20286  310      CONTINUE
20287           WRITE(LO,'(2X,A,4I11,I12)') PROC(I),(ICONF(I,K),K=1,5)
20288  300    CONTINUE
20289         IF(ISWMDL(11).GE.2) THEN
20290           WRITE(LO,'(/6X,A)')
20291      &      'diagram             with   /   without color re-connection'
20292           DO 320 I=1,8
20293             WRITE(LO,'(2X,A,2I11)') PROC(I),IRECN(I,1),IRECN(I,2)
20294  320      CONTINUE
20295         ENDIF
20296         RETURN
20297       ENDIF
20298 C
20299 C  gluons: first color positive, quarks second color zero
20300       IF(IP1.EQ.0) THEN
20301         IF(ICA1.LT.0) THEN
20302           I = ICA2
20303           ICA2 = ICA1
20304           ICA1 = I
20305         ENDIF
20306       ELSE
20307         ICA2 = 0
20308       ENDIF
20309       IF(IP2.EQ.0) THEN
20310         IF(ICB1.LT.0) THEN
20311           I = ICB2
20312           ICB2 = ICB1
20313           ICB1 = I
20314         ENDIF
20315       ELSE
20316         ICB2 = 0
20317       ENDIF
20318       IC2 = 0
20319       IC4 = 0
20320 C  debug output
20321       IF(IDEB(26).GE.15)
20322      &  WRITE(LO,'(1X,A,I4,/,5X,A,3I5,2X,3I5)')
20323      &  'PHO_HARCOL: process',MSPR,
20324      &  'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
20325 C
20326       IRC = 0
20327       IF(IPAMDL(21).EQ.1) THEN
20328 C
20329 C  soft color re-connection option
20330 C
20331         IF(MSPR.EQ.1) THEN
20332 C  hard g g final state, only g g --> g g
20333           IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
20334             IF(DT_RNDM(V).LT.PARMDL(140)) THEN
20335               IC1 = ICA1
20336               IC2 = ICA2
20337               IC3 = ICB1
20338               IC4 = ICB2
20339               IRECN(MSPR,1) = IRECN(MSPR,1)+1
20340               IRC = 1
20341               GOTO 100
20342             ENDIF
20343           ENDIF
20344         ELSE IF(MSPR.EQ.3) THEN
20345 C  hard q g final state
20346           IF((ICA1.NE.-ICA2).AND.(ICB1.NE.-ICB2)) THEN
20347             IF(DT_RNDM(V).LT.PARMDL(141)) THEN
20348               IC1 = ICA1
20349               IC2 = ICA2
20350               IC3 = ICB1
20351               IC4 = ICB2
20352               IRECN(MSPR,1) = IRECN(MSPR,1)+1
20353               IRC = 1
20354               GOTO 100
20355             ENDIF
20356           ENDIF
20357         ELSE IF((MSPR.EQ.5).OR.(MSPR.EQ.7).OR.(MSPR.EQ.8)) THEN
20358 C  hard q q final state
20359           IF(ICA1.NE.-ICB1) THEN
20360             IF(DT_RNDM(V).LT.PARMDL(142)) THEN
20361               IC1 = ICA1
20362               IC2 = ICA2
20363               IC3 = ICB1
20364               IC4 = ICB2
20365               IRECN(MSPR,1) = IRECN(MSPR,1)+1
20366               IRC = 1
20367               GOTO 100
20368             ENDIF
20369           ENDIF
20370         ENDIF
20371         IRECN(MSPR,2) = IRECN(MSPR,2)+1
20372       ENDIF
20373 C
20374       IF((ISWMDL(11).EQ.1).AND.(MSPR.LT.10)) THEN
20375 C
20376 C  large Nc limit of all graphs
20377 C
20378         IF(MSPR.EQ.1) THEN
20379 C  g g --> g g
20380           IF(DT_RNDM(V).GT.0.5D0) THEN
20381             IC1 = ICB1
20382             IC2 = ICA2
20383             IC3 = ICA1
20384             IC4 = ICB2
20385             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20386           ELSE
20387             IC1 = ICA1
20388             IC2 = ICB2
20389             IC3 = ICB1
20390             IC4 = ICA2
20391             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20392           ENDIF
20393         ELSE IF(MSPR.EQ.2) THEN
20394 C  q qb --> g g
20395           CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20396           IF(ICA1.LT.0) THEN
20397             IC1 = I1
20398             IC2 = ICA1
20399             IC3 = ICB1
20400             IC4 = I2
20401             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20402           ELSE
20403             IC1 = ICA1
20404             IC2 = I2
20405             IC3 = I1
20406             IC4 = ICB1
20407             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20408           ENDIF
20409         ELSE IF(MSPR.EQ.3) THEN
20410 C  q g --> q g
20411           IF(DT_RNDM(V).LT.0.5D0) THEN
20412             IF(IP1+IP2.GT.0) THEN
20413               IC1 = ICB1
20414               IC2 = ICA2
20415               IC3 = ICA1
20416               IC4 = ICB2
20417             ELSE IF(IP1.LT.0) THEN
20418               IC1 = ICB2
20419               IC3 = ICB1
20420               IC4 = ICA1
20421             ELSE
20422               IC1 = ICA1
20423               IC2 = ICB1
20424               IC3 = ICA2
20425             ENDIF
20426             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20427           ELSE
20428             IF(IP1.GT.0) THEN
20429               CALL PHO_HARCOR(-ICA1,ICB2)
20430               IC1 = ICA1
20431               IC3 = ICB1
20432               IC4 = -ICA1
20433             ELSE IF(IP2.GT.0) THEN
20434               CALL PHO_HARCOR(-ICB1,ICA2)
20435               IC1 = ICA1
20436               IC2 = -ICB1
20437               IC3 = ICB1
20438             ELSE IF(IP1.LT.0) THEN
20439               CALL PHO_HARCOR(-ICA1,ICB1)
20440               IC1 = ICA1
20441               IC3 = -ICA1
20442               IC4 = ICB2
20443             ELSE IF(IP2.LT.0) THEN
20444               CALL PHO_HARCOR(-ICB1,ICA1)
20445               IC1 = -ICB1
20446               IC2 = ICA2
20447               IC3 = ICB1
20448             ENDIF
20449             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20450           ENDIF
20451         ELSE IF(MSPR.EQ.4) THEN
20452 C  g g --> q qb
20453           IC1 = ICA1
20454           IC3 = ICB2
20455           CALL PHO_HARCOR(-ICB1,ICA2)
20456           IF(ICB2.EQ.-ICB1) IC3 = ICA2
20457           IF(IP3*IC1.LT.0) THEN
20458             I = IC1
20459             IC1 = IC3
20460             IC3 = I
20461           ENDIF
20462           ICONF(MSPR,2) = ICONF(MSPR,2)+1
20463         ELSE IF(MSPR.EQ.5) THEN
20464 C  q qb --> q qb
20465           IF(DT_RNDM(V).LT.0.5D0) THEN
20466             IF(ICA1*IP3.LT.0) THEN
20467               IC1 = ICB1
20468               IC3 = ICA1
20469             ELSE
20470               IC1 = ICA1
20471               IC3 = ICB1
20472             ENDIF
20473             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20474           ELSE
20475             IF(ICA1*IP3.LT.0) THEN
20476               IC1 = -ICA1
20477               IC3 = ICA1
20478             ELSE
20479               IC1 = ICA1
20480               IC3 = -ICA1
20481             ENDIF
20482             CALL PHO_HARCOR(-ICA1,ICB1)
20483             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20484           ENDIF
20485         ELSE IF(MSPR.EQ.6) THEN
20486 C  q qb --> qp qbp
20487           IF(ICA1*IP3.LT.0) THEN
20488             IC1 = ICB1
20489             IC3 = ICA1
20490             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20491           ELSE
20492             IC1 = ICA1
20493             IC3 = ICB1
20494             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20495           ENDIF
20496         ELSE IF(MSPR.EQ.7) THEN
20497 C  q q --> q q
20498           IF(DT_RNDM(V).LT.0.5D0) THEN
20499             IC1 = ICA1
20500             IC3 = ICB1
20501             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20502           ELSE
20503             IC1 = ICB1
20504             IC3 = ICA1
20505             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20506           ENDIF
20507         ELSE IF(MSPR.EQ.8) THEN
20508 C  q qp --> q qp
20509           IF(IP1*IP2.GT.0) THEN
20510             IF(IP3.EQ.IP1) THEN
20511               IC1 = ICB1
20512               IC3 = ICA1
20513             ELSE
20514               IC1 = ICA1
20515               IC3 = ICB1
20516             ENDIF
20517             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20518           ELSE
20519             IF(ICA1*IP3.LT.0) THEN
20520               IC1 = -ICA1
20521               IC3 = ICA1
20522             ELSE
20523               IC1 = ICA1
20524               IC3 = -ICA1
20525             ENDIF
20526             CALL PHO_HARCOR(-ICA1,ICB1)
20527             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20528           ENDIF
20529         ELSE
20530 C  unknown process
20531           WRITE(LO,'(/1X,A,I3)')
20532      &      'PHO_HARCOL:ERROR:invalid process number (MSPR)',MSPR
20533           CALL PHO_ABORT
20534         ENDIF
20535 C
20536       ELSE
20537 C
20538 C  color flow according to QCD leading order matrix element
20539 C
20540         U = -(1.D0+V)
20541         IF(MSPR.EQ.1) THEN
20542 C  g g --> g g
20543           PC(1) = 1/V**2  +2.D0/V    +3.D0  +2.D0*V    +V**2
20544           PC(2) = 1/U**2  +2.D0/U    +3.D0  +2.D0*U    +U**2
20545           PC(3) = (V/U)**2+2.D0*(V/U)+3.D0  +2.D0*(U/V)+(U/V)**2
20546           XI = (PC(1)+PC(2)+PC(3))*DT_RNDM(U)
20547           PCS = 0.D0
20548           DO 110 I=1,3
20549             PCS = PCS+PC(I)
20550             IF(XI.LT.PCS) GOTO 120
20551  110      CONTINUE
20552  120      CONTINUE
20553           IF(I.EQ.1) THEN
20554             CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20555             IF(DT_RNDM(V).GT.0.5D0) THEN
20556               IC1 = I1
20557               IC2 = ICA2
20558               IC3 = ICB1
20559               IC4 = I2
20560               CALL PHO_HARCOR(-ICB2,ICA1)
20561               IF(ICB1.EQ.-ICB2) IC3 = ICA1
20562             ELSE
20563               IC1 = ICA1
20564               IC2 = I2
20565               IC3 = I1
20566               IC4 = ICB2
20567               CALL PHO_HARCOR(-ICB1,ICA2)
20568               IF(ICB2.EQ.-ICB1) IC4 = ICA2
20569             ENDIF
20570           ELSE IF(I.EQ.2) THEN
20571             CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20572             IF(DT_RNDM(U).GT.0.5D0) THEN
20573               IC1 = ICB1
20574               IC2 = I2
20575               IC3 = I1
20576               IC4 = ICA2
20577               CALL PHO_HARCOR(-ICB2,ICA1)
20578               IF(ICB1.EQ.-ICB2) IC1 = ICA1
20579             ELSE
20580               IC1 = I1
20581               IC2 = ICB2
20582               IC3 = ICA1
20583               IC4 = I2
20584               CALL PHO_HARCOR(-ICB1,ICA2)
20585               IF(ICB2.EQ.-ICB1) IC2 = ICA2
20586             ENDIF
20587           ELSE
20588             IF(DT_RNDM(V).GT.0.5D0) THEN
20589               IC1 = ICB1
20590               IC2 = ICA2
20591               IC3 = ICA1
20592               IC4 = ICB2
20593             ELSE
20594               IC1 = ICA1
20595               IC2 = ICB2
20596               IC3 = ICB1
20597               IC4 = ICA2
20598             ENDIF
20599           ENDIF
20600           ICONF(MSPR,I) = ICONF(MSPR,I)+1
20601         ELSE IF(MSPR.EQ.2) THEN
20602 C  q qb --> g g
20603           PC(1) = U/V-2.D0*U**2
20604           PC(2) = V/U-2.D0*V**2
20605           CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20606           XI = (PC(1)+PC(2))*DT_RNDM(U)
20607           IF(XI.LT.PC(1)) THEN
20608             IF(ICA1.GT.0) THEN
20609               IC1 = ICA1
20610               IC2 = I2
20611               IC3 = I1
20612               IC4 = ICB1
20613               ICONF(MSPR,1) = ICONF(MSPR,1)+1
20614             ELSE
20615               IC1 = I1
20616               IC2 = ICA1
20617               IC3 = ICB1
20618               IC4 = I2
20619               ICONF(MSPR,2) = ICONF(MSPR,2)+1
20620             ENDIF
20621           ELSE
20622             IF(ICA1.GT.0) THEN
20623               IC1 = I1
20624               IC2 = ICB1
20625               IC3 = ICA1
20626               IC4 = I2
20627               ICONF(MSPR,3) = ICONF(MSPR,3)+1
20628             ELSE
20629               IC1 = ICB1
20630               IC2 = I2
20631               IC3 = I1
20632               IC4 = ICA1
20633               ICONF(MSPR,4) = ICONF(MSPR,4)+1
20634             ENDIF
20635           ENDIF
20636         ELSE IF(MSPR.EQ.3) THEN
20637 C  q g --> q g
20638           PC(1) = 2.D0*(U/V)**2-U
20639           PC(2) = 2.D0/V**2-1.D0/U
20640           XI = (PC(1)+PC(2))*DT_RNDM(V)
20641           IF(XI.LT.PC(1)) THEN
20642             CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20643             IF(IP1.GT.0) THEN
20644               IC1 = I1
20645               IC3 = ICB1
20646               IC4 = I2
20647               CALL PHO_HARCOR(-ICA1,ICB2)
20648               ICONF(MSPR,1) = ICONF(MSPR,1)+1
20649             ELSE IF(IP1.LT.0) THEN
20650               IC1 = I2
20651               IC3 = I1
20652               IC4 = ICB2
20653               CALL PHO_HARCOR(-ICA1,ICB1)
20654               ICONF(MSPR,1) = ICONF(MSPR,1)+1
20655             ELSE IF(IP2.GT.0) THEN
20656               IC1 = ICA1
20657               IC2 = I2
20658               IC3 = I1
20659               CALL PHO_HARCOR(-ICB1,ICA2)
20660               ICONF(MSPR,2) = ICONF(MSPR,2)+1
20661             ELSE
20662               IC1 = I1
20663               IC2 = ICA2
20664               IC3 = I2
20665               CALL PHO_HARCOR(-ICB1,ICA1)
20666               ICONF(MSPR,2) = ICONF(MSPR,2)+1
20667             ENDIF
20668           ELSE
20669             IF(IP1.GT.0) THEN
20670               IC1 = ICB1
20671               IC3 = ICA1
20672               IC4 = ICB2
20673               ICONF(MSPR,3) = ICONF(MSPR,3)+1
20674             ELSE IF(IP1.LT.0) THEN
20675               IC1 = ICB2
20676               IC3 = ICB1
20677               IC4 = ICA1
20678               ICONF(MSPR,3) = ICONF(MSPR,3)+1
20679             ELSE IF(IP2.GT.0) THEN
20680               IC1 = ICB1
20681               IC2 = ICA2
20682               IC3 = ICA1
20683               ICONF(MSPR,4) = ICONF(MSPR,4)+1
20684             ELSE
20685               IC1 = ICA1
20686               IC2 = ICB1
20687               IC3 = ICA2
20688               ICONF(MSPR,4) = ICONF(MSPR,4)+1
20689             ENDIF
20690           ENDIF
20691         ELSE IF(MSPR.EQ.4) THEN
20692 C  g g --> q qb
20693           PC(1) = U/V-2.D0*U**2
20694           PC(2) = V/U-2.D0*V**2
20695           XI = (PC(1)+PC(2))*DT_RNDM(U)
20696           IF(XI.LT.PC(1)) THEN
20697             IF(IP3.GT.0) THEN
20698               IC1 = ICA1
20699               IC3 = ICB2
20700               CALL PHO_HARCOR(-ICB1,ICA2)
20701               IF(ICB2.EQ.-ICB1) IC3 = ICA2
20702               ICONF(MSPR,1) = ICONF(MSPR,1)+1
20703             ELSE
20704               IC1 = ICA2
20705               IC3 = ICB1
20706               CALL PHO_HARCOR(-ICB2,ICA1)
20707               IF(ICB1.EQ.-ICB2) IC3 = ICA1
20708               ICONF(MSPR,2) = ICONF(MSPR,2)+1
20709             ENDIF
20710           ELSE
20711             IF(IP3.GT.0) THEN
20712               IC1 = ICB1
20713               IC3 = ICA2
20714               CALL PHO_HARCOR(-ICB2,ICA1)
20715               IF(ICB1.EQ.-ICB2) IC1 = ICA1
20716               ICONF(MSPR,3) = ICONF(MSPR,3)+1
20717             ELSE
20718               IC1 = ICB2
20719               IC3 = ICA1
20720               CALL PHO_HARCOR(-ICB1,ICA2)
20721               IF(ICB2.EQ.-ICB1) IC1 = ICA2
20722               ICONF(MSPR,4) = ICONF(MSPR,4)+1
20723             ENDIF
20724           ENDIF
20725         ELSE IF(MSPR.EQ.5) THEN
20726 C  q qb --> q qb
20727           PC(1) = (1.D0+U**2)/V**2
20728           PC(2) = (V**2+U**2)
20729           XI = (PC(1)+PC(2))*DT_RNDM(V)
20730           IF(XI.LT.PC(1)) THEN
20731             CALL PHO_HARCOR(-ICB1,ICA1)
20732             CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20733             IF(IP3.GT.0) THEN
20734               IC1 = I1
20735               IC3 = I2
20736               ICONF(MSPR,1) = ICONF(MSPR,1)+1
20737             ELSE
20738               IC1 = I2
20739               IC3 = I1
20740               ICONF(MSPR,2) = ICONF(MSPR,2)+1
20741             ENDIF
20742           ELSE
20743             IF(IP3.GT.0) THEN
20744               IC1 = MAX(ICA1,ICB1)
20745               IC3 = MIN(ICA1,ICB1)
20746               ICONF(MSPR,3) = ICONF(MSPR,3)+1
20747             ELSE
20748               IC1 = MIN(ICA1,ICB1)
20749               IC3 = MAX(ICA1,ICB1)
20750               ICONF(MSPR,4) = ICONF(MSPR,4)+1
20751             ENDIF
20752           ENDIF
20753         ELSE IF(MSPR.EQ.6) THEN
20754 C  q qb --> qp qpb
20755           IF(IP3.GT.0) THEN
20756             IC1 = MAX(ICA1,ICB1)
20757             IC3 = MIN(ICA1,ICB1)
20758             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20759           ELSE
20760             IC1 = MIN(ICA1,ICB1)
20761             IC3 = MAX(ICA1,ICB1)
20762             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20763           ENDIF
20764         ELSE IF(MSPR.EQ.7) THEN
20765 C  q q --> q q
20766           PC(1) = (1.D0+U**2)/V**2
20767           PC(2) = (1.D0+V**2)/U**2
20768           XI = (PC(1)+PC(2))*DT_RNDM(U)
20769           IF(XI.LT.PC(1)) THEN
20770             IC1 = ICB1
20771             IC3 = ICA1
20772             ICONF(MSPR,1) = ICONF(MSPR,1)+1
20773           ELSE
20774             IC1 = ICA1
20775             IC3 = ICB1
20776             ICONF(MSPR,2) = ICONF(MSPR,2)+1
20777           ENDIF
20778         ELSE IF(MSPR.EQ.8) THEN
20779 C  q qp --> q qp
20780           IF(IP1*IP2.LT.0) THEN
20781             CALL PHO_HARCOR(-ICB1,ICA1)
20782             CALL PHO_SELCOL(0,0,I1,K1,I2,K2,1)
20783             IF(IP1.GT.0) THEN
20784               IC1 = I1
20785               IC3 = I2
20786               ICONF(MSPR,1) = ICONF(MSPR,1)+1
20787             ELSE
20788               IC1 = I2
20789               IC3 = I1
20790               ICONF(MSPR,2) = ICONF(MSPR,2)+1
20791             ENDIF
20792           ELSE
20793             IC1 = ICB1
20794             IC3 = ICA1
20795             ICONF(MSPR,3) = ICONF(MSPR,3)+1
20796           ENDIF
20797
20798         ELSE IF(MSPR.EQ.10) THEN
20799 C  gam q --> q g
20800           CALL PHO_SELCOL(ICB1,ICB2,IC1,IC2,IC3,IC4,2)
20801           IF(IP3.EQ.0) THEN
20802             CALL PHO_SWAPI(IC1,IC3)
20803             CALL PHO_SWAPI(IC2,IC4)
20804           ENDIF
20805         ELSE IF(MSPR.EQ.11) THEN
20806 C  gam g --> q q
20807           IC1 = ICB1
20808           IC3 = ICB2
20809           IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
20810         ELSE IF(MSPR.EQ.12) THEN
20811 C  q gam --> q g
20812           CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,2)
20813           IF(IP3.EQ.0) THEN
20814             CALL PHO_SWAPI(IC1,IC3)
20815             CALL PHO_SWAPI(IC2,IC4)
20816           ENDIF
20817         ELSE IF(MSPR.EQ.13) THEN
20818 C  g gam --> q q
20819           IC1 = ICA1
20820           IC3 = ICA2
20821           IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
20822         ELSE IF(MSPR.EQ.14) THEN
20823           IF(ABS(IP3).GT.12) THEN
20824             IC1 = 0
20825             IC3 = 0
20826           ELSE
20827             CALL PHO_SELCOL(ICA1,ICA2,IC1,IC2,IC3,IC4,1)
20828             IF(IP3.LT.0) CALL PHO_SWAPI(IC1,IC3)
20829           ENDIF
20830         ELSE
20831 C  unknown process
20832           WRITE(LO,'(/1X,A,I3)')
20833      &      'PHO_HARCOL:ERROR:invalid process number',MSPR
20834           CALL PHO_ABORT
20835         ENDIF
20836       ENDIF
20837 C
20838  100  CONTINUE
20839 C  debug output
20840       IF(IDEB(26).GE.10) WRITE(LO,'(5X,A,3I5,2X,3I5)')
20841      &    'final partons and colors',IP3,IC1,IC2,IP4,IC3,IC4
20842 C  color connection?
20843 *     IF(((IC1.NE.-IC3).AND.(IC1.NE.-IC4)).AND.
20844 *    &  (((IC2.NE.0).AND.(IC2.NE.-IC3).AND.(IC2.NE.-IC4))
20845 *    &  .OR.(IC2.EQ.0))) THEN
20846 C  color exchange?
20847 *       IF(((IP1.EQ.IP3).AND.(ICA1.EQ.IC1).AND.(ICA2.EQ.IC2))
20848 *    &     .OR.((IP1.EQ.IP4).AND.(ICA1.EQ.IC3).AND.(ICA2.EQ.IC4))) THEN
20849 *         IF(IRC.NE.1) THEN
20850 *           WRITE(LO,'(1X,A,I10,I3)')
20851 *    &        'PHO_HARCOL:unexp. re-connection (event/MSPR):',KEVENT,MSPR
20852 *           WRITE(LO,'(5X,A,3I5,2X,3I5)')
20853 *    &        'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
20854 *           WRITE(LO,'(5X,A,3I5,2X,3I5)')
20855 *    &        'final partons and colors  ',IP3,IC1,IC2,IP4,IC3,IC4
20856 *         ENDIF
20857 *         IRC = 0
20858 *       ENDIF
20859 *     ENDIF
20860 *     IF(IRC.EQ.1) THEN
20861 *           WRITE(LO,'(1X,A,I10,I3)')
20862 *    &        'PHO_HARCOL:re-conn. failed (event/MSPR):',KEVENT,MSPR
20863 *           WRITE(LO,'(5X,A,3I5,2X,3I5)')
20864 *    &        'initial partons and colors',IP1,ICA1,ICA2,IP2,ICB1,ICB2
20865 *           WRITE(LO,'(5X,A,3I5,2X,3I5)')
20866 *    &        'final partons and colors  ',IP3,IC1,IC2,IP4,IC3,IC4
20867 *     ENDIF
20868 C
20869       ICC1 = IC1
20870       ICC2 = IC2
20871       ICD1 = IC3
20872       ICD2 = IC4
20873
20874       END
20875
20876 *$ CREATE PHO_HARCOR.FOR
20877 *COPY PHO_HARCOR
20878 CDECK  ID>, PHO_HARCOR
20879       SUBROUTINE PHO_HARCOR(ICOLD,ICNEW)
20880 C***********************************************************************
20881 C
20882 C     substituite color in /POEVT2/
20883 C
20884 C     input:    ICOLD   old color
20885 C               ICNEW   new color
20886 C
20887 C***********************************************************************
20888       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20889       SAVE
20890
20891 C  input/output channels
20892       INTEGER LI,LO
20893       COMMON /POINOU/ LI,LO
20894 C  standard particle data interface
20895       INTEGER NMXHEP
20896       PARAMETER (NMXHEP=4000)
20897       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
20898       DOUBLE PRECISION PHEP,VHEP
20899       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
20900      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
20901      &                VHEP(4,NMXHEP)
20902 C  extension to standard particle data interface (PHOJET specific)
20903       INTEGER IMPART,IPHIST,ICOLOR
20904       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
20905
20906       DO 100 I=NHEP,3,-1
20907         IF(ISTHEP(I).EQ.-1) THEN
20908           IF(ICOLOR(1,I).EQ.ICOLD) THEN
20909             ICOLOR(1,I) = ICNEW
20910             RETURN
20911           ELSE IF(IDHEP(I).EQ.21) THEN
20912             IF(ICOLOR(2,I).EQ.ICOLD) THEN
20913               ICOLOR(2,I) = ICNEW
20914               RETURN
20915             ENDIF
20916           ENDIF
20917 *       ELSE IF(ISTHEP(I).EQ.20) THEN
20918 *         IF(ICOLOR(1,I).EQ.-ICOLD) THEN
20919 *           WRITE(LO,*) ' PHO_HARCOR(3): line, old, new:',I,ICOLD,ICNEW
20920 *           ICOLOR(1,I) = -ICNEW
20921 *           RETURN
20922 *         ELSE IF(IDHEP(I).EQ.21) THEN
20923 *           IF(ICOLOR(2,I).EQ.-ICOLD) THEN
20924 *             WRITE(LO,*) ' PHO_HARCOR(4): line, old, new:',I,ICOLD,ICNEW
20925 *             ICOLOR(2,I) = -ICNEW
20926 *             RETURN
20927 *           ENDIF
20928 *         ENDIF
20929         ENDIF
20930  100  CONTINUE
20931       END
20932
20933 *$ CREATE PHO_HARREM.FOR
20934 *COPY PHO_HARREM
20935 CDECK  ID>, PHO_HARREM
20936       SUBROUTINE PHO_HARREM(JM1,JM2,IGEN,IHPOS,IVAL,INDXS,IC1,IC2,
20937      &                      IUSED,IREJ)
20938 C***********************************************************************
20939 C
20940 C     sample color structure for initial quark/gluon of hard scattering
20941 C     and write hadron remnant to /POEVT1/
20942 C
20943 C     input:    JM1,2   index of mother particle in POEVT1
20944 C               IGEN    mother particle production process
20945 C               IHPOS   hard pomeron number
20946 C               INDXH   index of hard parton
20947 C                       positive for labels 1
20948 C                       negative for labels 2
20949 C               IVAL     1  hard valence parton
20950 C                        0  hard sea parton connected by color flow with
20951 C                           valence quarks
20952 C                       -1  hard sea parton independent off valence
20953 C                           quarks
20954 C               INDXS   index of soft partons needed
20955 C
20956 C     output:   IC1,IC2 color label of initial parton
20957 C               IUSED   number of soft X values used
20958 C               IREJ    rejection flag
20959 C
20960 C**********************************************************************
20961       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20962       SAVE
20963
20964       PARAMETER ( TINY   =  1.D-10 )
20965
20966 C  input/output channels
20967       INTEGER LI,LO
20968       COMMON /POINOU/ LI,LO
20969 C  event debugging information
20970       INTEGER NMAXD
20971       PARAMETER (NMAXD=100)
20972       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
20973      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20974       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
20975      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
20976 C  model switches and parameters
20977       CHARACTER*8 MDLNA
20978       INTEGER ISWMDL,IPAMDL
20979       DOUBLE PRECISION PARMDL
20980       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
20981 C  data of c.m. system of Pomeron / Reggeon exchange
20982       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
20983       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
20984      &                 SIDP,CODP,SIFP,COFP
20985       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
20986      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
20987      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
20988 C  obsolete cut-off information
20989       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
20990       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
20991 C  light-cone x fractions and c.m. momenta of soft cut string ends
20992       INTEGER MAXSOF
20993       PARAMETER ( MAXSOF = 50 )
20994       INTEGER IJSI2,IJSI1
20995       DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
20996       COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
20997      &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
20998      &                IJSI1(MAXSOF),IJSI2(MAXSOF)
20999 C  hard scattering data
21000       INTEGER MSCAHD
21001       PARAMETER ( MSCAHD = 50 )
21002       INTEGER LSCAHD,LSC1HD,LSIDX,
21003      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
21004       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
21005       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
21006      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
21007      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
21008      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
21009      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
21010      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
21011      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
21012 C  standard particle data interface
21013       INTEGER NMXHEP
21014       PARAMETER (NMXHEP=4000)
21015       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
21016       DOUBLE PRECISION PHEP,VHEP
21017       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
21018      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
21019      &                VHEP(4,NMXHEP)
21020 C  extension to standard particle data interface (PHOJET specific)
21021       INTEGER IMPART,IPHIST,ICOLOR
21022       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
21023 C  internal rejection counters
21024       INTEGER NMXJ
21025       PARAMETER (NMXJ=60)
21026       CHARACTER*10 REJTIT
21027       INTEGER IFAIL
21028       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
21029
21030       IREJ = 0
21031
21032       INDXH = SIGN(LSIDX(ABS(IHPOS)),IHPOS)
21033
21034       IF(INDXH.GT.0) THEN
21035         IJH = IPHO_CNV1(NINHD(INDXH,1))
21036       ELSE
21037         IJH = IPHO_CNV1(NINHD(-INDXH,2))
21038       ENDIF
21039 C  direct process (photon or pomeron)
21040       IUSED = 0
21041       IC1   = 0
21042       IC2   = 0
21043       IF((IJH.EQ.22).OR.(IJH.EQ.990)) RETURN
21044
21045       IHP = 100*ABS(IHPOS)
21046       IVSW = 1
21047 ***************************************
21048 *     IF((IDHEP(JM1).EQ.22).OR.(IDHEP(JM1).EQ.990)) IVSW = 0
21049 ***************************************
21050
21051       IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,2I3,1X,5I4)')
21052      &  'PHO_HARREM: JM1,JM2,IHPOS,INDXH,IFLH,IVAL,INDXS:',
21053      &  JM1,JM2,IHPOS,INDXH,IJH,IVAL,INDXS
21054
21055 C  quark
21056 C****************************************************************
21057
21058         IF(IJH.NE.21) THEN
21059
21060 C  valence quark engaged in hard scattering
21061           IF(IVAL.EQ.1) THEN
21062             CALL PHO_PARREM(JM1,IJH,IREM,IREJ)
21063             IF(IREJ.NE.0) THEN
21064               WRITE(LO,'(/1X,2A,2I6)') 'PHO_HARREM: ',
21065      &          'invalid valence flavour requested JM,IFLA',JM1,IJH
21066               return
21067             ENDIF
21068             CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21069             IF(((ABS(IREM).GT.6).AND.(IREM.GT.0))
21070      &         .OR.((ABS(IREM).LE.6).AND.(IREM.LT.0))) THEN
21071               I = ICA1
21072               ICA1 = ICB1
21073               ICB1 = I
21074             ENDIF
21075 C  remnant of hadron
21076             IF(INDXH.GT.0) THEN
21077               P1 = PSOFT1(1,INDXS)
21078               P2 = PSOFT1(2,INDXS)
21079               P3 = PSOFT1(3,INDXS)
21080               P4 = PSOFT1(4,INDXS)
21081               IJSI1(INDXS) = IREM
21082             ELSE
21083               P1 = PSOFT2(1,INDXS)
21084               P2 = PSOFT2(2,INDXS)
21085               P3 = PSOFT2(3,INDXS)
21086               P4 = PSOFT2(4,INDXS)
21087               IJSI2(INDXS) = IREM
21088             ENDIF
21089 C  registration
21090             CALL PHO_REGPAR(-1,IREM,0,JM1,JM2,P1,P2,P3,P4,
21091      &                      IHP,IGEN,ICA1,IVSW,IPOS,1)
21092             IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21093      &        'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21094      &        IREM,IPOS,SIGN(INDXS,INDXH)
21095             IUSED = 1
21096
21097 C  sea quark engaged in hard scattering, valence quarks treated
21098           ELSE IF(IVAL.EQ.0) THEN
21099             IF(INDXH.GT.0) THEN
21100               E1 = PSOFT1(4,INDXS)
21101               E2 = PSOFT1(4,INDXS+1)
21102             ELSE
21103               E1 = PSOFT2(4,INDXS)
21104               E2 = PSOFT2(4,INDXS+1)
21105             ENDIF
21106             CALL PHO_VALFLA(JM1,IVFL1,IVFL2,E1,E2)
21107             CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21108             IF(DT_RNDM(P1).LT.0.5D0) THEN
21109               CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21110             ELSE
21111               CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21112             ENDIF
21113             IF(((ABS(IVFL1).GT.6).AND.(IVFL1.GT.0))
21114      &         .OR.((ABS(IVFL1).LE.6).AND.(IVFL1.LT.0))) THEN
21115               I = ICA1
21116               ICA1 = ICB1
21117               ICB1 = I
21118             ENDIF
21119             IF(INDXH.GT.0) THEN
21120               P1 = PSOFT1(1,INDXS)
21121               P2 = PSOFT1(2,INDXS)
21122               P3 = PSOFT1(3,INDXS)
21123               P4 = PSOFT1(4,INDXS)
21124               IJSI1(INDXS) = IVFL1
21125             ELSE
21126               P1 = PSOFT2(1,INDXS)
21127               P2 = PSOFT2(2,INDXS)
21128               P3 = PSOFT2(3,INDXS)
21129               P4 = PSOFT2(4,INDXS)
21130               IJSI2(INDXS) = IVFL1
21131             ENDIF
21132 C  registration
21133             CALL PHO_REGPAR(-1,IVFL1,0,JM1,JM2,P1,P2,P3,P4,
21134      &                      IHP,IGEN,ICA1,IVSW,IPOS,1)
21135             IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21136      &        'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21137      &        IVFL1,IPOS,SIGN(INDXS,INDXH)
21138 C
21139             IF(INDXH.GT.0) THEN
21140               P1 = PSOFT1(1,INDXS+1)
21141               P2 = PSOFT1(2,INDXS+1)
21142               P3 = PSOFT1(3,INDXS+1)
21143               P4 = PSOFT1(4,INDXS+1)
21144               IJSI1(INDXS+1) = IVFL2
21145             ELSE
21146               P1 = PSOFT2(1,INDXS+1)
21147               P2 = PSOFT2(2,INDXS+1)
21148               P3 = PSOFT2(3,INDXS+1)
21149               P4 = PSOFT2(4,INDXS+1)
21150               IJSI2(INDXS+1) = IVFL2
21151             ENDIF
21152 C  registration
21153             CALL PHO_REGPAR(-1,IVFL2,0,JM1,JM2,P1,P2,P3,P4,
21154      &                  IHP,IGEN,ICB1,IVSW,IPOS,1)
21155             IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21156      &        'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21157      &        IVFL2,IPOS,SIGN(INDXS+1,INDXH)
21158 C
21159             IF(IJH.LT.0) THEN
21160               ICB1 = ICC2
21161               ICA1 = ICC1
21162             ELSE
21163               ICB1 = ICC1
21164               ICA1 = ICC2
21165             ENDIF
21166             IF(INDXH.GT.0) THEN
21167               P1 = PSOFT1(1,INDXS+2)
21168               P2 = PSOFT1(2,INDXS+2)
21169               P3 = PSOFT1(3,INDXS+2)
21170               P4 = PSOFT1(4,INDXS+2)
21171               IJSI1(INDXS+2) = -IJH
21172             ELSE
21173               P1 = PSOFT2(1,INDXS+2)
21174               P2 = PSOFT2(2,INDXS+2)
21175               P3 = PSOFT2(3,INDXS+2)
21176               P4 = PSOFT2(4,INDXS+2)
21177               IJSI2(INDXS+2) = -IJH
21178             ENDIF
21179 C  registration
21180             CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
21181      &                      IHP,IGEN,ICA1,0,IPOS,1)
21182             IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21183      &        'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21184      &        -IJH,IPOS,SIGN(INDXS+2,INDXH)
21185             IUSED = 3
21186 C
21187 C  sea quark engaged in hard scattering, valences treated separately
21188           ELSE IF(IVAL.EQ.-1) THEN
21189             CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21190             IF(IJH.GT.0) THEN
21191               ICC1 = ICB1
21192               ICB1 = ICA1
21193               ICA1 = ICC1
21194             ENDIF
21195             IF(INDXH.GT.0) THEN
21196               P1 = PSOFT1(1,INDXS)
21197               P2 = PSOFT1(2,INDXS)
21198               P3 = PSOFT1(3,INDXS)
21199               P4 = PSOFT1(4,INDXS)
21200               IJSI1(INDXS) = -IJH
21201             ELSE
21202               P1 = PSOFT2(1,INDXS)
21203               P2 = PSOFT2(2,INDXS)
21204               P3 = PSOFT2(3,INDXS)
21205               P4 = PSOFT2(4,INDXS)
21206               IJSI2(INDXS) = -IJH
21207             ENDIF
21208 C  registration
21209             CALL PHO_REGPAR(-1,-IJH,0,JM1,JM2,P1,P2,P3,P4,
21210      &                      IHP,IGEN,ICA1,0,IPOS,1)
21211             IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21212      &        'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21213      &        -IJH,IPOS,SIGN(INDXS,INDXH)
21214             IUSED = 1
21215           ELSE
21216             WRITE(LO,'(1X,A,2I5)')
21217      &        'PHO_HARREM:ERROR:unsupported combination of IVAL,IJH',
21218      &        IVAL,IJH
21219             CALL PHO_ABORT
21220           ENDIF
21221 C
21222           IC1 = ICB1
21223           IC2 = 0
21224 C
21225 C  gluon
21226 C****************************************************************
21227 C
21228 C  gluon from valence quarks
21229         ELSE
21230           IF(IVAL.EQ.1) THEN
21231 C  purely gluonic pomeron remnant
21232             IF((IDHEP(JM1).EQ.990).AND.(IPAMDL(20).GT.0)) THEN
21233               IF(INDXH.GT.0) THEN
21234                 P1 = PSOFT1(1,INDXS) + PSOFT1(1,INDXS+1)
21235                 P2 = PSOFT1(2,INDXS) + PSOFT1(2,INDXS+1)
21236                 P3 = PSOFT1(3,INDXS) + PSOFT1(3,INDXS+1)
21237                 P4 = PSOFT1(4,INDXS) + PSOFT1(4,INDXS+1)
21238                 IJSI1(INDXS) = 0
21239               ELSE
21240                 P1 = PSOFT2(1,INDXS) + PSOFT2(1,INDXS+1)
21241                 P2 = PSOFT2(2,INDXS) + PSOFT2(2,INDXS+1)
21242                 P3 = PSOFT2(3,INDXS) + PSOFT2(3,INDXS+1)
21243                 P4 = PSOFT2(4,INDXS) + PSOFT2(4,INDXS+1)
21244                 IJSI2(INDXS) = 0
21245               ENDIF
21246               IFL1 = 21
21247               CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21248               IF(DT_RNDM(P2).LT.0.5D0) THEN
21249                 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21250               ELSE
21251                 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21252               ENDIF
21253 C  registration
21254               CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21255      &                        IHP,IGEN,ICA1,ICB1,IPOS,1)
21256               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21257      &          'PHO_HARREM: val.gluon:(IFL,IPOS,INDXS)',
21258      &          IFL1,IPOS,SIGN(INDXS,INDXH)
21259               IUSED = 2
21260 C  valence quark remnant
21261             ELSE
21262               IF(INDXH.GT.0) THEN
21263                 E1 = PSOFT1(4,INDXS)
21264                 E2 = PSOFT1(4,INDXS+1)
21265               ELSE
21266                 E1 = PSOFT2(4,INDXS)
21267                 E2 = PSOFT2(4,INDXS+1)
21268               ENDIF
21269               CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
21270               CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21271               IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21272      &           .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21273                 I = ICA1
21274                 ICA1 = ICB1
21275                 ICB1 = I
21276               ENDIF
21277               IF(DT_RNDM(P2).LT.0.5D0) THEN
21278                 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21279               ELSE
21280                 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21281               ENDIF
21282 C  remnant of hadron
21283               IF(INDXH.GT.0) THEN
21284                 P1 = PSOFT1(1,INDXS)
21285                 P2 = PSOFT1(2,INDXS)
21286                 P3 = PSOFT1(3,INDXS)
21287                 P4 = PSOFT1(4,INDXS)
21288                 IJSI1(INDXS) = IFL1
21289               ELSE
21290                 P1 = PSOFT2(1,INDXS)
21291                 P2 = PSOFT2(2,INDXS)
21292                 P3 = PSOFT2(3,INDXS)
21293                 P4 = PSOFT2(4,INDXS)
21294                 IJSI2(INDXS) = IFL1
21295               ENDIF
21296 C  registration
21297               CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21298      &                        IHP,IGEN,ICA1,IVSW,IPOS,1)
21299               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21300      &          'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21301      &          IFL1,IPOS,SIGN(INDXS,INDXH)
21302 C
21303               IF(INDXH.GT.0) THEN
21304                 P1 = PSOFT1(1,INDXS+1)
21305                 P2 = PSOFT1(2,INDXS+1)
21306                 P3 = PSOFT1(3,INDXS+1)
21307                 P4 = PSOFT1(4,INDXS+1)
21308                 IJSI1(INDXS+1) = IFL2
21309               ELSE
21310                 P1 = PSOFT2(1,INDXS+1)
21311                 P2 = PSOFT2(2,INDXS+1)
21312                 P3 = PSOFT2(3,INDXS+1)
21313                 P4 = PSOFT2(4,INDXS+1)
21314                 IJSI2(INDXS+1) = IFL2
21315               ENDIF
21316 C  registration
21317               CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21318      &                        IHP,IGEN,ICB1,IVSW,IPOS,1)
21319               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21320      &          'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21321      &          IFL2,IPOS,SIGN(INDXS+1,INDXH)
21322               IUSED = 2
21323             ENDIF
21324 C
21325 C  gluon from sea quarks connected with valence quarks
21326           ELSE IF(IVAL.EQ.0) THEN
21327             IF(INDXH.GT.0) THEN
21328               E1 = PSOFT1(4,INDXS)
21329               E2 = PSOFT1(4,INDXS+1)
21330             ELSE
21331               E1 = PSOFT2(4,INDXS)
21332               E2 = PSOFT2(4,INDXS+1)
21333             ENDIF
21334             CALL PHO_VALFLA(JM1,IFL1,IFL2,E1,E2)
21335             CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21336             IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21337      &         .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21338               I = ICA1
21339               ICA1 = ICB1
21340               ICB1 = I
21341             ENDIF
21342             IF(DT_RNDM(P3).LT.0.5D0) THEN
21343               CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21344             ELSE
21345               CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21346             ENDIF
21347 C  remnant of hadron
21348             IF(INDXH.GT.0) THEN
21349               P1 = PSOFT1(1,INDXS)
21350               P2 = PSOFT1(2,INDXS)
21351               P3 = PSOFT1(3,INDXS)
21352               P4 = PSOFT1(4,INDXS)
21353               IJSI1(INDXS) = IFL1
21354             ELSE
21355               P1 = PSOFT2(1,INDXS)
21356               P2 = PSOFT2(2,INDXS)
21357               P3 = PSOFT2(3,INDXS)
21358               P4 = PSOFT2(4,INDXS)
21359               IJSI2(INDXS) = IFL1
21360             ENDIF
21361 C  registration
21362             CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21363      &                      IHP,IGEN,ICA1,IVSW,IPOS,1)
21364             IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21365      &        'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21366      &        IFL1,IPOS,SIGN(INDXS,INDXH)
21367 C
21368             IF(INDXH.GT.0) THEN
21369               P1 = PSOFT1(1,INDXS+1)
21370               P2 = PSOFT1(2,INDXS+1)
21371               P3 = PSOFT1(3,INDXS+1)
21372               P4 = PSOFT1(4,INDXS+1)
21373               IJSI1(INDXS+1) = IFL2
21374             ELSE
21375               P1 = PSOFT2(1,INDXS+1)
21376               P2 = PSOFT2(2,INDXS+1)
21377               P3 = PSOFT2(3,INDXS+1)
21378               P4 = PSOFT2(4,INDXS+1)
21379               IJSI2(INDXS+1) = IFL2
21380             ENDIF
21381 C  registration
21382             CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21383      &                      IHP,IGEN,ICB1,IVSW,IPOS,1)
21384             IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21385      &        'PHO_HARREM: val.spectator:(IFL,IPOS,INDXS)',
21386      &        IFL2,IPOS,SIGN(INDXS+1,INDXH)
21387             IF(IPAMDL(18).EQ.0)  THEN
21388 C  sea quark pair
21389               CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
21390               IF(ICC1.GT.0) THEN
21391                 IFL1 = ABS(IFL1)
21392                 IFL2 = -IFL1
21393               ELSE
21394                 IFL1 = -ABS(IFL1)
21395                 IFL2 = -IFL1
21396               ENDIF
21397               IF(DT_RNDM(P4).LT.0.5D0) THEN
21398                 ICB1 = ICC2
21399                 CALL PHO_SELCOL(ICC1,0,ICA1,ICA2,ICC1,ICC2,2)
21400               ELSE
21401                 ICA1 = ICC1
21402                 CALL PHO_SELCOL(ICC2,0,ICB1,ICB2,ICC1,ICC2,2)
21403               ENDIF
21404               IF(INDXH.GT.0) THEN
21405                 P1 = PSOFT1(1,INDXS+2)
21406                 P2 = PSOFT1(2,INDXS+2)
21407                 P3 = PSOFT1(3,INDXS+2)
21408                 P4 = PSOFT1(4,INDXS+2)
21409                 IJSI1(INDXS+2) = IFL1
21410               ELSE
21411                 P1 = PSOFT2(1,INDXS+2)
21412                 P2 = PSOFT2(2,INDXS+2)
21413                 P3 = PSOFT2(3,INDXS+2)
21414                 P4 = PSOFT2(4,INDXS+2)
21415                 IJSI2(INDXS+2) = IFL1
21416               ENDIF
21417 C  registration
21418               CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21419      &                        IHP,IGEN,ICA1,0,IPOS,1)
21420               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21421      &          'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21422      &          IFL1,IPOS,SIGN(INDXS+2,INDXH)
21423 C
21424               IF(INDXH.GT.0) THEN
21425                 P1 = PSOFT1(1,INDXS+3)
21426                 P2 = PSOFT1(2,INDXS+3)
21427                 P3 = PSOFT1(3,INDXS+3)
21428                 P4 = PSOFT1(4,INDXS+3)
21429                 IJSI1(INDXS+3) = IFL2
21430               ELSE
21431                 P1 = PSOFT2(1,INDXS+3)
21432                 P2 = PSOFT2(2,INDXS+3)
21433                 P3 = PSOFT2(3,INDXS+3)
21434                 P4 = PSOFT2(4,INDXS+3)
21435                 IJSI2(INDXS+3) = IFL2
21436               ENDIF
21437 C  registration
21438               CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21439      &                        IHP,IGEN,ICB1,0,IPOS,1)
21440               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21441      &          'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21442      &          IFL2,IPOS,SIGN(INDXS+3,INDXH)
21443               IUSED = 4
21444             ELSE
21445               IUSED = 2
21446             ENDIF
21447 C
21448 C  gluon from independent sea quarks
21449           ELSE IF(IVAL.EQ.-1) THEN
21450             IF(IPAMDL(18).EQ.0) THEN
21451               CALL PHO_SELCOL(0,0,ICA1,ICA2,ICB1,ICB2,1)
21452               CALL PHO_SEAFLA(JM1,IFL1,IFL2,PARMDL(161))
21453               IF(((ABS(IFL1).LE.6).AND.(IFL1.LT.0))
21454      &           .OR.((ABS(IFL1).GT.6).AND.(IFL1.GT.0))) THEN
21455                 I = ICA1
21456                 ICA1 = ICB1
21457                 ICB1 = I
21458               ENDIF
21459               IF(DT_RNDM(P1).LT.0.5D0) THEN
21460                 CALL PHO_SELCOL(ICA1,ICA2,ICA1,ICA2,ICC1,ICC2,2)
21461               ELSE
21462                 CALL PHO_SELCOL(ICB1,ICB2,ICB1,ICB2,ICC1,ICC2,2)
21463               ENDIF
21464 C  remainder of hadron
21465               IF(INDXH.GT.0) THEN
21466                 P1 = PSOFT1(1,INDXS)
21467                 P2 = PSOFT1(2,INDXS)
21468                 P3 = PSOFT1(3,INDXS)
21469                 P4 = PSOFT1(4,INDXS)
21470                 IJSI1(INDXS) = IFL1
21471               ELSE
21472                 P1 = PSOFT2(1,INDXS)
21473                 P2 = PSOFT2(2,INDXS)
21474                 P3 = PSOFT2(3,INDXS)
21475                 P4 = PSOFT2(4,INDXS)
21476                 IJSI2(INDXS) = IFL1
21477               ENDIF
21478 C  registration
21479               CALL PHO_REGPAR(-1,IFL1,0,JM1,JM2,P1,P2,P3,P4,
21480      &                        IHP,IGEN,ICA1,ICA2,IPOS,1)
21481               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21482      &          'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21483      &          IFL1,IPOS,SIGN(INDXS,INDXH)
21484 C  remnant of sea
21485               IF(INDXH.GT.0) THEN
21486                 P1 = PSOFT1(1,INDXS-1)
21487                 P2 = PSOFT1(2,INDXS-1)
21488                 P3 = PSOFT1(3,INDXS-1)
21489                 P4 = PSOFT1(4,INDXS-1)
21490                 IJSI1(INDXS-1) = IFL2
21491               ELSE
21492                 P1 = PSOFT2(1,INDXS-1)
21493                 P2 = PSOFT2(2,INDXS-1)
21494                 P3 = PSOFT2(3,INDXS-1)
21495                 P4 = PSOFT2(4,INDXS-1)
21496                 IJSI2(INDXS-1) = IFL2
21497               ENDIF
21498 C  registration
21499               CALL PHO_REGPAR(-1,IFL2,0,JM1,JM2,P1,P2,P3,P4,
21500      &                        IHP,IGEN,ICB1,ICB2,IPOS,1)
21501               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,3I5)')
21502      &          'PHO_HARREM: sea spectator:(IFL,IPOS,INDXS)',
21503      &          IFL2,IPOS,SIGN(INDXS-1,INDXH)
21504               IUSED = 2
21505             ELSE
21506               CALL PHO_SELCOL(0,0,ICC1,ICA2,ICC2,ICB2,1)
21507               IF(IDEB(28).GE.20) WRITE(LO,'(1X,A,I5)')
21508      &          'PHO_HARREM: no spectator added:(INDXS)',
21509      &          SIGN(INDXS,INDXH)
21510               IUSED = 0
21511             ENDIF
21512 C
21513           ELSE
21514             WRITE(LO,'(1X,A,2I5)')
21515      &        'PHO_HARREM:ERROR: unsupported combination of IVAL,IJH',
21516      &        IVAL,IJH
21517             CALL PHO_ABORT
21518           ENDIF
21519           IC1 = ICC1
21520           IC2 = ICC2
21521         ENDIF
21522       END
21523
21524 *$ CREATE PHO_HARDIR.FOR
21525 *COPY PHO_HARDIR
21526 CDECK  ID>, PHO_HARDIR
21527       SUBROUTINE PHO_HARDIR(II,IVAL1,IVAL2,MSPAR1,MSPAR2,MHPAR1,MHPAR2,
21528      &                      IREJ)
21529 C**********************************************************************
21530 C
21531 C     parton orientated formulation of direct scattering processes
21532 C
21533 C     input:
21534 C
21535 C     output:   II        particle combination (1..4)
21536 C               IVAL1,2   0 no valence quarks engaged
21537 C                         1 valence quarks engaged
21538 C               MSPAR1,2  number of realized soft partons
21539 C               MHPAR1,2  number of realized hard partons
21540 C               IREJ      1 failure
21541 C                         0 success
21542 C
21543 C**********************************************************************
21544       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21545       SAVE
21546
21547 C  input/output channels
21548       INTEGER LI,LO
21549       COMMON /POINOU/ LI,LO
21550 C  event debugging information
21551       INTEGER NMAXD
21552       PARAMETER (NMAXD=100)
21553       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
21554      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21555       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
21556      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
21557 C  model switches and parameters
21558       CHARACTER*8 MDLNA
21559       INTEGER ISWMDL,IPAMDL
21560       DOUBLE PRECISION PARMDL
21561       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21562 C  hard scattering parameters used for most recent hard interaction
21563       INTEGER NFbeta,NF
21564       DOUBLE PRECISION ALQCD2,BQCD
21565       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
21566 C  data of c.m. system of Pomeron / Reggeon exchange
21567       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
21568       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
21569      &                 SIDP,CODP,SIFP,COFP
21570       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
21571      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
21572      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
21573 C  obsolete cut-off information
21574       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
21575       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
21576 C  hard cross sections and MC selection weights
21577       INTEGER Max_pro_2
21578       PARAMETER ( Max_pro_2 = 16 )
21579       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
21580      &  MH_acc_1,MH_acc_2
21581       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
21582       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
21583      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
21584      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
21585      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
21586      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
21587 C  data on most recent hard scattering
21588       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
21589       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
21590      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
21591      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
21592       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
21593      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
21594      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
21595      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
21596      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
21597 C  light-cone x fractions and c.m. momenta of soft cut string ends
21598       INTEGER MAXSOF
21599       PARAMETER ( MAXSOF = 50 )
21600       INTEGER IJSI2,IJSI1
21601       DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
21602       COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
21603      &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
21604      &                IJSI1(MAXSOF),IJSI2(MAXSOF)
21605 C  hard scattering data
21606       INTEGER MSCAHD
21607       PARAMETER ( MSCAHD = 50 )
21608       INTEGER LSCAHD,LSC1HD,LSIDX,
21609      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
21610       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
21611       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
21612      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
21613      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
21614      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
21615      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
21616      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
21617      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
21618 C  internal rejection counters
21619       INTEGER NMXJ
21620       PARAMETER (NMXJ=60)
21621       CHARACTER*10 REJTIT
21622       INTEGER IFAIL
21623       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
21624
21625       DIMENSION P1(4),P2(4),PD1(-6:6)
21626
21627       PARAMETER ( TINY   =  1.D-10 )
21628
21629       ITRY  = 0
21630       NTRY  = 10
21631       LSC1HD = 0
21632       LSIDX(1) = 1
21633
21634 C  check phase space
21635       IF(ECMP.LT.(2.D0*PTWANT+0.1D0)) THEN
21636         IFAIL(18) = IFAIL(18)+1
21637         IREJ = 50
21638         RETURN
21639       ENDIF
21640
21641       AS     = (PARMDL(160+II)/ECMP)**2
21642       AH     = (2.D0*PTWANT/ECMP)**2
21643
21644       ALNS   = LOG(AS)
21645       ALNH   = LOG(AH)
21646
21647       XMAX   = MAX(TINY,1.D0-AS)
21648       Z1MAX  = LOG(XMAX)
21649       Z1DIF  = Z1MAX-ALNH
21650 C
21651 C  main loop to select hard and soft parton kinematics
21652 C -----------------------------------------------------
21653  120  CONTINUE
21654         IREJ = 0
21655         ITRY   = ITRY+1
21656         LSC1HD = LSC1HD+1
21657         IF(ITRY.GT.1) THEN
21658           IFAIL(17) = IFAIL(17)+1
21659           IF(ITRY.GE.NTRY) THEN
21660             IREJ = 1
21661             GOTO 450
21662           ENDIF
21663         ENDIF
21664         LINE   = 0
21665         LSCAHD = 0
21666         XSS1   = 0.D0
21667         XSS2   = 0.D0
21668         MSPAR1 = 0
21669         MSPAR2 = 0
21670
21671 C  select hard V,X
21672         CALL PHO_HARSCA(1,II)
21673         XSS1   = XSS1+X1
21674         XSS2   = XSS2+X2
21675 C  debug output
21676         IF(IDEB(25).GE.20) THEN
21677           WRITE(LO,'(1X,A,2E12.4,2I5)')
21678      &      'PHO_HARDIR: AS,XMAX,process ID,ITRY',
21679      &      AS,XMAX,MSPR,ITRY
21680           WRITE(LO,'(1X,A,4E12.4)') 'HARD X1,2  SUM X1,2',
21681      &      X1,X2,XSS1,XSS2
21682         ENDIF
21683
21684       IF(MSPR.LE.11) THEN
21685         IF((XSS2.GT.XMAX).OR.((1.D0-XSS2).LT.AS)) GOTO 120
21686       ELSE IF(MSPR.LE.13) THEN
21687         IF((XSS1.GT.XMAX).OR.((1.D0-XSS1).LT.AS)) GOTO 120
21688       ENDIF
21689
21690 C  fill /POHSLT/
21691       LSCAHD     = 1
21692       LSIDX(1)   = 1
21693       XHD(1,1)   = X1
21694       XHD(1,2)   = X2
21695       X0HD(1,1)  = X1
21696       X0HD(1,2)  = X2
21697       VHD(1)     = V
21698       ETAHD(1,1) = ETAC
21699       ETAHD(1,2) = ETAD
21700       PTHD(1)    = PT
21701       Q2SCA(1,1) = QQPD
21702       Q2SCA(1,2) = QQPD
21703       NPROHD(1)  = MSPR
21704       NBRAHD(1,1)= IDPDG1
21705       NBRAHD(1,2)= IDPDG2
21706       DO 45 I=1,4
21707         PPH(I,1)   = PHI1(I)
21708         PPH(I,2)   = PHI2(I)
21709         PPH(4+I,1) = PHO1(I)
21710         PPH(4+I,2) = PHO2(I)
21711  45   CONTINUE
21712 C  valence quarks
21713       IVAL1 = IV1
21714       IVAL2 = IV2
21715       PDFVA(1,1) = 0.D0
21716       PDFVA(1,2) = 0.D0
21717 C  parton flavours
21718       IF(MSPR.LE.11) THEN
21719         NINHD(1,1) = IDPDG1
21720         NINHD(1,2) = IB
21721         PDFVA(1,2) = PDF2(IB)
21722         KHDIR = 1
21723       ELSE IF(MSPR.LE.13) THEN
21724         NINHD(1,1) = IA
21725         PDFVA(1,1) = PDF1(IA)
21726         NINHD(1,2) = IDPDG2
21727         KHDIR = 2
21728       ELSE
21729         NINHD(1,1) = IDPDG1
21730         NINHD(1,2) = IDPDG2
21731         KHDIR = 3
21732       ENDIF
21733       N0INHD(1,1) = NINHD(1,1)
21734       N0INHD(1,2) = NINHD(1,2)
21735       N0IVAL(1,1) = IVAL1
21736       N0IVAL(1,2) = IVAL2
21737       NOUTHD(1,1) = IC
21738       NOUTHD(1,2) = ID
21739
21740 C  reweight according to photon virtuality
21741       IF(MSPR.NE.14) THEN
21742         IF(IPAMDL(115).GE.1) THEN
21743           WGX = 1.D0
21744           IF(((MSPR.EQ.10).OR.(MSPR.EQ.11)).AND.(IDPDG2.EQ.22)) THEN
21745             QQPD = Q2SCA(1,2)
21746             IF(IPAMDL(115).EQ.1) THEN
21747               IF(QQPD.LT.(PVIRTP(2)+PARMDL(144))) THEN
21748                 WGX = 0.D0
21749               ELSE
21750                 WGX = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
21751      &               /LOG(QQPD/PARMDL(144))
21752               ENDIF
21753               IF(NINHD(1,2).EQ.0) WGX = WGX*WGX
21754             ELSE IF(IPAMDL(115).EQ.2) THEN
21755               CALL PHO_PDF(2,X2,QQPD,PVIRTP(2),PD1)
21756               WGX = PD1(IB)/PDFVA(1,2)
21757             ENDIF
21758           ELSE IF(((MSPR.EQ.12).OR.(MSPR.EQ.13))
21759      &            .AND.(IDPDG1.EQ.22)) THEN
21760             QQPD = Q2SCA(1,1)
21761             IF(IPAMDL(115).EQ.1) THEN
21762               IF(QQPD.LT.(PVIRTP(1)+PARMDL(144))) THEN
21763                 WGX = 0.D0
21764               ELSE
21765                 WGX = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
21766      &               /LOG(QQPD/PARMDL(144))
21767               ENDIF
21768               IF(NINHD(1,1).EQ.0) WGX = WGX*WGX
21769             ELSE IF(IPAMDL(115).EQ.2) THEN
21770               CALL PHO_PDF(1,X1,QQPD,PVIRTP(1),PD1)
21771               WGX = PD1(IA)/PDFVA(1,1)
21772             ENDIF
21773           ENDIF
21774
21775           IF(IDEB(25).GE.25)
21776      &      WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
21777      &        're-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
21778      &        KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX
21779
21780           IF(WGX.LT.DT_RNDM(WGX)) THEN
21781             IREJ = 50
21782             RETURN
21783           ENDIF
21784
21785           IF(WGX.GT.1.01D0)
21786      &      WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_HARDIR: ',
21787      &        're-weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
21788      &        KEVENT,MSPR,X1,X2,QQPD,PVIRTP,WGX
21789
21790         ENDIF
21791       ENDIF
21792
21793 C  generate ISR
21794       IF((MSPR.NE.14).AND.(ISWMDL(8).GE.2)) THEN
21795         IF(IPAMDL(109).EQ.1) THEN
21796           Q2H = PARMDL(93)*PT**2
21797         ELSE
21798           Q2H = -PARMDL(93)*VHD(1)*XHD(1,1)*XHD(1,2)*ECMP*ECMP
21799         ENDIF
21800         XHMAX1 =  1.D0 - XSS1 - AS + XHD(1,1)
21801         XHMAX2 =  1.D0 - XSS2 - AS + XHD(1,2)
21802         DO 42 J=1,4
21803           P1(J) = PPH(4+J,1)
21804           P2(J) = PPH(4+J,2)
21805  42     CONTINUE
21806         CALL PHO_HARISR(-1,P1,P2,NOUTHD(1,1),NOUTHD(1,2),N0INHD(1,1),
21807      &    N0INHD(1,2),N0IVAL(1,1),N0IVAL(1,2),Q2H,X0HD(1,1),X0HD(1,2),
21808      &    XHMAX1,XHMAX2,IFL1,IFL2,IVAL1,IVAL2,XISR1,XISR2,IREJ)
21809         XSS1 = XSS1+XISR1-XHD(1,1)
21810         XSS2 = XSS2+XISR2-XHD(1,2)
21811         NINHD(1,1) = IFL1
21812         NINHD(1,2) = IFL2
21813         XHD(1,1) = XISR1
21814         XHD(1,2) = XISR2
21815       ELSE
21816         IFL1 = NINHD(1,1)
21817         IFL2 = NINHD(1,2)
21818       ENDIF
21819       NIVAL(1,1) = IVAL1
21820       NIVAL(1,2) = IVAL2
21821
21822 C  add photon/hadron remnant
21823
21824 C  incoming gluon
21825       IF(IFL2.EQ.0) THEN
21826         XMAXX    = 1.D0 - XSS2 - AS
21827         XMAXH    = MIN(XMAXX,PARMDL(44))
21828         CALL PHO_HADSP2(IDBAM2,XSS2,XMAXH,XS2,IREJ)
21829         IVAL2 = 1
21830         MSPAR1 = 0
21831         MSPAR2 = 2
21832         MHPAR1 = 1
21833         MHPAR2 = 1
21834       ELSE IF(IFL1.EQ.0) THEN
21835         XMAXX    = 1.D0 - XSS1 - AS
21836         XMAXH    = MIN(XMAXX,PARMDL(44))
21837         CALL PHO_HADSP2(IDBAM1,XSS1,XMAXH,XS1,IREJ)
21838         IVAL1 = 1
21839         MSPAR1 = 2
21840         MSPAR2 = 0
21841         MHPAR1 = 1
21842         MHPAR2 = 1
21843
21844 C  incoming quark
21845       ELSE IF(ABS(IFL2).LE.12) THEN
21846         IF(IVAL2.EQ.1) THEN
21847           XS2(1) = 1.D0 - XSS2
21848           MSPAR1 = 0
21849           MSPAR2 = 1
21850           MHPAR1 = 1
21851           MHPAR2 = 1
21852         ELSE
21853           XMAXX    = 1.D0 - XSS2 - AS
21854           XMAXH    = MIN(XMAXX,PARMDL(44))
21855           CALL PHO_HADSP3(IDBAM2,XSS2,XMAXH,XS2,IREJ)
21856           MSPAR1 = 0
21857           MSPAR2 = 3
21858           MHPAR1 = 1
21859           MHPAR2 = 1
21860         ENDIF
21861       ELSE IF(ABS(IFL1).LE.12) THEN
21862         IF(IVAL1.EQ.1) THEN
21863           XS1(1) = 1.D0 - XSS1
21864           MSPAR1 = 1
21865           MSPAR2 = 0
21866           MHPAR1 = 1
21867           MHPAR2 = 1
21868         ELSE
21869           XMAXX    = 1.D0 - XSS1 - AS
21870           XMAXH    = MIN(XMAXX,PARMDL(44))
21871           CALL PHO_HADSP3(IDBAM1,XSS1,XMAXH,XS1,IREJ)
21872           MSPAR1 = 3
21873           MSPAR2 = 0
21874           MHPAR1 = 1
21875           MHPAR2 = 1
21876         ENDIF
21877
21878 C  double direct process
21879       ELSE IF(MSPR.EQ.14) THEN
21880         MSPAR1 = 0
21881         MSPAR2 = 0
21882         MHPAR1 = 1
21883         MHPAR2 = 1
21884
21885 C  unknown process
21886       ELSE
21887         WRITE(LO,'(/1X,A,I3/)')
21888      &    'PHO_HARDIR:ERROR: unsupported hard process (MSPR)',MSPR
21889         CALL PHO_ABORT
21890       ENDIF
21891
21892       IF(IREJ.NE.0) THEN
21893         IF(IDEB(25).GE.3) WRITE(LO,'(1X,A,3I5)')
21894      &    'PHO_HARDIR: int. rejection (MSPR,ITRY,NTRY)',MSPR,ITRY,NTRY
21895         GOTO 120
21896       ENDIF
21897
21898 C  soft particle momenta
21899       IF(MSPAR1.GT.0) THEN
21900         DO 50 I=1,MSPAR1
21901           PSOFT1(1,I) = 0.D0
21902           PSOFT1(2,I) = 0.D0
21903           PSOFT1(3,I) = XS1(I)*ECMP/2.D0
21904           PSOFT1(4,I) = XS1(I)*ECMP/2.D0
21905  50     CONTINUE
21906       ENDIF
21907       IF(MSPAR2.GT.0) THEN
21908         DO 55 I=1,MSPAR2
21909           PSOFT2(1,I) = 0.D0
21910           PSOFT2(2,I) = 0.D0
21911           PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
21912           PSOFT2(4,I) = XS2(I)*ECMP/2.D0
21913  55     CONTINUE
21914       ENDIF
21915 C  process counting
21916       MH_acc_1(MSPR,II) = MH_acc_1(MSPR,II)+1
21917       KSOFT = MAX(MSPAR1,MSPAR2)
21918       KHARD = MAX(MHPAR1,MHPAR2)
21919 C  debug output
21920       IF(IDEB(25).GE.10) THEN
21921         WRITE(LO,'(/1X,A,2I3,3I5)')
21922      &    'PHO_HARDIR: accepted IVAL1,IVAL2,MSPR,ITRY,NTRY',
21923      &     IVAL1,IVAL2,MSPR,ITRY,NTRY
21924         IF(MSPAR1.GT.0) THEN
21925           WRITE(LO,'(5X,A,I4)') 'soft x particle 1:',MSPAR1
21926           DO 105 I=1,MSPAR1
21927             WRITE(LO,'(10X,I3,E12.3)') I,XS1(I)
21928  105      CONTINUE
21929         ENDIF
21930         IF(MSPAR2.GT.0) THEN
21931           WRITE(LO,'(5X,A,I4)') 'soft x particle 2:',MSPAR2
21932           DO 106 I=1,MSPAR2
21933             WRITE(LO,'(10X,I3,E12.3)') I,XS2(I)
21934  106      CONTINUE
21935         ENDIF
21936         WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavor particle 1:',MHPAR1
21937         WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,1),NINHD(1,1)
21938         WRITE(LO,'(5X,A,I4)') 'fin.hard momenta  particle 1:',MHPAR1
21939         WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,1),K=5,8),NOUTHD(1,1)
21940         WRITE(LO,'(5X,A,I4)') 'ini.hard X/flavour particle 2:',MHPAR2
21941         WRITE(LO,'(10X,I3,E12.3,I8)') 1,XHD(1,2),NINHD(1,2)
21942         WRITE(LO,'(5X,A,I4)') 'fin.hard momenta  particle 2:',MHPAR2
21943         WRITE(LO,'(10X,I3,4E12.3,I8)') 1,(PPH(K,2),K=5,8),NOUTHD(1,2)
21944       ENDIF
21945       RETURN
21946
21947  450  CONTINUE
21948       IFAIL(16) = IFAIL(16)+1
21949       IF(IDEB(25).GE.2) THEN
21950         WRITE(LO,'(1X,A,3I5)')
21951      &    'PHO_HARDIR: rejection (ITRY,NTRY,IREJ)',ITRY,NTRY,IREJ
21952        WRITE(LO,'(5X,A,E12.4)') 'available energy:',ECMP
21953        IF(IDEB(25).GE.5) THEN
21954          CALL PHO_PREVNT(0)
21955        ELSE
21956          CALL PHO_PREVNT(-1)
21957        ENDIF
21958       ENDIF
21959
21960       END
21961
21962 *$ CREATE PHO_POMSCA.FOR
21963 *COPY PHO_POMSCA
21964 CDECK  ID>, PHO_POMSCA
21965       SUBROUTINE PHO_POMSCA(II,MSPOM,MHPOM,MSREG,IVAL1,IVAL2,
21966      &                     MSPAR1,MSPAR2,MHPAR1,MHPAR2,IREJ)
21967 C**********************************************************************
21968 C
21969 C     parton orientated formulation of soft and hard inelastic events
21970 C
21971 C
21972 C     input:    II        particle combiantion (1..4)
21973 C               MSPOM     number of soft pomerons
21974 C               MHPOM     number of semihard pomerons
21975 C               MSREG     number of soft reggeons
21976 C
21977 C     output:   IVAL1,2   0 no valence quark engaged
21978 C                         otherwise:  position of valence quark engaged
21979 C                         neg.number: gluon connected to valence quark
21980 C                                     by color flow
21981 C               MSPAR1,2  number of realized soft partons
21982 C               MHPAR1,2  number of realized hard partons
21983 C               IREJ      1 failure
21984 C                         0 success
21985 C
21986 C**********************************************************************
21987       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21988       SAVE
21989
21990       PARAMETER (TINY   =  1.D-30 )
21991
21992 C  input/output channels
21993       INTEGER LI,LO
21994       COMMON /POINOU/ LI,LO
21995 C  event debugging information
21996       INTEGER NMAXD
21997       PARAMETER (NMAXD=100)
21998       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
21999      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22000       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
22001      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22002 C  model switches and parameters
22003       CHARACTER*8 MDLNA
22004       INTEGER ISWMDL,IPAMDL
22005       DOUBLE PRECISION PARMDL
22006       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
22007 C  general process information
22008       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
22009       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
22010 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
22011       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
22012       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
22013       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
22014      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
22015 C  event weights and generated cross section
22016       INTEGER IPOWGC,ISWCUT,IVWGHT
22017       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
22018       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
22019      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
22020 C  hard cross sections and MC selection weights
22021       INTEGER Max_pro_2
22022       PARAMETER ( Max_pro_2 = 16 )
22023       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
22024      &  MH_acc_1,MH_acc_2
22025       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
22026       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
22027      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
22028      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
22029      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
22030      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
22031 C  hard scattering parameters used for most recent hard interaction
22032       INTEGER NFbeta,NF
22033       DOUBLE PRECISION ALQCD2,BQCD
22034       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
22035 C  data of c.m. system of Pomeron / Reggeon exchange
22036       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
22037       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
22038      &                 SIDP,CODP,SIFP,COFP
22039       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
22040      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
22041      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
22042 C  obsolete cut-off information
22043       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
22044       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
22045 C  some hadron information, will be deleted in future versions
22046       INTEGER NFS
22047       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
22048       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
22049 C  data on most recent hard scattering
22050       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22051       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22052      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22053      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22054       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22055      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22056      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22057      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22058      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22059 C  light-cone x fractions and c.m. momenta of soft cut string ends
22060       INTEGER MAXSOF
22061       PARAMETER ( MAXSOF = 50 )
22062       INTEGER IJSI2,IJSI1
22063       DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
22064       COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
22065      &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
22066      &                IJSI1(MAXSOF),IJSI2(MAXSOF)
22067 C  hard scattering data
22068       INTEGER MSCAHD
22069       PARAMETER ( MSCAHD = 50 )
22070       INTEGER LSCAHD,LSC1HD,LSIDX,
22071      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
22072       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
22073       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
22074      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
22075      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
22076      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
22077      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
22078      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
22079      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
22080 C  table of particle indices for recursive PHOJET calls
22081       INTEGER MAXIPX
22082       PARAMETER ( MAXIPX = 100 )
22083       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
22084       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
22085      &                IPOIX1,IPOIX2,IPOIX3
22086 C  internal rejection counters
22087       INTEGER NMXJ
22088       PARAMETER (NMXJ=60)
22089       CHARACTER*10 REJTIT
22090       INTEGER IFAIL
22091       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
22092
22093       DIMENSION P1(4),P2(4),PD1(-6:6)
22094
22095       IF(IDEB(24).GT.20) WRITE(LO,'(1X,A,3I5)')
22096      &  'PHO_POMSCA: MSPOM,MHPOM,MSREG',MSPOM,MHPOM,MSREG
22097
22098       ITRY  = 0
22099       NTRY  = 10
22100       IREJ  = 0
22101       INMAX = 10
22102       MHARD = MHPOM
22103
22104 C  phase space limitation (single hard valence-valence quark scattering)
22105       IF(MHPOM.GT.0) THEN
22106         Emin = 2.D0*PTWANT + 0.2D0
22107         IF(ECMP.LT.Emin) THEN
22108           IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P,3E10.3)') 'PHO_POMSCA: ',
22109      &      'kin. rejection (1) (Ecm,Ptcut,Emin)',ECMP,PTWANT,Emin
22110           IREJ = 50
22111           IFAIL(6) = IFAIL(6) + 1
22112           RETURN
22113         ENDIF
22114       ENDIF
22115
22116       SAS    = PARMDL(160+II)/ECMP
22117       SAH    = 2.D0*PTWANT/ECMP
22118       AS     = SAS**2
22119       AH     = SAH**2
22120
22121 C  save energy for leading particle effect
22122       XMAXP1 = 1.D0
22123       if(IHFLS(1).ne.0) XMAXP1 = 1.D0-PARMDL(165)*XPSUB
22124       XMAXP2 = 1.D0
22125       if(IHFLS(2).ne.0) XMAXP2 = 1.D0-PARMDL(165)*XTSUB
22126
22127 C
22128 C  main loop to select hard and soft parton kinematics
22129 C -----------------------------------------------------
22130       IFAIL(31) = IFAIL(31)+MHARD
22131  20   CONTINUE
22132         IREJ  = 0
22133         IHARD = 0
22134         LSC1HD = 0
22135         ITRY  = ITRY+1
22136         IF(ITRY.GT.1) IFAIL(5) = IFAIL(5)+1
22137         IF(ITRY.GE.NTRY) THEN
22138           IREJ = 1
22139           GOTO 450
22140         ENDIF
22141         LINE   = 0
22142         LSCAHD = 0
22143         IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0).AND.(IPROCE.EQ.1)) THEN
22144           XSS1   = MAX(0.D0,1.D0-XPSUB)
22145           XSS2   = MAX(0.D0,1.D0-XTSUB)
22146         ELSE
22147           XSS1   = 0.D0
22148           XSS2   = 0.D0
22149         ENDIF
22150  22     continue
22151
22152 C  partons needed to construct soft/hard interactions
22153         MSPAR1 = 2*MSPOM+MSREG+MHPOM
22154         MSPAR2 = MSPAR1
22155         MHPAR1 = MHPOM
22156         MHPAR2 = MHPOM
22157
22158 C  number of strings
22159         MSCHA = 2*MSPOM+MSREG
22160         MHCHA = 2*MHPOM
22161
22162         KSOFT = MSCHA
22163         KHARD = MHCHA
22164
22165 C  check actual phase space limit
22166         XX = SAS*DBLE(MSCHA)+SAH*DBLE(MHCHA)/2.D0
22167         IF(XX.GE.1.D0) THEN
22168           IF(IDEB(24).GE.3) WRITE(LO,'(1X,2A,/1X,4I3,1P4E12.4)')
22169      &      'PHO_POMSCA: internal kin. rejection ',
22170      &      '(MSpom,MHpom,MSchain,MHchain,Ecm,AS,AH,XX):',
22171      &      MSPOM,MHPOM,MSCHA,MHCHA,ECMP,AS,AH,XX
22172           if(MSPOM+MSREG+MHPOM.gt.1) then
22173             if(MSREG.gt.0) then
22174               MSREG = MSREG-1
22175             else if(MSPOM.gt.0) THEN
22176               MSPOM = MSPOM-1
22177             else if(MHPOM.gt.1) then
22178               MHPOM = MHPOM-1
22179             endif
22180             goto 22
22181           endif
22182           IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P2E10.3)')
22183      &      'PHO_POMSCA: kin. rejection (2) (Ecm,Ptcut)',ECMP,PTWANT
22184           IREJ = 50
22185           IFAIL(6) = IFAIL(6) + 1
22186           RETURN
22187         ENDIF
22188
22189         XMAXX1 = MAX(TINY,1.D0-MIN(MSPAR1,1)*AS-MIN(MHPAR1,1)*AH)
22190         XMAXX2 = MAX(TINY,1.D0-MIN(MSPAR2,1)*AS-MIN(MHPAR2,1)*AH)
22191
22192 C  very low energy phase space restriction
22193         if(MHARD.gt.0) then
22194           if((XMAXX1*XMAXX2.le.AH)) then
22195             IF(IDEB(24).GE.1) WRITE(LO,'(1X,A,1P2E10.3)')
22196      &        'PHO_POMSCA: kin. rejection (3) (Ecm,Ptcut)',ECMP,PTWANT
22197             IREJ = 50
22198             IFAIL(6) = IFAIL(6) + 1
22199             RETURN
22200           endif
22201         endif
22202
22203         AS = MAX(AS,PSOMIN/PCMP)
22204         ALNS  = LOG(AS)
22205         ALNH  = LOG(AH)
22206         Z1MAX = LOG(XMAXX1)
22207         Z2MAX = LOG(XMAXX2)
22208         Z1DIF = Z1MAX+Z2MAX-ALNH
22209         Z2DIF = Z1DIF
22210         PTMAX = 0.D0
22211 C
22212 C  select hard parton momenta
22213 C ------------------- begin of inner loop -------------------
22214         IF(IPOIX3.EQ.0) IPOWGC(4+II) = 0
22215         IF(MHARD.GT.MSCAHD) THEN
22216           WRITE(LO,'(1X,2A,2I3)') 'PHO_POMSCA: ',
22217      &      'no space left in /POHSLT/ (MHARD,MSCAHD):',MHARD,MSCAHD
22218           IREJ = 1
22219           RETURN
22220         ENDIF
22221         DO 11 NN=1,MHARD
22222 C
22223 C  generate one resolved hard scattering
22224 C
22225 C  high-pt option
22226           IF((NN.EQ.1).AND.(II.EQ.1).AND.(HSWCUT(4+II).GT.PTWANT)) THEN
22227             CALL PHO_HARINT(-1,ECMP,PVIRTP(1),PVIRTP(2),
22228      &                  -1,Max_pro_2,1,4,MSPOM+MHPOM)
22229             XSCUT = HSig(9)
22230             AHS    = AH
22231             ALNHS  = ALNH
22232             Z1DIFS = Z1DIF
22233             Z2DIFS = Z2DIF
22234             AH    = (2.D0*PTWANT/ECMP)**2
22235             ALNH  = LOG(AH)
22236             Z1DIF = Z1MAX+Z2MAX-ALNH
22237             Z2DIF = Z1DIF
22238             IF((Z1DIF.LE.0.01D0).OR.(Z2DIF.LE.0.01D0)) THEN
22239               IF(IDEB(24).GE.1) WRITE(LO,'(1X,2A,/1X,1P4E12.3)')
22240      &          'PHO_POMSCA: kin.rejection, high-pt option ',
22241      &          '(Z1/2max,ALNH,Z1dif):',Z1MAX,Z2MAX,ALNH,Z1DIF
22242               IREJ = 5
22243               RETURN
22244             ENDIF
22245             CALL PHO_HARSCA(2,II)
22246             CALL PHO_HARINT(1,ECMP,PVIRTP(1),PVIRTP(2),
22247      &                  -1,Max_pro_2,1,4,MSPOM+MHPOM)
22248             AH    = AHS
22249             ALNH  = ALNHS
22250             Z1DIF = Z1DIFS
22251             Z2DIF = Z2DIFS
22252             IPOWGC(4+II) = IPOWGC(4+II)+1
22253             HSWGHT(4+II) = XSCUT/HSig(9)*DBLE(MHARD)
22254 C  minimum bias option
22255           ELSE
22256             CALL PHO_HARSCA(2,II)
22257           ENDIF
22258
22259 C  fill /POHSLT/
22260           LSIDX(NN)    = NN
22261           LSCAHD       = NN
22262           XHD(NN,1)    = X1
22263           XHD(NN,2)    = X2
22264           X0HD(NN,1)   = X1
22265           X0HD(NN,2)   = X2
22266           VHD(NN)      = V
22267           ETAHD(NN,1)  = ETAC
22268           ETAHD(NN,2)  = ETAD
22269           PTHD(NN)     = PT
22270           NPROHD(NN)   = MSPR
22271           Q2SCA(NN,1)  = QQPD
22272           Q2SCA(NN,2)  = QQPD
22273           PDFVA(NN,1)  = PDF1(IA)
22274           PDFVA(NN,2)  = PDF2(IB)
22275           NINHD(NN,1)  = IA
22276           NINHD(NN,2)  = IB
22277           N0INHD(NN,1) = IA
22278           N0INHD(NN,2) = IB
22279           NIVAL(NN,1)  = IV1
22280           NIVAL(NN,2)  = IV2
22281           N0IVAL(NN,1) = IV1
22282           N0IVAL(NN,2) = IV2
22283           NOUTHD(NN,1) = IC
22284           NOUTHD(NN,2) = ID
22285           NBRAHD(NN,1) = IDPDG1
22286           NBRAHD(NN,2) = IDPDG2
22287           I3 = 8*(NN-1)
22288           I4 = 8*(NN-1)+4
22289           DO 50 I=1,4
22290             PPH(I3+I,1) = PHI1(I)
22291             PPH(I3+I,2) = PHI2(I)
22292             PPH(I4+I,1) = PHO1(I)
22293             PPH(I4+I,2) = PHO2(I)
22294  50       CONTINUE
22295
22296  11     CONTINUE
22297
22298 C  sort according to pt-hat
22299         DO 12 NN=1,MHARD
22300           PTMX = PTHD(LSIDX(NN))
22301           IPTM = NN
22302           DO 13 I=NN+1,MHARD
22303             IF(PTHD(LSIDX(I)).GT.PTMX) THEN
22304               IPTM = I
22305               PTMX = PTHD(LSIDX(I))
22306             ENDIF
22307  13       CONTINUE
22308           IF(IPTM.NE.NN) CALL PHO_SWAPI(LSIDX(NN),LSIDX(IPTM))
22309  12     CONTINUE
22310         IPTM = LSIDX(1)
22311
22312 C  copy partons, generate ISR
22313         DO 15 L=1,MHARD
22314           NN = LSIDX(L)
22315           XSSS1  = XSS1+XHD(NN,1)
22316           XSSS2  = XSS2+XHD(NN,2)
22317 C  debug output
22318           IF(IDEB(24).GE.10) WRITE(LO,'(1X,A,3I4,1P,3E11.3)')
22319      &      'PHO_POMSCA: NR,LSIDX,MSPR,X1,X2,PT',
22320      &      L,NN,NPROHD(NN),XHD(NN,1),XHD(NN,2),PTHD(NN)
22321 C  check phase space
22322           IF(    (XSSS1.GT.XMAXX1)
22323      &       .OR.(XSSS2.GT.XMAXX2)
22324      &       .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
22325             IF(IHARD.EQ.0) THEN
22326               IF(ISWMDL(2).NE.1) GOTO 20
22327               MHPOM = 0
22328               MSPOM = 1
22329               MSREG = 0
22330             ENDIF
22331             GOTO 199
22332           ENDIF
22333
22334 C  reweight according to photon virtuality
22335           IF(IPAMDL(115).GE.1) THEN
22336             QQPD = Q2SCA(NN,1)
22337             WGX = 1.D0
22338             IF(IDPDG1.EQ.22) THEN
22339               IF(IPAMDL(115).EQ.1) THEN
22340                 IF(QQPD.LT.PVIRTP(1)+PARMDL(144)) THEN
22341                   WG1 = 0.D0
22342                 ELSE
22343                   WG1 = LOG(QQPD/(PVIRTP(1)+PARMDL(144)))
22344      &                 /LOG(QQPD/PARMDL(144))
22345                 ENDIF
22346                 IF(NINHD(NN,1).EQ.0) WG1 = WG1*WG1
22347               ELSE IF(IPAMDL(115).EQ.2) THEN
22348                 CALL PHO_PDF(1,X0HD(NN,1),QQPD,PVIRTP(1),PD1)
22349                 WG1 = PD1(NINHD(NN,1))/PDFVA(NN,1)
22350               ENDIF
22351               WGX = WG1
22352             ENDIF
22353             QQPD = Q2SCA(NN,2)
22354             IF(IDPDG2.EQ.22) THEN
22355               IF(IPAMDL(115).EQ.1) THEN
22356                 IF(QQPD.LT.PVIRTP(2)+PARMDL(144)) THEN
22357                   WG1 = 0.D0
22358                 ELSE
22359                   WG1 = LOG(QQPD/(PVIRTP(2)+PARMDL(144)))
22360      &                 /LOG(QQPD/PARMDL(144))
22361                 ENDIF
22362                 IF(NINHD(NN,2).EQ.0) WG1 = WG1*WG1
22363               ELSE IF(IPAMDL(115).EQ.2) THEN
22364                 CALL PHO_PDF(2,X0HD(NN,2),QQPD,PVIRTP(2),PD1)
22365                 WG1 = PD1(NINHD(NN,2))/PDFVA(NN,2)
22366               ENDIF
22367               WGX = WGX*WG1
22368             ENDIF
22369
22370             IF(IDEB(24).GE.25)
22371      &        WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)') 'PHO_POMSCA: ',
22372      &          ' re-weight with (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
22373      &          KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX
22374
22375             IF(WGX.LT.DT_RNDM(WGX)) THEN
22376               IF(L.EQ.1) THEN
22377                 IREJ = 50
22378                 RETURN
22379               ELSE
22380                 GOTO 199
22381               ENDIF
22382             ENDIF
22383
22384             IF(WGX.GT.1.D0) WRITE(LO,'(1X,2A,/5X,I10,I3,1P6E10.3)')
22385      &        'PHO_POMSCA: ',
22386      &        'weight >1 (EVE, MSPR, X1/2, Q2, PV1/2, W1/W2)',
22387      &        KEVENT,MSPR,X0HD(NN,1),X0HD(NN,2),QQPD,PVIRTP,WGX
22388
22389           ENDIF
22390
22391 C  generate ISR
22392           IF((ISWMDL(8).GE.2)
22393      &       .AND.((IPAMDL(101).NE.1).OR.(L.EQ.1))) THEN
22394             IF(IPAMDL(109).EQ.1) THEN
22395               Q2H = PARMDL(93)*PTHD(NN)**2
22396             ELSE
22397               Q2H = -PARMDL(93)*VHD(NN)
22398      &              *XHD(NN,1)*XHD(NN,2)*ECMP*ECMP
22399             ENDIF
22400             XHMAX1 = 1.D0 - XSSS1 - MSCHA*AS + XHD(NN,1)
22401             XHMAX2 = 1.D0 - XSSS2 - MSCHA*AS + XHD(NN,2)
22402             I3     = 8*NN-4
22403             DO 42 J=1,4
22404               P1(J) = PPH(I3+J,1)
22405               P2(J) = PPH(I3+J,2)
22406  42         CONTINUE
22407             IF(IDEB(24).GE.10)
22408      &        WRITE(LO,'(1X,A,/5X,2I3,1P,3E12.4)')
22409      &          'PHO_POMSCA: generate ISR for (L,NN,X1,X2,Q2H)',
22410      &          L,NN,XHD(NN,1),XHD(NN,2),Q2H
22411             J = NN
22412             IF(L.EQ.1) J = -NN
22413             CALL PHO_HARISR(J,P1,P2,NOUTHD(NN,1),NOUTHD(NN,2),
22414      &        N0INHD(NN,1),N0INHD(NN,2),N0IVAL(NN,1),N0IVAL(NN,2),Q2H,
22415      &        X0HD(NN,1),X0HD(NN,2),XHMAX1,XHMAX2,IFL1,IFL2,
22416      &        NIVAL(NN,1),NIVAL(NN,2),XISR1,XISR2,IREJ)
22417             XSSS1 = XSSS1+XISR1-XHD(NN,1)
22418             XSSS2 = XSSS2+XISR2-XHD(NN,2)
22419             NINHD(NN,1) = IFL1
22420             NINHD(NN,2) = IFL2
22421             XHD(NN,1) = XISR1
22422             XHD(NN,2) = XISR2
22423           ENDIF
22424
22425 C  check phase space
22426           IF(    (XSSS1.GT.XMAXX1)
22427      &       .OR.(XSSS2.GT.XMAXX2)
22428      &       .OR.((1.D0-XSSS1)*(1.D0-XSSS2).LT.AS) ) THEN
22429             IF(IHARD.EQ.0) THEN
22430               IF(ISWMDL(2).NE.1) GOTO 20
22431               MHPOM = 0
22432               MSPOM = 1
22433               MSREG = 0
22434             ENDIF
22435             GOTO 199
22436           ENDIF
22437
22438 C  leave energy for leading particle effect
22439           IF((IHARD.GT.0).AND.
22440      &       ((XSSS1.GT.XMAXP1).OR.(XSSS2.GT.XMAXP2))) then
22441             GOTO 199
22442           endif
22443
22444 C  hard scattering accepted
22445           IHARD = IHARD+1
22446           XSS1 = XSSS1
22447           XSS2 = XSSS2
22448           IFAIL(31) = IFAIL(31)-1
22449
22450  15     CONTINUE
22451
22452 C ------------------- end of inner (hard) loop -------------------
22453  199    CONTINUE
22454
22455         MHPOM =  IHARD
22456         MHPAR1 = IHARD
22457         MHPAR2 = IHARD
22458
22459 C  count valences involved in hard scattering
22460         IVAL1  = 0
22461         IVAL2  = 0
22462         DO 17 L=1,IHARD
22463           NN = LSIDX(L)
22464           IF((NIVAL(NN,1).NE.0).AND.(IVAL1.EQ.0)) IVAL1 = NN
22465           IF((NIVAL(NN,2).NE.0).AND.(IVAL2.EQ.0)) IVAL2 = NN
22466  17     CONTINUE
22467
22468         IQUA1  = 0
22469         IQUA2  = 0
22470         IVGLU1 = 0
22471         IVGLU2 = 0
22472         DO 18 L=1,IHARD
22473           NN = LSIDX(L)
22474
22475 C  photon, pomeron valences
22476           IF((IVAL1.EQ.0).AND.(NINHD(NN,1).NE.0)) THEN
22477             IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
22478               NIVAL(NN,1) = 1
22479               IVAL1 = NN
22480             ENDIF
22481           ENDIF
22482           IF((IVAL2.EQ.0).AND.(NINHD(NN,2).NE.0)) THEN
22483             IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
22484               NIVAL(NN,2) = 1
22485               IVAL2 = NN
22486             ENDIF
22487           ENDIF
22488
22489 C  total number of quarks
22490           IF(NINHD(NN,1).NE.0) THEN
22491             IQUA1 = IQUA1+1
22492           ELSE IF(IVGLU1.EQ.0) THEN
22493             IVGLU1 = NN
22494           ENDIF
22495           IF(NINHD(NN,2).NE.0) THEN
22496             IQUA2 = IQUA2+1
22497           ELSE IF(IVGLU2.EQ.0) THEN
22498             IVGLU2 = NN
22499           ENDIF
22500  18     CONTINUE
22501
22502 C  gluons emitted by valence quarks
22503         VALPRO = 1.D0
22504         IF(II.EQ.1) VALPRO = VALPRG(1)
22505         IVQ1 = 1
22506         IVG1 = 0
22507         IVAL1 = MAX(IVAL1,0)
22508         IF(IVAL1.EQ.0) THEN
22509           IVQ1 = 0
22510           IF((IVGLU1.NE.0).AND.(DT_RNDM(XSS1).LT.VALPRO)) THEN
22511             IVAL1 = -IVGLU1
22512             IVG1 = 1
22513           ENDIF
22514         ENDIF
22515         VALPRO = 1.D0
22516         IF(II.EQ.1) VALPRO = VALPRG(2)
22517         IVQ2 = 1
22518         IVG2 = 0
22519         IVAL2 = MAX(IVAL2,0)
22520         IF(IVAL2.EQ.0) THEN
22521           IVQ2 = 0
22522           IF((IVGLU2.NE.0).AND.(DT_RNDM(XSS2).LT.VALPRO)) THEN
22523             IVAL2 = -IVGLU2
22524             IVG2 = 1
22525           ENDIF
22526         ENDIF
22527         MSPOM = MAX(0,MSPOM-IQUA1-IQUA2)
22528 C  debug output
22529         IF(IDEB(24).GE.5) WRITE(LO,'(1X,A,6I4)')
22530      &    'PHO_POMSCA: IVAL1/2,IQUA1/2,IVGLU1/2',
22531      &    IVAL1,IVAL2,IQUA1,IQUA2,IVGLU1,IVGLU2
22532
22533 C  select soft X values
22534  25     CONTINUE
22535 C  number of soft/remnant quarks
22536         IF(MSPOM.EQ.0) THEN
22537           IF(IPAMDL(18).EQ.0) THEN
22538             MSPAR1 = 2+2*MHPOM+MSREG-IQUA1-2*IVQ1-2*IVG1
22539             MSPAR2 = 2+2*MHPOM+MSREG-IQUA2-2*IVQ2-2*IVG2
22540           ELSE
22541             MSPAR1 = 2+MSREG+IQUA1-2*IVQ1
22542             MSPAR2 = 2+MSREG+IQUA2-2*IVQ2
22543           ENDIF
22544         ELSE
22545           IF(IPAMDL(18).EQ.0) THEN
22546             MSPAR1 = 2*MSPOM+MSREG+2*MHPOM-IQUA1
22547             MSPAR2 = 2*MSPOM+MSREG+2*MHPOM-IQUA2
22548           ELSE
22549             MSPAR1 = 2*MSPOM+MSREG+IQUA1+2*IVG1
22550             MSPAR2 = 2*MSPOM+MSREG+IQUA2+2*IVG2
22551           ENDIF
22552         ENDIF
22553 C  debug output
22554         IF(IDEB(24).GE.15) WRITE(LO,'(1X,A,9I3)')
22555      &    'PHO_POMSCA: MSP,MSR,MHP,IVQ1/2,IVG1/2,MSPAR1/2',
22556      &    MSPOM,MSREG,MHPOM,IVQ1,IVQ2,IVG1,IVG2,MSPAR1,MSPAR2
22557
22558         XMAX1  = 1.D0 - MAX(MSPAR1-1,0)*AS - XSS1
22559         XMAX2  = 1.D0 - MAX(MSPAR2-1,0)*AS - XSS2
22560         I1 = IVQ1
22561         I2 = IVQ2
22562         IF(IVAL1.LE.0) I1 = 0
22563         IF(IVAL2.LE.0) I2 = 0
22564         IF((IVQ1+IVG1)*(IVQ2+IVG2).NE.0) THEN
22565           MSDIFF = 2*MSPOM
22566         ELSE
22567           MSDIFF = 2*MAX(0,MSPOM-1)
22568         ENDIF
22569         MSG1 = MSPAR1
22570         MSG2 = MSPAR2
22571         MSM1 = MSPAR1-MSDIFF
22572         MSM2 = MSPAR2-MSDIFF
22573         XMAXH1 = MIN(XMAX1,PARMDL(44))
22574         XMAXH2 = MIN(XMAX2,PARMDL(44))
22575         CALL PHO_SOFTXX(NPOSP(1),NPOSP(2),MSG1,MSG2,I1,I2,MSM1,MSM2,
22576      &              XSS1,XSS2,XMAXH1,XMAXH2,XS1,XS2,IREJ)
22577
22578 C  correct for proper simulation of high pt tail
22579         IF(IREJ.NE.0) THEN
22580           IF(IDEB(48).GE.2) WRITE(LO,'(1X,A,4I4)')
22581      &      'PHO_STDPAR: rejection (PHO_SOFTXX): MSPOM,MHPOM,I1,I2',
22582      &      MSPOM,MHPOM,I1,I2
22583           IF(MSPOM*MHPOM.GT.0) THEN
22584             MSPOM = MSPOM-1
22585             GOTO 25
22586           ELSE IF(MSPOM.GT.1) THEN
22587             MSPOM = MSPOM-1
22588             GOTO 25
22589           ELSE IF(MHPOM.GT.1) THEN
22590             IHARD = IHARD-1
22591             IF((IPAMDL(13).GT.0).AND.(IPOIX3.EQ.0)
22592      &         .AND.(IPROCE.EQ.1)) THEN
22593               XSS1   = MAX(0.D0,1.D0-XPSUB)
22594               XSS2   = MAX(0.D0,1.D0-XTSUB)
22595             ELSE
22596               XSS1   = 0.D0
22597               XSS2   = 0.D0
22598             ENDIF
22599             DO 103 K=1,IHARD
22600               I = LSIDX(K)
22601               XSS1 = XSS1+ XHD(I,1)
22602               XSS2 = XSS2+ XHD(I,2)
22603  103        CONTINUE
22604             GOTO 199
22605           ENDIF
22606           IREJ = 4
22607           GOTO 450
22608         ENDIF
22609 C  accepted
22610         MSPOM  = MSPOM-(MSPAR1-MSG1)/2
22611         MSPAR1 = MSG1
22612         MSPAR2 = MSG2
22613 C  ------------ kinematics sampled ---------------
22614 C  debug output
22615         IF(IDEB(24).GE.10) THEN
22616           WRITE(LO,'(1X,A,I3)')
22617      &      'PHO_POMSCA: soft x values, ITRY',ITRY
22618           DO 104 I=2,MAX(MSPAR1,MSPAR2)
22619             WRITE(LO,'(10X,I3,2E12.3)') I,XS1(I),XS2(I)
22620  104      CONTINUE
22621         ENDIF
22622       IF((1.D0-XSS1)*(1.D0-XSS2).LT.AS) GOTO 20
22623
22624 C  end of loop
22625       XS1(1) = 1.D0 - XSS1
22626       XS2(1) = 1.D0 - XSS2
22627
22628 C  process counting
22629       DO 30 N=1,LSCAHD
22630         MH_acc_1(NPROHD(N),II) = MH_acc_1(NPROHD(N),II)+1
22631  30   CONTINUE
22632
22633 C  soft particle momenta
22634       IF(MAX(MSPAR1,MSPAR2).GT.MAXSOF) THEN
22635         WRITE(LO,'(1X,2A,3I4)') 'PHO_POMSCA: no space left in ',
22636      &    '/POSOFT/ (MSPAR1/2,MAXSOF):',MSPAR1,MSPAR2,MAXSOF
22637         IREJ = 1
22638         RETURN
22639       ENDIF
22640       DO 55 I=1,MSPAR1
22641         PSOFT1(1,I) = 0.D0
22642         PSOFT1(2,I) = 0.D0
22643         PSOFT1(3,I) = XS1(I)*ECMP/2.D0
22644         PSOFT1(4,I) = XS1(I)*ECMP/2.D0
22645  55   CONTINUE
22646       DO 60 I=1,MSPAR2
22647         PSOFT2(1,I) = 0.D0
22648         PSOFT2(2,I) = 0.D0
22649         PSOFT2(3,I) = -XS2(I)*ECMP/2.D0
22650         PSOFT2(4,I) = XS2(I)*ECMP/2.D0
22651  60   CONTINUE
22652
22653       KSOFT = MAX(MSPAR1,MSPAR2)
22654       KHARD = MAX(MHPAR1,MHPAR2)
22655       KSPOM = MSPOM
22656       KSREG = MSREG
22657       KHPOM = MHPOM
22658
22659 C  debug output
22660       IF(IDEB(24).GE.10) THEN
22661         WRITE(LO,'(/1X,A,2I3,2I5)')
22662      &    'PHO_POMSCA: accepted IVAL1,IVAL2,ITRY,NTRY',
22663      &     IVAL1,IVAL2,ITRY,NTRY
22664         IF(MSPAR1+MSPAR2.GT.0) THEN
22665           WRITE(LO,'(5X,A)') 'soft x particle1   particle2:'
22666           XTMP1 = 0.D0
22667           XTMP2 = 0.D0
22668           DO 105 I=1,MAX(MSPAR1,MSPAR2)
22669             IF(I.LE.MIN(MSPAR1,MSPAR2)) THEN
22670               WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),XS2(I)
22671               XTMP1 = XTMP1+XS1(I)
22672               XTMP2 = XTMP2+XS2(I)
22673             ELSE IF(I.LE.MSPAR1) THEN
22674               WRITE(LO,'(10X,I3,2E13.4)') I,XS1(I),0.D0
22675               XTMP1 = XTMP1+XS1(I)
22676             ELSE IF(I.LE.MSPAR2) THEN
22677               WRITE(LO,'(10X,I3,2E13.4)') I,0.D0,XS2(I)
22678               XTMP2 = XTMP2+XS2(I)
22679             ENDIF
22680  105      CONTINUE
22681           WRITE(LO,'(5X,A,2E13.4)') 'sum X1/2 (soft):',XTMP1,XTMP2
22682         ENDIF
22683         IF(MHPAR1.GT.0) THEN
22684           WRITE(LO,'(5X,A)')
22685      &      'NR  IDX  MSPR hard X / hard X ISR / flavor particle 1,2:'
22686           DO 107 K=1,MHPAR1
22687             I = LSIDX(K)
22688             WRITE(LO,'(5X,3I3,4E12.3,2I3)')
22689      &        K,I,NPROHD(I),X0HD(I,1),X0HD(I,2),XHD(I,1),XHD(I,2),
22690      &        NINHD(I,1),NINHD(I,2)
22691               XTMP1 = XTMP1+XHD(I,1)
22692               XTMP2 = XTMP2+XHD(I,2)
22693  107      CONTINUE
22694           WRITE(LO,'(1X,A,2E13.4)') 'sum X1/2 (soft+hard):',XTMP1,XTMP2
22695           WRITE(LO,'(5X,A)') 'hard momenta  particle1:'
22696           DO 108 K=1,MHPAR1
22697             I = LSIDX(K)
22698             I3 = 8*I-4
22699             WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,1),L=1,4),
22700      &        NOUTHD(I,1)
22701  108      CONTINUE
22702           WRITE(LO,'(5X,A)') 'hard momenta  particle2:'
22703           DO 110 K=1,MHPAR2
22704             I = LSIDX(K)
22705             I3 = 8*I-4
22706             WRITE(LO,'(5X,2I3,1P,4E12.3,I5)') K,I,(PPH(I3+L,2),L=1,4),
22707      &        NOUTHD(I,2)
22708  110      CONTINUE
22709         ENDIF
22710       ENDIF
22711       RETURN
22712
22713 C  event rejected, print debug information
22714  450  CONTINUE
22715       IFAIL(4) = IFAIL(4)+1
22716       IF(IDEB(24).GE.2) THEN
22717         WRITE(LO,'(1X,2A,/,10X,7I5)') 'PHO_POMSCA: ',
22718      &    'rejection (MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ)',
22719      &    MSPOM,MHPOM,IHARD,MHARD,ITRY,NTRY,IREJ
22720         WRITE(LO,'(5X,A,I4,1P,2E12.4)') 'IP,Ecm,PTcut:',II,ECMP,PTWANT
22721         IF(IDEB(24).GE.5) THEN
22722           CALL PHO_PREVNT(0)
22723         ELSE
22724           CALL PHO_PREVNT(-1)
22725         ENDIF
22726       ENDIF
22727
22728       END
22729
22730 *$ CREATE PHO_HARX12.FOR
22731 *COPY PHO_HARX12
22732 CDECK  ID>, PHO_HARX12
22733       SUBROUTINE PHO_HARX12
22734 C**********************************************************************
22735 C
22736 C     selection of x1 and x2 according to 1/x1*1/x2
22737 C
22738 C**********************************************************************
22739       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22740       SAVE
22741
22742       PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
22743
22744 C  input/output channels
22745       INTEGER LI,LO
22746       COMMON /POINOU/ LI,LO
22747 C  data on most recent hard scattering
22748       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22749       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22750      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22751      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22752       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22753      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22754      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22755      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22756      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22757
22758 10    CONTINUE
22759         Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
22760         Z2 = Z2MAX-DT_RNDM(X2)*Z2DIF
22761         IF ( (Z1+Z2).LT.ALNH ) GOTO 10
22762       X1   = EXP(Z1)
22763       X2   = EXP(Z2)
22764       AXX  = AH/(X1*X2)
22765       W    = SQRT(MAX(TINY,1.D0-AXX))
22766       W1   = AXX/(1.D0+W)
22767
22768       END
22769
22770 *$ CREATE PHO_HARDX1.FOR
22771 *COPY PHO_HARDX1
22772 CDECK  ID>, PHO_HARDX1
22773       SUBROUTINE PHO_HARDX1
22774 C**********************************************************************
22775 C
22776 C     selection of x1 according to 1/x1
22777 C     ( x2 = 1 )
22778 C
22779 C**********************************************************************
22780       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22781       SAVE
22782
22783       PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
22784
22785 C  input/output channels
22786       INTEGER LI,LO
22787       COMMON /POINOU/ LI,LO
22788 C  data on most recent hard scattering
22789       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22790       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22791      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22792      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22793       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22794      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22795      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22796      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22797      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22798
22799       Z1 = Z1MAX-DT_RNDM(X1)*Z1DIF
22800       X2   = 1.D0
22801       X1   = EXP(Z1)
22802       AXX  = AH/X1
22803       W    = SQRT(MAX(TINY,1.D0-AXX))
22804       W1   = AXX/(1.D0+W)
22805
22806       END
22807
22808 *$ CREATE PHO_HARKIN.FOR
22809 *COPY PHO_HARKIN
22810 CDECK  ID>, PHO_HARKIN
22811       SUBROUTINE PHO_HARKIN(IREJ)
22812 C***********************************************************************
22813 C
22814 C     selection of kinematic variables
22815 C     (resolved and direct processes)
22816 C
22817 C***********************************************************************
22818       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22819       SAVE
22820
22821       PARAMETER ( TINY= 1.D-30, TINYP=1.D-14 )
22822
22823 C  input/output channels
22824       INTEGER LI,LO
22825       COMMON /POINOU/ LI,LO
22826 C  event debugging information
22827       INTEGER NMAXD
22828       PARAMETER (NMAXD=100)
22829       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
22830      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22831       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
22832      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
22833 C  data of c.m. system of Pomeron / Reggeon exchange
22834       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
22835       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
22836      &                 SIDP,CODP,SIFP,COFP
22837       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
22838      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
22839      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
22840 C  data on most recent hard scattering
22841       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22842       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22843      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
22844      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
22845       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
22846      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
22847      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
22848      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
22849      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
22850 C  internal cross check information on hard scattering limits
22851       DOUBLE PRECISION ETAMI,ETAMA,XXMI,XXMA
22852       COMMON /POHLIM/ ETAMI(2,15),ETAMA(2,15),XXMI(2,15),XXMA(2,15)
22853
22854       PARAMETER ( Max_pro_2 = 16 )
22855       DIMENSION RM(-1:Max_pro_2)
22856       DATA RM / 3.31D0, 0.0D0,
22857      &          7.60D0, 0.65D0, 4.00D0, 0.65D0, 0.89D0,
22858      &          0.45D0, 0.89D0, 0.89D0, 0.0D0,  4.776D0,
22859      &          0.615D0,4.776D0,0.615D0,1.0D0,  0.0D0,
22860      &          1.0D0 /
22861
22862       IREJ = 0
22863       M    = MSPR
22864
22865 C------------- resolved processes -----------
22866       IF     ( M.EQ.1 ) THEN
22867 10      CALL PHO_HARX12
22868         V  =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
22869         U  =-1.D0-V
22870         R  = (1.D0+W)*2.25D0*(V*V*(3.D0-U*V-V/(U*U))-U)
22871         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22872      &    'PHO_HARKIN:weight error',M
22873         IF ( R*W.LT.RM(1)*DT_RNDM(X2) ) GOTO 10
22874         IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22875       ELSEIF ( M.EQ.2 .OR. M.EQ.4 ) THEN
22876 20      CALL PHO_HARX12
22877         WL = LOG(W1)
22878         V  =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
22879         U  =-1.D0-V
22880         R  = (U*U+V*V)*((16.D0/27.D0)/U-(4.D0/3.D0)*V)*(WL/W)*AXX
22881         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22882      &    'PHO_HARKIN:weight error',M
22883         IF ( R*W.LT.RM(M)*DT_RNDM(X2) ) GOTO 20
22884         IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22885       ELSEIF ( M.EQ.3 ) THEN
22886 30      CALL PHO_HARX12
22887         V  =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
22888         U  =-1.D0-V
22889         R  = (1.D0+W)*(1.D0+U*U)*(1.D0-(4.D0/9.D0)*V*V/U)
22890         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22891      &    'PHO_HARKIN:weight error',M
22892         IF ( R*W.LT.RM(3)*DT_RNDM(X2) ) GOTO 30
22893       ELSEIF ( M.EQ.5 ) THEN
22894 50      CALL PHO_HARX12
22895         V  =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
22896         U  =-1.D0-V
22897         R  = (4.D0/9.D0)*(1.D0+U*U+V*V*(U*U+V*V))-(8.D0/27.D0)*U*U*V
22898         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22899      &    'PHO_HARKIN:weight error',M
22900         IF ( R*W.LT.RM(5)*DT_RNDM(X2) ) GOTO 50
22901       ELSEIF ( M.EQ.6 ) THEN
22902 60      CALL PHO_HARX12
22903         V  =-0.5D0*(1.D0+W)+DT_RNDM(X1)*W
22904         U  =-1.D0-V
22905         R  = (4.D0/9.D0)*(U*U+V*V)*AXX
22906         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22907      &    'PHO_HARKIN:weight error',M
22908         IF ( R*W.LT.RM(6)*DT_RNDM(V) ) GOTO 60
22909       ELSEIF ( M.EQ.7 ) THEN
22910 70      CALL PHO_HARX12
22911         V  =-0.5D0*W1/(W1+DT_RNDM(X1)*W)
22912         U  =-1.D0-V
22913         R  = (1.D0+W)*((2.D0/9.D0)*(1.D0+U*U+(1.D0+V*V)*V*V/(U*U))
22914      &       -(4.D0/27.D0)*V/U)
22915         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22916      &    'PHO_HARKIN:weight error',M
22917         IF ( R*W.LT.RM(7)*DT_RNDM(X2) ) GOTO 70
22918         IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22919       ELSEIF ( M.EQ.8 ) THEN
22920 80      CALL PHO_HARX12
22921         V  =-0.5D0*AXX/(W1+2.D0*DT_RNDM(X1)*W)
22922         U  =-1.D0-V
22923         R  = (4.D0/9.D0)*(1.D0+U*U)
22924         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22925      &    'PHO_HARKIN:weight error',M
22926         IF ( R*W.LT.RM(8)*DT_RNDM(X2) ) GOTO 80
22927       ELSEIF ( M.EQ.-1 ) THEN
22928 90      CALL PHO_HARX12
22929         WL = LOG(W1)
22930         V  =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
22931         U  =-1.D0-V
22932         R  = (1.D0+V*V)*(V/(U*U)-(4.D0/9.D0))*(WL/W)*AXX
22933         IF(R*W.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22934      &    'PHO_HARKIN:weight error',M
22935         IF ( R*W.LT.RM(-1)*DT_RNDM(X2) ) GOTO 90
22936 C------------- direct / single-resolved processes -----------
22937       ELSEIF ( M.EQ.10 ) THEN
22938 100     CALL PHO_HARDX1
22939         WL = LOG(AXX/(1.D0+W)**2)
22940         U  =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
22941         R  = -(8.D0/3.D0)*(U*U+1.D0)*WL*AXX
22942         IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22943      &    'PHO_HARKIN:weight error',M
22944         IF ( R.LT.RM(10)*DT_RNDM(U) ) GOTO 100
22945         V  =-1.D0-U
22946         X2 = X1
22947         X1 = 1.D0
22948       ELSEIF ( M.EQ.11) THEN
22949 110     CALL PHO_HARDX1
22950         WL = LOG(W1)
22951         U  =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
22952         V  =-1.D0-U
22953         R  = (U*U+V*V)/V*WL*AXX
22954         IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22955      &    'PHO_HARKIN:weight error',M
22956         IF ( R.LT.RM(11)*DT_RNDM(X2) ) GOTO 110
22957         IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22958         X2 = X1
22959         X1 = 1.D0
22960       ELSEIF ( M.EQ.12 ) THEN
22961 120     CALL PHO_HARDX1
22962         WL = LOG(AXX/(1.D0+W)**2)
22963         V  =-(1.D0+W)/2.D0*EXP(DT_RNDM(X1)*WL)
22964         R  = -(8.D0/3.D0)*(V*V+1.D0)*WL*AXX
22965         IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22966      &    'PHO_HARKIN:weight error',M
22967         IF ( R.LT.RM(12)*DT_RNDM(V) ) GOTO 120
22968       ELSEIF ( M.EQ.13) THEN
22969 130     CALL PHO_HARDX1
22970         WL = LOG(W1)
22971         V  =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
22972         U  =-1.D0-V
22973         R  = (U*U+V*V)/U*WL*AXX
22974         IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22975      &    'PHO_HARKIN:weight error',M
22976         IF ( R.LT.RM(13)*DT_RNDM(X2) ) GOTO 130
22977         IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22978 C------------- (double) direct process -----------
22979       ELSEIF ((M.EQ.14).OR.(M.EQ.16)) THEN
22980         X1 = 1.D0
22981         X2 = 1.D0
22982         AXX= AH
22983         W  = SQRT(MAX(TINY,1.D0-AXX))
22984         W1 = AXX/(1.D0+W)
22985         WL = LOG(W1)
22986  140    V  =-EXP(-0.6931472D0+DT_RNDM(X1)*WL)
22987         U  =-1.D0-V
22988         R  = -(U*U+V*V)/U
22989         IF(R.GT.RM(M)) WRITE(LO,'(1X,A,I3)')
22990      &    'PHO_HARKIN:weight error',M
22991         IF ( R.LT.RM(14)*DT_RNDM(X2) ) GOTO 140
22992         IF ( DT_RNDM(V).LE.0.5D0 ) V = U
22993 C---------------------------------------------
22994       ELSE
22995         WRITE(LO,'(/1X,A,I3)')
22996      &    'PHO_HARKIN:ERROR:unsupported process (MSPR)',MSPR
22997         CALL PHO_ABORT
22998       ENDIF
22999
23000       V    = MAX(MIN(V,-TINYP ),-1.D0+TINYP)
23001       U    = -1.D0-V
23002       U    = MAX(MIN(U,-TINYP ),-1.D0+TINYP)
23003       PT   = SQRT(U*V*X1*X2)*ECMP
23004       ETAC = 0.5D0*LOG((U*X1)/(V*X2))
23005       ETAD = 0.5D0*LOG((V*X1)/(U*X2))
23006
23007 ***************************************************************
23008       MM = M
23009       IF(M.EQ.-1) MM = 3
23010       ETAMI(1,MM) = MIN(ETAMI(1,MM),ETAC)
23011       ETAMA(1,MM) = MAX(ETAMA(1,MM),ETAC)
23012       ETAMI(2,MM) = MIN(ETAMI(2,MM),ETAD)
23013       ETAMA(2,MM) = MAX(ETAMA(2,MM),ETAD)
23014       XXMI(1,MM) = MIN(XXMI(1,MM),X1)
23015       XXMA(1,MM) = MAX(XXMA(1,MM),X1)
23016       XXMI(2,MM) = MIN(XXMI(2,MM),X2)
23017       XXMA(2,MM) = MAX(XXMA(2,MM),X2)
23018 ***************************************************************
23019
23020       IF(IDEB(81).GE.25) WRITE(LO,'(1X,A,/5X,6E12.3)')
23021      &  'PHO_HARKIN: V,PT,ETAC,ETAD,X1,X2',V,PT,ETAC,ETAD,X1,X2
23022
23023       END
23024
23025 *$ CREATE PHO_HARWGH.FOR
23026 *COPY PHO_HARWGH
23027 CDECK  ID>, PHO_HARWGH
23028       SUBROUTINE PHO_HARWGH(PDS,PDA,PDB,FDISTR)
23029 C***********************************************************************
23030 C
23031 C     calculate product of PDFs and coupling constants
23032 C     according to selected MSPR (process type)
23033 C
23034 C     input:    /POCKIN/
23035 C
23036 C     output:   PDS     resulting from PDFs alone
23037 C               FDISTR  complete weight function
23038 C               PDA,PDB fields containing the PDFs
23039 C
23040 C***********************************************************************
23041       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23042       SAVE
23043
23044       PARAMETER ( TINY= 1.D-30, TINY6=1.D-06)
23045
23046 C  input/output channels
23047       INTEGER LI,LO
23048       COMMON /POINOU/ LI,LO
23049 C  event debugging information
23050       INTEGER NMAXD
23051       PARAMETER (NMAXD=100)
23052       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
23053      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23054       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
23055      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23056 C  model switches and parameters
23057       CHARACTER*8 MDLNA
23058       INTEGER ISWMDL,IPAMDL
23059       DOUBLE PRECISION PARMDL
23060       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
23061 C  data of c.m. system of Pomeron / Reggeon exchange
23062       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23063       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23064      &                 SIDP,CODP,SIFP,COFP
23065       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23066      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
23067      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
23068 C  currently activated parton density parametrizations
23069       CHARACTER*8 PDFNAM
23070       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
23071       DOUBLE PRECISION PDFLAM,PDFQ2M
23072       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
23073      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
23074 C  hard scattering parameters used for most recent hard interaction
23075       INTEGER NFbeta,NF
23076       DOUBLE PRECISION ALQCD2,BQCD
23077       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
23078 C  some hadron information, will be deleted in future versions
23079       INTEGER NFS
23080       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
23081       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
23082 C  scale parameters for parton model calculations
23083       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
23084       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
23085       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
23086      &                NQQAL,NQQALI,NQQALF,NQQPD
23087 C  data on most recent hard scattering
23088       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23089       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23090      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23091      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23092       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23093      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23094      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23095      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23096      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23097 C  hard cross sections and MC selection weights
23098       INTEGER Max_pro_2
23099       PARAMETER ( Max_pro_2 = 16 )
23100       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
23101      &  MH_acc_1,MH_acc_2
23102       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
23103       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
23104      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
23105      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
23106      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
23107      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
23108 C  some constants
23109       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
23110       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
23111      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
23112
23113       DOUBLE PRECISION PHO_ALPHAS,pho_alphae
23114       DIMENSION PDA(-6:6),PDB(-6:6)
23115
23116       FDISTR = 0.D0
23117 C  set hard scale  QQ  for alpha and partondistr.
23118       IF     ( NQQAL.EQ.1 ) THEN
23119         QQAL = AQQAL*PT*PT
23120       ELSEIF ( NQQAL.EQ.2 ) THEN
23121         QQAL = AQQAL*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
23122       ELSEIF ( NQQAL.EQ.3 ) THEN
23123         QQAL = AQQAL*X1*X2*ECMP*ECMP
23124       ELSEIF ( NQQAL.EQ.4 ) THEN
23125         QQAL = AQQAL*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
23126       ENDIF
23127       IF     ( NQQPD.EQ.1 ) THEN
23128         QQPD = AQQPD*PT*PT
23129       ELSEIF ( NQQPD.EQ.2 ) THEN
23130         QQPD = AQQPD*X1*X2*ECMP*ECMP*U*V/(1.D0+V*V+U*U)
23131       ELSEIF ( NQQPD.EQ.3 ) THEN
23132         QQPD = AQQPD*X1*X2*ECMP*ECMP
23133       ELSEIF ( NQQPD.EQ.4 ) THEN
23134         QQPD = AQQPD*X1*X2*ECMP*ECMP*(U*V)**(1.D0/3.D0)
23135       ENDIF
23136 C  coupling constants, PDFs
23137       IF(MSPR.LT.9) THEN
23138         ALPHA1 = PHO_ALPHAS(QQAL,3)
23139         ALPHA2 = ALPHA1
23140         CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
23141         CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
23142         IF ( MSPR.EQ.1  .OR.  MSPR.EQ.4 ) THEN
23143           PDS   = PDA(0)*PDB(0)
23144         ELSE
23145           S2    = 0.D0
23146           S3    = 0.D0
23147           S4    = 0.D0
23148           S5    = 0.D0
23149           DO 10 I=1,NF
23150             S2  = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
23151             S3  = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
23152             S4  = S4+PDA(I)+PDA(-I)
23153             S5  = S5+PDB(I)+PDB(-I)
23154  10       CONTINUE
23155           IF ((MSPR.EQ.2).OR.(MSPR.EQ.5).OR.(MSPR.EQ.6)) THEN
23156             PDS = S2
23157           ELSE IF((MSPR.EQ.3).OR.(MSPR.EQ.-1)) THEN
23158             PDS = PDA(0)*S5+PDB(0)*S4
23159           ELSE IF(MSPR.EQ.7) THEN
23160             PDS = S3
23161           ELSE IF(MSPR.EQ.8) THEN
23162             PDS = S4*S5-(S2+S3)
23163           ENDIF
23164         ENDIF
23165       ELSE IF(MSPR.LT.12) THEN
23166         ALPHA2 = PHO_ALPHAS(QQAL,2)
23167         IF(IDPDG1.EQ.22) THEN
23168           ALPHA1 = pho_alphae(QQAL)
23169         ELSE IF(IDPDG1.EQ.990) THEN
23170           ALPHA1 = PARMDL(74)
23171         ENDIF
23172         CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
23173         S4    = 0.D0
23174         S6    = 0.D0
23175         DO 15 I=1,NF
23176           S4  = S4+PDB(I)+PDB(-I)
23177 C  charge counting
23178 *         IF(MOD(I,2).EQ.0) THEN
23179 *           S6  = S6+(PDB(I)+PDB(-I))*4.D0/9.D0
23180 *         ELSE
23181 *           S6  = S6+(PDB(I)+PDB(-I))*1.D0/9.D0
23182 *         ENDIF
23183           S6  = S6+(PDB(I)+PDB(-I))*Q_ch2(I)
23184  15     CONTINUE
23185         IF(MSPR.EQ.10) THEN
23186           IF(IDPDG1.EQ.990) THEN
23187             PDS = S4
23188           ELSE
23189             PDS = S6
23190           ENDIF
23191         ELSE
23192           PDS = PDB(0)
23193         ENDIF
23194       ELSE IF(MSPR.LT.14) THEN
23195         ALPHA1 = PHO_ALPHAS(QQAL,1)
23196         IF(IDPDG2.EQ.22) THEN
23197           ALPHA2 = pho_alphae(QQAL)
23198         ELSE IF(IDPDG2.EQ.990) THEN
23199           ALPHA2 = PARMDL(74)
23200         ENDIF
23201         CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
23202         S4    = 0.D0
23203         S6    = 0.D0
23204         DO 20 I=1,NF
23205           S4  = S4+PDA(I)+PDA(-I)
23206 C  charge counting
23207 *         IF(MOD(I,2).EQ.0) THEN
23208 *           S6  = S6+(PDA(I)+PDA(-I))*4.D0/9.D0
23209 *         ELSE
23210 *           S6  = S6+(PDA(I)+PDA(-I))*1.D0/9.D0
23211 *         ENDIF
23212           S6  = S6+(PDA(I)+PDA(-I))*Q_ch2(I)
23213  20     CONTINUE
23214         IF(MSPR.EQ.12) THEN
23215           IF(IDPDG2.EQ.990) THEN
23216             PDS = S4
23217           ELSE
23218             PDS = S6
23219           ENDIF
23220         ELSE
23221           PDS = PDA(0)
23222         ENDIF
23223       ELSE IF(MSPR.EQ.14) THEN
23224         SSR = X1*X2*ECMP*ECMP
23225         IF(IDPDG1.EQ.22) THEN
23226           ALPHA1 = pho_alphae(SSR)
23227         ELSE IF(IDPDG1.EQ.990) THEN
23228           ALPHA1 = PARMDL(74)
23229         ENDIF
23230         IF(IDPDG2.EQ.22) THEN
23231           ALPHA2 = pho_alphae(SSR)
23232         ELSE IF(IDPDG2.EQ.990) THEN
23233           ALPHA2 = PARMDL(74)
23234         ENDIF
23235         PDS = 1.D0
23236       ELSE
23237         WRITE(LO,'(/1X,A,I4)')
23238      &    'PHO_HARWGH:ERROR: invalid hard process number (MSPR)',MSPR
23239         CALL PHO_ABORT
23240       ENDIF
23241
23242 C  complete weight
23243       FDISTR  = HFac(MSPR)*ALPHA1*ALPHA2*PDS
23244
23245 C  debug output
23246       IF(IDEB(15).GE.20) WRITE(LO,'(1X,A,/5X,I3,2I6,4E10.3)')
23247      &    'PHO_HARWGH: MSPR,ID1,ID2,AL1,AL2,PDS,FDIS',
23248      &    MSPR,IDPDG1,IDPDG2,ALPHA1,ALPHA2,PDS,FDISTR
23249
23250       END
23251
23252 *$ CREATE PHO_HARSCA.FOR
23253 *COPY PHO_HARSCA
23254 CDECK  ID>, PHO_HARSCA
23255       SUBROUTINE PHO_HARSCA(IMODE,IP)
23256 C***********************************************************************
23257 C
23258 C     PHO_HARSCA determines the type of hard subprocess, the partons
23259 C     taking part in this subprocess and the kinematic variables
23260 C
23261 C     input:  IMODE   1   direct processes
23262 C                     2   resolved processes
23263 C                     -1  initialization
23264 C                     -2  output of statistics
23265 C             IP      1-4 particle combination (hadron/photon)
23266 C
23267 C***********************************************************************
23268       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23269       SAVE
23270
23271       PARAMETER( EPS  = 1.D-10,
23272      &           DEPS = 1.D-30 )
23273
23274 C  input/output channels
23275       INTEGER LI,LO
23276       COMMON /POINOU/ LI,LO
23277 C  event debugging information
23278       INTEGER NMAXD
23279       PARAMETER (NMAXD=100)
23280       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
23281      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23282       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
23283      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
23284 C  model switches and parameters
23285       CHARACTER*8 MDLNA
23286       INTEGER ISWMDL,IPAMDL
23287       DOUBLE PRECISION PARMDL
23288       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
23289 C  internal rejection counters
23290       INTEGER NMXJ
23291       PARAMETER (NMXJ=60)
23292       CHARACTER*10 REJTIT
23293       INTEGER IFAIL
23294       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
23295 C  hard scattering parameters used for most recent hard interaction
23296       INTEGER NFbeta,NF
23297       DOUBLE PRECISION ALQCD2,BQCD
23298       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
23299 C  data of c.m. system of Pomeron / Reggeon exchange
23300       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23301       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23302      &                 SIDP,CODP,SIFP,COFP
23303       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23304      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
23305      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
23306 C  names of hard scattering processes
23307       INTEGER Max_pro_1
23308       PARAMETER ( Max_pro_1 = 16 )
23309       CHARACTER*18 PROC
23310       COMMON /POHPRO/ PROC(0:Max_pro_1)
23311 C  data on most recent hard scattering
23312       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23313       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23314      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23315      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23316       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23317      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23318      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23319      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23320      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23321 C  hard scattering data
23322       INTEGER MSCAHD
23323       PARAMETER ( MSCAHD = 50 )
23324       INTEGER LSCAHD,LSC1HD,LSIDX,
23325      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
23326       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
23327       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
23328      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
23329      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
23330      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
23331      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
23332      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
23333      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
23334 C  hard cross sections and MC selection weights
23335       INTEGER Max_pro_2
23336       PARAMETER ( Max_pro_2 = 16 )
23337       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
23338      &  MH_acc_1,MH_acc_2
23339       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
23340       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
23341      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
23342      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
23343      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
23344      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
23345 C  cross sections
23346       INTEGER IPFIL,IFAFIL,IFBFIL
23347       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
23348      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
23349      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
23350      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
23351      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
23352       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
23353      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
23354      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
23355      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
23356      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
23357      &                IPFIL,IFAFIL,IFBFIL
23358 C  some constants
23359       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
23360       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
23361      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
23362
23363  111  CONTINUE
23364
23365 C  resolved processes
23366       IF(IMODE.EQ.2) THEN
23367
23368         MH_pro_on(0,IP) = 0
23369         HWgx(9)  = 0.D0
23370         DO 15 M=-1,8
23371           IF(MH_pro_on(M,IP).EQ.1) HWgx(9) = HWgx(9)+HWgx(M)
23372  15     CONTINUE
23373         IF(HWgx(9).LT.DEPS) THEN
23374           WRITE(LO,'(/1X,2A,I4,1P,E12.4)') 'PHO_HARSCA:ERROR: ',
23375      &      'no resolved process possible for IP',IP,HWgx(9)
23376           CALL PHO_ABORT
23377         ENDIF
23378 C
23379 C ----------------------------------------------I
23380 C  begin of iteration loop (resolved processes) I
23381 C                                               I
23382         IREJSC = 0
23383  10     CONTINUE
23384         IREJSC = IREJSC+1
23385         IF(IREJSC.GT.1000) THEN
23386           WRITE(LO,'(/1X,A,I10)')
23387      &      'PHO_HARSCA:ERROR: too many rejections (resolved)',IREJSC
23388             CALL PHO_ABORT
23389         ENDIF
23390
23391 C  find subprocess
23392         B      = DT_RNDM(X1)*HWgx(9)
23393         MSPR   =-2
23394         SUM    = 0.D0
23395  20     MSPR   = MSPR+1
23396         IF ( MH_pro_on(MSPR,IP).EQ.1 ) SUM = SUM+HWgx(MSPR)
23397         IF ( SUM.LT.B  .AND. MSPR.LT.8 ) GOTO 20
23398
23399         IF(IDEB(78).GE.20) WRITE(LO,'(1x,a,i3,i6)')
23400      &    'PHO_HARSCA: resolved process (MSPR,IREJSC)',MSPR,IREJSC
23401
23402 C  find kin. variables X1,X2 and V
23403         CALL PHO_HARKIN(IREJ)
23404         IF(IREJ.NE.0) THEN
23405           IFAIL(29) = IFAIL(29)+1
23406           GOTO 10
23407         ENDIF
23408 C  calculate remaining distribution
23409         CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
23410 C  actualize counter for cross-section calculation
23411         if(F.LE.1.D-15) then
23412           F = 0.D0
23413           goto 10
23414         endif
23415 *       XSECT(5,MSPR) = XSECT(5,MSPR)+F
23416 *       XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
23417         MH_tried(MSPR,IP) = MH_tried(MSPR,IP)+1
23418 C  check F against FMAX
23419         WEIGHT = F/(HWgx(MSPR)+DEPS)
23420         IF ( WEIGHT.LT.DT_RNDM(X2) ) GOTO 10
23421 C-------------------------------------------------------------------
23422         IF(WEIGHT.GT.1.D0) THEN
23423           WRITE(LO,1234) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR),WEIGHT
23424  1234     FORMAT(/,' PHO_HARSCA: (resolved) W>1 (MSPR,IP,ID1,2)',
23425      &      2I3,2I7,/' F,HWgx(MSPR),W',3E12.4)
23426           WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
23427      &      ECMP,PTWANT,AS,AH,PT
23428           WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
23429      &      ETAC,ETAD,X1,X2,V
23430           CALL PHO_PREVNT(-1)
23431         ENDIF
23432 C-------------------------------------------------------------------
23433 C                                             I
23434 C  end of iteration loop (resolved processes) I
23435 C --------------------------------------------I
23436 C
23437 C*********************************************************************
23438 C
23439 C  direct processes
23440
23441       ELSE IF(IMODE.EQ.1) THEN
23442
23443 C  single-resolved processes kinematically forbidden
23444         if(Z1DIF.lt.0.D0) then
23445           HWgx(10) = 0.D0
23446           HWgx(11) = 0.D0
23447           HWgx(12) = 0.D0
23448           HWgx(13) = 0.D0
23449         endif
23450
23451         HWgx(15)  = 0.D0
23452         if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
23453           DO M= 10,14
23454             IF(MH_pro_on(M,IP).EQ.1) then
23455               if((M.eq.10).or.(M.eq.11)) then
23456                 fac = FSUH(1)*FSUP(2)
23457               else if((M.eq.12).or.(M.eq.13)) then
23458                 fac = FSUP(1)*FSUH(2)
23459               else
23460                 fac = FSUH(1)*FSUH(2)
23461               endif
23462               HWgx(15) = HWgx(15)+HWgx(M)*fac
23463             endif
23464           ENDDO
23465         else
23466           DO M= 10,14
23467             IF(MH_pro_on(M,IP).EQ.1) HWgx(15)=HWgx(15)+HWgx(M)
23468           ENDDO
23469         endif
23470         IF(HWgx(15).LT.DEPS) THEN
23471           WRITE(LO,'(/1X,2A,I4)') 'PHO_HARSCA:ERROR: ',
23472      &      'no direct/single-resolved process possible (IP)',IP
23473           CALL PHO_ABORT
23474         ENDIF
23475 C
23476 C ----------------------------------------------I
23477 C  begin of iteration loop (direct processes)   I
23478 C                                               I
23479         IREJSC = 0
23480  100    CONTINUE
23481         IREJSC = IREJSC+1
23482         IF(IREJSC.GT.1000) THEN
23483           WRITE(LO,'(/1X,A,I10)')
23484      &      'PHO_HARSCA:ERROR: too many rejections (direct)',IREJSC
23485             CALL PHO_ABORT
23486         ENDIF
23487
23488 C  find subprocess
23489         B      = DT_RNDM(X1)*HWgx(15)
23490         MSPR   = 9
23491         SUM    = 0.D0
23492         if((IPAMDL(115).eq.0).and.(IP.eq.1)) then
23493  150      continue
23494             MSPR   = MSPR+1
23495             IF(MH_pro_on(MSPR,IP).EQ.1) then
23496               if((MSPR.eq.10).or.(MSPR.eq.11)) then
23497                 fac = FSUH(1)*FSUP(2)
23498               else if((MSPR.eq.12).or.(MSPR.eq.13)) then
23499                 fac = FSUP(1)*FSUH(2)
23500               else
23501                 fac = FSUH(1)*FSUH(2)
23502               endif
23503               SUM = SUM+HWgx(MSPR)*fac
23504             endif
23505           IF ( SUM.LT.B  .AND. MSPR.LT.14 ) GOTO 150
23506         else
23507  200      continue
23508             MSPR   = MSPR+1
23509             IF(MH_pro_on(MSPR,IP).EQ.1) SUM = SUM+HWgx(MSPR)
23510           IF ( SUM.LT.B  .AND. MSPR.LT.14 ) GOTO 200
23511         endif
23512
23513         IF(IDEB(78).GE.20) WRITE(LO,'(1x,a,i3,i6)')
23514      &    'PHO_HARSCA: direct process (MSPR,IREJSC)',MSPR,IREJSC
23515
23516 C  find kin. variables X1,X2 and V
23517         CALL PHO_HARKIN(IREJ)
23518         IF(IREJ.NE.0) THEN
23519           IFAIL(28) = IFAIL(28)+1
23520           GOTO 100
23521         ENDIF
23522
23523 C  calculate remaining distribution
23524         CALL PHO_HARWGH(PDS,PDF1,PDF2,F)
23525
23526 C  counter for cross-section calculation
23527         if(F.LE.1.D-15) then
23528           F=0.D0
23529           goto 100
23530         endif
23531 *       XSECT(5,MSPR) = XSECT(5,MSPR)+F
23532 *       XSECT(6,MSPR) = XSECT(6,MSPR)+F*F
23533         MH_tried(MSPR,IP) = MH_tried(MSPR,IP)+1
23534 C  check F against FMAX
23535         WEIGHT = F/(HWgx(MSPR)+DEPS)
23536         IF(WEIGHT.LT.DT_RNDM(X2)) GOTO 100
23537 C-------------------------------------------------------------------
23538         IF(WEIGHT.GT.1.D0) THEN
23539           WRITE(LO,1235) MSPR,IP,IDPDG1,IDPDG2,F,HWgx(MSPR),WEIGHT
23540  1235     FORMAT(/,' PHO_HARSCA: (direct) W>1 (MSPR,IP,ID1,2)',
23541      &      2I3,2I7,/,' F,HWgx(MSPR),W',3E12.4)
23542           WRITE(LO,'(1X,A,5E11.3)') 'ECM,PTWANT,AS,AH,PT',
23543      &      ECMP,PTWANT,AS,AH,PT
23544           WRITE(LO,'(1X,A,5E11.3)') 'ETAC,ETAD,X1,X2,V',
23545      &      ETAC,ETAD,X1,X2,V
23546           CALL PHO_PREVNT(-1)
23547         ENDIF
23548 C-------------------------------------------------------------------
23549 C                                             I
23550 C  end of iteration loop (direct processes)   I
23551 C --------------------------------------------I
23552
23553       ELSE IF(IMODE.EQ.-1) THEN
23554
23555 C  initialize cross section calculations
23556
23557         DO 40 M=-1,Max_pro_2
23558 *         DO 30 I=5,6
23559 *           XSECT(I,M) = 0.D0
23560 *30       CONTINUE
23561 C  reset counters
23562           DO 35 J=1,4
23563             MH_tried(M,J) = 0
23564             MH_acc_1(M,J) = 0
23565             MH_acc_2(M,J) = 0
23566  35       CONTINUE
23567  40     CONTINUE
23568         IF(IDEB(78).GE.0) THEN
23569           WRITE(LO,'(/1X,A,/1X,A)')
23570      &      'PHO_HARSCA: activated hard processes',
23571      &      '------------------------------------'
23572           WRITE(LO,'(5X,A)') 'PROCESS,    IP= 1 ... 4 (on/off)'
23573           DO 42 M=1,Max_pro_2
23574             WRITE(LO,'(1X,I3,5X,A,4I3)') M,PROC(M),
23575      &        (MH_pro_on(M,J),J=1,4)
23576  42       CONTINUE
23577         ENDIF
23578         RETURN
23579
23580       ELSE IF(IMODE.EQ.-2) THEN
23581
23582 C  calculation of process statistics
23583
23584         do K=1,4
23585
23586           MH_tried(0,K)  = 0
23587           MH_acc_1(0,K)  = 0
23588           MH_acc_2(0,K)  = 0
23589           MH_tried(9,K)  = 0
23590           MH_acc_1(9,K)  = 0
23591           MH_acc_2(9,K)  = 0
23592           MH_tried(15,K) = 0
23593           MH_acc_1(15,K) = 0
23594           MH_acc_2(15,K) = 0
23595
23596           MH_tried(3,K) = MH_tried(3,K)+MH_tried(-1,K)
23597           MH_acc_1(3,K) = MH_acc_1(3,K)+MH_acc_1(-1,K)
23598           MH_acc_2(3,K) = MH_acc_2(3,K)+MH_acc_2(-1,K)
23599
23600           do M=1,8
23601             MH_tried(9,K) = MH_tried(9,K)+MH_tried(M,K)
23602             MH_acc_1(9,K) = MH_acc_1(9,K)+MH_acc_1(M,K)
23603             MH_acc_2(9,K) = MH_acc_2(9,K)+MH_acc_2(M,K)
23604           enddo
23605           do M=10,14
23606             MH_tried(15,K) = MH_tried(15,K)+MH_tried(M,K)
23607             MH_acc_1(15,K) = MH_acc_1(15,K)+MH_acc_1(M,K)
23608             MH_acc_2(15,K) = MH_acc_2(15,K)+MH_acc_2(M,K)
23609           enddo
23610           MH_tried(0,K) = MH_tried(9,K)+MH_tried(15,K)
23611           MH_acc_1(0,K) = MH_acc_1(9,K)+MH_acc_1(15,K)
23612           MH_acc_2(0,K) = MH_acc_2(9,K)+MH_acc_2(15,K)
23613         enddo
23614
23615         IF(IDEB(78).GE.1) THEN
23616           WRITE(LO,'(/1X,A,/1X,A)')
23617      &      'PHO_HARSCA: internal rejection statistics',
23618      &      '-----------------------------------------'
23619           do K=1,4
23620             IF(MH_tried(0,K).GT.0) THEN
23621               WRITE(LO,'(5X,A,I3)')
23622      &          'process (sampled/accepted) for IP:',K
23623               do M=0,Max_pro_2
23624                 WRITE(LO,'(1X,I3,1X,A,2X,3I12,F10.4)') M,PROC(M),
23625      &            MH_tried(M,K),MH_acc_1(M,K),MH_acc_2(K,K),
23626      &            dble(MH_acc_1(M,K))/dble(max(1,MH_tried(M,K)))
23627               enddo
23628             ENDIF
23629           enddo
23630         ENDIF
23631         RETURN
23632
23633       ELSE
23634         WRITE(LO,'(/1X,2A,I10)') 'PHO_HARSCA:ERROR: ',
23635      &    'unsupported mode',IMODE
23636         CALL PHO_ABORT
23637       ENDIF
23638
23639 C  the event is accepted now
23640 C  actualize counter for accepted events
23641       MH_acc_1(MSPR,IP) = MH_acc_1(MSPR,IP)+1
23642       IF(MSPR.EQ.-1) MSPR = 3
23643 C
23644 C  find flavor of initial partons
23645 C
23646       SUM    = 0.D0
23647       SCHECK = DT_RNDM(SUM)*PDS-EPS
23648       IF     ( MSPR.EQ.1  .OR.  MSPR.EQ.4 ) THEN
23649         IA = 0
23650         IB = 0
23651       ELSEIF ( MSPR.EQ.2  .OR.  MSPR.EQ.5  .OR.  MSPR.EQ.6 ) THEN
23652         DO 610 IA=-NF,NF
23653           IF ( IA.EQ.0 ) GOTO 610
23654           SUM  = SUM+PDF1(IA)*PDF2(-IA)
23655           IF ( SUM.GE.SCHECK ) GOTO 620
23656  610      CONTINUE
23657  620    IB =-IA
23658       ELSEIF ( MSPR.EQ.3 ) THEN
23659         IB     = 0
23660         DO 630 IA=-NF,NF
23661           IF ( IA.EQ.0 ) GOTO 630
23662           SUM  = SUM+PDF1(0)*PDF2(IA)
23663           IF ( SUM.GE.SCHECK ) GOTO 640
23664           SUM  = SUM+PDF1(IA)*PDF2(0)
23665           IF ( SUM.GE.SCHECK ) GOTO 650
23666  630    CONTINUE
23667  640    IB     = IA
23668         IA     = 0
23669  650    CONTINUE
23670       ELSEIF ( MSPR.EQ.7 ) THEN
23671         DO 660 IA=-NF,NF
23672           IF ( IA.EQ.0 ) GOTO 660
23673           SUM  = SUM+PDF1(IA)*PDF2(IA)
23674           IF ( SUM.GE.SCHECK ) GOTO 670
23675  660      CONTINUE
23676  670    IB     = IA
23677       ELSEIF ( MSPR.EQ.8 ) THEN
23678         DO 690 IA=-NF,NF
23679           IF ( IA.EQ.0 ) GOTO 690
23680           DO 680 IB=-NF,NF
23681             IF ( ABS(IB).EQ.ABS(IA)  .OR.  IB.EQ.0 ) GOTO 680
23682             SUM = SUM+PDF1(IA)*PDF2(IB)
23683             IF ( SUM.GE.SCHECK ) GOTO 700
23684  680        CONTINUE
23685  690      CONTINUE
23686  700    CONTINUE
23687       ELSEIF ( MSPR.EQ.10 ) THEN
23688         IA     = 0
23689         DO 710 IB=-NF,NF
23690           IF ( IB.NE.0 ) THEN
23691             IF(IDPDG1.EQ.22) THEN
23692 *             IF(MOD(ABS(IB),2).EQ.0) THEN
23693 *               SUM = SUM+PDF2(IB)*4.D0/9.D0
23694 *             ELSE
23695 *               SUM = SUM+PDF2(IB)*1.D0/9.D0
23696 *             ENDIF
23697               SUM = SUM+PDF2(IB)*Q_ch2(IB)
23698             ELSE
23699               SUM = SUM+PDF2(IB)
23700             ENDIF
23701             IF ( SUM.GE.SCHECK ) GOTO 720
23702           ENDIF
23703  710    CONTINUE
23704  720    CONTINUE
23705       ELSEIF ( MSPR.EQ.12 ) THEN
23706         IB     = 0
23707         DO 810 IA=-NF,NF
23708           IF ( IA.NE.0 ) THEN
23709             IF(IDPDG2.EQ.22) THEN
23710 *             IF(MOD(ABS(IA),2).EQ.0) THEN
23711 *               SUM = SUM+PDF1(IA)*4.D0/9.D0
23712 *             ELSE
23713 *               SUM = SUM+PDF1(IA)*1.D0/9.D0
23714 *             ENDIF
23715               SUM = SUM+PDF1(IA)*Q_ch2(IA)
23716             ELSE
23717               SUM = SUM+PDF1(IA)
23718             ENDIF
23719             IF ( SUM.GE.SCHECK ) GOTO 820
23720           ENDIF
23721  810    CONTINUE
23722  820    CONTINUE
23723       ELSEIF ((MSPR.EQ.11).OR.(MSPR.EQ.13).OR.(MSPR.EQ.14)) THEN
23724         IA     = 0
23725         IB     = 0
23726       ENDIF
23727 C  final check
23728       IF((ABS(IA).GT.NF).OR.(ABS(IB).GT.NF)) THEN
23729         WRITE(LO,*) 'PHO_HARSCA: rejection, final check IA,IB',IA,IB
23730         WRITE(LO,*) 'EVENT,MSPR,IA,IB,NF: ',KEVENT,MSPR,IA,IB,NF
23731         GOTO 111
23732       ENDIF
23733 C
23734 C  find flavour of final partons
23735 C
23736       IC = IA
23737       ID = IB
23738       IF     ( MSPR.EQ.2 ) THEN
23739         IC = 0
23740         ID = 0
23741       ELSEIF ( MSPR.EQ.4 ) THEN
23742         IC = INT(FLOAT(NF+NF)*DT_RNDM(SUM))+1
23743         IF ( IC.GT.NF ) IC = NF-IC
23744         ID =-IC
23745       ELSEIF ( MSPR.EQ.6 ) THEN
23746         IC = INT(FLOAT(NF+NF-2)*DT_RNDM(SUM))+1
23747         IF ( IC.GT.NF-1 ) IC = NF-1-IC
23748         IF ( ABS(IC).EQ.ABS(IA) ) IC = SIGN(NF,IC)
23749         ID =-IC
23750       ELSEIF ( MSPR.EQ.11) THEN
23751         SUM = 0.D0
23752         DO 730 IC=-NF,NF
23753           IF ( IC.NE.0 ) THEN
23754             IF(IDPDG1.EQ.22) THEN
23755 *             IF(MOD(ABS(IC),2).EQ.0) THEN
23756 *               SUM = SUM + 4.D0
23757 *             ELSE
23758 *               SUM = SUM + 1.D0
23759 *             ENDIF
23760               SUM = SUM + Q_ch2(IC)
23761             ELSE
23762               SUM = SUM + 1.D0
23763             ENDIF
23764           ENDIF
23765  730    CONTINUE
23766         SCHECK = DT_RNDM(SUM)*SUM-EPS
23767         SUM = 0.D0
23768         DO 740 IC=-NF,NF
23769           IF ( IC.NE.0 ) THEN
23770             IF(IDPDG1.EQ.22) THEN
23771 *             IF(MOD(ABS(IC),2).EQ.0) THEN
23772 *               SUM = SUM + 4.D0
23773 *             ELSE
23774 *               SUM = SUM + 1.D0
23775 *             ENDIF
23776               SUM = SUM + Q_ch2(IC)
23777             ELSE
23778               SUM = SUM + 1.D0
23779             ENDIF
23780             IF ( SUM.GE.SCHECK ) GOTO 750
23781           ENDIF
23782  740    CONTINUE
23783  750    CONTINUE
23784         ID = -IC
23785       ELSEIF ( MSPR.EQ.12) THEN
23786         IC = 0
23787         ID = IA
23788       ELSEIF ( MSPR.EQ.13) THEN
23789         SUM = 0.D0
23790         DO 830 IC=-NF,NF
23791           IF ( IC.NE.0 ) THEN
23792             IF(IDPDG2.EQ.22) THEN
23793 *             IF(MOD(ABS(IC),2).EQ.0) THEN
23794 *               SUM = SUM + 4.D0
23795 *             ELSE
23796 *               SUM = SUM + 1.D0
23797 *             ENDIF
23798               SUM = SUM +  Q_ch2(IC)
23799             ELSE
23800               SUM = SUM + 1.D0
23801             ENDIF
23802           ENDIF
23803  830    CONTINUE
23804         SCHECK = DT_RNDM(SUM)*SUM-EPS
23805         SUM = 0.D0
23806         DO 840 IC=-NF,NF
23807           IF ( IC.NE.0 ) THEN
23808             IF(IDPDG2.EQ.22) THEN
23809 *             IF(MOD(ABS(IC),2).EQ.0) THEN
23810 *               SUM = SUM + 4.D0
23811 *             ELSE
23812 *               SUM = SUM + 1.D0
23813 *             ENDIF
23814               SUM = SUM +  Q_ch2(IC)
23815             ELSE
23816               SUM = SUM + 1.D0
23817             ENDIF
23818             IF ( SUM.GE.SCHECK ) GOTO 850
23819           ENDIF
23820  840    CONTINUE
23821  850    CONTINUE
23822         ID = -IC
23823       ELSEIF ( MSPR.EQ.14) THEN
23824         SUM = 0.D0
23825         DO 930 IC=1,NF
23826           FAC1 = 1.D0
23827           FAC2 = 1.D0
23828           IF(MOD(ABS(IC),2).EQ.0) THEN
23829             IF(IDPDG1.EQ.22) FAC1 = 4.D0
23830             IF(IDPDG2.EQ.22) FAC2 = 4.D0
23831           ENDIF
23832           SUM = SUM + FAC1*FAC2
23833  930    CONTINUE
23834         IF(IPAMDL(64).NE.0) THEN
23835           IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) SUM = SUM + 81.D0
23836         ENDIF
23837         SCHECK = DT_RNDM(SUM)*SUM-EPS
23838         SUM = 0.D0
23839         DO 940 IC=1,NF
23840           FAC1 = 1.D0
23841           FAC2 = 1.D0
23842           IF(MOD(ABS(IC),2).EQ.0) THEN
23843             IF(IDPDG1.EQ.22) FAC1 = 4.D0
23844             IF(IDPDG2.EQ.22) FAC2 = 4.D0
23845           ENDIF
23846           SUM = SUM + FAC1*FAC2
23847           IF ( SUM.GE.SCHECK ) GOTO 950
23848  940    CONTINUE
23849         IC = 15
23850  950    CONTINUE
23851         ID = -IC
23852         IF(DT_RNDM(FAC1).GT.0.5D0) CALL PHO_SWAPI(IC,ID)
23853       ENDIF
23854       if(IC.eq.0) then
23855         XM3 = 0.D0
23856       else
23857         XM3 = PHO_PMASS(IC,3)
23858       endif
23859       if(ID.eq.0) then
23860         XM4 = 0.D0
23861       else
23862         XM4 = PHO_PMASS(ID,3)
23863       endif
23864       IF(ABS(IC).EQ.15) GOTO 955
23865
23866 C  valence quarks involved?
23867       IV1 = 0
23868       IF(IA.NE.0) THEN
23869         IF(IDPDG1.EQ.22) THEN
23870           CALL PHO_QPMPDF(IA,X1,QQPD,0.D0,PVIRTP(1),FXP)
23871           IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(IA)-FXP) IV1 = 1
23872         ELSE
23873           IF(DT_RNDM(XM3)*PDF1(IA).GT.PDF1(-IA)) IV1 = 1
23874         ENDIF
23875       ENDIF
23876       IV2 = 0
23877       IF(IB.NE.0) THEN
23878         IF(IDPDG2.EQ.22) THEN
23879           CALL PHO_QPMPDF(IB,X2,QQPD,0.D0,PVIRTP(2),FXP)
23880           IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(IB)-FXP) IV2 = 1
23881         ELSE
23882           IF(DT_RNDM(XM4)*PDF2(IB).GT.PDF2(-IB)) IV2 = 1
23883         ENDIF
23884       ENDIF
23885 C
23886 C  fill event record
23887 C
23888  955  CONTINUE
23889       CALL PHO_SFECFE(SINPHI,COSPHI)
23890       ECM2 = ECMP/2.D0
23891 C  incoming partons
23892       PHI1(1) = 0.D0
23893       PHI1(2) = 0.D0
23894       PHI1(3) = ECM2*X1
23895       PHI1(4) = PHI1(3)
23896       PHI1(5) = 0.D0
23897       PHI2(1) = 0.D0
23898       PHI2(2) = 0.D0
23899       PHI2(3) = -ECM2*X2
23900       PHI2(4) = -PHI2(3)
23901       PHI2(5) = 0.D0
23902 C  outgoing partons
23903       PHO1(1) = PT*COSPHI
23904       PHO1(2) = PT*SINPHI
23905       PHO1(3) = -ECM2*(U*X1-V*X2)
23906       PHO1(4) = -ECM2*(U*X1+V*X2)
23907       PHO1(5) = XM3
23908       PHO2(1) = -PHO1(1)
23909       PHO2(2) = -PHO1(2)
23910       PHO2(3) = -ECM2*(V*X1-U*X2)
23911       PHO2(4) = -ECM2*(V*X1+U*X2)
23912       PHO2(5) = XM4
23913
23914 C  convert to mass shell
23915       CALL PHO_MSHELL(PHO1,PHO2,XM3,XM4,PHO1,PHO2,IREJ)
23916       IF(IREJ.NE.0) THEN
23917         IF(IDEB(78).GE.5) WRITE(LO,'(1X,A,1P,3E11.3)')
23918      &    'PHO_HARSCA: rejection by PHO_MSHELL (PT,M1,M2)',
23919      &    PT,XM3,XM4
23920         GOTO 111
23921       ENDIF
23922       PTfin = SQRT(PHO1(1)**2+PHO1(2)**2)
23923
23924 C  debug output
23925       IF(IDEB(78).GE.20) THEN
23926         SHAT = X1*X2*ECMP*ECMP
23927         WRITE(LO,'(1X,A,5I4)') 'PHO_HARSCA: MSPR,IA,IB,IC,ID',
23928      &    MSPR,IA,IB,IC,ID
23929         WRITE(LO,'(5X,A,1P,4E11.3)') 'X1/2,MU2,Q2 ',X1,X2,QQPD,QQAL
23930         WRITE(LO,'(5X,A,1P,4E11.3)') 'U,V,PT,SHAT ',U,V,PT,SHAT
23931         WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI1 ',PHI1
23932         WRITE(LO,'(5X,A,1P,5E11.3)') 'PHI2 ',PHI2
23933         WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO1 ',PHO1
23934         WRITE(LO,'(5X,A,1P,5E11.3)') 'PHO2 ',PHO2
23935       ENDIF
23936
23937       END
23938
23939 *$ CREATE PHO_HARFAC.FOR
23940 *COPY PHO_HARFAC
23941 CDECK  ID>, PHO_HARFAC
23942       SUBROUTINE PHO_HARFAC(PTCUT,ECMI)
23943 C*********************************************************************
23944 C
23945 C     initialization: find scaling factors and maxima of remaining
23946 C                     weights
23947 C
23948 C     input:   PTCUT  transverse momentum cutoff
23949 C              ECMI   cms energy
23950 C
23951 C     output:  Hfac(-1:Max_pro_2)  field for sampling hard processes
23952 C
23953 C*********************************************************************
23954       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23955       SAVE
23956
23957       PARAMETER ( MXABWT = 96 )
23958
23959 C  input/output channels
23960       INTEGER LI,LO
23961       COMMON /POINOU/ LI,LO
23962 C  data of c.m. system of Pomeron / Reggeon exchange
23963       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
23964       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
23965      &                 SIDP,CODP,SIFP,COFP
23966       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
23967      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
23968      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
23969 C  some constants
23970       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
23971       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
23972      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
23973 C  hard scattering parameters used for most recent hard interaction
23974       INTEGER NFbeta,NF
23975       DOUBLE PRECISION ALQCD2,BQCD
23976       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
23977 C  integration precision for hard cross sections (obsolete)
23978       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
23979       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
23980 C  data on most recent hard scattering
23981       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23982       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23983      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
23984      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
23985       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
23986      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
23987      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
23988      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
23989      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
23990 C  hard cross sections and MC selection weights
23991       INTEGER Max_pro_2
23992       PARAMETER ( Max_pro_2 = 16 )
23993       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
23994      &  MH_acc_1,MH_acc_2
23995       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
23996       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
23997      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
23998      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
23999      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24000      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24001
24002       DIMENSION       ABSZ(MXABWT),WEIG(MXABWT)
24003       DIMENSION S(-1:Max_pro_2),S1(-1:Max_pro_2),S2(-1:Max_pro_2),
24004      &          F124(-1:Max_pro_2)
24005       DATA F124 / 1.D0,0.D0,
24006      &            4.D0,2.D0,2.D0,2.D0,4.D0,1.D0,4.D0,4.D0,0.D0,1.D0,
24007      &            2.D0,1.D0,2.D0,1.D0,0.D0,1.D0 /
24008
24009       SS     = ECMI*ECMI
24010       AH     = (2.D0*PTCUT/ECMI)**2
24011       ALN    = LOG(AH)
24012       HLN    = LOG(0.5D0)
24013       NPOINT = NGAUIN
24014       CALL PHO_GAUSET(0.D0,1.D0,NPOINT,ABSZ,WEIG)
24015       DO 10 M=-1,Max_pro_2
24016         S1(M) = 0.D0
24017 10    CONTINUE
24018
24019 C  resolved processes
24020       DO 80 I1=1,NPOINT
24021         Z1   = ABSZ(I1)
24022         X1   = EXP(ALN*Z1)
24023         DO 20 M=-1,9
24024           S2(M) = 0.D0
24025 20      CONTINUE
24026
24027         DO 60 I2=1,NPOINT
24028           Z2    = (1.D0-Z1)*ABSZ(I2)
24029           X2    = EXP(ALN*Z2)
24030           FAXX  = AH/(X1*X2)
24031           W     = SQRT(1.D0-FAXX)
24032           W1    = FAXX/(1.+W)
24033           WLOG  = LOG(W1)
24034           FWW   = FAXX*WLOG/W
24035           DO 30 M=-1,9
24036             S(M) = 0.D0
24037 30        CONTINUE
24038
24039           DO 40 I=1,NPOINT
24040             Z   = ABSZ(I)
24041             VA  =-0.5D0*W1/(W1+Z*W)
24042             UA  =-1.D0-VA
24043             VB  =-0.5D0*FAXX/(W1+2.D0*W*Z)
24044             UB  =-1.D0-VB
24045             VC  =-EXP(HLN+Z*WLOG)
24046             UC  =-1.D0-VC
24047             VE  =-0.5D0*(1.D0+W)+Z*W
24048             UE  =-1.D0-VE
24049             S(1)  = S(1)+(1.+W)*2.25*(VA*VA*(3.-UA*VA-VA/(UA*UA))-UA)*
24050      &           WEIG(I)
24051             S(2)  = S(2)+(VC*VC+UC*UC)*((16./27.)/UC-(4./3.)*VC)*FWW*
24052      &            WEIG(I)
24053             S(3)  = S(3)+(1.+W)*(1.+UA*UA)*(1.-(4./9.)*VA*VA/UA)*WEIG(I)
24054             S(5)  = S(5)+((4./9.)*(1.+UB*UB+(UB*UB+VB*VB)*VB*VB)-
24055      &            (8./27.)*UA*UA*VA)*WEIG(I)
24056             S(6)  = S(6)+(4./9.)*(UE*UE+VE*VE)*FAXX*WEIG(I)
24057             S(7)  = S(7)+(1.+W)*((2./9.)*(1.+UA*UA+(1.+VA*VA)*VA*VA/
24058      &            (UA*UA))-(4./27.)*VA/UA)*WEIG(I)
24059             S(8)  = S(8)+(4./9.)*(1.+UB*UB)*WEIG(I)
24060             S(-1) = S(-1)+(1.+VC*VC)*(VC/(UC*UC)-(4./9.))*FWW*WEIG(I)
24061 40        CONTINUE
24062           S(4)    = S(2)*(9./32.)
24063           DO 50 M=-1,8
24064             S2(M) = S2(M)+S(M)*WEIG(I2)*W
24065 50        CONTINUE
24066 60      CONTINUE
24067         DO 70 M=-1,8
24068           S1(M) = S1(M)+S2(M)*(1.D0-Z1)*WEIG(I1)
24069 70      CONTINUE
24070 80    CONTINUE
24071       S1(4) = S1(4)*NF
24072       S1(6) = S1(6)*MAX(0,NF-1)
24073 C
24074 C  direct processes
24075       IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
24076      &   .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24077         DO 180 I1=1,NPOINT
24078           Z2   = ABSZ(I1)
24079           X2   = EXP(ALN*Z2)
24080           FAXX  = AH/X2
24081           W     = SQRT(1.D0-FAXX)
24082           W1    = FAXX/(1.D0+W)
24083           WLOG  = LOG(W1)
24084           WL = LOG(FAXX/(1.D0+W)**2)
24085           FWW1  = FAXX*WL/ALN
24086           FWW2  = FAXX*WLOG/ALN
24087           DO 130 M=10,12
24088             S(M) = 0.D0
24089  130      CONTINUE
24090 C
24091           DO 140 I=1,NPOINT
24092             Z   = ABSZ(I)
24093             UA  =-(1.D0+W)/2.D0*EXP(Z*WL)
24094             VA  =-1.D0-UA
24095             VB  =-EXP(HLN+Z*WLOG)
24096             UB  =-1.D0-VB
24097             S(10)  = S(10)+(8.D0/3.D0)*(1.D0+UA*UA)*WEIG(I)*FWW1
24098             S(11) = S(11)-(VB*VB+UB*UB)/UB*WEIG(I)*FWW2
24099  140      CONTINUE
24100           DO 170 M=10,11
24101             S1(M) = S1(M)+S(M)*WEIG(I1)
24102  170      CONTINUE
24103  180    CONTINUE
24104         S1(12) = S1(10)
24105         S1(13) = S1(11)
24106 C  quark charges fractions
24107         IF(IDPDG1.EQ.22) THEN
24108           CHRNF = 0.D0
24109           DO 100 I=1,NF
24110             CHRNF = CHRNF + Q_ch2(I)
24111  100      CONTINUE
24112           S1(11) = S1(11)*CHRNF
24113         ELSE IF(IDPDG1.EQ.990) THEN
24114           S1(11) = S1(11)*NF
24115         ELSE
24116           S1(11) = 0.D0
24117         ENDIF
24118         IF(IDPDG2.EQ.22) THEN
24119           CHRNF = 0.D0
24120           DO 200 I=1,NF
24121             CHRNF = CHRNF + Q_ch2(I)
24122  200      CONTINUE
24123           S1(13) = S1(13)*CHRNF
24124         ELSE IF(IDPDG2.EQ.990) THEN
24125           S1(13) = S1(13)*NF
24126         ELSE
24127           S1(13) = 0.D0
24128         ENDIF
24129       ENDIF
24130 C
24131 C  global factors
24132       FFF    = PI*GEV2MB*ALN*ALN/(AH*SS)
24133       DO 90 M=-1,Max_pro_2
24134         Hfac(M) = MAX(FFF*F124(M)*S1(M),0.D0)
24135 90    CONTINUE
24136 C
24137 C  double direct process
24138       IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
24139      &   .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
24140         FAC = 0.D0
24141         DO 300 I=1,NF
24142           IF(IDPDG1.EQ.22) THEN
24143             F1 = Q_ch2(I)
24144           ELSE
24145             F1 = 1.D0
24146           ENDIF
24147           IF(IDPDG2.EQ.22) THEN
24148             F2 = Q_ch2(I)
24149           ELSE
24150             F2 = 1.D0
24151           ENDIF
24152           FAC = FAC+F1*F2*3.D0
24153  300    CONTINUE
24154         ZZ = SQRT(1.D0-4.D0*PTCUT*PTCUT/SS)
24155         Hfac(14) = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)
24156      &               *GEV2MB*FAC
24157       ENDIF
24158       END
24159
24160 *$ CREATE PHO_HARWGX.FOR
24161 *COPY PHO_HARWGX
24162 CDECK  ID>, PHO_HARWGX
24163       SUBROUTINE PHO_HARWGX(PTCUT,ECM)
24164 C**********************************************************************
24165 C
24166 C     find maximum of remaining weight for MC sampling
24167 C
24168 C     input:   PTCUT  transverse momentum cutoff
24169 C              ECM    cms energy
24170 C
24171 C     output:  HWgx(-1:Max_pro_2)  field for sampling hard processes
24172 C
24173 C**********************************************************************
24174       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24175       SAVE
24176
24177       PARAMETER ( NKM = 10 )
24178       PARAMETER ( TINY = 1.D-20 )
24179
24180 C  input/output channels
24181       INTEGER LI,LO
24182       COMMON /POINOU/ LI,LO
24183 C  event debugging information
24184       INTEGER NMAXD
24185       PARAMETER (NMAXD=100)
24186       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24187      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24188       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24189      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24190 C  data on most recent hard scattering
24191       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24192       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24193      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24194      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24195       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24196      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24197      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24198      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24199      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24200 C  hard cross sections and MC selection weights
24201       INTEGER Max_pro_2
24202       PARAMETER ( Max_pro_2 = 16 )
24203       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
24204      &  MH_acc_1,MH_acc_2
24205       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
24206       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
24207      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
24208      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
24209      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24210      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24211
24212       DIMENSION Z(3),D(3),FF(0:NKM),PDA(-6:6),PDB(-6:6),XM1(NKM),
24213      &  XM2(NKM),PTM(NKM),ZMX(3,NKM),DMX(3,NKM),IMX(NKM),IPO(NKM)
24214       DIMENSION IFTAB(-1:Max_pro_2)
24215       DATA IFTAB  / 4,0,1,2,4,1,2,2,3,5,0,6,7,8,9,10,0,10 /
24216
24217 C  initial settings
24218       AH    = (2.D0*PTCUT/ECM)**2
24219       ALNH  = LOG(AH)
24220       FF(0) = 0.D0
24221       DO 22 I=1,NKM
24222         FF(I) = 0.D0
24223         XM1(I) = 0.D0
24224         XM2(I) = 0.D0
24225         PTM(I) = 0.D0
24226         ZMX(1,I) = 0.D0
24227         ZMX(2,I) = 0.D0
24228         ZMX(3,I) = 0.D0
24229         DMX(1,I) = 0.D0
24230         DMX(2,I) = 0.D0
24231         DMX(3,I) = 0.D0
24232         IMX(I) = 0
24233         IPO(I) = 0
24234  22   CONTINUE
24235
24236       NKML = 10
24237       DO 40 NKON=1,NKML
24238
24239         DO 50 IST=1,3
24240 C  start configuration
24241         IF(IST.EQ.1) THEN
24242           Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24243           Z(2) = 0.5
24244           Z(3) = 0.1
24245           D(1) =-0.5
24246           D(2) = 0.5
24247           D(3) = 0.5
24248         ELSE IF(IST.EQ.2) THEN
24249           Z(1) = 0.999D0
24250           Z(2) = 0.5
24251           Z(3) = 0.0
24252           D(1) =-0.5
24253           D(2) = 0.5
24254           D(3) = 0.5
24255         ELSE IF(IST.EQ.3) THEN
24256           Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24257           Z(2) = 0.1
24258           Z(3) = 0.1
24259           D(1) =-0.5
24260           D(2) = 0.5
24261           D(3) = 0.5
24262         ELSE IF(IST.EQ.4) THEN
24263           Z(1) = MIN(0.999D0,LOG(0.5D0)/LOG(AH))
24264           Z(2) = 0.9
24265           Z(3) = 0.1
24266           D(1) =-0.5
24267           D(2) = 0.5
24268           D(3) = 0.5
24269         ENDIF
24270         IT   = 0
24271         CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F2)
24272 C  process possible?
24273         IF(F2.LE.0.D0) GOTO 35
24274
24275  10     CONTINUE
24276           IT   = IT+1
24277           FOLD = F2
24278           DO 30 I=1,3
24279             D(I) = D(I)/5.D0
24280             Z(I)   = Z(I)+D(I)
24281             CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
24282             IF ( F2.GT.F3 ) Z(I) = Z(I)-D(I)
24283             IF ( F2.GT.F3 ) D(I) =-D(I)
24284  20         CONTINUE
24285               F1   = MIN(F2,F3)
24286               F2   = MAX(F2,F3)
24287               Z(I) = Z(I)+D(I)
24288               CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F3)
24289             IF ( F3.GT.F2 ) GOTO 20
24290             ZZ     = Z(I)-D(I)
24291             Z(I)   = ZZ+0.5*D(I)*(F3-F1)/MAX(TINY,F2+F2-F1-F3)
24292             IF ( ABS(ZZ-Z(I)).GT.D(I)*0.1D0 )
24293      &        CALL PHO_HARWGI(ECM,PTCUT,NKON,Z,F1)
24294             IF ( F1.LE.F2 ) Z(I) = ZZ
24295             F2     = MAX(F1,F2)
24296  30       CONTINUE
24297         IF((ABS(FOLD-F2)/MAX(TINY,F2).GT.0.002D0).OR.(IT.LT.3)) GOTO 10
24298
24299         IF(F2.GT.FF(NKON)) THEN
24300           FF(NKON)  = MAX(F2,0.D0)
24301           XM1(NKON) = X1
24302           XM2(NKON) = X2
24303           PTM(NKON) = PT
24304           ZMX(1,NKON) = Z(1)
24305           ZMX(2,NKON) = Z(2)
24306           ZMX(3,NKON) = Z(3)
24307           DMX(1,NKON) = D(1)
24308           DMX(2,NKON) = D(2)
24309           DMX(3,NKON) = D(3)
24310           IMX(NKON) = IT
24311           IPO(NKON) = IST
24312         ENDIF
24313 C
24314  50     CONTINUE
24315  35     CONTINUE
24316  40   CONTINUE
24317
24318 C  debug output
24319       IF(IDEB(38).GE.5) THEN
24320         WRITE(LO,'(/1X,A)')
24321      &    'PHO_HARWGX: maximum of weight (I,IT,IS,FF,Z(1-3),D(1-3))'
24322         DO 60 I=1,NKM
24323           IF(IMX(I).NE.0) WRITE(LO,'(1X,I2,I3,I2,7E10.3)') I,IMX(I),
24324      &      IPO(I),FF(I),ZMX(1,I),ZMX(2,I),ZMX(3,I),DMX(1,I),
24325      &      DMX(2,I),DMX(3,I)
24326  60     CONTINUE
24327       ENDIF
24328
24329       DO 70 I=-1,Max_pro_2
24330         HWgx(I)  = MAX(FF(IFTAB(I))*Hfac(I),0.D0)
24331  70   CONTINUE
24332
24333 C  debug output
24334       IF(IDEB(38).GE.5) THEN
24335         WRITE(LO,'(/1X,A)') 'PHO_HARWGX: total weights'
24336         WRITE(LO,'(5X,A)') 'I    X1   X2   PT   HWgx(I)  FDIS'
24337         DO 80 I=-1,Max_pro_2
24338           IF((IFTAB(I).NE.0).AND.(HWgx(I).GT.0.D0)) THEN
24339             MSPR = I
24340             X1 = MIN(XM1(IFTAB(I)),0.9999999999D0)
24341             X2 = MIN(XM2(IFTAB(I)),0.9999999999D0)
24342             PT = PTM(IFTAB(I))
24343             CALL PHO_HARWGH(PDS,PDA,PDB,FDIS)
24344             WRITE(LO,'(1X,I3,5E12.3)') I,X1,X2,PT,HWgx(I),FDIS
24345           ENDIF
24346  80     CONTINUE
24347       ENDIF
24348
24349       END
24350
24351 *$ CREATE PHO_HARWGI.FOR
24352 *COPY PHO_HARWGI
24353 CDECK  ID>, PHO_HARWGI
24354       SUBROUTINE PHO_HARWGI(ECMX,PTCUT,NKON,Z,FDIS)
24355 C**********************************************************************
24356 C
24357 C     auxiliary subroutine to find maximum of remaining weight
24358 C
24359 C     input:  ECMX   current CMS energy
24360 C             PTCUT  current pt cutoff
24361 C             NKON   process label  1..5  resolved
24362 C                                   6..7  direct particle 1
24363 C                                   8..9  direct particle 2
24364 C                                   10    double direct
24365 C             Z(3)   transformed variable
24366 C
24367 C     output: remaining weight
24368 C
24369 C**********************************************************************
24370       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24371       SAVE
24372
24373       DIMENSION Z(3)
24374
24375       PARAMETER ( NKM   = 10 )
24376       PARAMETER ( TINY  = 1.D-30,
24377      &            TINY6 = 1.D-06 )
24378
24379 C  input/output channels
24380       INTEGER LI,LO
24381       COMMON /POINOU/ LI,LO
24382 C  event debugging information
24383       INTEGER NMAXD
24384       PARAMETER (NMAXD=100)
24385       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24386      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24387       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24388      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24389 C  model switches and parameters
24390       CHARACTER*8 MDLNA
24391       INTEGER ISWMDL,IPAMDL
24392       DOUBLE PRECISION PARMDL
24393       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24394 C  data of c.m. system of Pomeron / Reggeon exchange
24395       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
24396       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
24397      &                 SIDP,CODP,SIFP,COFP
24398       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
24399      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
24400      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
24401 C  currently activated parton density parametrizations
24402       CHARACTER*8 PDFNAM
24403       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
24404       DOUBLE PRECISION PDFLAM,PDFQ2M
24405       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
24406      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
24407 C  hard scattering parameters used for most recent hard interaction
24408       INTEGER NFbeta,NF
24409       DOUBLE PRECISION ALQCD2,BQCD
24410       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
24411 C  some hadron information, will be deleted in future versions
24412       INTEGER NFS
24413       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
24414       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
24415 C  scale parameters for parton model calculations
24416       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24417       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24418       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24419      &                NQQAL,NQQALI,NQQALF,NQQPD
24420 C  data on most recent hard scattering
24421       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24422       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24423      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24424      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24425       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24426      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24427      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24428      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24429      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24430
24431       DOUBLE PRECISION PHO_ALPHAS,pho_alphae
24432       DIMENSION F(NKM),PDA(-6:6),PDB(-6:6)
24433
24434       FDIS = 0.D0
24435
24436       IF(IDEB(64).GE.25) WRITE(LO,'(1X,A,/5X,5E12.3,I5)')
24437      &  'PHO_HARWGI: ECM,PT,Z,NK',ECMX,PTCUT,Z,NKON
24438 C  check input values
24439       IF ( Z(1).LT.0.D0  .OR.  Z(1).GT.1.D0 ) RETURN
24440       IF ( Z(2).LT.0.D0  .OR.  Z(2).GT.1.D0 ) RETURN
24441       IF ( Z(3).LT.0.D0  .OR.  Z(3).GT.1.D0 ) RETURN
24442 C  transformations
24443       Y1    = EXP(ALNH*Z(1))
24444       IF(NKON.LE.5) THEN
24445 C  resolved kinematic
24446         Y2  =-(1.D0-Y1)+2.D0*(1.D0-Y1)*Z(2)
24447         X1  = 0.5D0*(Y2+SQRT(Y2*Y2+4.D0*Y1))
24448         X2  = X1-Y2
24449         X1 = MIN(X1,0.999999999999D0)
24450         X2 = MIN(X2,0.999999999999D0)
24451       ELSE IF(NKON.LE.7) THEN
24452 C  direct kinematic 1
24453         X1 = 1.D0
24454         X2 = MIN(Y1,0.999999999999D0)
24455       ELSE IF(NKON.LE.9) THEN
24456 C  direct kinematic 2
24457         X1 = MIN(Y1,0.999999999999D0)
24458         X2 = 1.D0
24459       ELSE
24460 C  double direct kinematic
24461         X1 = 1.D0
24462         X2 = 1.D0
24463       ENDIF
24464       W   = SQRT(MAX(TINY,1.D0-AH/Y1))
24465       V   =-0.5D0+W*(Z(3)-0.5D0)
24466       U   =-(1.D0+V)
24467       PT  = MAX(SQRT(U*V*Y1*ECMX*ECMX),PTCUT)
24468
24469 C  set hard scale  QQ  for alpha and partondistr.
24470       IF     ( NQQAL.EQ.1 ) THEN
24471         QQAL = AQQAL*PT*PT
24472       ELSEIF ( NQQAL.EQ.2 ) THEN
24473         QQAL = AQQAL*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
24474       ELSEIF ( NQQAL.EQ.3 ) THEN
24475         QQAL = AQQAL*Y1*ECMX*ECMX
24476       ELSEIF ( NQQAL.EQ.4 ) THEN
24477         QQAL = AQQAL*Y1*ECMX*ECMX*(U*V)**(1./3.)
24478       ENDIF
24479       IF     ( NQQPD.EQ.1 ) THEN
24480         QQPD = AQQPD*PT*PT
24481       ELSEIF ( NQQPD.EQ.2 ) THEN
24482         QQPD = AQQPD*Y1*ECMX*ECMX*U*V/(1.+V*V+U*U)
24483       ELSEIF ( NQQPD.EQ.3 ) THEN
24484         QQPD = AQQPD*Y1*ECMX*ECMX
24485       ELSEIF ( NQQPD.EQ.4 ) THEN
24486         QQPD = AQQPD*Y1*ECMX*ECMX*(U*V)**(1./3.)
24487       ENDIF
24488 C
24489       IF(NKON.LE.5) THEN
24490         DO 10 N=1,5
24491           F(N) = 0.D0
24492  10     CONTINUE
24493 C  resolved processes
24494         ALPHA1 = PHO_ALPHAS(QQAL,3)
24495         ALPHA2 = ALPHA1
24496         CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
24497         CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
24498 C  calculate full distribution FDIS
24499         DO 20 I=1,NF
24500           F(2) = F(2)+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
24501           F(3) = F(3)+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
24502           F(4) = F(4)+PDA(I)+PDA(-I)
24503           F(5) = F(5)+PDB(I)+PDB(-I)
24504 20      CONTINUE
24505         F(1)   = PDA(0)*PDB(0)
24506         T      = PDA(0)*F(5)+PDB(0)*F(4)
24507         F(5)   = F(4)*F(5)-(F(2)+F(3))
24508         F(4)   = T
24509       ELSE IF(NKON.LE.7) THEN
24510 C  direct processes particle 1
24511         IF(IDPDG1.EQ.22) THEN
24512           ALPHA1 = pho_alphae(QQAL)
24513           CH1 = 4.D0/9.D0
24514           CH2 = 3.D0/9.D0
24515         ELSE IF(IDPDG1.EQ.990) THEN
24516           ALPHA1 = PARMDL(74)
24517           CH1 = 1.D0
24518           CH2 = 0.D0
24519         ELSE
24520           FDIS = -1.D0
24521           RETURN
24522         ENDIF
24523         ALPHA2 = PHO_ALPHAS(QQAL,2)
24524         CALL PHO_PDF(2,X2,QQPD,0.D0,PDB)
24525         F(6) = 0.D0
24526         DO 30 I=1,NF
24527           F(6) = F(6)+(PDB(I)+PDB(-I))*(CH1-CH2*MOD(I,2))
24528  30     CONTINUE
24529         F(7)   = PDB(0)
24530       ELSE IF(NKON.LE.9) THEN
24531 C  direct processes particle 2
24532         ALPHA1 = PHO_ALPHAS(QQAL,1)
24533         IF(IDPDG2.EQ.22) THEN
24534           ALPHA2 = pho_alphae(QQAL)
24535           CH1 = 4.D0/9.D0
24536           CH2 = 3.D0/9.D0
24537         ELSE IF(IDPDG2.EQ.990) THEN
24538           ALPHA2 = PARMDL(74)
24539           CH1 = 1.D0
24540           CH2 = 0.D0
24541         ELSE
24542           FDIS = -1.D0
24543           RETURN
24544         ENDIF
24545         CALL PHO_PDF(1,X1,QQPD,0.D0,PDA)
24546         F(8) = 0.D0
24547         DO 40 I=1,NF
24548           F(8) = F(8)+(PDA(I)+PDA(-I))*(CH1-CH2*MOD(I,2))
24549  40     CONTINUE
24550         F(9)   = PDA(0)
24551       ELSE
24552 C  double direct process
24553         SSR = ECMX*ECMX
24554         IF(IDPDG1.EQ.22) THEN
24555           ALPHA1 = pho_alphae(SSR)
24556         ELSE IF(IDPDG1.EQ.990) THEN
24557           ALPHA1 = PARMDL(74)
24558         ELSE
24559           FDIS = -1.D0
24560           RETURN
24561         ENDIF
24562         IF(IDPDG2.EQ.22) THEN
24563           ALPHA2 = pho_alphae(SSR)
24564         ELSE IF(IDPDG2.EQ.990) THEN
24565           ALPHA2 = PARMDL(74)
24566         ELSE
24567           FDIS = -1.D0
24568           RETURN
24569         ENDIF
24570         F(10) = 1.D0
24571       ENDIF
24572
24573       FDIS   = MAX(0.D0,F(NKON)*ALPHA1*ALPHA2)
24574
24575 C  debug output
24576       IF(IDEB(64).GE.20) WRITE(LO,'(1X,A,/2X,I3,2I6,7E11.3)')
24577      &  'PHO_HARWGI: NKON,ID1,ID2,AL1,AL2,X1,X2,PT,F(NKON),FDIS',
24578      &  NKON,IDPDG1,IDPDG2,ALPHA1,ALPHA2,X1,X2,PT,F(NKON),FDIS
24579
24580       END
24581
24582 *$ CREATE PHO_HARINI.FOR
24583 *COPY PHO_HARINI
24584 CDECK  ID>, PHO_HARINI
24585       SUBROUTINE PHO_HARINI(IP,IDP1,IDP2,PV1,PV2,NOUT,MODE)
24586 C**********************************************************************
24587 C
24588 C     initialize calculation of hard cross section
24589 C
24590 C     must not be called during MC generation
24591 C
24592 C***********************************************************************
24593       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24594       SAVE
24595
24596       PARAMETER ( DEPS   = 1.D-10 )
24597
24598 C  input/output channels
24599       INTEGER LI,LO
24600       COMMON /POINOU/ LI,LO
24601 C  event debugging information
24602       INTEGER NMAXD
24603       PARAMETER (NMAXD=100)
24604       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24605      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24606       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24607      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24608 C  model switches and parameters
24609       CHARACTER*8 MDLNA
24610       INTEGER ISWMDL,IPAMDL
24611       DOUBLE PRECISION PARMDL
24612       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24613 C  currently activated parton density parametrizations
24614       CHARACTER*8 PDFNAM
24615       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
24616       DOUBLE PRECISION PDFLAM,PDFQ2M
24617       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
24618      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
24619 C  some constants
24620       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
24621       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
24622      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
24623 C  scale parameters for parton model calculations
24624       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24625       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24626       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24627      &                NQQAL,NQQALI,NQQALF,NQQPD
24628 C  data of c.m. system of Pomeron / Reggeon exchange
24629       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
24630       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
24631      &                 SIDP,CODP,SIFP,COFP
24632       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
24633      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
24634      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
24635 C  obsolete cut-off information
24636       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
24637       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
24638 C  hard scattering parameters used for most recent hard interaction
24639       INTEGER NFbeta,NF
24640       DOUBLE PRECISION ALQCD2,BQCD
24641       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
24642
24643       double precision pho_alphas
24644
24645       CHARACTER*20 RFLAG
24646
24647 C  set local Pomeron c.m. system data
24648       IDPDG1    = IDP1
24649       IDPDG2    = IDP2
24650       PVIRTP(1) = PV1
24651       PVIRTP(2) = PV2
24652 C  initialize PDFs
24653       CALL PHO_ACTPDF(IDPDG1,1)
24654       CALL PHO_ACTPDF(IDPDG2,2)
24655 C  initialize alpha_s calculation
24656       DUMMY = PHO_ALPHAS(0.D0,-4)
24657 C  initialize scales with defaults
24658       IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
24659         IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24660           AQQAL  = PARMDL(83)
24661           AQQALI = PARMDL(86)
24662           AQQALF = PARMDL(89)
24663           AQQPD  = PARMDL(92)
24664           NQQAL  = IPAMDL(83)
24665           NQQALI = IPAMDL(86)
24666           NQQALF = IPAMDL(89)
24667           NQQPD  = IPAMDL(92)
24668         ELSE
24669           AQQAL  = PARMDL(82)
24670           AQQALI = PARMDL(85)
24671           AQQALF = PARMDL(88)
24672           AQQPD  = PARMDL(91)
24673           NQQAL  = IPAMDL(82)
24674           NQQALI = IPAMDL(85)
24675           NQQALF = IPAMDL(88)
24676           NQQPD  = IPAMDL(91)
24677         ENDIF
24678       ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
24679         AQQAL  = PARMDL(82)
24680         AQQALI = PARMDL(85)
24681         AQQALF = PARMDL(88)
24682         AQQPD  = PARMDL(91)
24683         NQQAL  = IPAMDL(82)
24684         NQQALI = IPAMDL(85)
24685         NQQALF = IPAMDL(88)
24686         NQQPD  = IPAMDL(91)
24687       ELSE
24688         AQQAL  = PARMDL(81)
24689         AQQALI = PARMDL(84)
24690         AQQALF = PARMDL(87)
24691         AQQPD  = PARMDL(90)
24692         NQQAL  = IPAMDL(81)
24693         NQQALI = IPAMDL(84)
24694         NQQALF = IPAMDL(87)
24695         NQQPD  = IPAMDL(90)
24696       ENDIF
24697       IF(PARMDL(109+IP).LT.DEPS) PARMDL(109+IP) = AQQAL
24698       IF(PARMDL(113+IP).LT.DEPS) PARMDL(113+IP) = AQQALI
24699       IF(PARMDL(117+IP).LT.DEPS) PARMDL(117+IP) = AQQALF
24700       IF(PARMDL(121+IP).LT.DEPS) PARMDL(121+IP) = AQQPD
24701       IF(IPAMDL(64+IP).LT.0) IPAMDL(64+IP) = NQQAL
24702       IF(IPAMDL(68+IP).LT.0) IPAMDL(68+IP) = NQQALI
24703       IF(IPAMDL(72+IP).LT.0) IPAMDL(72+IP) = NQQALF
24704       IF(IPAMDL(76+IP).LT.0) IPAMDL(76+IP) = NQQPD
24705       AQQAL  = PARMDL(109+IP)
24706       AQQALI = PARMDL(113+IP)
24707       AQQALF = PARMDL(117+IP)
24708       AQQPD  = PARMDL(121+IP)
24709       NQQAL  = IPAMDL(64+IP)
24710       NQQALI = IPAMDL(68+IP)
24711       NQQALF = IPAMDL(72+IP)
24712       NQQPD  = IPAMDL(76+IP)
24713       PTCUT(1) = PARMDL(36)
24714       PTCUT(2) = PARMDL(37)
24715       PTCUT(3) = PARMDL(38)
24716       PTCUT(4) = PARMDL(39)
24717       PTANO(1) = PARMDL(130)
24718       PTANO(2) = PARMDL(131)
24719       PTANO(3) = PARMDL(132)
24720       PTANO(4) = PARMDL(133)
24721       RFLAG = '(energy-independent)'
24722       IF(IPAMDL(7).GT.0) RFLAG = '(energy-dependent)'
24723
24724 C  write out all settings
24725       IF((IDEB(66).GE.15).OR.(MODE.GT.0)) THEN
24726         WRITE(NOUT,1050) IP,IDPDG1,IDPDG2,PTCUT(IP),RFLAG,
24727      &    PDFNAM(1),IGRP(1),ISET(1),IEXT(1),
24728      &    PDFNAM(2),IGRP(2),ISET(2),IEXT(2),
24729      &    PDFLAM,NF,NQQAL,AQQAL,NQQPD,AQQPD
24730 1050    FORMAT(/,
24731      &    ' PHO_HARINI: hard scattering parameters for IP:',I3/,
24732      &    5X,'particle 1 / particle 2:',2I8,/,
24733      &    5X,'min. PT   :',F7.1,2X,A,/,
24734      &    5X,'PDF side 1:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
24735      &    5X,'PDF side 2:',2X,A8,' IGRP/ISET/IEXT ',3I4,/,
24736      &    5X,'LAMBDA1,2 (4 active flavours):',2F8.3,/,
24737      &    5X,'max. number of active flavours NF  :',I3,/,
24738      &    5X,'NQQAL/AQQAL/NQQPD/AQQPD:',I5,F8.3,I5,F8.3)
24739       ENDIF
24740
24741       END
24742
24743 *$ CREATE PHO_HARINT.FOR
24744 *COPY PHO_HARINT
24745 CDECK  ID>, PHO_HARINT
24746       SUBROUTINE PHO_HARINT(IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM)
24747 C**********************************************************************
24748 C
24749 C     interpolate cross sections and weights for hard scattering
24750 C
24751 C     input:  IPP    particle combination (neg. for add. user cuts)
24752 C             ECM    CMS energy (GeV)
24753 C             P2V1/2 particle virtualities (pos., GeV**2)
24754 C             I1     first subprocess to calculate
24755 C             I2     last subprocess to calculate
24756 C                    <-1  only scales and cutoffs calculated
24757 C             K1     first variable to calculate
24758 C             K2     last variable to calculate
24759 C             MSPOM  cross sections to use for pt distribution
24760 C                    0  reggeon
24761 C                    >0 pomeron
24762 C
24763 C             for K1 < 3 the soft pt distribution is also calculated
24764 C
24765 C     output: interpolated values in HWgx, HSig, Hdpt
24766 C
24767 C***********************************************************************
24768       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24769       SAVE
24770
24771       PARAMETER ( DEPS   = 1.D-15,
24772      &            DEPS2  = 2.D-15 )
24773
24774 C  input/output channels
24775       INTEGER LI,LO
24776       COMMON /POINOU/ LI,LO
24777 C  event debugging information
24778       INTEGER NMAXD
24779       PARAMETER (NMAXD=100)
24780       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
24781      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24782       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
24783      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
24784 C  model switches and parameters
24785       CHARACTER*8 MDLNA
24786       INTEGER ISWMDL,IPAMDL
24787       DOUBLE PRECISION PARMDL
24788       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
24789 C  Reggeon phenomenology parameters
24790       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
24791      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
24792       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
24793      &                ALREG,ALREGP,GR(2),B0REG(2),
24794      &                GPPP,GPPR,B0PPP,B0PPR,
24795      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
24796 C  parameters of 2x2 channel model
24797       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
24798       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
24799 C  data needed for soft-pt calculation
24800       DOUBLE PRECISION SIGS,DSIGHP,SIGH,FS,FH,BETAS,AAS,PTCON
24801       COMMON /POINT3/ SIGS,DSIGHP,SIGH,FS,FH,BETAS(3),AAS,PTCON
24802 C  scale parameters for parton model calculations
24803       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
24804       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
24805       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
24806      &                NQQAL,NQQALI,NQQALF,NQQPD
24807 C  obsolete cut-off information
24808       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
24809       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
24810 C  event weights and generated cross section
24811       INTEGER IPOWGC,ISWCUT,IVWGHT
24812       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
24813       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
24814      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
24815 C  parameters for DGLAP backward evolution in ISR
24816       INTEGER NFSISR
24817       DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
24818       COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
24819 C  hard cross sections and MC selection weights
24820       INTEGER Max_pro_2
24821       PARAMETER ( Max_pro_2 = 16 )
24822       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
24823      &  MH_acc_1,MH_acc_2
24824       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
24825       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
24826      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
24827      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
24828      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
24829      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
24830 C  interpolation tables for hard cross section and MC selection weights
24831       INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
24832       PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
24833       INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
24834       DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
24835      &  HQ2a_tab,HQ2b_tab,HEcm_tab
24836       COMMON /POHTAB/
24837      &  Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24838      &  HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24839      &  HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24840      &  Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
24841      &  HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
24842      &  HEcm_tab(1:Max_tab_E,0:4),
24843      &  IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
24844 C  data on most recent hard scattering
24845       INTEGER IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24846       DOUBLE PRECISION PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24847      &                 PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,QQPD,QQAL,
24848      &                 PDF1,PDF2,WEIGHT,PHI1,PHI2,PHO1,PHO2
24849       COMMON /POCKIN/ PTWANT,AS,AH,ALNS,ALNH,Z1MAX,Z1DIF,Z2MAX,Z2DIF,
24850      &                PT,PTfin,ETAC,ETAD,X1,X2,V,U,W,W1,AXX,
24851      &                QQPD,QQAL,PDF1(-6:6),PDF2(-6:6),WEIGHT,
24852      &                PHI1(5),PHI2(5),PHO1(5),PHO2(5),
24853      &                IA,IB,IC,ID,IV1,IV2,MSPR,IREJSC
24854 C  energy-interpolation table
24855       INTEGER IEETA2
24856       PARAMETER ( IEETA2 = 20 )
24857       INTEGER ISIMAX
24858       DOUBLE PRECISION SIGTAB,SIGECM
24859       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
24860
24861       DOUBLE PRECISION XP,PTS
24862       DIMENSION XP(2),PTS(0:2,2)
24863
24864       INTEGER IV
24865       DIMENSION IV(2)
24866
24867       IF(IDEB(58).GE.25) WRITE(LO,'(1X,2A,/,5X,I2,3E12.3,5I4)')
24868      &    'PHO_HARINT: called with ',
24869      &    'IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM',
24870      &    IPP,ECM,P2V1,P2V2,I1,I2,K1,K2,MSPOM
24871
24872       IP = ABS(IPP)
24873       IF(IPP.GT.0) THEN
24874 C  default minimum bias cutoff
24875         PTCUT(IP) = pho_ptcut(ECM,IP)
24876       ELSE
24877 C  user defined additional cutoff
24878         PTCUT(IP) = HSWCUT(4+IP)
24879       ENDIF
24880       PTWANT = PTCUT(IP)
24881
24882 C  ISR cutoffs
24883       Q2CUT     = MIN(PTWANT**2,PARMDL(125+IP))
24884       Q2MISR(1) = MAX(P2V1,Q2CUT)
24885       Q2MISR(2) = MAX(P2V2,Q2CUT)
24886 C  cutoff for direct photon contribution to photon PDF
24887       PTANO(IP) = MIN(PTCUT(IP),PARMDL(129+IP))
24888       PTA1      = PTANO(IP)
24889 C  scales for hard scattering
24890       AQQAL  = PARMDL(109+IP)
24891       AQQALI = PARMDL(113+IP)
24892       AQQALF = PARMDL(117+IP)
24893       AQQPD  = PARMDL(121+IP)
24894       NQQAL  = IPAMDL(64+IP)
24895       NQQALI = IPAMDL(68+IP)
24896       NQQALF = IPAMDL(72+IP)
24897       NQQPD  = IPAMDL(76+IP)
24898       IF(IDEB(58).GE.15) WRITE(LO,'(1X,A,4I3,4E10.3)')
24899      &  'PHO_HARINT: scales:',
24900      &  NQQAL,NQQALI,NQQALF,NQQPD,AQQAL,AQQALI,AQQALF,AQQPD
24901
24902       IF(I2.LT.-1) RETURN
24903
24904       IL = IP
24905       IF(IPP.LT.0) IL = 0
24906
24907 C  double-log interpolation
24908       IF(ECM.LT.2.1D0*PTCUT(IP)) THEN
24909         DO 50 M=I1,I2
24910           Hfac(M) = 0.D0
24911           HWgx(M) = 0.D0
24912           HSig(M) = 0.D0
24913           Hdpt(M) = 0.D0
24914  50     CONTINUE
24915       ELSE
24916         I=1
24917  310    CONTINUE
24918           I = I+1
24919         IF((ECM.GT.HEcm_tab(I,IL)).AND.(I.LT.IH_Ecm_up(IL))) GOTO 310
24920
24921         Ia = 1
24922         Ib = 1
24923         fac = LOG(ECM/HEcm_tab(I-1,IL))
24924      &       /LOG(HEcm_tab(I,IL)/HEcm_tab(I-1,IL))
24925         do M=I1,I2
24926 C  factor due to phase space integration
24927           XX = LOG(Hfac_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
24928      &      *LOG((Hfac_tab(M,I,Ia,Ib,IL)+DEPS)
24929      &           /(Hfac_tab(M,I-1,Ia,Ib,IL)+DEPS))
24930           XX = EXP(XX)
24931           IF(XX.LT.DEPS2) XX = 0.D0
24932           Hfac(M) = XX
24933 C  max. weight
24934           XX = LOG(HWgx_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
24935      &      *LOG((HWgx_tab(M,I,Ia,Ib,IL)+DEPS)
24936      &           /(HWgx_tab(M,I-1,Ia,Ib,IL)+DEPS))
24937           XX = EXP(XX)
24938           IF(XX.LT.DEPS2) XX = 0.D0
24939           HWgx(M) = XX*1.2D0
24940 C  hard cross section
24941           XX = LOG(HSig_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
24942      &      *LOG((HSig_tab(M,I,Ia,Ib,IL)+DEPS)
24943      &           /(HSig_tab(M,I-1,Ia,Ib,IL)+DEPS))
24944           XX = EXP(XX)
24945           IF(XX.LT.DEPS2) XX = 0.D0
24946           HSig(M) = XX
24947 C  differential hard cross section
24948           XX = LOG(Hdpt_tab(M,I-1,Ia,Ib,IL)+DEPS) + fac
24949      &      *LOG((Hdpt_tab(M,I,Ia,Ib,IL)+DEPS)
24950      &           /(Hdpt_tab(M,I-1,Ia,Ib,IL)+DEPS))
24951           XX = EXP(XX)
24952           IF(XX.LT.DEPS2) XX = 0.D0
24953           Hdpt(M) = XX
24954         enddo
24955       ENDIF
24956
24957       IF((K1.LT.3).AND.(K2.GE.3)) THEN
24958 C  cross check
24959         IF((I1.GT.9).OR.(I2.LT.9)) THEN
24960           WRITE(LO,'(1X,2A,2I4)') 'PHO_HARINT: ',
24961      &      'hard cross section not calculated ',I1,I2
24962         ENDIF
24963         SIGH   = HSig(9)
24964         DSIGHP = Hdpt(9)
24965 C  load soft cross sections from interpolation table
24966         IF(ECM.LE.SIGECM(IP,1)) THEN
24967           L1 = 1
24968           L2 = 1
24969         ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
24970           DO 55 I=2,ISIMAX
24971             IF(ECM.LE.SIGECM(IP,I)) GOTO 205
24972  55       CONTINUE
24973  205      CONTINUE
24974           L1 = I-1
24975           L2 = I
24976         ELSE
24977           WRITE(LO,'(/1X,A,I3,1P,2E11.3)')
24978      &      'PHO_HARINT: energy too high (IP,Ecm,Emax)',
24979      &      IP,ECM,SIGECM(IP,ISIMAX)
24980           CALL PHO_PREVNT(-1)
24981           L1 = ISIMAX-1
24982           L2 = ISIMAX
24983         ENDIF
24984         FAC2=0.D0
24985         IF(L1.NE.L2) FAC2=LOG(ECM/SIGECM(IP,L1))
24986      &                    /LOG(SIGECM(IP,L2)/SIGECM(IP,L1))
24987         FAC1=1.D0-FAC2
24988         SIGS = FAC2*(SIGTAB(IP,56,L2)+SIGTAB(IP,57,L2))+
24989      &         FAC1*(SIGTAB(IP,56,L1)+SIGTAB(IP,57,L1))
24990
24991         FS = FPS(IP)
24992         FH = FPH(IP)
24993         CALL PHO_SOFTPT(-1,PTWANT,PTWANT,XP,IV,PTS)
24994       ENDIF
24995
24996  300  CONTINUE
24997
24998 C  debug output
24999       IF(IDEB(58).GE.15) THEN
25000         WRITE(LO,'(1X,A,I10,3I2,2E10.3)')
25001      &    'PHO_HARINT: weights EV,IP,K1/2,ECM,PTC',
25002      &    KEVENT,IP,K1,K2,ECM,PTCUT(IP)
25003         DO 162 M=I1,I2
25004           WRITE(LO,'(5X,2I3,1p,4E12.3)')
25005      &      M,MH_pro_on(M,IP),Hfac(M),HWgx(M),HSig(M),Hdpt(M)
25006  162    CONTINUE
25007       ENDIF
25008
25009       END
25010
25011 *$ CREATE PHO_PTCUT.FOR
25012 *COPY PHO_PTCUT
25013       DOUBLE PRECISION FUNCTION PHO_PTCUT(ECM,IP)
25014 C***********************************************************************
25015 C
25016 C     calculate energy-dependent transverse momentum cutoff
25017 C
25018 C***********************************************************************
25019       IMPLICIT NONE
25020       SAVE
25021
25022       double precision ECM
25023       integer IP
25024
25025 C  input/output channels
25026       INTEGER LI,LO
25027       COMMON /POINOU/ LI,LO
25028 C  event debugging information
25029       INTEGER NMAXD
25030       PARAMETER (NMAXD=100)
25031       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
25032      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25033       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
25034      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25035 C  model switches and parameters
25036       CHARACTER*8 MDLNA
25037       INTEGER ISWMDL,IPAMDL
25038       DOUBLE PRECISION PARMDL
25039       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25040
25041       pho_ptcut = PARMDL(35+IP)
25042
25043       IF(IPAMDL(7).EQ.1) THEN
25044 C  Bopp et al. type (DPMJET)
25045         pho_ptcut = PARMDL(35+IP)
25046      &             + max(0.D0,0.12D0*(LOG10(ECM/50.D0))**3)
25047       ELSE IF(IPAMDL(7).EQ.2) THEN
25048 C  Gribov-Levin-Ryskin type
25049         pho_ptcut = PARMDL(35+IP)
25050      &             + 0.065D0*exp(0.9D0*sqrt(2.D0*log(Ecm)))
25051       ENDIF
25052
25053       END
25054
25055 *$ CREATE PHO_HARMCI.FOR
25056 *COPY PHO_HARMCI
25057 CDECK  ID>, PHO_HARMCI
25058       SUBROUTINE PHO_HARMCI(IP,EMAXF)
25059 C**********************************************************************
25060 C
25061 C     initialize MC sampling and calculate hard cross section
25062 C
25063 C     input:  IP       particle combination (neg. number for user cut)
25064 C             EMAXF    maximum CMS energy for
25065 C                      interpolation table in reference to PTCUT(1..4)
25066 C
25067 C***********************************************************************
25068       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25069       SAVE
25070
25071       PARAMETER (DEPS   = 1.D-10,
25072      &           PLARGE = 1.D20 )
25073
25074 C  input/output channels
25075       INTEGER LI,LO
25076       COMMON /POINOU/ LI,LO
25077 C  event debugging information
25078       INTEGER NMAXD
25079       PARAMETER (NMAXD=100)
25080       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
25081      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25082       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
25083      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
25084 C  some constants
25085       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25086       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25087      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25088 C  global event kinematics and particle IDs
25089       INTEGER IFPAP,IFPAB
25090       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
25091       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
25092 C  data of c.m. system of Pomeron / Reggeon exchange
25093       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25094       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25095      &                 SIDP,CODP,SIFP,COFP
25096       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25097      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
25098      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
25099 C  model switches and parameters
25100       CHARACTER*8 MDLNA
25101       INTEGER ISWMDL,IPAMDL
25102       DOUBLE PRECISION PARMDL
25103       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25104 C  obsolete cut-off information
25105       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
25106       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
25107 C  scale parameters for parton model calculations
25108       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25109       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25110       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25111      &                NQQAL,NQQALI,NQQALF,NQQPD
25112 C  names of hard scattering processes
25113       INTEGER Max_pro_1
25114       PARAMETER ( Max_pro_1 = 16 )
25115       CHARACTER*18 PROC
25116       COMMON /POHPRO/ PROC(0:Max_pro_1)
25117 C  hard cross sections and MC selection weights
25118       INTEGER Max_pro_2
25119       PARAMETER ( Max_pro_2 = 16 )
25120       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
25121      &  MH_acc_1,MH_acc_2
25122       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
25123       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
25124      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
25125      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
25126      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
25127      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
25128 C  interpolation tables for hard cross section and MC selection weights
25129       INTEGER Max_tab_E,Max_tab_Q2,Max_pro_tab
25130       PARAMETER ( Max_tab_E = 20, Max_tab_Q2 = 10, Max_pro_tab = 16 )
25131       INTEGER IH_Q2a_up,IH_Q2b_up,IH_Ecm_up
25132       DOUBLE PRECISION Hfac_tab,HWgx_tab,HSig_tab,Hdpt_tab,
25133      &  HQ2a_tab,HQ2b_tab,HEcm_tab
25134       COMMON /POHTAB/
25135      &  Hfac_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25136      &  HWgx_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25137      &  HSig_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25138      &  Hdpt_tab(-1:Max_pro_tab,Max_tab_E,Max_tab_Q2,Max_tab_Q2,0:4),
25139      &  HQ2a_tab(1:Max_tab_Q2,0:4),HQ2b_tab(1:Max_tab_Q2,0:4),
25140      &  HEcm_tab(1:Max_tab_E,0:4),
25141      &  IH_Q2a_up(0:4),IH_Q2b_up(0:4),IH_Ecm_up(0:4)
25142 C  event weights and generated cross section
25143       INTEGER IPOWGC,ISWCUT,IVWGHT
25144       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
25145       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
25146      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
25147
25148       COMPLEX*16 DSIG
25149       DIMENSION DSIG(0:Max_pro_2),DSPT(0:Max_pro_2)
25150
25151 C  initialization for all pt cutoffs
25152       I = ABS(IP)
25153       IL = I
25154       IF(IP.LT.0) THEN
25155         IL = 0
25156         PTC = HSWCUT(4+I)
25157       else
25158         PTC = pho_ptcut(parmdl(19),I)
25159       ENDIF
25160
25161 C  skip unassigned PTCUT
25162       IF(PTC.LT.0.5D0) GOTO 1000
25163
25164       IH_Q2a_up(I) = 1
25165       IH_Q2b_up(I) = 1
25166       do ib=1,Max_tab_Q2
25167         do ia=1,Max_tab_Q2
25168           do ie=1,Max_tab_E
25169             do m=-1,Max_pro_2
25170               Hfac_tab(M,Ie,Ia,Ib,I) = 0.D0
25171               HWgx_tab(M,Ie,Ia,Ib,I) = 0.D0
25172               HSig_tab(M,Ie,Ia,Ib,I) = 0.D0
25173               Hdpt_tab(M,Ie,Ia,Ib,I) = 0.D0
25174             enddo
25175           enddo
25176         enddo
25177       enddo
25178
25179       ELLOW = LOG(2.05*PTC)
25180       DELTA = (LOG(EMAXF)-ELLOW)/DBLE(IH_Ecm_up(I)-1)
25181 C  energy too low
25182       IF(DELTA.LE.0.D0) GOTO 1000
25183
25184 C  switch between external particles and Pomeron
25185       IF(I.EQ.4) THEN
25186         IDP1 = 990
25187         PV1  = 0.D0
25188         IDP2 = 990
25189         PV2  = 0.D0
25190       ELSE IF(I.EQ.3) THEN
25191         IDP1 = IFPAP(2)
25192         PV1  = PVIRT(2)
25193         IDP2 = 990
25194         PV2  = 0.D0
25195       ELSE IF(I.EQ.2) THEN
25196         IDP1 = IFPAP(1)
25197         PV1  = PVIRT(1)
25198         IDP2 = 990
25199         PV2  = 0.D0
25200       ELSE
25201         IDP1 = IFPAP(1)
25202         PV1  = PVIRT(1)
25203         IDP2 = IFPAP(2)
25204         PV2  = PVIRT(2)
25205       ENDIF
25206
25207 C  initialize PT scales
25208       IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
25209         IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25210           FPS(I) = PARMDL(105)
25211           FPH(I) = PARMDL(106)
25212         ELSE
25213           FPS(I) = PARMDL(103)
25214           FPH(I) = PARMDL(104)
25215         ENDIF
25216       ELSE IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25217         FPS(I) = PARMDL(103)
25218         FPH(I) = PARMDL(104)
25219       ELSE
25220         FPS(I) = PARMDL(101)
25221         FPH(I) = PARMDL(102)
25222       ENDIF
25223
25224 C  initialize hard scattering
25225       IF(IP.GT.0) THEN
25226         CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8)+1)
25227       ELSE
25228         CALL PHO_HARINI(I,IDP1,IDP2,PV1,PV2,6,IDEB(8))
25229       ENDIF
25230
25231 C  energy/virtuality grid
25232       do Ie=1,IH_Ecm_up(IL)
25233         HEcm_tab(Ie,IL) = EXP(ELLOW+DELTA*(IE-1))
25234       enddo
25235       do Ia=1,IH_Q2a_up(IL)
25236         HQ2a_tab(Ia,IL) = 0.D0
25237       enddo
25238       do Ib=1,IH_Q2b_up(IL)
25239         HQ2b_tab(Ib,IL) = 0.D0
25240       enddo
25241
25242 C  initialization for several energies and particle virtualities
25243       do Ie=1,IH_Ecm_up(IL)
25244         do Ia=1,IH_Q2a_up(IL)
25245           do Ib=1,IH_Q2b_up(IL)
25246
25247             EE = HEcm_tab(IE,IL)
25248             Q2a = HQ2a_tab(Ia,IL)
25249             Q2b = HQ2b_tab(Ib,IL)
25250             CALL PHO_HARINT(IP,EE,0.D0,0.D0,0,-2,0,0,1)
25251             IF(IDEB(8).GE.5) WRITE(LO,'(1X,A,2E10.3,2I7)')
25252      &        'PHO_HARMCI: initialization PT,ECM,ID1,ID2:',
25253      &        PTCUT(I),EE,IDPDG1,IDPDG2
25254             Hfac_tab(0,Ie,Ia,Ib,IL) = PTCUT(I)
25255             CALL PHO_HARFAC(PTCUT(I),EE)
25256             CALL PHO_HARWGX(PTCUT(I),EE)
25257             CALL PHO_HARXTO(EE,PTCUT(I),PTCUT(I),DSIG,DSPT)
25258             IF(IDEB(8).GE.10) THEN
25259               WRITE(LO,'(1X,A,/,1X,A)')
25260      &          'hard cross sections SIGH(mb),DSIG/DPT(mb/GeV**2)',
25261      &          '------------------------------------------------'
25262               DO M=0,Max_pro_2
25263                 WRITE(LO,'(10X,A,1P2E14.4)')
25264      &            PROC(M),DREAL(DSIG(M)),DSPT(M)
25265               ENDDO
25266             ENDIF
25267
25268 C  store in interpolation tables
25269             Hfac_tab(-1,IE,Ia,Ib,IL) = Hfac(-1)
25270             HWgx_tab(-1,IE,Ia,Ib,IL) = HWgx(-1)
25271             do M=0,Max_pro_2
25272               Hfac_tab(M,IE,Ia,Ib,IL) = Hfac(M)
25273               HWgx_tab(M,IE,Ia,Ib,IL) = HWgx(M)
25274               HSig_tab(M,IE,Ia,Ib,IL) = DREAL(DSIG(M))*MH_pro_on(M,I)
25275               Hdpt_tab(M,IE,Ia,Ib,IL) = DSPT(M)*MH_pro_on(M,I)
25276             enddo
25277
25278 C  summed quantities
25279             HSig_tab(9,IE,Ia,Ib,IL) = 0.D0
25280             Hdpt_tab(9,IE,Ia,Ib,IL) = 0.D0
25281             do M=1,8
25282               IF(MH_pro_on(M,I).GT.0) THEN
25283                 HSig_tab(9,IE,Ia,Ib,IL) =
25284      &            HSig_tab(9,IE,Ia,Ib,IL) + HSig_tab(M,IE,Ia,Ib,IL)
25285                 Hdpt_tab(9,IE,Ia,Ib,IL) =
25286      &            Hdpt_tab(9,IE,Ia,Ib,IL) + Hdpt_tab(M,IE,Ia,Ib,IL)
25287               ENDIF
25288             enddo
25289             HSig_tab(15,IE,Ia,Ib,IL) = 0.D0
25290             Hdpt_tab(15,IE,Ia,Ib,IL) = 0.D0
25291             do M=10,14
25292               IF(MH_pro_on(M,I).GT.0) THEN
25293                 HSig_tab(15,IE,Ia,Ib,IL) =
25294      &            HSig_tab(15,IE,Ia,Ib,IL) + HSig_tab(M,IE,Ia,Ib,IL)
25295                 Hdpt_tab(15,IE,Ia,Ib,IL) =
25296      &            Hdpt_tab(15,IE,Ia,Ib,IL) + Hdpt_tab(M,IE,Ia,Ib,IL)
25297               ENDIF
25298             enddo
25299             HSig_tab(0,IE,Ia,Ib,IL) =
25300      &        HSig_tab(9,IE,Ia,Ib,IL) + HSig_tab(15,IE,Ia,Ib,IL)
25301             Hdpt_tab(0,IE,Ia,Ib,IL) =
25302      &        Hdpt_tab(9,IE,Ia,Ib,IL) + Hdpt_tab(15,IE,Ia,Ib,IL)
25303
25304           enddo
25305         enddo
25306       enddo
25307
25308 C  debug output of weights
25309  1000 CONTINUE
25310       IF(IDEB(8).GE.5) THEN
25311         WRITE(LO,'(/1X,A,5X,2I7,I3,F7.2,/1X,A)')
25312      &    'PHO_HARMCI: weights, maxima (ID1/2,IP,PTC)',
25313      &    IDPDG1,IDPDG2,IP,PTCUT(I),
25314      &    '------------------------------------------'
25315         DO M=-1,Max_pro_2
25316           IF((M.EQ.0).OR.(M.EQ.9).OR.(M.EQ.15)) GOTO 512
25317           WRITE(LO,'(2X,A,I3,2I7)')
25318      &      'PHO_HARMCI: ECM Hfac, HWgx, HSig, Hdpt for MSTR,ID1,ID2',
25319      &      M,IDPDG1,IDPDG2
25320           do k=1,IH_Ecm_up(IL)
25321             do ia=1,IH_Q2a_up(IL)
25322               do ib=1,IH_Q2b_up(IL)
25323                 WRITE(LO,'(3X,1p,7E10.3)') HEcm_tab(k,IL),
25324      &            HQ2a_tab(ia,IL),HQ2b_tab(ib,IL),
25325      &            Hfac_tab(M,k,ia,ib,IL),HWgx_tab(M,k,ia,ib,IL),
25326      &            HSig_tab(M,k,ia,ib,IL),Hdpt_tab(M,k,ia,ib,IL)
25327               enddo
25328             enddo
25329           enddo
25330  512      CONTINUE
25331         ENDDO
25332       ENDIF
25333
25334       END
25335
25336 *$ CREATE PHO_HARXR3.FOR
25337 *COPY PHO_HARXR3
25338 CDECK  ID>, PHO_HARXR3
25339       SUBROUTINE PHO_HARXR3(ECMH,PT,ETAC,ETAD,DSIGMC)
25340 C**********************************************************************
25341 C
25342 C     differential cross section DSIG/(DETAC*DETAD*DPT)
25343 C
25344 C     input:  ECMH     CMS energy
25345 C             PT       parton PT
25346 C             ETAC     pseudorapidity of parton C
25347 C             ETAD     pseudorapidity of parton D
25348 C
25349 C     output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac/detad
25350 C
25351 C**********************************************************************
25352       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25353       SAVE
25354
25355       PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-20)
25356
25357       PARAMETER ( Max_pro_2 = 16 )
25358       COMPLEX*16 DSIGMC
25359       DIMENSION DSIGMC(0:Max_pro_2)
25360       DIMENSION DSIGM(0:Max_pro_2)
25361
25362 C  input/output channels
25363       INTEGER LI,LO
25364       COMMON /POINOU/ LI,LO
25365 C  some constants
25366       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25367       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25368      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25369 C  Reggeon phenomenology parameters
25370       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25371      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25372       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25373      &                ALREG,ALREGP,GR(2),B0REG(2),
25374      &                GPPP,GPPR,B0PPP,B0PPR,
25375      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25376 C  currently activated parton density parametrizations
25377       CHARACTER*8 PDFNAM
25378       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
25379       DOUBLE PRECISION PDFLAM,PDFQ2M
25380       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
25381      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
25382 C  hard scattering parameters used for most recent hard interaction
25383       INTEGER NFbeta,NF
25384       DOUBLE PRECISION ALQCD2,BQCD
25385       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25386 C  scale parameters for parton model calculations
25387       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25388       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25389       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25390      &                NQQAL,NQQALI,NQQALF,NQQPD
25391
25392       DOUBLE PRECISION PHO_ALPHAS
25393       DIMENSION PDA(-6:6),PDB(-6:6)
25394
25395       DO 10 I=1,9
25396         DSIGMC(I) = CMPLX(0.D0,0.D0)
25397         DSIGM(I)  = 0.D0
25398 10    CONTINUE
25399
25400       EC     = EXP(ETAC)
25401       ED     = EXP(ETAD)
25402 C  kinematic conversions
25403       XA     = PT*(EC+ED)/ECMH
25404       XB     = XA/(EC*ED)
25405       IF((XA.GE.1.D0).OR.(XB.GE.1.D0)) THEN
25406         WRITE(LO,'(/1X,A,2E12.4)') 'PHO_HARXR3:ERROR:X1 OR X2 > 1',XA,XB
25407         RETURN
25408       ENDIF
25409       SP     = XA*XB*ECMH*ECMH
25410       UP     =-ECMH*PT*EC*XB
25411       UP     = UP/SP
25412       TP     =-(1.D0+UP)
25413       UU     = UP*UP
25414       TT     = TP*TP
25415 C  set hard scale  QQ  for alpha and partondistr.
25416       IF     ( NQQAL.EQ.1 ) THEN
25417         QQAL = AQQAL*PT*PT
25418       ELSEIF ( NQQAL.EQ.2 ) THEN
25419         QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25420       ELSEIF ( NQQAL.EQ.3 ) THEN
25421         QQAL = AQQAL*SP
25422       ELSEIF ( NQQAL.EQ.4 ) THEN
25423         QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25424       ENDIF
25425       IF     ( NQQPD.EQ.1 ) THEN
25426         QQPD = AQQPD*PT*PT
25427       ELSEIF ( NQQPD.EQ.2 ) THEN
25428         QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25429       ELSEIF ( NQQPD.EQ.3 ) THEN
25430         QQPD = AQQPD*SP
25431       ELSEIF ( NQQPD.EQ.4 ) THEN
25432         QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25433       ENDIF
25434
25435       ALPHA  = PHO_ALPHAS(QQAL,3)
25436       FACTOR = PI2*GEV2MB*PT*(ALPHA/SP)**2*AKFAC
25437 C  parton distributions (times x)
25438       CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
25439       CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
25440       S1    = PDA(0)*PDB(0)
25441       S2    = 0.D0
25442       S3    = 0.D0
25443       S4    = 0.D0
25444       S5    = 0.D0
25445       DO 20 I=1,NF
25446         S2  = S2+PDA(I)*PDB(-I)+PDA(-I)*PDB( I)
25447         S3  = S3+PDA(I)*PDB( I)+PDA(-I)*PDB(-I)
25448         S4  = S4+PDA(I)+PDA(-I)
25449         S5  = S5+PDB(I)+PDB(-I)
25450 20    CONTINUE
25451 C  partial cross sections (including color and symmetry factors)
25452 C  resolved photon matrix elements (light quarks)
25453       DSIGM(1) = 2.25D0*(3.-((UP*TP)+UP/TT+TP/UU))
25454       DSIGM(6) = (4.D0/9.D0)*(UU+TT)
25455       DSIGM(8) = (4.D0/9.D0)*(1.D0+UU)/TT
25456       DSIGM(2) = (16.D0/27.D0)*(UU+TT)/(UP*TP)-3.D0*DSIGM(6)
25457       DSIGM(3) = ((1.D0+UU)/TT)-(4.D0/9.D0)*(1.D0+UU)/UP
25458       DSIGM(4) = (9.D0/32.D0)*DSIGM(2)
25459       DSIGM(5) = DSIGM(6)+DSIGM(8)-(8.D0/27.D0)*UU/TP
25460       DSIGM(7) = 0.5D0*(DSIGM(8)+(4.D0/9.D0)*(1.D0+TT)/UU-
25461      &           (8.D0/27.D0)/(UP*TP))
25462 C
25463       DSIGM(1) = FACTOR*DSIGM(1)*S1
25464       DSIGM(2) = FACTOR*DSIGM(2)*S2
25465       DSIGM(3) = FACTOR*DSIGM(3)*(PDA(0)*S5+PDB(0)*S4)
25466       DSIGM(4) = FACTOR*DSIGM(4)*S1*NF
25467       DSIGM(5) = FACTOR*DSIGM(5)*S2
25468       DSIGM(6) = FACTOR*DSIGM(6)*S2*MAX(0,(NF-1))
25469       DSIGM(7) = FACTOR*DSIGM(7)*S3
25470       DSIGM(8) = FACTOR*DSIGM(8)*(S4*S5-(S2+S3))
25471 C  complex part
25472       X=ABS(TP-UP)
25473       FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25474 C
25475       DO 50 I=1,8
25476         IF(DSIGM(I).LT.EPS) DSIGM(I) = 0.D0
25477         DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25478         DSIGMC(9) = DSIGMC(9)+DSIGMC(I)
25479  50   CONTINUE
25480       END
25481
25482 *$ CREATE PHO_HARXR2.FOR
25483 *COPY PHO_HARXR2
25484 CDECK  ID>, PHO_HARXR2
25485       SUBROUTINE PHO_HARXR2(ECMH,PT,ETAC,DSIGMC)
25486 C**********************************************************************
25487 C
25488 C     differential cross section DSIG/(DETAC*DPT)
25489 C
25490 C     input:  ECMH     CMS energy
25491 C             PT       parton PT
25492 C             ETAC     pseudorapidity of parton C
25493 C
25494 C     output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
25495 C
25496 C**********************************************************************
25497       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25498       SAVE
25499
25500       PARAMETER ( TINY= 1.D-20 )
25501
25502       PARAMETER ( Max_pro_2 = 16 )
25503       COMPLEX*16 DSIGMC
25504       DIMENSION DSIGMC(0:Max_pro_2)
25505
25506 C  input/output channels
25507       INTEGER LI,LO
25508       COMMON /POINOU/ LI,LO
25509 C  integration precision for hard cross sections (obsolete)
25510       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25511       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25512
25513       COMPLEX*16 DSIG1
25514       DIMENSION DSIG1(0:Max_pro_2)
25515       DIMENSION ABSZ(32),WEIG(32)
25516
25517       DO 10 M=1,9
25518         DSIGMC(M) = CMPLX(0.D0,0.D0)
25519         DSIG1(M)  = 0.D0
25520 10    CONTINUE
25521 C
25522       EC  = EXP(ETAC)
25523       ARG = ECMH/PT
25524       IF  ( ARG.LE.EC .OR. ARG.LE.1.D0/EC ) RETURN
25525       EDU = LOG(ARG-EC)
25526       EDL =-LOG(ARG-1.D0/EC)
25527       NPOINT = NGAUET
25528       CALL PHO_GAUSET(EDL,EDU,NPOINT,ABSZ,WEIG)
25529       DO 30 I=1,NPOINT
25530         CALL PHO_HARXR3(ECMH,PT,ETAC,ABSZ(I),DSIG1)
25531         DO 20 M=1,9
25532           PCTRL= DREAL(DSIG1(M))/TINY
25533           IF( PCTRL.GE.1.D0 ) THEN
25534             DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
25535           ENDIF
25536 20      CONTINUE
25537 30    CONTINUE
25538       END
25539
25540 *$ CREATE PHO_HARXD2.FOR
25541 *COPY PHO_HARXD2
25542 CDECK  ID>, PHO_HARXD2
25543       SUBROUTINE PHO_HARXD2(ECMH,PT,ETAC,DSIGMC)
25544 C**********************************************************************
25545 C
25546 C     differential cross section DSIG/(DETAC*DPT) for direct processes
25547 C
25548 C     input:  ECMH     CMS energy of scattering system
25549 C             PT       parton PT
25550 C             ETAC     pseudorapidity of parton C
25551 C
25552 C     output: DSIGMC(0:15) QCD-PM cross sections dsigma/dpt/detac
25553 C
25554 C**********************************************************************
25555       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25556       SAVE
25557
25558       PARAMETER ( Max_pro_2 = 16 )
25559       COMPLEX*16 DSIGMC
25560       DIMENSION DSIGMC(0:Max_pro_2)
25561       PARAMETER ( TINY= 1.D-30, ONEP1=1.1, TINY6=1.D-06, EPS=1.D-25)
25562
25563 C  input/output channels
25564       INTEGER LI,LO
25565       COMMON /POINOU/ LI,LO
25566 C  model switches and parameters
25567       CHARACTER*8 MDLNA
25568       INTEGER ISWMDL,IPAMDL
25569       DOUBLE PRECISION PARMDL
25570       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25571 C  data of c.m. system of Pomeron / Reggeon exchange
25572       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25573       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25574      &                 SIDP,CODP,SIFP,COFP
25575       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25576      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
25577      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
25578 C  Reggeon phenomenology parameters
25579       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25580      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25581       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25582      &                ALREG,ALREGP,GR(2),B0REG(2),
25583      &                GPPP,GPPR,B0PPP,B0PPR,
25584      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25585 C  currently activated parton density parametrizations
25586       CHARACTER*8 PDFNAM
25587       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
25588       DOUBLE PRECISION PDFLAM,PDFQ2M
25589       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
25590      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
25591 C  hard scattering parameters used for most recent hard interaction
25592       INTEGER NFbeta,NF
25593       DOUBLE PRECISION ALQCD2,BQCD
25594       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25595 C  some hadron information, will be deleted in future versions
25596       INTEGER NFS
25597       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
25598       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
25599 C  scale parameters for parton model calculations
25600       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
25601       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
25602       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
25603      &                NQQAL,NQQALI,NQQALF,NQQPD
25604 C  some constants
25605       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25606       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25607      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25608
25609       DOUBLE PRECISION PHO_ALPHAS,pho_alphae
25610       DIMENSION PDA(-6:6),PDB(-6:6),DSIGM(0:Max_pro_2)
25611
25612 *     ONE32=1.D0/9.D0
25613 *     TWO32=4.D0/9.D0
25614       DO 10 I=10,13
25615         DSIGMC(I) = CMPLX(0.D0,0.D0)
25616         DSIGM(I) = 0.D0
25617  10   CONTINUE
25618       DSIGMC(15) = CMPLX(0.D0,0.D0)
25619       DSIGM(15) = 0.D0
25620
25621 C  direct particle 1
25622       IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)) THEN
25623         EC     = EXP(ETAC)
25624         ED     = ECMH/PT-EC
25625 C  kinematic conversions
25626         XA     = 1.D0
25627         XB     = 1.D0/(EC*ED)
25628         IF ( XB.GE.1.D0 ) THEN
25629           WRITE(LO,'(/1X,A,2E12.4)')
25630      &      'PHO_HARXD2:ERROR: XB>1 (XA,XB)',XA,XB
25631           RETURN
25632         ENDIF
25633         SP     = XA*XB*ECMH*ECMH
25634         UP     =-ECMH*PT*EC*XB
25635         UP     = UP/SP
25636         TP     =-(1.D0+UP)
25637         UU     = UP*UP
25638         TT     = TP*TP
25639 C  set hard scale  QQ  for alpha and partondistr.
25640         IF     ( NQQAL.EQ.1 ) THEN
25641           QQAL = AQQAL*PT*PT
25642         ELSEIF ( NQQAL.EQ.2 ) THEN
25643           QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25644         ELSEIF ( NQQAL.EQ.3 ) THEN
25645           QQAL = AQQAL*SP
25646         ELSEIF ( NQQAL.EQ.4 ) THEN
25647           QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25648         ENDIF
25649         IF     ( NQQPD.EQ.1 ) THEN
25650           QQPD = AQQPD*PT*PT
25651         ELSEIF ( NQQPD.EQ.2 ) THEN
25652           QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25653         ELSEIF ( NQQPD.EQ.3 ) THEN
25654           QQPD = AQQPD*SP
25655         ELSEIF ( NQQPD.EQ.4 ) THEN
25656           QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25657         ENDIF
25658
25659         ALPHA2 = PHO_ALPHAS(QQAL,2)
25660         IF(IDPDG1.EQ.22) THEN
25661           ALPHA1 = pho_alphae(QQAL)
25662         ELSE IF(IDPDG1.EQ.990) THEN
25663           ALPHA1 = PARMDL(74)
25664         ENDIF
25665         FACTOR = -PI2*GEV2MB*UP/PT*ALPHA1*ALPHA2/SP*AKFAC
25666 C  parton distribution (times x)
25667         CALL PHO_PDF(2,XB,QQPD,0.D0,PDB)
25668         S1    = PDB(0)
25669 C  charge counting
25670         S2    = 0.D0
25671         S3    = 0.D0
25672         IF(IDPDG1.EQ.22) THEN
25673           DO 20 I=1,NF
25674 *           IF(MOD(I,2).EQ.0) THEN
25675 *             S2 = S2 + (PDB(I)+PDB(-I))*TWO32
25676 *             S3 = S3 + TWO32
25677 *           ELSE
25678 *             S2 = S2 + (PDB(I)+PDB(-I))*ONE32
25679 *             S3 = S3 + ONE32
25680 *           ENDIF
25681             S2 = S2 + (PDB(I)+PDB(-I))*Q_ch2(I)
25682             S3 = S3 + Q_ch2(I)
25683  20       CONTINUE
25684         ELSE IF(IDPDG1.EQ.990) THEN
25685           DO 25 I=1,NF
25686             S2 = S2 + PDB(I)+PDB(-I)
25687  25       CONTINUE
25688           S3 = NF
25689         ENDIF
25690 C  partial cross sections (including color and symmetry factors)
25691 C  direct photon matrix elements
25692         DSIGM(10) = -8.D0/3.D0*(UU+1.D0)/UP
25693         DSIGM(11) = (UU+TT)/(UP*TP)
25694 C
25695         DSIGM(10) = FACTOR*DSIGM(10)*S2
25696         DSIGM(11) = FACTOR*DSIGM(11)*S1*S3
25697 C  complex part
25698         X=ABS(TP-UP)
25699         FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25700 C
25701         DO 50 I=10,11
25702           IF(DSIGM(I).LT.0.D0) THEN
25703             WRITE(LO,'(1X,A,I3,1P,2E12.4)')
25704      &        'PHO_HARXD2: neg. cross section',I,DSIGM(I),ECMH
25705             DSIGM(I) = 0.D0
25706           ENDIF
25707           DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25708           DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
25709  50     CONTINUE
25710       ENDIF
25711 C
25712 C  direct particle 2
25713       IF((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
25714         EC     = EXP(ETAC)
25715         ED     = 1.D0/(ECMH/PT-1.D0/EC)
25716 C  kinematic conversions
25717         XA     = PT*(EC+ED)/ECMH
25718         XB     = 1.D0
25719         IF ( XA.GE.1.D0 ) THEN
25720           WRITE(LO,'(/1X,A,2E12.4)')
25721      &      'PHO_HARXD2:ERROR:XA>1 (XA,XB)',XA,XB
25722           RETURN
25723         ENDIF
25724         SP     = XA*XB*ECMH*ECMH
25725         UP     =-ECMH*PT*EC*XB
25726         UP     = UP/SP
25727         TP     =-(1.D0+UP)
25728         UU     = UP*UP
25729         TT     = TP*TP
25730 C  set hard scale  QQ  for alpha and partondistr.
25731         IF     ( NQQAL.EQ.1 ) THEN
25732           QQAL = AQQAL*PT*PT
25733         ELSEIF ( NQQAL.EQ.2 ) THEN
25734           QQAL = AQQAL*SP*UP*TP/(1.D0+TT+UU)
25735         ELSEIF ( NQQAL.EQ.3 ) THEN
25736           QQAL = AQQAL*SP
25737         ELSEIF ( NQQAL.EQ.4 ) THEN
25738           QQAL = AQQAL*SP*(UP*TP)**(1.D0/3.D0)
25739         ENDIF
25740         IF     ( NQQPD.EQ.1 ) THEN
25741           QQPD = AQQPD*PT*PT
25742         ELSEIF ( NQQPD.EQ.2 ) THEN
25743           QQPD = AQQPD*SP*UP*TP/(1.D0+TT+UU)
25744         ELSEIF ( NQQPD.EQ.3 ) THEN
25745           QQPD = AQQPD*SP
25746         ELSEIF ( NQQPD.EQ.4 ) THEN
25747           QQPD = AQQPD*SP*(UP*TP)**(1.D0/3.D0)
25748         ENDIF
25749
25750         ALPHA1 = PHO_ALPHAS(QQAL,1)
25751         IF(IDPDG2.EQ.22) THEN
25752           ALPHA2 = pho_alphae(QQAL)
25753         ELSE IF(IDPDG2.EQ.990) THEN
25754           ALPHA2 = PARMDL(74)
25755         ENDIF
25756         FACTOR = -PI2*GEV2MB*TP/PT*ALPHA1*ALPHA2/SP*AKFAC
25757 C  parton distribution (times x)
25758         CALL PHO_PDF(1,XA,QQPD,0.D0,PDA)
25759         S1    = PDA(0)
25760 C  charge counting
25761         S2    = 0.D0
25762         S3    = 0.D0
25763         IF(IDPDG2.EQ.22) THEN
25764           DO 70 I=1,NF
25765 *           IF(MOD(I,2).EQ.0) THEN
25766 *             S2 = S2 + (PDA(I)+PDA(-I))*TWO32
25767 *             S3 = S3 + TWO32
25768 *           ELSE
25769 *             S2 = S2 + (PDA(I)+PDA(-I))*ONE32
25770 *             S3 = S3 + ONE32
25771 *           ENDIF
25772             S2 = S2 + (PDA(I)+PDA(-I))*Q_ch2(I)
25773             S3 = S3 + Q_ch2(I)
25774  70       CONTINUE
25775         ELSE IF(IDPDG2.EQ.990) THEN
25776           DO 75 I=1,NF
25777             S2 = S2 + PDA(I)+PDA(-I)
25778  75       CONTINUE
25779           S3 = NF
25780         ENDIF
25781 C  partial cross sections (including color and symmetry factors)
25782 C  direct photon matrix elements
25783         DSIGM(12) = -8.D0/3.D0*(TT+1.D0)/TP
25784         DSIGM(13) = (UU+TT)/(UP*TP)
25785 C
25786         DSIGM(12) = FACTOR*DSIGM(12)*S2
25787         DSIGM(13) = FACTOR*DSIGM(13)*S3*S1
25788 C  complex part
25789         X=ABS(TP-UP)
25790         FAC2 = -LOG((X+2.D0)/(X+1.D-30))/PI
25791 C
25792         DO 80 I=12,13
25793           IF(DSIGM(I).LT.0.D0) THEN
25794             WRITE(LO,'(1X,A,I3,1P,2E12.4)')
25795      &        'PHO_HARXD2: neg. cross section:',I,DSIGM(I),ECMH
25796             DSIGM(I) = 0.D0
25797           ENDIF
25798           DSIGMC(I) = CMPLX(DSIGM(I),DSIGM(I)*FAC2)
25799           DSIGMC(15) = DSIGMC(15)+DSIGMC(I)
25800  80     CONTINUE
25801       ENDIF
25802       END
25803
25804 *$ CREATE PHO_HARXPT.FOR
25805 *COPY PHO_HARXPT
25806 CDECK  ID>, PHO_HARXPT
25807       SUBROUTINE PHO_HARXPT(ECMH,PT,IPRO,DSIGMC)
25808 C**********************************************************************
25809 C
25810 C     differential cross section DSIG/DPT
25811 C
25812 C     input:  ECMH     CMS energy of scattering system
25813 C             PT       parton PT
25814 C             IPRO     1  resolved processes
25815 C                      2  direct processes
25816 C                      3  resolved and direct processes
25817 C
25818 C     output: DSIGMC(0:12) QCD-PM cross sections dsigma/dpt
25819 C
25820 C**********************************************************************
25821       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25822       SAVE
25823
25824       PARAMETER ( Max_pro_2 = 16 )
25825       COMPLEX*16 DSIGMC
25826       DIMENSION  DSIGMC(0:Max_pro_2)
25827       PARAMETER ( TINY= 1.D-10, ONEP1=1.1, EPS=1.D-25)
25828
25829 C  input/output channels
25830       INTEGER LI,LO
25831       COMMON /POINOU/ LI,LO
25832 C  some constants
25833       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25834       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25835      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25836 C  model switches and parameters
25837       CHARACTER*8 MDLNA
25838       INTEGER ISWMDL,IPAMDL
25839       DOUBLE PRECISION PARMDL
25840       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25841 C  data of c.m. system of Pomeron / Reggeon exchange
25842       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25843       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25844      &                 SIDP,CODP,SIFP,COFP
25845       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25846      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
25847      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
25848 C  Reggeon phenomenology parameters
25849       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25850      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25851       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25852      &                ALREG,ALREGP,GR(2),B0REG(2),
25853      &                GPPP,GPPR,B0PPP,B0PPR,
25854      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25855 C  integration precision for hard cross sections (obsolete)
25856       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25857       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25858 C  hard scattering parameters used for most recent hard interaction
25859       INTEGER NFbeta,NF
25860       DOUBLE PRECISION ALQCD2,BQCD
25861       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
25862 C  some hadron information, will be deleted in future versions
25863       INTEGER NFS
25864       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
25865       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
25866
25867       double precision pho_alphae
25868
25869       COMPLEX*16 DSIG1
25870       DIMENSION  DSIG1(0:Max_pro_2)
25871       DIMENSION ABSZ(32),WEIG(32)
25872
25873       DO 10 M=0,Max_pro_2
25874         DSIGMC(M) = CMPLX(0.D0,0.D0)
25875         DSIG1(M)  = CMPLX(0.D0,0.D0)
25876  10   CONTINUE
25877
25878 C  resolved and direct processes
25879       AMT = 2.D0*PT/ECMH
25880       IF ( AMT.GE.1.D0 ) RETURN
25881       ECU = LOG((SQRT(1.D0-AMT*AMT)+1.D0)/AMT)
25882       ECL = -ECU
25883       NPOINT = NGAUET
25884       CALL PHO_GAUSET(ECL,ECU,NPOINT,ABSZ,WEIG)
25885       DO 30 I=1,NPOINT
25886         DSIG1(9)  = CMPLX(0.D0,0.D0)
25887         DSIG1(15) = CMPLX(0.D0,0.D0)
25888         IF(IPRO.EQ.1) THEN
25889           CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
25890         ELSE IF(IPRO.EQ.2) THEN
25891           CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
25892         ELSE
25893           CALL PHO_HARXR2(ECMH,PT,ABSZ(I),DSIG1)
25894           CALL PHO_HARXD2(ECMH,PT,ABSZ(I),DSIG1)
25895         ENDIF
25896         DO 20 M=1,Max_pro_2
25897           DSIGMC(M) = DSIGMC(M)+WEIG(I)*DSIG1(M)
25898  20     CONTINUE
25899  30   CONTINUE
25900
25901 C  direct processes
25902       IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
25903      &   .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
25904         FAC = 0.D0
25905         SS = ECMH*ECMH
25906         ALPHAE = pho_alphae(SS)
25907         DO 300 I=1,NF
25908           IF(IDPDG1.EQ.22) THEN
25909 *           F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
25910             F1 = Q_ch2(I)*ALPHAE
25911           ELSE
25912             F1 = PARMDL(74)
25913           ENDIF
25914           IF(IDPDG2.EQ.22) THEN
25915 *           F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
25916             F2 = Q_ch2(I)*ALPHAE
25917           ELSE
25918             F2 = PARMDL(74)
25919           ENDIF
25920           FAC = FAC+F1*F2*3.D0
25921  300    CONTINUE
25922 C  direct cross sections
25923         ZZ = SQRT(1.D0-4.D0*PT*PT/SS+TINY)
25924         T1 = -SS/2.D0*(1.D0+ZZ)
25925         T2 = -SS/2.D0*(1.D0-ZZ)
25926         XM = -2.D0*PT/ZZ*((SS+T1)/T1+T1/(SS+T1)+(SS+T2)/T2+T2/(SS+T2))
25927 C  hadronic part
25928         DSIGMC(14) = GEV2MB*2.D0*PI*FAC/(SS*SS)*XM*AKFAC
25929
25930 C  leptonic part (e, mu, tau)
25931         DSIGMC(16) = 0.D0
25932         IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
25933           DSIGMC(16) = DSIGMC(14)/FAC*3.D0*ALPHAE**2
25934 C  simulation of tau together with quarks
25935           IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
25936         ENDIF
25937       ENDIF
25938
25939       DSIGMC(15) = DSIGMC(15)+DSIGMC(14)
25940       DSIGMC(0)  = DSIGMC(9)+DSIGMC(15)
25941
25942       END
25943
25944 *$ CREATE PHO_HARXTO.FOR
25945 *COPY PHO_HARXTO
25946 CDECK  ID>, PHO_HARXTO
25947       SUBROUTINE PHO_HARXTO(ECMH,PTCUTR,PTCUTD,DSIGMC,DSDPTC)
25948 C**********************************************************************
25949 C
25950 C     total hard cross section (perturbative QCD, Parton Model)
25951 C
25952 C     input:  ECMH     CMS energy of scattering system
25953 C             PTCUTR   PT cutoff for resolved processes
25954 C             PTCUTD   PT cutoff for direct processes (photon, Pomeron)
25955 C
25956 C     output: DSIGMC(0:MARPR2) cross sections for given cutoff
25957 C             DSDPTC(0:MARPR2) differential cross sections at cutoff
25958 C
25959 C     note:  COMPLEX*16          DSIGMC
25960 C            DOUBLE PRECISION    DSDPTC
25961 C
25962 C**********************************************************************
25963       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25964       SAVE
25965
25966       PARAMETER ( Max_pro_2 = 16 )
25967       COMPLEX*16 DSIGMC
25968       DIMENSION DSIGMC(0:Max_pro_2),DSDPTC(0:Max_pro_2)
25969
25970 C  input/output channels
25971       INTEGER LI,LO
25972       COMMON /POINOU/ LI,LO
25973 C  model switches and parameters
25974       CHARACTER*8 MDLNA
25975       INTEGER ISWMDL,IPAMDL
25976       DOUBLE PRECISION PARMDL
25977       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
25978 C  data of c.m. system of Pomeron / Reggeon exchange
25979       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
25980       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
25981      &                 SIDP,CODP,SIFP,COFP
25982       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
25983      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
25984      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
25985 C  Reggeon phenomenology parameters
25986       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
25987      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
25988       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
25989      &                ALREG,ALREGP,GR(2),B0REG(2),
25990      &                GPPP,GPPR,B0PPP,B0PPR,
25991      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
25992 C  some constants
25993       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
25994       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
25995      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
25996 C  integration precision for hard cross sections (obsolete)
25997       INTEGER NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25998       COMMON /POGAUP/ NGAUP1,NGAUP2,NGAUET,NGAUIN,NGAUSO
25999 C  some hadron information, will be deleted in future versions
26000       INTEGER NFS
26001       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
26002       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
26003 C  hard scattering parameters used for most recent hard interaction
26004       INTEGER NFbeta,NF
26005       DOUBLE PRECISION ALQCD2,BQCD
26006       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
26007
26008       double precision pho_alphae
26009
26010       COMPLEX*16 DSIG1
26011       DIMENSION DSIG1(0:Max_pro_2)
26012       DIMENSION ABSZ(32),WEIG(32)
26013
26014       DATA FAC / 3.0D0 /
26015
26016       DO 10 M=0,Max_pro_2
26017         DSIGMC(M)= CMPLX(0.D0,0.D0)
26018  10   CONTINUE
26019       EEC=ECMH/2.001D0
26020 C
26021       IF ( PTCUTR.GE.EEC ) GOTO 100
26022 C
26023 C  integration for resolved processes
26024       PTMIN  = PTCUTR
26025       PTMAX  = MIN(FAC*PTMIN,EEC)
26026       NPOINT = NGAUP1
26027       CALL PHO_HARXPT(ECMH,PTMIN,1,DSIG1)
26028       DO 60 M=1,9
26029         DSDPTC(M) = DREAL(DSIG1(M))
26030  60   CONTINUE
26031       DSIGH   = DREAL(DSIG1(9))
26032       PTMXX  = 0.95D0*PTMAX
26033       CALL PHO_HARXPT(ECMH,PTMXX,1,DSIG1)
26034       DSIGL  = DREAL(DSIG1(9))
26035       EX     = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
26036       EX1    = 1.0D0-EX
26037       DO 50 K=1,2
26038         IF ( PTMIN.GE.PTMAX ) GOTO 40
26039         RL   = PTMIN**EX1
26040         RU   = PTMAX**EX1
26041         CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
26042         DO 30 I=1,NPOINT
26043           R  = ABSZ(I)
26044           PT = R**(1.0D0/EX1)
26045           CALL PHO_HARXPT(ECMH,PT,1,DSIG1)
26046           F  = WEIG(I)*PT/(R*EX1)
26047           DO 20 M=1,9
26048             DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
26049  20       CONTINUE
26050  30     CONTINUE
26051  40     PTMIN  = PTMAX
26052         PTMAX  = EEC
26053         NPOINT = NGAUP2
26054  50   CONTINUE
26055  100  CONTINUE
26056       DSIGMC(0) = DSIGMC(9)
26057       DSDPTC(0) = DSDPTC(9)
26058 C
26059 C  integration for direct processes
26060       IF((PTCUTD.GE.EEC).OR.(PTCUTD.LT.0.5D0)) RETURN
26061 C
26062       IF((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990)
26063      &   .OR.(IDPDG2.EQ.22).OR.(IDPDG2.EQ.990)) THEN
26064         PTMIN  = PTCUTD
26065         PTMAX  = MIN(FAC*PTMIN,EEC)
26066         NPOINT = NGAUP1
26067         CALL PHO_HARXPT(ECMH,PTMIN,2,DSIG1)
26068         IF(DREAL(DSIG1(15)).LT.1.D-15) GOTO 170
26069         DO 160 M=10,16
26070           DSDPTC(M) = DREAL(DSIG1(M))
26071  160    CONTINUE
26072         DSIGH   = DREAL(DSIG1(15)-DSIG1(14))
26073         PTMXX  = 0.95D0*PTMAX
26074         CALL PHO_HARXPT(ECMH,PTMXX,2,DSIG1)
26075         DSIGL  = DREAL(DSIG1(15)-DSIG1(14))
26076         EX     = LOG(DSIGH/(DSIGL+1.D-30))/LOG(FAC)
26077         EX1    = 1.0D0-EX
26078         DO 150 K=1,2
26079           IF ( PTMIN.GE.PTMAX ) GOTO 140
26080           RL   = PTMIN**EX1
26081           RU   = PTMAX**EX1
26082           CALL PHO_GAUSET(RL,RU,NPOINT,ABSZ,WEIG)
26083           DO 130 I=1,NPOINT
26084             R  = ABSZ(I)
26085             PT = R**(1.0D0/EX1)
26086             CALL PHO_HARXPT(ECMH,PT,2,DSIG1)
26087             F  = WEIG(I)*PT/(R*EX1)
26088             DO 120 M=10,15
26089               DSIGMC(M) = DSIGMC(M)+F*DSIG1(M)
26090  120        CONTINUE
26091  130      CONTINUE
26092  140      PTMIN  = PTMAX
26093           PTMAX  = EEC
26094           NPOINT = NGAUP2
26095  150    CONTINUE
26096       ENDIF
26097 C
26098  170  CONTINUE
26099 C
26100 C  double direct process
26101       IF(((IDPDG1.EQ.22).OR.(IDPDG1.EQ.990))
26102      &   .AND.((IDPDG2.EQ.22).OR.(IDPDG2.EQ.990))) THEN
26103         FACC = 0.D0
26104         SS = ECMH*ECMH
26105         ALPHAE = pho_alphae(SS)
26106         DO 300 I=1,NF
26107           IF(IDPDG1.EQ.22) THEN
26108 *           F1 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
26109             F1 = Q_ch2(I)*ALPHAE
26110           ELSE
26111             F1 = PARMDL(74)
26112           ENDIF
26113           IF(IDPDG2.EQ.22) THEN
26114 *           F2 = (4.D0-3.D0*MOD(I,2))/9.D0*ALPHAE
26115             F2 = Q_ch2(I)*ALPHAE
26116           ELSE
26117             F2 = PARMDL(74)
26118           ENDIF
26119           FACC = FACC + F1*F2*3.D0
26120  300    CONTINUE
26121
26122         ZZ = SQRT(1.D0-4.D0*PTCUTD*PTCUTD/SS)
26123         R  = 4.D0*PI/SS*(LOG((1.D0+ZZ)/(1.D0-ZZ))-ZZ)*GEV2MB
26124 C  hadronic cross section
26125         DSIGMC(14) = R*FACC*AKFAC
26126 C  leptonic cross section
26127         IF((IDPDG1.EQ.22).AND.(IDPDG2.EQ.22)) THEN
26128           DSIGMC(16) = R*3.D0*ALPHAE**2*AKFAC
26129 C  simulation of tau together with quarks
26130           IF(IPAMDL(64).NE.0) DSIGMC(14) = DSIGMC(14)+DSIGMC(16)/3.D0
26131           DSIGMC(16) = DSIGMC(16)*2.D0/3.D0
26132         ELSE
26133           DSIGMC(16) = CMPLX(0.D0,0.D0)
26134         ENDIF
26135 C  sum of direct part
26136         DSIGMC(15) = CMPLX(0.D0,0.D0)
26137         DO 400 I=10,14
26138           DSIGMC(15) = DSIGMC(15) + DSIGMC(I)
26139  400    CONTINUE
26140       ENDIF
26141 C total sum (hadronic)
26142       DSIGMC(0) = DSIGMC(9) + DSIGMC(15)
26143       DSDPTC(0) = DSDPTC(9) + DSDPTC(15)
26144
26145       END
26146
26147 *$ CREATE PHO_HARISR.FOR
26148 *COPY PHO_HARISR
26149 CDECK  ID>, PHO_HARISR
26150       SUBROUTINE PHO_HARISR(IHPOM,P1,P2,IPF1,IPF2,IPA1,IPA2,IV1,IV2,Q2H,
26151      &  XH1,XH2,XHMAX1,XHMAX2,IPB1,IPB2,IVO1,IVO2,XISR1,XISR2,IREJ)
26152 C********************************************************************
26153 C
26154 C     initial state radiation according to DGLAP evolution equations
26155 C     (backward evolution, no spin effects)
26156 C
26157 C     input:    IHPOM     index of hard Pomeron
26158 C                         negative: delete all previous entries
26159 C               P1,P2     4 momenta of hard scattered final partons
26160 C                         (in CMS of hard scattering)
26161 C               IPF1,2    flavours of final partons
26162 C               IPA1,2    flavours of initial partons
26163 C               IV1,2     valence quark labels (0/1)
26164 C               Q2H       momentum transfer (squared, positive)
26165 C               XH1,XH2   x values of initial partons
26166 C               XHMAX1,2  max. x values allowed
26167 C
26168 C     output:   all emitted partons in /POPISR/, final state
26169 C               partons are the first two entries
26170 C               shower evolution traced in /PODGL1/
26171 C               IPB1,2    flavours of new initial partons
26172 C               XISR1,2   x values of new initial partons
26173 C               IVO1,2    valence quark labels (0/1)
26174 C
26175 C     attention: quark numbering according to PDG convention,
26176 C                but 0 for gluons
26177 C
26178 C********************************************************************
26179       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26180       SAVE
26181
26182       PARAMETER (RHOMAS =  0.766D0,
26183      &           DEPS   =  1.D-10,
26184      &           TINY   =  1.D-10)
26185
26186       DIMENSION P1(4),P2(4)
26187
26188 C  input/output channels
26189       INTEGER LI,LO
26190       COMMON /POINOU/ LI,LO
26191 C  event debugging information
26192       INTEGER NMAXD
26193       PARAMETER (NMAXD=100)
26194       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
26195      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26196       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
26197      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26198 C  internal rejection counters
26199       INTEGER NMXJ
26200       PARAMETER (NMXJ=60)
26201       CHARACTER*10 REJTIT
26202       INTEGER IFAIL
26203       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
26204 C  model switches and parameters
26205       CHARACTER*8 MDLNA
26206       INTEGER ISWMDL,IPAMDL
26207       DOUBLE PRECISION PARMDL
26208       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
26209 C  data of c.m. system of Pomeron / Reggeon exchange
26210       INTEGER NPOSP,IDPDG1,IDBAM1,IDPDG2,IDBAM2
26211       DOUBLE PRECISION ECMP,PCMP,PMASSP,PVIRTP,GAMBEP,
26212      &                 SIDP,CODP,SIFP,COFP
26213       COMMON /POPCMS/ ECMP,PCMP,PMASSP(2),PVIRTP(2),GAMBEP(4),
26214      &                SIDP,CODP,SIFP,COFP,NPOSP(2),
26215      &                IDPDG1,IDBAM1,IDPDG2,IDBAM2
26216 C  some hadron information, will be deleted in future versions
26217       INTEGER NFS
26218       DOUBLE PRECISION QMASS,BET,PCOUDI,PNORM,VALPRG
26219       COMMON /POHDRN/ QMASS(6),BET,PCOUDI,PNORM,VALPRG(2),NFS
26220 C  currently activated parton density parametrizations
26221       CHARACTER*8 PDFNAM
26222       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
26223       DOUBLE PRECISION PDFLAM,PDFQ2M
26224       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
26225      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
26226 C  scale parameters for parton model calculations
26227       INTEGER NQQAL,NQQALI,NQQALF,NQQPD
26228       DOUBLE PRECISION AQQAL,AQQALI,AQQALF,AQQPD
26229       COMMON /POHSCL/ AQQAL,AQQALI,AQQALF,AQQPD,
26230      &                NQQAL,NQQALI,NQQALF,NQQPD
26231 C  parameters for DGLAP backward evolution in ISR
26232       INTEGER NFSISR
26233       DOUBLE PRECISION Q2MISR,PMISR,ZMISR,AL2ISR
26234       COMMON /PODGL1/ Q2MISR(2),PMISR(2),ZMISR(2),AL2ISR(2),NFSISR
26235 C  initial state parton radiation (internal part)
26236       INTEGER MXISR3,MXISR4
26237       PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
26238       INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
26239       DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
26240       COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
26241      &                ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
26242      &                IFL1(2,MXISR3),IFL2(2,MXISR3),
26243      &                IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
26244 C  some constants
26245       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
26246       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
26247      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
26248 C  particles created by initial state evolution
26249       INTEGER MXISR1,MXISR2
26250       PARAMETER ( MXISR1 = 150, MXISR2 = 50 )
26251       INTEGER IFLISR,IPOISR,IMXISR
26252       DOUBLE PRECISION PHISR
26253       COMMON /POPISR/ IFLISR(2,MXISR1),PHISR(2,4,MXISR1),
26254      &                IPOISR(2,2,MXISR2),IMXISR(2)
26255
26256       DOUBLE PRECISION PYP,EER,THER,QMAXR
26257       INTEGER PYK
26258
26259       DIMENSION XHMA(2),NEXT(2),PD1(-6:6),PD2(-6:6),WGGAP(-6:6),
26260      &          WGPDF(-6:6),XHMI(2),GB(4),PM(4),PN(4),PC(2,4),Q2(2),
26261      &          IVAL(2),IPAL(2),IL(2),IFSUM(2),IDMO(2)
26262
26263       IREJ = 0
26264       NTRY = 1000
26265       NITER = 0
26266 C  debug output
26267       IF(IDEB(79).GE.10) THEN
26268         WRITE(LO,'(1X,A,/1X,I10,3I3,5E11.3,2(/5X,4E12.3))')
26269      &    'PHO_HARISR: KEV,IHPOM,IP1,IP2,Q2H,XH1,XH2,XHM1,XHM2:',
26270      &    KEVENT,IHPOM,IPA1,IPA2,Q2H,XH1,XH2,XHMAX1,XHMAX2,P1,P2
26271       ENDIF
26272       IF(IHPOM.EQ.0) RETURN
26273 C
26274  10   CONTINUE
26275       NACC = 0
26276       IDMO(1) = IDPDG1
26277       IDMO(2) = IDPDG2
26278 C
26279 C  copy final state partons to local fields
26280       IHIDX = ABS(IHPOM)
26281       IF(IHIDX.GT.MXISR2) THEN
26282         WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26283      &    '/POPISR/ for hard scattering labels (IHIDX,MXISR2):',
26284      &    IHIDX,MXISR2
26285         IREJ = 1
26286       ENDIF
26287       DO 50 K=1,2
26288         IF(IHPOM.LT.0) IMXISR(K) = 0
26289         IPOISR(K,1,IHIDX) = IMXISR(K)+1
26290         IPAL(K) = IPOISR(K,1,IHIDX)
26291  50   CONTINUE
26292       DO 55 I=1,4
26293         PHISR(1,I,IPAL(1)) = P1(I)
26294         PHISR(2,I,IPAL(2)) = P2(I)
26295  55   CONTINUE
26296       IFLISR(1,IPAL(1)) = IPF1
26297       IFLISR(2,IPAL(2)) = IPF2
26298 C
26299 C  check limitations, initialize /PODGL1/
26300       IF((Q2H.GT.Q2MISR(1)).AND.(XH1.LT.XHMAX1)) THEN
26301         NEXT(1) = 1
26302         Q2SH(1,1) = Q2H
26303       ELSE
26304         NEXT(1) = 0
26305         Q2SH(1,1) = 0.D0
26306       ENDIF
26307       IF((Q2H.GT.Q2MISR(2)).AND.(XH2.LT.XHMAX2)) THEN
26308         NEXT(2) = 1
26309         Q2SH(2,1) = Q2H
26310       ELSE
26311         NEXT(2) = 0
26312         Q2SH(2,1) = 0.D0
26313       ENDIF
26314 C
26315       ISH(1) = 1
26316       ISH(2) = 1
26317       XPSH(1,1) = XH1
26318       XPSH(2,1) = XH2
26319 C
26320       IFL1(1,1) = IPA1
26321       IVAL(1)   = IV1
26322       IF((IPA1.EQ.22).OR.(IPA1.EQ.990)) NEXT(1) = 0
26323       IFL1(2,1) = IPA2
26324       IVAL(2)   = IV2
26325       IF((IPA2.EQ.22).OR.(IPA2.EQ.990)) NEXT(2) = 0
26326 C
26327       IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,/5X,2I2,3E12.3)')
26328      &  'PHO_HARISR:INITIAL TESTS (NEXT1,2 Q2H Q21,2)',NEXT,Q2H,Q2MISR
26329       IF(NEXT(1)+NEXT(2).EQ.0) GOTO 800
26330 C
26331 C  initialize parton shower loop
26332       B0QCD = (33.D0-2.D0*NFSISR)/6.D0
26333       AL2ISR(1) = PDFLAM(1)
26334       AL2ISR(2) = PDFLAM(2)
26335       XHMA(1) = XHMAX1
26336       XHMA(2) = XHMAX2
26337       XHMI(1) = PMISR(1)/PCMP
26338       XHMI(2) = PMISR(2)/PCMP
26339       ZPSH(1,1) = 1.D0
26340       ZPSH(2,1) = 1.D0
26341       SHAT1 = XH1*XH2*ECMP**2
26342       IF(IPAMDL(109).EQ.1) THEN
26343         PT2SH(1,1) = Q2H
26344       ELSE
26345         PT2SH(1,1) = Q2H*(1.D0-Q2H/SHAT1)
26346       ENDIF
26347       PT2SH(2,1) = PT2SH(1,1)
26348       IF(PT2SH(1,1).LT.Q2MISR(1)) NEXT(1) = 0
26349       IF(PT2SH(2,1).LT.Q2MISR(2)) NEXT(2) = 0
26350       THSH(1,1) = 2.D0*SQRT(Q2H/SHAT1)
26351       THSH(2,1) = THSH(1,1)
26352       IFANO(1) = 0
26353       IFANO(2) = 0
26354       ZZ = 1.D0
26355       IF(IREJ.NE.0) GOTO 800
26356 C
26357 C  main generation loop
26358 C -------------------------------------------------
26359  100  CONTINUE
26360 C  choose parton side to become solved
26361         IF((NEXT(1)+NEXT(2)).EQ.2) THEN
26362           IF(Q2SH(1,ISH(1)).GT.Q2SH(2,ISH(2))) THEN
26363             IP = 1
26364           ELSE IF(Q2SH(2,ISH(2)).GT.Q2SH(1,ISH(1))) THEN
26365             IP = 2
26366           ELSE
26367             IP = MAX(INT(DT_RNDM(SHAT1)*2.D0+0.999999D0),1)
26368           ENDIF
26369         ELSE IF(NEXT(1).EQ.1) THEN
26370           IP = 1
26371         ELSE IF(NEXT(2).EQ.1) THEN
26372           IP = 2
26373         ELSE
26374           GOTO 800
26375         ENDIF
26376         INDX = ISH(IP)
26377 C  INDX now parton position of parton to become solved
26378 C  IP   now side to be treated
26379         XP = XPSH(IP,INDX)
26380         Q2P = Q2SH(IP,INDX)
26381         PT2 = PT2SH(IP,INDX)
26382         IFLB = IFL1(IP,INDX)
26383 C  check available x
26384         XMIP = XHMI(IP)
26385 C  cutoff by x limitation: no further development
26386         IF((XHMA(IP)-XP).LT.XMIP*2.D0) THEN
26387           NEXT(IP) = 0
26388           Q2SH(IP,INDX) = 0.D0
26389           IF(IDEB(79).GE.17) THEN
26390             WRITE(LO,'(1X,A,/5X,3E12.4,2I3)')
26391      &        'PHO_HARISR: evolution x-stop (XP,XMIP,XHMA,IP,INDX)',
26392      &        XP,XMIP,XHMA(IP),IP,INDX
26393           ENDIF
26394           GOTO 100
26395         ENDIF
26396 C  initial value of evolution variable t
26397         TT = LOG(AQQALI*Q2P/AL2ISR(IP))
26398         DO 110 I=-NFSISR,NFSISR
26399           WGGAP(I) = 0.D0
26400           WGPDF(I) = 0.D0
26401  110    CONTINUE
26402 C  DGLAP weights
26403         ZMIN = XP/XHMA(IP)
26404         ZMAX = XP/(XP+XMIP)
26405         CF = 4./3.
26406 C  q --> q g, g --> g g
26407         IF(IFLB.EQ.0) THEN
26408           WGGAP(0) = CF*((ZMAX**2-ZMIN**2)/2.D0-2.D0*(ZMAX-ZMIN)
26409      &      +2.D0*LOG(ZMAX/ZMIN))
26410           DO 120 I=1,NFSISR
26411             WGGAP(I)  = WGGAP(0)
26412             WGGAP(-I) = WGGAP(0)
26413  120      CONTINUE
26414           WGGAP(0) = 6.D0*((ZMIN**3-ZMAX**3)/3.D0+(ZMAX**2-ZMIN**2)/2.D0
26415      &      -2.D0*(ZMAX-ZMIN)+LOG(ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)))
26416 C  q --> g q, g --> q qb
26417         ELSE IF(ABS(IFLB).LE.6) THEN
26418           WGGAP(IFLB) = CF*((ZMIN**2-ZMAX**2)/2.D0-ZMAX+ZMIN
26419      &      -2.D0*LOG((1.D0-ZMAX)/(1.D0-ZMIN)))
26420           IF(IVAL(IP).EQ.0) WGGAP(0) = 0.5D0*(2./3.*(ZMAX**3-ZMIN**3)
26421      &      -ZMAX**2+ZMIN**2+ZMAX-ZMIN)
26422         ELSE
26423           WRITE(LO,'(/1X,A,I7)')
26424      &      'PHO_HARISR:ERROR: unsupported particle ID',IFLB
26425           CALL PHO_ABORT
26426         ENDIF
26427 C  anomalous/resolved evolution
26428         IPDFC = 0
26429         IF(IPAMDL(110).GE.1) THEN
26430           IF((IDMO(IP).EQ.22).AND.(IFLB.NE.0)
26431      &       .AND.(IFLB.NE.21)) THEN
26432             WGDIR = 0.D0
26433             IF(NQQALI.EQ.1) THEN
26434               SCALE2 = PT2*AQQPD
26435             ELSE
26436               SCALE2 = Q2P*AQQPD
26437             ENDIF
26438             CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26439             IPDFC = 1
26440             CALL PHO_QPMPDF(IFLB,XP,SCALE2,PTA1,PVIRTP(IP),WGDIR)
26441             XI = DT_RNDM(XP)*PD1(IFLB)
26442             IF(WGDIR.GT.XI) THEN
26443 C  debug output
26444               IF(IDEB(79).GE.17) WRITE(LO,'(1X,2A,/5X,4E12.5,I2,I3)')
26445      &          'PHO_HARISR: ',
26446      &          'direct splitting (WGDIR,WGPDF,X,SCALE2,IP,IFLB)',
26447      &          WGDIR,PD1(IFLB),XP,SCALE2,IP,IFLB
26448               Q2SH(IP,INDX) = 0.D0
26449               NEXT(IP) = 0
26450               IFANO(IP) = INDX
26451               GOTO 100
26452             ENDIF
26453           ENDIF
26454         ENDIF
26455 C
26456 C  rejection loop for z,t sampling
26457 C ------------------------------------
26458  200    CONTINUE
26459           NITER = NITER+1
26460           IF(NITER.GE.NTRY) THEN
26461             WRITE(LO,'(1X,A,2I6)')
26462      &        'PHO_HARISR: too many rejections',NITER,NTRY
26463             CALL PHO_PREVNT(-1)
26464 C  clean up event
26465             IREJ = 1
26466             GOTO 10
26467           ENDIF
26468 C  PDF weights
26469           IF(IPDFC.EQ.0) THEN
26470             IF(NQQALI.EQ.1) THEN
26471               SCALE2 = PT2*AQQPD
26472             ELSE
26473               SCALE2 = Q2P*AQQPD
26474             ENDIF
26475             CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26476           ENDIF
26477           IPDFC = 0
26478 C
26479           WGTOT = 0.D0
26480           DO 210 I=-NFSISR,NFSISR
26481             WGPDF(I) = PD1(I)/(PD1(IFLB)+1.D-12)*5.D0
26482             WGTOT = WGTOT+WGPDF(I)*WGGAP(I)
26483  210      CONTINUE
26484 C
26485  215      CONTINUE
26486 C  sample new t value
26487           TT = TT*EXP(MAX(-10.D0,LOG(DT_RNDM(SHAT1))*B0QCD/WGTOT))
26488           Q2NEW = AL2ISR(IP)*EXP(TT)/AQQALI
26489 C  debug output
26490           IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.5)')
26491      &      'PHO_HARISR: pre-selected Q2:',Q2NEW
26492 C  compare to limits
26493           IF(Q2NEW.LT.Q2MISR(IP)) THEN
26494             Q2SH(IP,INDX) = 0.D0
26495             NEXT(IP) = 0
26496             IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,2E10.3,2I3)')
26497      &        'PHO_HARISR: evolution Q2-stop (Q2,Q2MIN,IP,INDX):',
26498      &        Q2NEW,Q2MISR(IP),IP,INDX
26499             GOTO 100
26500           ENDIF
26501           Q2SH(IP,INDX) = Q2NEW
26502           TT = LOG(AQQALI*Q2NEW/AL2ISR(IP))
26503 C  selection of flavours
26504           XI = WGTOT*DT_RNDM(TT)
26505           IFLA = -NFSISR-1
26506  220      CONTINUE
26507             IFLA = IFLA+1
26508             XI = XI-WGPDF(IFLA)*WGGAP(IFLA)
26509           IF((XI.GT.0.D0).AND.(IFLA.LT.NFSISR)) GOTO 220
26510 C  debug output
26511           IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,2I3)')
26512      &      'PHO_HARISR: pre-selected IFLA (IFLA,IFLB):',IFLA,IFLB
26513 C  selection of z
26514           CALL PHO_HARZSP(IFLA,IFLB,NFSISR,ZMIN,ZMAX,ZZ)
26515 C  debug output
26516           IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,E12.3)')
26517      &      'PHO_HARISR: pre-selected ZZ',ZZ
26518 C  angular ordering
26519           THETA = 4.D0*ZZ**2*Q2NEW/((ECMP*XP)**2*(1.D0-ZZ))
26520           IF(THETA.GT.THSH(IP,INDX)) THEN
26521             IF(IDEB(79).GE.20) WRITE(LO,'(1X,A,2E12.3)')
26522      &        'PHO_HARISR: reject by angle (NEW/OLD)',
26523      &        THETA,THSH(IP,INDX)
26524             GOTO 215
26525           ENDIF
26526 C  rejection weight given by new PDFs
26527           XNEW = XP/ZZ
26528           PT2NEW = Q2NEW*(1.D0-ZZ)
26529           IF(NQQALI.EQ.1) THEN
26530             SCALE2 = PT2NEW*AQQPD
26531           ELSE
26532             SCALE2 = Q2NEW*AQQPD
26533           ENDIF
26534           IF(SCALE2.LT.Q2MISR(IP)) THEN
26535             Q2SH(IP,INDX) = 0.D0
26536             NEXT(IP) = 0
26537             IF(IDEB(79).GE.17) WRITE(LO,'(1X,A,2E10.3,2I3)')
26538      &        'PHO_HARISR: evol.Q2-stop (SCALE2,Q2MIN,IP,INDX):',
26539      &        Q2NEW,Q2MISR(IP),IP,INDX
26540             GOTO 100
26541           ENDIF
26542           CALL PHO_PDF(IP,XNEW,SCALE2,0.D0,PD2)
26543           IF(PD2(IFLA).LT.1.D-10) GOTO 200
26544           CALL PHO_PDF(IP,XP,SCALE2,0.D0,PD1)
26545           PD1(IFLB) = MAX(PD1(IFLB),1.D-10)
26546           WGF = PD2(IFLA)/PD1(IFLB)/(WGPDF(IFLA)+1.D-12)
26547           IF(NQQALI.EQ.1) WGF = WGF*LOG(Q2NEW*AQQALI/AL2ISR(IP))
26548      &      /LOG(PT2NEW*AQQALI/AL2ISR(IP))
26549           IF((WGF.GT.1.D0).AND.(IDEB(79).GE.2)) THEN
26550             WRITE(LO,'(1X,A,E12.3)')
26551      &        'PHO_HARISR: final weight:',WGF
26552             WRITE(LO,'(6X,A,I7,2I3,3E11.3)')
26553      &      'EV,IFLA,IFLB,Q2,PT2,Z:',KEVENT,IFLA,IFLB,Q2NEW,PT2NEW,ZZ
26554           ENDIF
26555         IF(WGF.LT.DT_RNDM(XNEW)) GOTO 200
26556
26557         IF(IDEB(79).GE.15) THEN
26558           WRITE(LO,'(1X,A,/3X,3I3,3E11.3)')
26559      &      'PHO_HARISR: accepted IP,IFLA,IFLB,PT2,Q2,Z:',
26560      &      IP,IFLA,IFLB,PT2NEW,Q2NEW,ZZ
26561         ENDIF
26562
26563         IF(INDX.GE.MXISR3) THEN
26564           WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26565      &      '/POINT6/ for parton radiation (INDX,MXISR3):',INDX,MXISR3
26566           IREJ = 1
26567           RETURN
26568         ENDIF
26569 C  branching accepted, registration
26570         Q2SH(IP,INDX) = Q2NEW
26571         PT2SH(IP,INDX) = PT2NEW
26572         ZPSH(IP,INDX) = ZZ
26573         IFL2(IP,INDX) = IFLA-IFLB
26574         Q2SH(IP,INDX+1) = Q2NEW
26575         PT2SH(IP,INDX+1) = PT2SH(IP,INDX)
26576         XPSH(IP,INDX+1) = XNEW
26577         THSH(IP,INDX+1) = THETA
26578         IFL1(IP,INDX+1) = IFLA
26579         ISH(IP) = ISH(IP)+1
26580
26581         NACC = NACC+1
26582         IF(NACC.GT.MXISR4) THEN
26583           WRITE(LO,'(1X,2A,2I4)') 'PHO_HARISR: no space left in ',
26584      &      '/POINT6/ for parton radiation (NACC,MXISR4):',NACC,MXISR4
26585           IREJ = 1
26586           RETURN
26587         ENDIF
26588         SHAT(NACC) = SHAT1
26589         IBRA(1,NACC) = IP
26590         IBRA(2,NACC) = INDX
26591         SHAT1 = SHAT1/ZZ
26592
26593 C  generation of next branching
26594       IF(NEXT(1)+NEXT(2).NE.0) GOTO 100
26595
26596  800  CONTINUE
26597
26598 C  new initial flavours, x values
26599       IPB1 = IFL1(1,ISH(1))
26600       IPB2 = IFL1(2,ISH(2))
26601       XISR1 = XPSH(1,ISH(1))
26602       XISR2 = XPSH(2,ISH(2))
26603       IVO1  = IVAL(1)
26604       IVO2  = IVAL(2)
26605 C  valence flavours
26606       IF(IPB1.NE.0) THEN
26607         IF(ISH(1).GT.1) THEN
26608           CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
26609           IF(IDPDG1.EQ.22) THEN
26610             CALL PHO_QPMPDF(IPB1,XISR1,Q2MISR(1),0.D0,PVIRTP(1),FXP)
26611             IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(IPB1)-FXP) IVAL(1) = 1
26612           ELSE
26613             CALL PHO_PDF(1,XISR1,Q2MISR(1),0.D0,PD1)
26614             IF(DT_RNDM(XISR1)*PD1(IPB1).GT.PD1(-IPB1)) IVAL(1) = 1
26615           ENDIF
26616         ENDIF
26617       ENDIF
26618       IF(IPB2.NE.0) THEN
26619         IF(ISH(2).GT.1) THEN
26620           CALL PHO_PDF(2,XISR2,Q2MISR(2),0.D0,PD1)
26621           IF(IDPDG2.EQ.22) THEN
26622             CALL PHO_QPMPDF(IPB2,XISR2,Q2MISR(2),0.D0,PVIRTP(2),FXP)
26623             IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(IPB2)-FXP) IVAL(2) = 1
26624           ELSE
26625             IF(DT_RNDM(XISR2)*PD1(IPB2).GT.PD1(-IPB2)) IVAL(2) = 1
26626           ENDIF
26627         ENDIF
26628       ENDIF
26629
26630 C  parton kinematics
26631       IF(NACC.GT.0) THEN
26632 C  final partons in CMS
26633         PM(3) = (XH1-XH2)*ECMP/2.D0
26634         PM(4) = (XH1+XH2)*ECMP/2.D0
26635         SH = XH1*XH2*ECMP**2
26636         SSH = SQRT(SH)
26637         GB(3) = PM(3)/SSH
26638         GB(4) = PM(4)/SSH
26639         CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P1(1),P1(2),P1(3),
26640      &    P1(4),PTOT1,PHISR(1,1,IPAL(1)),PHISR(1,2,IPAL(1)),
26641      &    PHISR(1,3,IPAL(1)),PHISR(1,4,IPAL(1)))
26642         CALL PHO_ALTRA(GB(4),0.D0,0.D0,-GB(3),P2(1),P2(2),P2(3),
26643      &    P2(4),PTOT1,PHISR(2,1,IPAL(2)),PHISR(2,2,IPAL(2)),
26644      &    PHISR(2,3,IPAL(2)),PHISR(2,4,IPAL(2)))
26645         IL(1) = 1
26646         IL(2) = 1
26647         DO 900 I=1,NACC
26648           IPA = IBRA(1,I)
26649           IPB = 3-IPA
26650           IL(IPA) = IBRA(2,I)
26651 C  new initial partons in CMS
26652           SH = SHAT(I)
26653           SSH = SQRT(SH)
26654           SHZ = SH/ZPSH(IPA,IL(IPA))
26655           SSHZ = SQRT(SHZ)
26656           Q2(1) = Q2SH(1,IL(1))
26657           Q2(2) = Q2SH(2,IL(2))
26658           PC(1,1) = 0.D0
26659           PC(1,2) = 0.D0
26660           PC(1,3) = SQRT((SH+Q2(1)+Q2(2))**2-4.D0*Q2(1)*Q2(2))
26661      &             /(2.D0*SSH)
26662           PC(1,4) = (SH-Q2(1)+Q2(2))/(2.D0*SSH)
26663           PC(2,1) = 0.D0
26664           PC(2,2) = 0.D0
26665           PC(2,3) = -PC(1,3)
26666           PC(2,4) = SSH-PC(1,4)
26667           XMS4 = PHO_PMASS(IFL2(IPA,IL(IPA)),1)**2
26668           EE3 = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
26669           S1 = SH+Q2(IPA)+Q2(IPB)
26670           S3 = SHZ+Q2(IPB)+Q2SH(IPA,IL(IPA)+1)
26671           R1 = SQRT(S1**2-4.D0*Q2(IPA)*Q2(IPB))
26672           R3 = SQRT(S3**2-4.D0*Q2(IPB)*Q2SH(IPA,IL(IPA)+1))
26673           IF(Q2(IPB).LT.0.1D0) THEN
26674             XMS4M = (Q2(IPA)/ZPSH(IPA,IL(IPA))-Q2SH(IPA,IL(IPA)+1))
26675      &             *(SH/(SH+Q2(IPA))-SH/(SHZ+Q2SH(IPA,IL(IPA)+1)))
26676           ELSE
26677             XMS4M = (S1*S3-R1*R3)/(2.D0*Q2(IPB))
26678      &             -Q2(IPA)-Q2SH(IPA,IL(IPA)+1)
26679           ENDIF
26680           NGEN = 1
26681 C  max. virtuality for time-like showers
26682           QMAX = MIN(XMS4M,PARMDL(95)*Q2(IPA))
26683           IF((IPAMDL(111).GE.1).AND.(QMAX.GT.PARMDL(94))) THEN
26684 C  generate time-like parton shower
26685             KF = IFL2(IPA,IL(IPA))
26686             IF(KF.EQ.0) KF = 21
26687             EER = MIN(EE3-PC(IPA,4),ECMP)
26688             THER = 0.
26689             CALL PY1ENT(1,KF,EER,THER,THER)
26690             QMAXR = SQRT(QMAX)
26691             CALL PYSHOW(1,0,QMAXR)
26692 C debug output
26693             IF(IDEB(79).GE.25) THEN
26694               WRITE(LO,'(1X,2A,/,5X,1P,4E12.4)') 'PHO_HARISR: ',
26695      &          'PYSHOW called for EE,QMAX,XMS4M,Q2(IPA)',
26696      &          EER,QMAX,XMS4M,Q2(IPA)
26697               CALL PYLIST(1)
26698             ENDIF
26699             NGEN = PYK(0,1)
26700             IF(NGEN.GT.1) THEN
26701               PJX = 0.D0
26702               PJY = 0.D0
26703               PJZ = 0.D0
26704               PJE = 0.D0
26705               KK = IPAL(IPA)
26706               DO 820 K=3,NGEN
26707                 IF(PYK(K,1).LE.4) THEN
26708                   KK = KK+1
26709                   IF(KK.GT.MXISR1) THEN
26710                     WRITE(LO,'(1X,2A,2I5)') 'PHO_HARISR: no space ',
26711      &                'left in /POPISR/ (KK,MXISR1):',KK,MXISR1
26712                     IREJ = 1
26713                     RETURN
26714                   ENDIF
26715                   PHISR(IPA,1,KK) = PYP(K,1)
26716                   PJX = PJX+PHISR(IPA,1,KK)
26717                   PHISR(IPA,2,KK) = PYP(K,2)
26718                   PJY = PJY+PHISR(IPA,2,KK)
26719                   PHISR(IPA,3,KK) = PYP(K,3)
26720                   PJZ = PJZ+PHISR(IPA,3,KK)
26721                   PHISR(IPA,4,KK) = PYP(K,4)
26722                   PJE = PJE+PHISR(IPA,4,KK)
26723                   IFLISR(IPA,KK)  = PYK(K,2)
26724                   IF(IFLISR(IPA,KK).EQ.21) IFLISR(IPA,KK) = 0
26725                   IF(IFLISR(IPA,KK).EQ.5) IFLISR(IPA,KK) = 3
26726                   IF(IFLISR(IPA,KK).EQ.-5) IFLISR(IPA,KK) = -3
26727                 ENDIF
26728  820          CONTINUE
26729               NGEN = KK-IPAL(IPA)
26730               XMS4 = (PJE+PJZ)*(PJE-PJZ)-PJX**2-PJY**2
26731               PP4  = SQRT(PJE**2-XMS4)
26732               EE3  = (SHZ-Q2(IPA)+Q2(IPB)-XMS4)/(2.D0*SSH)
26733 C debug output
26734               IF(IDEB(79).GE.20) WRITE(LO,'(1X,2A,/,5X,1P,6E12.4)')
26735      &         'PHO_HARISR: ',
26736      &         'time-like shower: PJE,PJX,PJY,PJZ,PP4,XMS4',
26737      &         PJE,PJX,PJY,PJZ,PP4,XMS4
26738             ENDIF
26739           ENDIF
26740           PZ3 = (2.D0*PC(IPA,4)*EE3+Q2(IPA)+Q2SH(IPA,IL(IPA)+1)+XMS4)
26741      &          /(2.D0*PC(IPA,3))
26742           PT3 = (EE3+PZ3)*(EE3-PZ3)+Q2SH(IPA,IL(IPA)+1)
26743           IF(PT3.LT.0.D0) THEN
26744             IF(IDEB(79).GE.5) WRITE(LO,'(1X,A,E12.3)')
26745      &        'PHO_HARISR: rejection due to PT3',PT3
26746             GOTO 10
26747           ENDIF
26748           PT3 = SQRT(PT3)
26749           CALL PHO_SFECFE(SFE,CFE)
26750           PX3 = CFE*PT3
26751           PY3 = SFE*PT3
26752 C
26753           IF(NGEN.GT.1) THEN
26754 C  time-like shower generated
26755             EE4 = EE3-PC(IPA,4)
26756             PZ4 = PZ3-PC(IPA,3)
26757             PP4 = SQRT(PT3**2+PZ4**2)
26758 C  Lorentz boost
26759             GAM = (EE4*PJE-PP4*PJZ)/XMS4
26760             BEG = (PJE*PP4-EE4*PJZ)/XMS4
26761 C  rotation angles
26762             CODD = PZ4/PP4
26763             SIDD = SQRT(PX3**2+PY3**2)/PP4
26764             COFD = 1.D0
26765             SIFD = 0.D0
26766             IF(PP4*SIDD.GT.1.D-5) THEN
26767               COFD = PX3/(SIDD*PP4)
26768               SIFD = PY3/(SIDD*PP4)
26769               ANORF = SQRT(COFD*COFD+SIFD*SIFD)
26770               COFD = COFD/ANORF
26771               SIFD = SIFD/ANORF
26772             ENDIF
26773 C  copy partons back
26774             KK = IPAL(IPA)
26775             DO 830 K=1,NGEN
26776               KK = KK+1
26777               PX = PHISR(IPA,1,KK)
26778               PY = PHISR(IPA,2,KK)
26779               PZ = PHISR(IPA,3,KK)
26780               COH= PHISR(IPA,4,KK)
26781               EE = GAM*COH+BEG*PZ
26782               PZ = GAM*PZ +BEG*COH
26783               PHISR(IPA,4,KK) = EE
26784               CALL PHO_TRANS(PX,PY,PZ,CODD,SIDD,COFD,SIFD,
26785      &          PHISR(IPA,1,KK),PHISR(IPA,2,KK),PHISR(IPA,3,KK))
26786  830        CONTINUE
26787             IPAL(IPA) = KK
26788           ELSE
26789 C  no time-like shower generated
26790             IPAL(IPA) = IPAL(IPA)+1
26791             PHISR(IPA,1,IPAL(IPA)) = PX3
26792             PHISR(IPA,2,IPAL(IPA)) = PY3
26793             PHISR(IPA,3,IPAL(IPA)) = PZ3-PC(IPA,3)
26794             PHISR(IPA,4,IPAL(IPA)) = EE3-PC(IPA,4)
26795             IFLISR(IPA,IPAL(IPA))  = IFL2(IPA,IL(IPA))
26796           ENDIF
26797           PC(IPA,1) = PX3
26798           PC(IPA,2) = PY3
26799           PC(IPA,3) = PZ3
26800           PC(IPA,4) = EE3
26801 C  boost / rotate into new CMS
26802           DO 842 K=1,4
26803             GB(K) = (PC(1,K)+PC(2,K))/SSHZ
26804  842      CONTINUE
26805           CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),PC(1,1),PC(1,2),
26806      &      PC(1,3),PC(1,4),PTOT1,PM(1),PM(2),PM(3),PM(4))
26807           COG= PM(3)/PTOT1
26808           SIG= SQRT(PM(1)**2+PM(2)**2)/PTOT1
26809           COH=1.D0
26810           SIH=0.D0
26811           IF(PTOT1*SIG.GT.1.D-5) THEN
26812             COH=PM(1)/(SIG*PTOT1)
26813             SIH=PM(2)/(SIG*PTOT1)
26814             ANORF=SQRT(COH*COH+SIH*SIH)
26815             COH=COH/ANORF
26816             SIH=SIH/ANORF
26817           ENDIF
26818           DO 845 K=1,2
26819             DO 844 L=IPOISR(K,1,IHIDX),IPAL(K)
26820               CALL PHO_ALTRA(GB(4),-GB(1),-GB(2),-GB(3),
26821      &          PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),
26822      &          PTOT1,PM(1),PM(2),PM(3),PM(4))
26823               CALL PHO_TRANI(PM(1),PM(2),PM(3),COG,SIG,COH,SIH,PN(1),
26824      &          PN(2),PN(3))
26825               CALL PHO_TRANS(PN(1),PN(2),PN(3),1.D0,0.D0,COH,SIH,
26826      &          PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L))
26827               PHISR(K,4,L) = PM(4)
26828  844        CONTINUE
26829  845      CONTINUE
26830  900    CONTINUE
26831 C  boost back to global CMS
26832         PM(3) = (XISR1-XISR2)/2.D0
26833         PM(4) = (XISR1+XISR2)/2.D0
26834         SSH = SQRT(XISR1*XISR2)
26835         GB(3) = PM(3)/SSH
26836         GB(4) = PM(4)/SSH
26837         DO 945 K=1,2
26838           DO 944 L=IPOISR(K,1,IHIDX),IPAL(K)
26839             CALL PHO_ALTRA(GB(4),0.D0,0.D0,GB(3),PHISR(K,1,L),
26840      &        PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L),PTOT1,PM(1),
26841      &        PM(2),PM(3),PM(4))
26842             PHISR(K,1,L) = PM(1)
26843             PHISR(K,2,L) = PM(2)
26844             PHISR(K,3,L) = PM(3)
26845             PHISR(K,4,L) = PM(4)
26846  944      CONTINUE
26847  945    CONTINUE
26848       ENDIF
26849       IPOISR(1,2,IHIDX) = IPAL(1)
26850       IPOISR(2,2,IHIDX) = IPAL(2)
26851       IMXISR(1) = IPAL(1)
26852       IMXISR(2) = IPAL(2)
26853 C
26854 C  debug output
26855       IF(IDEB(79).GE.10) THEN
26856         WRITE(LO,'(1X,A,2I10/,6X,A,2E12.3,2I5)') 'NUMBER OF EMISSIONS',
26857      &    ISH(1)-1,ISH(2)-1,'NEW X1,X2,IFL1,ILF2',XISR1,XISR2,IPB1,IPB2
26858         IF(NACC.GT.0) THEN
26859           WRITE(LO,'(1X,A,2I5,/6X,A)')
26860      &    'PHO_HARISR: ISR configuration (NITER,NACC)',NITER,NACC,
26861      &    ' SIDE   NO.   IFLB IFLC     Q2SH    PT2SH     XH         ZZ'
26862           DO 600 II=1,NACC
26863             K = IBRA(1,II)
26864             I = IBRA(2,II)
26865             WRITE(LO,'(5X,4I5,4E11.3)')
26866      &        K,I,IFL1(K,I),IFL2(K,I),Q2SH(K,I),PT2SH(K,I),XPSH(K,I),
26867      &        ZPSH(K,I)
26868  600      CONTINUE
26869         ENDIF
26870 C  check of final configuration
26871         PX3 = 0.D0
26872         PY3 = 0.D0
26873         PZ3 = 0.D0
26874         EE3 = 0.D0
26875         IFSUM(1) = 0
26876         IFSUM(2) = 0
26877         WRITE(LO,'(1X,A)') 'PHO_HARISR: outgoing partons'
26878         DO 745 K=1,2
26879           DO 744 L=IPOISR(K,1,IHIDX),IPOISR(K,2,IHIDX)
26880             WRITE(LO,'(6X,2I4,I6,4E11.3)') K,L,IFLISR(K,L),
26881      &        PHISR(K,1,L),PHISR(K,2,L),PHISR(K,3,L),PHISR(K,4,L)
26882             IFSUM(K) = IFSUM(K)+ IFLISR(K,L)
26883             PX3 = PX3 + PHISR(K,1,L)
26884             PY3 = PY3 + PHISR(K,2,L)
26885             PZ3 = PZ3 + PHISR(K,3,L)
26886             EE3 = EE3 + PHISR(K,4,L)
26887  744      CONTINUE
26888  745    CONTINUE
26889         IFSUM(1) = IFSUM(1)-IPB1
26890         IFSUM(2) = IFSUM(2)-IPB2
26891         PZ3 = PZ3 -(XISR1-XISR2)*ECMP/2.D0
26892         EE3 = EE3 -(XISR1+XISR2)*ECMP/2.D0
26893         WRITE(LO,'(1X,A,2I4,4E11.3)') 'CHECK:IFL1,2 PCM(1-4)',
26894      &    IFSUM,PX3,PY3,PZ3,EE3
26895       ENDIF
26896       END
26897
26898 *$ CREATE PHO_HARZSP.FOR
26899 *COPY PHO_HARZSP
26900 CDECK  ID>, PHO_HARZSP
26901       SUBROUTINE PHO_HARZSP(IFLA,IFLB,NFSH,ZMIN,ZMAX,ZZ)
26902 C*********************************************************************
26903 C
26904 C     sampling of z values from DGLAP kernels
26905 C
26906 C     input:  IFLA,IFLB      parton flavours
26907 C             NFSH           flavours involved in hard processes
26908 C             ZMIN           minimal ZZ allowed
26909 C             ZMAX           maximal ZZ allowed
26910 C
26911 C     output: ZZ             z value
26912 C
26913 C*********************************************************************
26914       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26915       SAVE
26916
26917       PARAMETER ( DEPS   =  1.D-10 )
26918
26919 C  input/output channels
26920       INTEGER LI,LO
26921       COMMON /POINOU/ LI,LO
26922 C  event debugging information
26923       INTEGER NMAXD
26924       PARAMETER (NMAXD=100)
26925       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
26926      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26927       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
26928      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
26929 C  internal rejection counters
26930       INTEGER NMXJ
26931       PARAMETER (NMXJ=60)
26932       CHARACTER*10 REJTIT
26933       INTEGER IFAIL
26934       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
26935
26936       IF(ZMAX.LE.ZMIN) THEN
26937         WRITE(LO,'(1X,A,2E12.3)')
26938      &    'PHO_HARZSP: ZMAX<ZMIN (ZMAX,ZMIN)',ZMAX,ZMIN
26939         CALL PHO_PREVNT(-1)
26940         ZZ = 0.D0
26941         RETURN
26942       ENDIF
26943 C
26944       IF(IFLB.EQ.0) THEN
26945         IF(IFLA.EQ.0) THEN
26946 C  g --> g g
26947           C1 = ZMAX/ZMIN*(1.D0-ZMIN)/(1.D0-ZMAX)
26948           C2 = (1.D0-ZMIN)/ZMIN
26949  100      CONTINUE
26950             ZZ = 1.D0/(1.D0+C2/C1**DT_RNDM(ZMIN))
26951           IF(((1.D0-ZZ*(1.D0-ZZ))**2).LT.DT_RNDM(ZMAX)) GOTO 100
26952         ELSE IF(ABS(IFLA).LE.NFSH) THEN
26953 C  q --> q g
26954           C1 = ZMAX/ZMIN
26955  200      CONTINUE
26956             ZZ = ZMIN*C1**DT_RNDM(ZMIN)
26957           IF((0.5D0*(1.D0+(1.D0-ZZ)**2)).LT.DT_RNDM(ZMAX)) GOTO 200
26958         ELSE
26959           GOTO 900
26960         ENDIF
26961       ELSE IF(ABS(IFLB).LE.NFSH) THEN
26962         IF(IFLA.EQ.0) THEN
26963 C  g --> q qb
26964           C1 = ZMAX-ZMIN
26965  300      CONTINUE
26966             ZZ = ZMIN+C1*DT_RNDM(ZMIN)
26967           IF((2.D0*ZZ*(ZZ-1.D0)+1.D0).LT.DT_RNDM(ZMAX)) GOTO 300
26968         ELSE IF(ABS(IFLA).LE.NFSH) THEN
26969 C  q --> g q
26970           C1 = (1.D0-ZMAX)/(1.D0-ZMIN)
26971           C2 = 1.D0-ZMIN
26972  400      CONTINUE
26973             ZZ = 1.D0-C2*C1**DT_RNDM(ZMIN)
26974           IF(0.5D0*(1.D0+ZZ**2).LT.DT_RNDM(ZMAX)) GOTO 400
26975         ELSE
26976           GOTO 900
26977         ENDIF
26978       ELSE
26979         GOTO 900
26980       ENDIF
26981 C  debug output
26982       IF(IDEB(80).GE.20) WRITE(LO,'(1X,A,2I3,3E11.3)')
26983      &  'PHO_HARZSP: IFLA,IFLB,ZZ,ZMIN,ZMAX',
26984      &  IFLA,IFLB,ZZ,ZMIN,ZMAX
26985       RETURN
26986
26987  900  CONTINUE
26988       WRITE(LO,'(/1X,A,2I7)') 'PHO_HARZSP:ERROR: invalid flavours A,B',
26989      &  IFLA,IFLB
26990       CALL PHO_ABORT
26991
26992       END
26993
26994 *$ CREATE PHO_ALPHAE.FOR
26995 *COPY PHO_ALPHAE
26996 CDECK  ID>, PHO_ALPHAE
26997       DOUBLE PRECISION FUNCTION PHO_ALPHAE(Q2)
26998 C**********************************************************************
26999 C
27000 C     calculation of ALPHA_em
27001 C
27002 C     input:    Q2      scale in GeV**2
27003 C
27004 C**********************************************************************
27005       IMPLICIT NONE
27006       SAVE
27007
27008       DOUBLE PRECISION Q2
27009
27010 C  input/output channels
27011       INTEGER LI,LO
27012       COMMON /POINOU/ LI,LO
27013 C  model switches and parameters
27014       CHARACTER*8 MDLNA
27015       INTEGER ISWMDL,IPAMDL
27016       DOUBLE PRECISION PARMDL
27017       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27018
27019       DOUBLE PRECISION PYALEM
27020
27021       pho_alphae = 1.D0/137.D0
27022
27023       if(ipamdl(120).eq.1) then
27024         pho_alphae = PYALEM(Q2)
27025       endif
27026
27027       END
27028
27029 *$ CREATE PHO_ALPHAS.FOR
27030 *COPY PHO_ALPHAS
27031 CDECK  ID>, PHO_ALPHAS
27032       DOUBLE PRECISION FUNCTION PHO_ALPHAS(Q2,IMODE)
27033 C**********************************************************************
27034 C
27035 C     calculation of ALPHA_S
27036 C
27037 C     input:    IMODE = 1         lambda_QCD**2 for PDF 1 evolution
27038 C                       2         lambda_QCD**2 for PDF 2 evolution
27039 C                       3         lambda_QCD**2 for hard scattering
27040 C               Q2      scale in GeV**2
27041 C
27042 C     initialization needed:
27043 C               IMODE = 0         lambda values taken from PDF table
27044 C                       -1        given Q2 is 4-flavour lambda 1
27045 C                       -2        given Q2 is 4-flavour lambda 2
27046 C                       -3        given Q2 is 4-flavour lambda 3
27047 C
27048 C
27049 C**********************************************************************
27050       IMPLICIT NONE
27051       SAVE
27052
27053       DOUBLE PRECISION Q2
27054       INTEGER IMODE
27055
27056 C  input/output channels
27057       INTEGER LI,LO
27058       COMMON /POINOU/ LI,LO
27059 C  model switches and parameters
27060       CHARACTER*8 MDLNA
27061       INTEGER ISWMDL,IPAMDL
27062       DOUBLE PRECISION PARMDL
27063       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27064 C  hard scattering parameters used for most recent hard interaction
27065       INTEGER NFbeta,NF
27066       DOUBLE PRECISION ALQCD2,BQCD
27067       COMMON /POHAPA/ ALQCD2(3,4),BQCD(4),NFbeta,NF
27068 C  currently activated parton density parametrizations
27069       CHARACTER*8 PDFNAM
27070       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
27071       DOUBLE PRECISION PDFLAM,PDFQ2M
27072       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
27073      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
27074
27075       INTEGER I
27076
27077       PHO_ALPHAS = 0.D0
27078
27079       IF(IMODE.GT.0) THEN
27080
27081         IF(Q2.LT.PARMDL(148)) THEN
27082           NFbeta = 1
27083         ELSE IF(Q2.LT.PARMDL(149)) THEN
27084           NFbeta = 2
27085         ELSE IF(Q2.LT.PARMDL(150)) THEN
27086           NFbeta = 3
27087         ELSE
27088           NFbeta = 4
27089         ENDIF
27090
27091         PHO_ALPHAS = BQCD(NFbeta)/LOG(Q2/ALQCD2(IMODE,NFbeta))
27092         NFbeta = NFbeta+2
27093
27094       ELSE IF(IMODE.EQ.0) THEN
27095
27096         DO I=1,3
27097           if(I.EQ.3) then
27098             ALQCD2(I,2) = PDFLAM(1)*PDFLAM(2)
27099           else
27100             ALQCD2(I,2) = PDFLAM(I)*PDFLAM(I)
27101           endif
27102           ALQCD2(I,1) = PARMDL(148)
27103      &                 *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
27104           ALQCD2(I,3) = PARMDL(149)
27105      &                 *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
27106           ALQCD2(I,4) = PARMDL(150)
27107      &                 *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))
27108
27109         ENDDO
27110
27111       ELSE IF(IMODE.LT.0) THEN
27112
27113         if(IMODE.eq.-4) then
27114           I = 3
27115           ALQCD2(I,2) = SQRT(ALQCD2(1,2)*ALQCD2(2,2))
27116         else
27117           I = -IMODE
27118           ALQCD2(I,2) = Q2
27119         endif
27120         ALQCD2(I,1) = PARMDL(148)
27121      &               *(ALQCD2(I,2)/PARMDL(148))**(BQCD(1)/BQCD(2))
27122         ALQCD2(I,3) = PARMDL(149)
27123      &               *(ALQCD2(I,2)/PARMDL(149))**(BQCD(3)/BQCD(2))
27124         ALQCD2(I,4) = PARMDL(150)
27125      &               *(ALQCD2(I,2)/PARMDL(150))**(BQCD(4)/BQCD(2))
27126
27127       ENDIF
27128
27129       END
27130
27131 *$ CREATE PHO_DFWRAP.FOR
27132 *COPY PHO_DFWRAP
27133 CDECK  ID>, PHO_DFWRAP
27134       SUBROUTINE PHO_DFWRAP(MODE,JM1,JM2)
27135 C**********************************************************************
27136 C
27137 C     wrapper for diffraction dissociation in hadron-nucleus and
27138 C     nucleus-nucleus collisions with DPMJET
27139 C
27140 C     input:      MODE     1:   transformation into CMS
27141 C                          2:   transformation into Lab
27142 C                 JM1/2    indices of old mother particles
27143 C                 JM1/2N   indices of new mother particles
27144 C
27145 C**********************************************************************
27146       IMPLICIT NONE
27147       SAVE
27148
27149       INTEGER MODE,JM1,JM2
27150
27151 C  input/output channels
27152       INTEGER LI,LO
27153       COMMON /POINOU/ LI,LO
27154 C  event debugging information
27155       INTEGER NMAXD
27156       PARAMETER (NMAXD=100)
27157       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27158      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27159       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27160      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27161 C  standard particle data interface
27162       INTEGER NMXHEP
27163       PARAMETER (NMXHEP=4000)
27164       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
27165       DOUBLE PRECISION PHEP,VHEP
27166       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27167      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
27168      &                VHEP(4,NMXHEP)
27169 C  extension to standard particle data interface (PHOJET specific)
27170       INTEGER IMPART,IPHIST,ICOLOR
27171       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
27172 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
27173       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
27174       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
27175       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
27176      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
27177
27178       DOUBLE PRECISION GAMBED(4),P1(4),P2(4),P3(4),P4(4),XM1,XM2
27179       DOUBLE PRECISION SS,ECMD,PTOT1,CODD,SIDD,COFD,SIFD,ANORF
27180
27181       INTEGER I,NHEPS,JM1S,JM2S,JM1N,JM2N,IREJ
27182
27183 C  transformation into CMS
27184
27185       IF(MODE.EQ.1) THEN
27186
27187         JM1S = JM1
27188         JM2S = JM2
27189         NHEPS = NHEP
27190
27191         XM1 = PHEP(5,JM1)
27192         XM2 = PHEP(5,JM2)
27193
27194 C  boost into CMS
27195         P1(1) = PHEP(1,JM1)+PHEP(1,JM2)
27196         P1(2) = PHEP(2,JM1)+PHEP(2,JM2)
27197         P1(3) = PHEP(3,JM1)+PHEP(3,JM2)
27198         P1(4) = PHEP(4,JM1)+PHEP(4,JM2)
27199         SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
27200         ECMD = SQRT(SS)
27201         DO 10 I=1,4
27202           GAMBED(I) = P1(I)/ECMD
27203  10     CONTINUE
27204         CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
27205      &             PHEP(1,JM1),PHEP(2,JM1),PHEP(3,JM1),
27206      &             PHEP(4,JM1),PTOT1,P1(1),P1(2),P1(3),P1(4))
27207 C  rotation angles
27208         CODD = P1(3)/PTOT1
27209         SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
27210         COFD = 1.D0
27211         SIFD = 0.D0
27212         IF(PTOT1*SIDD.GT.1.D-5) THEN
27213           COFD = P1(1)/(SIDD*PTOT1)
27214           SIFD = P1(2)/(SIDD*PTOT1)
27215           ANORF= SQRT(COFD*COFD+SIFD*SIFD)
27216           COFD = COFD/ANORF
27217           SIFD = SIFD/ANORF
27218         ENDIF
27219
27220 C  initial particles in CMS
27221
27222         P1(1) = 0.D0
27223         P1(2) = 0.D0
27224         P1(3) = ECMD/2.D0*XPSUB
27225         P1(4) = P1(3)
27226
27227         P2(1) = 0.D0
27228         P2(2) = 0.D0
27229         P2(3) = -ECMD/2.D0*XTSUB
27230         P2(4) = -P2(3)
27231
27232         CALL PHO_MSHELL(P1,P2,XM1,XM2,P3,P4,IREJ)
27233
27234         CALL PHO_REGPAR(1,IDHEP(JM1),IMPART(JM1),JM1,JM2,
27235      &    P3(1),P3(2),P3(3),P3(4),IPHIST(1,JM1),IPHIST(2,JM1),
27236      &    ICOLOR(1,JM1),ICOLOR(2,JM1),JM1N,1)
27237
27238         CALL PHO_REGPAR(1,IDHEP(JM2),IMPART(JM2),JM2,JM1,
27239      &    P4(1),P4(2),P4(3),P4(4),IPHIST(1,JM2),IPHIST(2,JM2),
27240      &    ICOLOR(1,JM2),ICOLOR(2,JM2),JM2N,1)
27241
27242         JM1 = JM1N
27243         JM2 = JM2N
27244
27245 C  transformation into lab.
27246
27247       ELSE IF(MODE.EQ.2) THEN
27248
27249         CALL PHO_LTRHEP(JM1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
27250      &    GAMBED(1),GAMBED(2),GAMBED(3))
27251
27252         JM1 = JM1S
27253         JM2 = JM2S
27254
27255 C  clean up after rejection
27256
27257       ELSE IF(MODE.EQ.-2) THEN
27258
27259         NHEP = NHEPS
27260
27261         JM1 = JM1S
27262         JM2 = JM2S
27263
27264       ELSE
27265
27266         WRITE(LO,'(1X,A,I6)') 'PHO_DFWRAP: invalid MODE parameter:',MODE
27267
27268       ENDIF
27269
27270       END
27271
27272 *$ CREATE PHO_DIFDIS.FOR
27273 *COPY PHO_DIFDIS
27274 CDECK  ID>, PHO_DIFDIS
27275       SUBROUTINE PHO_DIFDIS(IDIF1,IDIF2,IMOTH1,IMOTH2,SPROB,IMODE,
27276      &                      MSOFT,MHARD,IREJ)
27277 C***********************************************************************
27278 C
27279 C     sampling of diffractive events of different kinds,
27280 C                            (produced particles stored in /POEVT1/)
27281 C
27282 C     input:   IDIF1/2   diffractive process particle 1/2
27283 C                          0   elastic/quasi-elastic scattering
27284 C                          1   diffraction dissociation
27285 C              IMOTH1/2  index of mother particles in /POEVT1/
27286 C              SPROB     suppression factor (survival probability) for
27287 C                        resolved diffraction dissociation
27288 C              IMODE     mode of operation
27289 C                          0  sampling of diffractive cut
27290 C                          1  sampling of enhanced cut
27291 C                          2  sampling of diffractive cut without
27292 C                             scattering (needed for double-pomeron)
27293 C                         -1  initialization
27294 C                         -2  output of statistics
27295 C
27296 C     output:   MSOFT    number of generated soft strings
27297 C               MHARD    number of generated hard strings
27298 C               IDIF1/2  diffraction label for particle 1/2 in /PROCES/
27299 C                          0   quasi elastic scattering
27300 C                          1   low-mass diffractive dissociation
27301 C                          2   soft high-mass diffractive dissociation
27302 C                          3   hard resolved diffractive dissociation
27303 C                          4   hard direct diffractive dissociation
27304 C               IREJ     rejection label
27305 C                          0  successful generation of partons
27306 C                          1  failure
27307 C
27308 C***********************************************************************
27309       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27310       SAVE
27311
27312       PARAMETER ( EPS  = 1.D-7,
27313      &            DEPS = 1.D-10)
27314
27315 C  input/output channels
27316       INTEGER LI,LO
27317       COMMON /POINOU/ LI,LO
27318 C  event debugging information
27319       INTEGER NMAXD
27320       PARAMETER (NMAXD=100)
27321       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27322      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27323       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27324      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27325 C  general process information
27326       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
27327       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
27328 C  internal rejection counters
27329       INTEGER NMXJ
27330       PARAMETER (NMXJ=60)
27331       CHARACTER*10 REJTIT
27332       INTEGER IFAIL
27333       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
27334 C  global event kinematics and particle IDs
27335       INTEGER IFPAP,IFPAB
27336       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
27337       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
27338 C  c.m. kinematics of diffraction
27339       INTEGER NPOSD
27340       DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
27341      &                 SIDD,CODD,SIFD,COFD,PDCMS
27342       COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
27343      &                SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
27344 C  obsolete cut-off information
27345       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
27346       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
27347 C  some constants
27348       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
27349       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
27350      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
27351 C  model switches and parameters
27352       CHARACTER*8 MDLNA
27353       INTEGER ISWMDL,IPAMDL
27354       DOUBLE PRECISION PARMDL
27355       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27356 C  Reggeon phenomenology parameters
27357       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
27358      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
27359       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
27360      &                ALREG,ALREGP,GR(2),B0REG(2),
27361      &                GPPP,GPPR,B0PPP,B0PPR,
27362      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
27363 C  parameters of 2x2 channel model
27364       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
27365       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
27366 C  table of particle indices for recursive PHOJET calls
27367       INTEGER MAXIPX
27368       PARAMETER ( MAXIPX = 100 )
27369       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
27370       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
27371      &                IPOIX1,IPOIX2,IPOIX3
27372 C  standard particle data interface
27373       INTEGER NMXHEP
27374       PARAMETER (NMXHEP=4000)
27375       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
27376       DOUBLE PRECISION PHEP,VHEP
27377       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27378      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
27379      &                VHEP(4,NMXHEP)
27380 C  extension to standard particle data interface (PHOJET specific)
27381       INTEGER IMPART,IPHIST,ICOLOR
27382       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
27383 C  event weights and generated cross section
27384       INTEGER IPOWGC,ISWCUT,IVWGHT
27385       DOUBLE PRECISION SIGGEN,HSWGHT,HSWCUT,EVWGHT
27386       COMMON /POWGHT/ SIGGEN(4),HSWGHT(0:10),HSWCUT(20),EVWGHT(0:10),
27387      &                IPOWGC(0:10),ISWCUT(20),IVWGHT(0:10)
27388
27389       DOUBLE PRECISION P1,P2,XMASS,AMP,PP,PD1,PD2
27390       DIMENSION P1(5),P2(5),XMASS(2),AMP(2),PP(7,2),PD1(7),PD2(7)
27391       DIMENSION IDPDG(2),IDBAM(2),IPAR(2),IPOSP(2,2),IRPDG(2),IVEC(2),
27392      &          IRBAM(2),IFL1P(2),IFL2P(2),ISAM(2),JSAM(2),KSAM(2),
27393      &          IDIR(2),IPROC(2)
27394
27395       IF(IMODE.EQ.-1) THEN
27396 C  initialization
27397         RETURN
27398       ELSE IF(IMODE.EQ.-2) THEN
27399 C  output of statistics
27400         RETURN
27401       ENDIF
27402
27403       IREJ = 0
27404 C  mass cuts
27405       PIMASS  = 0.140D0
27406 C  debug output
27407       IF(IDEB(45).GE.10) THEN
27408         WRITE(LO,'(1X,2A,/16X,7I6)') 'PHO_DIFDIS: (1) ',
27409      &    'IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
27410      &    IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE
27411       ENDIF
27412       IPAR(1) = IDIF1
27413       IPAR(2) = IDIF2
27414 C  save current status
27415       MSOFT = 0
27416       MHARD = 0
27417       KHPOMS = KHPOM
27418       KSPOMS = KSPOM
27419       KSREGS = KSREG
27420       KHDIRS = KHDIR
27421       IPOIS1 = IPOIX1
27422       IPOIS2 = IPOIX2
27423       IPOIS3 = IPOIX3
27424       JDA11 = JDAHEP(1,IMOTH1)
27425       JDA21 = JDAHEP(2,IMOTH1)
27426       JDA12 = JDAHEP(1,IMOTH2)
27427       JDA22 = JDAHEP(2,IMOTH2)
27428       ISTH1 = ISTHEP(IMOTH1)
27429       ISTH2 = ISTHEP(IMOTH2)
27430       NHEPS = NHEP
27431 C  get mother data
27432       NPOSD(1) = IMOTH1
27433       NPOSD(2) = IMOTH2
27434       DO 20 I=1,2
27435         IDPDG(I) = IDHEP(NPOSD(I))
27436         IDBAM(I) = IMPART(NPOSD(I))
27437         AMP(I) = PHO_PMASS(IDBAM(I),0)
27438         IF(IDPDG(I).EQ.22) THEN
27439           PMASSD(I) = 0.765D0
27440           PVIRTD(I) = PHEP(5,NPOSD(I))**2
27441         ELSE
27442           PMASSD(I) = PHO_PMASS(IDBAM(I),0)
27443           PVIRTD(I) = 0.D0
27444         ENDIF
27445  20   CONTINUE
27446 C  get CM system
27447       P1(1) = PHEP(1,IMOTH1)+PHEP(1,IMOTH2)
27448       P1(2) = PHEP(2,IMOTH1)+PHEP(2,IMOTH2)
27449       P1(3) = PHEP(3,IMOTH1)+PHEP(3,IMOTH2)
27450       P1(4) = PHEP(4,IMOTH1)+PHEP(4,IMOTH2)
27451       SS = (P1(4)+P1(3))*(P1(4)-P1(3))-P1(1)**2-P1(2)**2
27452       ECMD = SQRT(SS)
27453       IF(IDEB(45).GE.15) WRITE(LO,'(1X,A,E12.4)')
27454      &  'PHO_DIFDIS: availabe energy',ECMD
27455 C  check total available energy
27456       IF((AMP(1)+AMP(2)+0.1D0).GE.ECMD) THEN
27457         IF(IDEB(45).GE.2) WRITE(LO,'(1X,2A,/5X,A,1P,3E11.3)')
27458      &    'PHO_DIFDIS: ',
27459      &    'not enough energy for inelastic diffraction',
27460      &    'ECM, particle masses:',ECMD,AMP
27461         IFAIL(7) = IFAIL(7)+1
27462         IREJ = 1
27463         RETURN
27464       ENDIF
27465 C  boost into CMS
27466       DO 10 I=1,4
27467         GAMBED(I) = P1(I)/ECMD
27468  10   CONTINUE
27469       CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
27470      &           PHEP(1,IMOTH1),PHEP(2,IMOTH1),PHEP(3,IMOTH1),
27471      &           PHEP(4,IMOTH1),PTOT1,P1(1),P1(2),P1(3),P1(4))
27472 C  rotation angles
27473       CODD = P1(3)/PTOT1
27474       SIDD = SQRT(P1(1)**2+P1(2)**2)/PTOT1
27475       COFD = 1.D0
27476       SIFD = 0.D0
27477       IF(PTOT1*SIDD.GT.1.D-5) THEN
27478         COFD = P1(1)/(SIDD*PTOT1)
27479         SIFD = P1(2)/(SIDD*PTOT1)
27480         ANORF= SQRT(COFD*COFD+SIFD*SIFD)
27481         COFD = COFD/ANORF
27482         SIFD = SIFD/ANORF
27483       ENDIF
27484 C  initial particles in CMS
27485       PDCMS(1,1) = 0.D0
27486       PDCMS(2,1) = 0.D0
27487       PDCMS(3,1) = PTOT1
27488       PDCMS(4,1) = P1(4)
27489       PDCMS(1,2) = 0.D0
27490       PDCMS(2,2) = 0.D0
27491       PDCMS(3,2) = -PTOT1
27492       PDCMS(4,2) = ECMD-P1(4)
27493 C  get new CM momentum
27494       AM12 = PMASSD(1)**2
27495       AM22 = PMASSD(2)**2
27496       PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)
27497
27498 C  coherence constraint (min/max diffractive mass allowed)
27499       IF(IMODE.EQ.2) THEN
27500         THRM1 = PARMDL(71)/SQRT(1-PARMDL(72))
27501         THRM1 = MAX(THRM1,PARMDL(70)*PARMDL(71))
27502         THRM2 = SQRT(1-PARMDL(72))*ECMD
27503         THRM2 = MIN(THRM2,ECMD/PARMDL(70))
27504       ELSE
27505         THRM1 = PARMDL(46)
27506         THRM2 = PARMDL(45)*ECMD
27507 C  check kinematic limits
27508         IF(THRM2.LE.(4.D0*PARMDL(162))) IPAR(1) = MIN(IPAR(1),1)
27509         IF(THRM2.LE.(4.D0*PARMDL(163))) IPAR(2) = MIN(IPAR(2),1)
27510       ENDIF
27511
27512 C  check energy vs. coherence constraints
27513       IF(MAX(PARMDL(162),PMASSD(1)+THRM1).GE.THRM2) IPAR(1) = 0
27514       IF(MAX(PARMDL(163),PMASSD(2)+THRM1).GE.THRM2) IPAR(2) = 0
27515
27516 C  no phase space available
27517       IF(IPAR(1)+IPAR(2).EQ.0) THEN
27518         IF(IDEB(45).GE.2) WRITE(LO,'(1X,2A,1P,E11.3,2(/5X,A,2E11.3))')
27519      &    'PHO_DIFDIS: ',
27520      &    'not enough phase space for ine. diffraction (Ecm)',ECMD,
27521      &    'side 1: min. mass, upper mass limit:',
27522      &    MAX(PARMDL(162),PMASSD(1)+THRM1),THRM2,
27523      &    'side 2: min. mass, upper mass limit:',
27524      &    MAX(PARMDL(163),PMASSD(2)+THRM1),THRM2
27525         IFAIL(7) = IFAIL(7)+1
27526         IREJ = 1
27527         RETURN
27528       ENDIF
27529
27530       ITRY = 0
27531       ITRYM = 10
27532       IPARS1 = IPAR(1)
27533       IPARS2 = IPAR(2)
27534
27535 C  main rejection loop
27536 C -------------------------------
27537  50   CONTINUE
27538       ITRY = ITRY+1
27539       IF(ITRY.GT.1) THEN
27540         IFAIL(13) = IFAIL(13)+1
27541         IF(ITRY.GE.ITRYM) THEN
27542           IF(IDEB(45).GE.2) WRITE(LO,'(1X,A,I10,2I3)')
27543      &      'PHO_DIFDIS: rejection (KEVE,IPAR1/2) ',KEVENT,IPAR
27544           IFAIL(7) = IFAIL(7)+1
27545           IREJ = 1
27546           RETURN
27547         ENDIF
27548       ENDIF
27549       KSPOM = KSPOMS
27550       KHPOM = KHPOMS
27551       KHDIR = KHDIRS
27552       KSREG = KSREGS
27553       IPAR(1) = IPARS1
27554       IPAR(2) = IPARS2
27555 C  reset mother-daugther relations
27556       NHEP = NHEPS
27557       JDAHEP(1,IMOTH1) = JDA11
27558       JDAHEP(2,IMOTH1) = JDA21
27559       JDAHEP(1,IMOTH2) = JDA12
27560       JDAHEP(2,IMOTH2) = JDA22
27561       ISTHEP(IMOTH1) = ISTH1
27562       ISTHEP(IMOTH2) = ISTH2
27563       IPOIX1 = IPOIS1
27564       IPOIX2 = IPOIS2
27565       IPOIX3 = IPOIS3
27566 C
27567       NSLP = 0
27568       NCOR = 0
27569  55   CONTINUE
27570
27571 C  calculation of kinematics
27572       DO 100 I=1,2
27573 C  sampling of masses
27574         IRPDG(I) = 0
27575         IRBAM(I) = 0
27576         IFL1P(I) = IDPDG(I)
27577         IFL2P(I) = IDBAM(I)
27578         IVEC(I)  = 0
27579         IDIR(I) = 0
27580         ISAM(I) = 0
27581         JSAM(I) = 0
27582         KSAM(I) = 0
27583         IF(IPAR(I).EQ.0) THEN
27584 C  vector meson dominance assumed
27585           XMASS(I) = AMP(I)
27586           CALL PHO_VECRES(IVEC(I),XMASS(I),IFL1P(I),IFL2P(I))
27587 C  diffraction dissociation
27588         ELSE IF(IPAR(I).EQ.1) THEN
27589           XMMIN = MAX(PARMDL(161+I),PMASSD(I)+THRM1)
27590           PREF2 = PMASSD(I)**2
27591           XMASS(I) = PHO_DFMASS(XMMIN,THRM2,PREF2,PVIRTD(I),ISWMDL(22))
27592         ELSE
27593           WRITE(LO,'(/1X,A,2I3)')
27594      &      'PHO_DIFDIS:ERROR:invalid IPAR1,IPAR2',IPAR(1),IPAR(2)
27595           CALL PHO_ABORT
27596         ENDIF
27597  100  CONTINUE
27598
27599 C  sampling of momentum transfer
27600       CALL PHO_DIFSLP(IPAR(1),IPAR(2),IVEC(1),IVEC(2),XMASS(1),XMASS(2),
27601      &            THRM2,TT,SLWGHT,IREJ)
27602       IF(IREJ.NE.0) THEN
27603         NSLP=NSLP+1
27604         IF(NSLP.LT.100) GOTO 55
27605         WRITE(LO,'(1X,2A,/10X,2I3,2E12.3)') 'PHO_DIFDIS: ',
27606      &   'too many slope rejections:IPAR1,IPAR2,M1,M2',IPAR,XMASS
27607         IREJ = 5
27608         RETURN
27609       ENDIF
27610
27611 C  correct for t-M^2 correlation in diffraction
27612       IF(DT_RNDM(TT).GT.SLWGHT) THEN
27613         NCOR=NCOR+1
27614         IF(NCOR.LT.100) GOTO 55
27615         WRITE(LO,'(1X,2A,I10)') 'PHO_DIFDIS: ',
27616      &   'too many rejections due to t-M**2 correlation (EVE)',KEVENT
27617         IREJ = 5
27618         RETURN
27619       ENDIF
27620
27621 C  debug output
27622       IF(IDEB(45).GE.5) THEN
27623         WRITE(LO,'(1X,A,/5X,2I3,3E12.3)')
27624      &    'PHO_DIFDIS: IPAR1,IPAR2,XMASS1,XMASS2,TT',IPAR,XMASS,TT
27625       ENDIF
27626 C  not double pomeron scattering
27627       IF(IMODE.NE.2) THEN
27628 C  sample diffractive interaction processes
27629         DO 120 I=1,2
27630           IF(IPAR(I).NE.0) THEN
27631 C  find particle combination
27632             IF(IDPDG(I).EQ.IFPAP(1)) THEN
27633               IP = 2
27634             ELSE IF(IDPDG(I).EQ.IFPAP(2)) THEN
27635               IP = 3
27636             ELSE IF(IDPDG(I).EQ.990) THEN
27637               IP = 4
27638             ELSE
27639               IP = I+1
27640             ENDIF
27641 C  sample dissociation process
27642             CALL PHO_DIFPRO(IP,ISWMDL(16),IDPDG(I),990,XMASS(I),
27643      &        PVIRTD(I),0.D0,SPROB,IPROC(I),ISAM(I),JSAM(I),
27644      &        KSAM(I),IDIR(I))
27645             IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
27646 C  store process label
27647               IF(IDIR(I).GT.0) THEN
27648                 IPAR(I) = 4
27649               ELSE IF(KSAM(I).GT.0) THEN
27650                 IPAR(I) = 3
27651               ELSE IF(ISAM(I).GT.0) THEN
27652                 IPAR(I) = 2
27653               ELSE
27654                 IPAR(I) = 1
27655 C  mass fine correction
27656                 CALL PHO_MASSAD(IDPDG(I),IFL1P(I),IFL2P(I),PMASSD(I),
27657      &            XMASS(I),XMNEW,IRPDG(I),IRBAM(I))
27658                 XMASS(I) = XMNEW
27659               ENDIF
27660             ELSE
27661 C  diffractive pomeron-hadron interaction
27662               IPAR(I) = 10+IPROC(I)
27663             ENDIF
27664 C  debug output
27665             IF(IDEB(45).GE.15) WRITE(LO,'(1X,A,/10X,I3,E12.4,5I3)')
27666      &        'PHO_DIFDIS: IP,XMASS,IPROC,ISAM,JSAM,KSAM,IDIR',
27667      &        IP,XMASS(I),IPROC(I),ISAM(I),JSAM(I),KSAM(I),IDIR(I)
27668           ENDIF
27669  120    CONTINUE
27670       ENDIF
27671 C  actualize debug information
27672       IF(IMODE.EQ.1) THEN
27673         IDIFR1 = IPAR(1)
27674         IDIFR2 = IPAR(2)
27675       ENDIF
27676 C  calculate new momenta in CMS
27677       CALL PHO_DIFKIN(XMASS(1),XMASS(2),TT,P1,P2,IREJ)
27678       IF(IREJ.NE.0) GOTO 50
27679       DO 130 I=1,4
27680         PP(I,1) = P1(I)
27681         PP(I,2) = P2(I)
27682  130  CONTINUE
27683
27684 C  comment line for diffraction
27685       CALL PHO_REGPAR(30,IPROCE,IMODE,NPOSD(1),NPOSD(2),XMASS(1),
27686      &   XMASS(2),TT,ECMD,IPAR(1),IPAR(2),IDPDG(1),IDPDG(2),ICPOS,1)
27687 C  write diffractive strings/particles
27688       DO 200 I=1,2
27689         I1 = I
27690         I2 = 3-I1
27691         DO K=1,4
27692           PD1(K) = PP(K,I1)
27693           PD2(K) = PP(K,I2)
27694         ENDDO
27695         PP(6,I1) = SIGN(PHEP(5,NPOSD(I1))**2,PHEP(5,NPOSD(I1)))
27696         PP(7,I1) = TT
27697         IGEN = IPHIST(2,NPOSD(I1))
27698         if(IGEN.eq.0) IGEN = -I1*10
27699         CALL PHO_DIFPAR(NPOSD(I1),NPOSD(I2),IGEN,IFL1P(I1),IFL2P(I1),
27700      &    IPAR(I1),PD1,PD2,IPOSP(1,I1),IPOSP(2,I1),IMODE,IREJ)
27701         IF(IREJ.NE.0) THEN
27702           IFAIL(7+I) = IFAIL(7+I)+1
27703           IF(IDEB(45).GE.3) WRITE(LO,'(1X,A,2I3,E11.3)')
27704      &      'PHO_DIFDIS: rejection by PHO_DIFPAR (I,IPAR,XM)',
27705      &      I,IPAR(I),XMASS(I)
27706           GOTO 50
27707         ENDIF
27708         ICOLOR(I1,ICPOS) = IPOSP(1,I1)
27709  200  CONTINUE
27710 C  double-pomeron scattering?
27711       IF(IMODE.EQ.2) GOTO 150
27712
27713 C  diffractive final states
27714       DO 300 I=1,2
27715  110    CONTINUE
27716         IF(IPAR(I).EQ.0) THEN
27717 C  vector meson production
27718           IF(IDPDG(I).EQ.22) THEN
27719             IF(ISWMDL(21).GE.0) THEN
27720               ISP = IPAMDL(3)
27721               IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
27722               CALL PHO_SDECAY(IPOSP(1,I),ISP,2)
27723             ENDIF
27724 C  hadronic state of multi-pomeron coupling
27725           ELSE IF(IDPDG(I).EQ.990) THEN
27726             CALL PHO_SDECAY(IPOSP(1,I),0,2)
27727           ENDIF
27728         ELSE
27729           IF((IPROC(I).EQ.1).OR.(IPROC(I).EQ.8)) THEN
27730             IF(ISAM(I)+JSAM(I)+KSAM(I).EQ.0) JSAM(I) = 1
27731             IF(IDIR(I).GT.0) THEN
27732               IPAR(I) = 4
27733             ELSE IF(KSAM(I).GT.0) THEN
27734               IPAR(I) = 3
27735             ELSE IF(ISAM(I).GT.0) THEN
27736               IPAR(I) = 2
27737             ELSE
27738               IPAR(I) = 1
27739             ENDIF
27740           ELSE
27741             IPAR(I) = 10+IPROC(I)
27742           ENDIF
27743           IPHIST(I,ICPOS) = IPAR(I)
27744 C  update debug informantion
27745           KSPOM = ISAM(I)
27746           KSREG = JSAM(I)
27747           KHPOM = KSAM(I)
27748           KHDIR = IDIR(I)
27749           IDIFR1 = IPAR(1)
27750           IDIFR2 = IPAR(2)
27751           IF((IRPDG(I).NE.0).AND.(ISWMDL(23).GT.0)) THEN
27752
27753 C  resonance decay, pi+pi- background
27754             P1(1) = PHEP(1,IPOSP(1,I))+PHEP(1,IPOSP(2,I))
27755             P1(2) = PHEP(2,IPOSP(1,I))+PHEP(2,IPOSP(2,I))
27756             P1(3) = PHEP(3,IPOSP(1,I))+PHEP(3,IPOSP(2,I))
27757             P1(4) = PHEP(4,IPOSP(1,I))+PHEP(4,IPOSP(2,I))
27758             CALL PHO_REGPAR(1,IRPDG(I),IRBAM(I),IPOSP(1,I),IPOSP(2,I),
27759      &        P1(1),P1(2),P1(3),P1(4),0,2,0,0,IPOS,1)
27760 C  decay
27761             IF(IDPDG(I).EQ.22) THEN
27762               IPHIST(2,IPOS) = 3
27763               IF(ISWMDL(21).GE.0) THEN
27764                 ISP = IPAMDL(3)
27765                 IF(ISWMDL(21).GE.2) ISP = IPAMDL(4)
27766                 CALL PHO_SDECAY(IPOS,ISP,2)
27767               ENDIF
27768             ELSE
27769               CALL PHO_SDECAY(IPOS,IPAMDL(3),2)
27770             ENDIF
27771             IREJ = 0
27772           ELSE
27773
27774 C  particle-pomeron scattering
27775             IF(IPAR(I).LE.4) THEN
27776 C  non-diffractive particle-pomeron scattering
27777               IGEN = IPHIST(2,NPOSD(I))
27778               if(IGEN.eq.0) then
27779                 if(I.eq.1) then
27780                   IGEN = 5
27781                 else
27782                   IGEN = 6
27783                 endif
27784               endif
27785               CALL PHO_STDPAR(IPOSP(1,I),IPOSP(2,I),IGEN,
27786      &          ISAM(I),JSAM(I),KSAM(I),IDIR(I),IREJ)
27787             ELSE
27788 C  diffractive particle-pomeron scattering
27789               IPOIX2 = IPOIX2+1
27790               IPORES(IPOIX2)   = IPROC(I)
27791               IPOPOS(1,IPOIX2) = IPOSP(1,I)
27792               IPOPOS(2,IPOIX2) = IPOSP(2,I)
27793             ENDIF
27794           ENDIF
27795         ENDIF
27796
27797 C  rejection?
27798         IF(IREJ.NE.0) THEN
27799           IFAIL(20+I) = IFAIL(20+I)+1
27800           IF(IPAR(I).GT.1) THEN
27801             IF(IPAR(I).EQ.3) IFAIL(7+2*I) = IFAIL(7+2*I)+1
27802             IF(IPAR(I).EQ.4) IFAIL(8+2*I) = IFAIL(8+2*I)+1
27803             IF(IDIR(I).GT.0) THEN
27804               IDIR(I) = 0
27805             ELSE IF(KSAM(I).GT.0) THEN
27806               KSAM(I) = KSAM(I)-1
27807             ELSE IF(ISAM(I).GT.0) THEN
27808               ISAM(I) = ISAM(I)-1
27809             ENDIF
27810             GOTO 110
27811           ELSE
27812             IF(IDEB(45).GE.2) WRITE(LO,'(1X,A,2I3,E11.3)')
27813      &        'PHO_DIFDIS: rejection PHO_STDPAR (I,IPAR,XM)',
27814      &        I,IPAR(I),XMASS(I)
27815             GOTO 50
27816           ENDIF
27817         ENDIF
27818  300  CONTINUE
27819
27820       IDIF1 = IPAR(1)
27821       IDIF2 = IPAR(2)
27822 C  update debug information
27823       KSPOM = KSPOMS+ISAM(1)+ISAM(2)
27824       KSREG = KSREGS+JSAM(1)+JSAM(2)
27825       KHPOM = KHPOMS+KSAM(1)+KSAM(2)
27826       KHDIR = KHDIRS+IDIR(1)+IDIR(2)
27827
27828  150  CONTINUE
27829
27830 C  debug output
27831       IF(IDEB(45).GE.10) THEN
27832         WRITE(LO,'(1X,2A,/18X,7I6)') 'PHO_DIFDIS: (2) ',
27833      &    'IPAR1,IPAR2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE',
27834      &    IPAR,NPOSD,MSOFT,MHARD,IMODE
27835       ENDIF
27836       IF(IDEB(45).GE.15) THEN
27837         WRITE(LO,'(2(/1X,A))') 'PHO_DIFDIS: output of /POEVT1/',
27838      &                        '------------------------------'
27839         CALL PHO_PREVNT(0)
27840       ENDIF
27841
27842       END
27843
27844 *$ CREATE PHO_DIFPRO.FOR
27845 *COPY PHO_DIFPRO
27846 CDECK  ID>, PHO_DIFPRO
27847       SUBROUTINE PHO_DIFPRO(IP,ICUT,ID1,ID2,XMASS,P2V1,P2V2,SPROB,
27848      &                  IPROC,ISAM,JSAM,KSAM,IDIR)
27849 C*********************************************************************
27850 C
27851 C     sampling of diffraction dissociation process
27852 C
27853 C     input:  IP       particle combination
27854 C             ICUT     user imposed limitations
27855 C             ID1/2    PDG particle code of scattering particles
27856 C             XMASS    diffractively produced mass (GeV)
27857 C             P2V1/2   virtuality of scattering particles (Gev**2)
27858 C             SPROB    suppression factor for resolved single and
27859 C                      double diffraction dissociation
27860 C
27861 C     output: IRPOC    process ID
27862 C             ISAM     number of cut pomerons (soft)
27863 C             JSAM     number of cut reggeons
27864 C             KSAM     number of cut pomerons (hard)
27865 C             IDIR     direct hard interaction
27866 C
27867 C*********************************************************************
27868       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27869       SAVE
27870
27871 C  input/output channels
27872       INTEGER LI,LO
27873       COMMON /POINOU/ LI,LO
27874 C  event debugging information
27875       INTEGER NMAXD
27876       PARAMETER (NMAXD=100)
27877       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27878      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27879       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27880      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27881 C  general process information
27882       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
27883       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
27884 C  model switches and parameters
27885       CHARACTER*8 MDLNA
27886       INTEGER ISWMDL,IPAMDL
27887       DOUBLE PRECISION PARMDL
27888       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
27889 C  energy-interpolation table
27890       INTEGER IEETA2
27891       PARAMETER ( IEETA2 = 20 )
27892       INTEGER ISIMAX
27893       DOUBLE PRECISION SIGTAB,SIGECM
27894       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
27895
27896       ISAM = 0
27897       JSAM = 0
27898       KSAM = 0
27899       IDIR = 0
27900
27901       IF(XMASS.GT.3.D0) THEN
27902 C  rapidity gap survival probability
27903         SPRO = 1.D0
27904         IF(ISWMDL(28).GE.1) SPRO = SPROB
27905 C  sample interaction
27906         IPROC = 0
27907         CALL PHO_SAMPRO(IP,ID1,ID2,XMASS,P2V1,P2V2,SPRO,IPROC)
27908       ELSE
27909         IPROC = 1
27910       ENDIF
27911       IF(IPROC.EQ.1) CALL PHO_SAMPRB(XMASS,IP,ISAM,JSAM,KSAM)
27912 C  non-diffractive hadron-pomeron interaction
27913       IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
27914 C  option for suppression of multiple interaction
27915         IF(ICUT.EQ.0) THEN
27916           IPROC = 1
27917           IF(ISAM+KSAM+IDIR.GT.0) THEN
27918             ISAM = 1
27919             JSAM = 0
27920           ELSE
27921             JSAM = 1
27922           ENDIF
27923           KSAM = 0
27924           IDIR = 0
27925         ELSE IF(ICUT.EQ.1) THEN
27926           IF(IDIR.GT.0) THEN
27927           ELSE IF(KSAM.GT.0) THEN
27928             KSAM = 1
27929             ISAM = 0
27930             JSAM = 0
27931           ELSE IF(ISAM.GT.0) THEN
27932             ISAM = 1
27933             JSAM = 0
27934           ELSE
27935             JSAM = 1
27936           ENDIF
27937         ELSE IF(ICUT.EQ.2) THEN
27938           KSAM = MIN(KSAM,1)
27939         ELSE IF(ICUT.EQ.3) THEN
27940           ISAM = MIN(ISAM,1)
27941         ENDIF
27942       ENDIF
27943       END
27944
27945 *$ CREATE PHO_DIFPAR.FOR
27946 *COPY PHO_DIFPAR
27947 CDECK  ID>, PHO_DIFPAR
27948       SUBROUTINE PHO_DIFPAR(IMOTH1,IMOTH2,IGENM,IFL1,IFL2,IPAR,P1,P2,
27949      &                     IPOSH1,IPOSH2,IMODE,IREJ)
27950 C***********************************************************************
27951 C
27952 C     perform string construction for diffraction dissociation
27953 C
27954 C     input:     IMOTH1,2     index of mother particles in POEVT1
27955 C                IGENM        production process of mother particles
27956 C                IFL1,IFL2    particle numbers
27957 C                             (IDPDG,IDBAM for quasi-elas. hadron)
27958 C                IPAR         0  quasi-elasic scattering
27959 C                             1  single string configuration
27960 C                             2  two string configuration
27961 C                P1           massive 4 momentum of first
27962 C                P1(6)        virtuality/squ.mass of particle (GeV**2)
27963 C                P1(7)        virtuality of Pomeron (neg, GeV**2)
27964 C                P2           massive 4 momentum of second particle
27965 C                IMODE        1   diffraction dissociation
27966 C                             2   double-pomeron scattering
27967 C
27968 C     output:    IPOSH1,2     index of the particles in /POEVT1/
27969 C                IREJ         0  successful string construction
27970 C                             1  no string construction possible
27971 C
27972 C***********************************************************************
27973       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27974       SAVE
27975
27976       DIMENSION P1(7),P2(7)
27977
27978       PARAMETER ( EPS  = 1.D-7,
27979      &            DEPS = 1.D-10)
27980
27981 C  input/output channels
27982       INTEGER LI,LO
27983       COMMON /POINOU/ LI,LO
27984 C  event debugging information
27985       INTEGER NMAXD
27986       PARAMETER (NMAXD=100)
27987       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
27988      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27989       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
27990      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
27991 C  internal rejection counters
27992       INTEGER NMXJ
27993       PARAMETER (NMXJ=60)
27994       CHARACTER*10 REJTIT
27995       INTEGER IFAIL
27996       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
27997 C  c.m. kinematics of diffraction
27998       INTEGER NPOSD
27999       DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
28000      &                 SIDD,CODD,SIFD,COFD,PDCMS
28001       COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
28002      &                SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
28003 C  model switches and parameters
28004       CHARACTER*8 MDLNA
28005       INTEGER ISWMDL,IPAMDL
28006       DOUBLE PRECISION PARMDL
28007       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28008 C  some constants
28009       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28010       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28011      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28012 C  standard particle data interface
28013       INTEGER NMXHEP
28014       PARAMETER (NMXHEP=4000)
28015       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28016       DOUBLE PRECISION PHEP,VHEP
28017       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28018      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28019      &                VHEP(4,NMXHEP)
28020 C  extension to standard particle data interface (PHOJET specific)
28021       INTEGER IMPART,IPHIST,ICOLOR
28022       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28023
28024       DIMENSION PCH1(2,4)
28025       data IC1 /0/
28026       data IC2 /0/
28027
28028       IREJ = 0
28029       ILTR1 = NHEP+1
28030       IGEN = IGENM
28031       if(IGENM.le.-10) IGEN = 0
28032
28033 C  elastic part
28034       IF(IPAR.EQ.0) THEN
28035         IF((IFL1.EQ.92).OR.(IFL1.EQ.91)) THEN
28036           if(IGEN.eq.0) IGEN = 3
28037 C  pi+/pi- isotropic background
28038           CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,
28039      &      P1(1),P1(2),P1(3),P1(4),0,IGEN,0,0,IPOSH1,1)
28040           CALL PHO_SDECAY(IPOSH1,0,-2)
28041         ELSE
28042           if(IGEN.eq.0) then
28043             IGEN = 2
28044             if(IFL1.ne.IDHEP(IMOTH1)) IGEN = 3
28045           endif
28046 C  registration of particle or resonance
28047           CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,P1(1),P1(2),P1(3),
28048      &      P1(4),0,IGEN,0,0,IPOSH1,1)
28049         ENDIF
28050
28051 C  diffraction dissociation
28052       ELSE IF((IPAR.GE.1).AND.(IPAR.LE.18)) THEN
28053 C  calculation of resulting particle momenta
28054         IF(IMOTH1.EQ.NPOSD(1)) THEN
28055           K = 2
28056         ELSE
28057           K = 1
28058         ENDIF
28059         DO 100 I=1,4
28060           PCH1(2,I) = PDCMS(I,K)-P2(I)
28061           PCH1(1,I) = P1(I)-PCH1(2,I)
28062  100    CONTINUE
28063
28064 C  registration
28065         if(IMODE.LT.2) then
28066           if(IGEN.eq.0) IGEN = -IGENM/10+4
28067           CALL PHO_REGPAR(1,IFL1,IFL2,IMOTH1,IMOTH2,PCH1(1,1),
28068      &      PCH1(1,2),PCH1(1,3),PCH1(1,4),-1,IGEN,IC1,IC2,IPOSH1,1)
28069         else
28070           if(IGEN.eq.0) IGEN = 4
28071         endif
28072         CALL PHO_REGPAR(1,990,0,IMOTH2,IMOTH1,PCH1(2,1),PCH1(2,2),
28073      &    PCH1(2,3),PCH1(2,4),-1,IGEN,IC1,IC2,IPOSH2,1)
28074
28075 C  invalid IPAR
28076       ELSE
28077         WRITE(LO,'(/1X,A,I6)') 'PHO_DIFPAR:ERROR: invalid IPAR:',IPAR
28078         CALL PHO_ABORT
28079       ENDIF
28080
28081 C  back transformation
28082       CALL PHO_LTRHEP(ILTR1,NHEP,CODD,SIDD,COFD,SIFD,GAMBED(4),
28083      &  GAMBED(1),GAMBED(2),GAMBED(3))
28084
28085       END
28086
28087 *$ CREATE PHO_QELAST.FOR
28088 *COPY PHO_QELAST
28089 CDECK  ID>, PHO_QELAST
28090       SUBROUTINE PHO_QELAST(IPROC,JM1,JM2,IREJ)
28091 C**********************************************************************
28092 C
28093 C     sampling of quasi elastic processes
28094 C
28095 C     input:   IPROC  2   purely elastic scattering
28096 C              IPROC  3   q-ela. omega/omega/phi/pi+pi- production
28097 C              IPROC  4   double pomeron scattering
28098 C              IPROC  -1  initialization
28099 C              IPROC  -2  output of statistics
28100 C              JM1/2      index of initial particle 1/2
28101 C
28102 C     output:  initial and final particles in /POEVT1/ involving
28103 C              polarized resonances in /POEVT1/ and decay
28104 C              products
28105 C
28106 C              IREJ    0  successful
28107 C                      1  failure
28108 C                     50  user rejection
28109 C
28110 C**********************************************************************
28111       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28112       SAVE
28113
28114       PARAMETER ( NTAB = 20,
28115      &            EPS  = 1.D-10,
28116      &            PIMASS = 0.13D0,
28117      &            DEPS = 1.D-10)
28118
28119 C  input/output channels
28120       INTEGER LI,LO
28121       COMMON /POINOU/ LI,LO
28122 C  event debugging information
28123       INTEGER NMAXD
28124       PARAMETER (NMAXD=100)
28125       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28126      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28127       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28128      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28129 C  global event kinematics and particle IDs
28130       INTEGER IFPAP,IFPAB
28131       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28132       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28133 C  c.m. kinematics of diffraction
28134       INTEGER NPOSD
28135       DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
28136      &                 SIDD,CODD,SIFD,COFD,PDCMS
28137       COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
28138      &                SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
28139 C  model switches and parameters
28140       CHARACTER*8 MDLNA
28141       INTEGER ISWMDL,IPAMDL
28142       DOUBLE PRECISION PARMDL
28143       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28144 C  some constants
28145       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28146       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28147      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28148 C  cross sections
28149       INTEGER IPFIL,IFAFIL,IFBFIL
28150       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
28151      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
28152      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
28153      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
28154      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
28155       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
28156      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
28157      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
28158      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
28159      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
28160      &                IPFIL,IFAFIL,IFBFIL
28161 C  standard particle data interface
28162       INTEGER NMXHEP
28163       PARAMETER (NMXHEP=4000)
28164       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28165       DOUBLE PRECISION PHEP,VHEP
28166       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28167      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28168      &                VHEP(4,NMXHEP)
28169 C  extension to standard particle data interface (PHOJET specific)
28170       INTEGER IMPART,IPHIST,ICOLOR
28171       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28172
28173       DOUBLE PRECISION P,PK1,PK2,PMI,RMASS
28174       DIMENSION   P(4,2),PK1(5),PK2(5),PMI(2),RMASS(2)
28175       DIMENSION   IFL(2),IDPRO(4)
28176       character*15 pho_pname
28177       CHARACTER*8  VMESA(0:4),VMESB(0:4)
28178       DIMENSION   ISAMVM(4,4)
28179       DATA IDPRO / 113,223,333,92 /
28180       DATA VMESA / 'vmeson  ','rho     ','omega   ','phi     ',
28181      &             'pi+pi-  ' /
28182       DATA VMESB / 'vmeson  ','rho     ','omega   ','phi     ',
28183      &             'pi+pi-  ' /
28184
28185 C  sampling of elastic/quasi-elastic processes
28186       IF((IPROC.EQ.2).OR.(IPROC.EQ.3)) THEN
28187         IREJ = 0
28188         NPOSD(1) = JM1
28189         NPOSD(2) = JM2
28190         DO 55 I=1,2
28191           PMI(I) = PHEP(5,NPOSD(I))
28192           IF(PMI(I).LT.0.1D0) PMI(I) = 0.765D0
28193  55     CONTINUE
28194 C  get CM system
28195         PK1(1) = PHEP(1,JM1)+PHEP(1,JM2)
28196         PK1(2) = PHEP(2,JM1)+PHEP(2,JM2)
28197         PK1(3) = PHEP(3,JM1)+PHEP(3,JM2)
28198         PK1(4) = PHEP(4,JM1)+PHEP(4,JM2)
28199         SS = (PK1(4)+PK1(3))*(PK1(4)-PK1(3))-PK1(1)**2-PK1(2)**2
28200         ECMD = SQRT(SS)
28201
28202         IF(ECMD.LE.PMI(1)+PMI(2)) THEN
28203           IF(IDEB(34).GE.3) WRITE(LO,'(1X,A,I12,3E12.4)')
28204      &      'PHO_QELAST: too small mass (EV,ECM,M1,M2)',KEVENT,
28205      &      ECMD,PMI
28206           IREJ = 5
28207           RETURN
28208         ENDIF
28209
28210         DO 60 I=1,4
28211           GAMBED(I) = PK1(I)/ECMD
28212  60     CONTINUE
28213         CALL PHO_ALTRA(GAMBED(4),-GAMBED(1),-GAMBED(2),-GAMBED(3),
28214      &           PHEP(1,NPOSD(1)),PHEP(2,NPOSD(1)),PHEP(3,NPOSD(1)),
28215      &           PHEP(4,NPOSD(1)),PTOT1,PK1(1),PK1(2),PK1(3),PK1(4))
28216 C  rotation angles
28217         CODD = PK1(3)/PTOT1
28218         SIDD = SQRT(PK1(1)**2+PK1(2)**2)/PTOT1
28219         COFD = 1.D0
28220         SIFD = 0.D0
28221         IF(PTOT1*SIDD.GT.1.D-5) THEN
28222           COFD = PK1(1)/(SIDD*PTOT1)
28223           SIFD = PK1(2)/(SIDD*PTOT1)
28224           ANORF = SQRT(COFD*COFD+SIFD*SIFD)
28225           COFD = COFD/ANORF
28226           SIFD = SIFD/ANORF
28227         ENDIF
28228 C  get CM momentum
28229         AM12 = PMI(1)**2
28230         AM22 = PMI(2)**2
28231         PCMD = PHO_XLAM(SS,AM12,AM22)/(2.D0*ECMD)
28232
28233 C  production process of mother particles
28234         IGEN = IPHIST(2,NPOSD(1))
28235         if(IGEN.eq.0) IGEN = IPROC
28236
28237         ICALL = ICALL + 1
28238 C  main rejection label
28239  50     CONTINUE
28240 C  determine process and final particles
28241         IFL(1) = IDHEP(NPOSD(1))
28242         IFL(2) = IDHEP(NPOSD(2))
28243         IF(IPROC.EQ.3) THEN
28244           ITRY = 0
28245  100      CONTINUE
28246           ITRY = ITRY+1
28247           IF(ITRY.GT.50) THEN
28248             IF(IDEB(34).GE.3) WRITE(LO,'(1X,A,I12,I5,E12.4)')
28249      &        'PHO_QELAST: mass rejection (EV,ITRY,ECM)',KEVENT,
28250      &        ITRY,ECMD
28251             IREJ = 5
28252             RETURN
28253           ENDIF
28254           XI = DT_RNDM(PCMD)*SIGVM(0,0)-DEPS
28255           DO 110 I=1,4
28256             DO 120 J=1,4
28257               XI = XI-SIGVM(I,J)
28258               IF(XI.LE.0.D0) GOTO 130
28259  120        CONTINUE
28260  110      CONTINUE
28261  130      CONTINUE
28262           IF(IFL(1).EQ.22) IFL(1) = IDPRO(I)
28263           IF(IFL(2).EQ.22) IFL(2) = IDPRO(J)
28264           ISAMVM(I,J) = ISAMVM(I,J)+1
28265           ISAMQE = ISAMQE+1
28266 C  sample new masses
28267           CALL PHO_SAMASS(IFL(1),RMASS(1))
28268           CALL PHO_SAMASS(IFL(2),RMASS(2))
28269           IF(RMASS(1)+RMASS(2).GE.ECMD) GOTO 100
28270         ELSE IF(IPROC.EQ.2) THEN
28271           I = 0
28272           J = 0
28273           ISAMEL = ISAMEL+1
28274           RMASS(1) = PHO_PMASS(NPOSD(1),2)
28275           RMASS(2) = PHO_PMASS(NPOSD(2),2)
28276         ELSE
28277           WRITE(LO,'(/1X,A,I6)') 'PHO_QELAST:ERROR: invalid IPROC',IPROC
28278           CALL PHO_ABORT
28279         ENDIF
28280 C  sample momentum transfer
28281         CALL PHO_DIFSLP(0,0,I,J,RMASS(1),RMASS(2),RMASS(1),TT,
28282      &    SLWGHT,IREJ)
28283         IF(IDEB(34).GE.5) WRITE(LO,'(1X,A,2I6,I3,3E11.3)')
28284      &    'PHO_QELAST: IF1,2,T,RM1,RM2',IFL,IPROC,TT,RMASS
28285 C  calculate new momenta
28286         CALL PHO_DIFKIN(RMASS(1),RMASS(2),TT,PK1,PK2,IREJ)
28287         IF(IREJ.NE.0) GOTO 50
28288         DO K=1,4
28289           P(K,1) = PK1(K)
28290           P(K,2) = PK2(K)
28291         ENDDO
28292 C  comment line for elastic/quasi-elastic scattering
28293         CALL PHO_REGPAR(35,IPROC,0,NPOSD(1),NPOSD(2),RMASS(1),RMASS(2),
28294      &    TT,ECMD,IFL(1),IFL(2),IDHEP(NPOSD(1)),IDHEP(NPOSD(2)),ICPOS,1)
28295
28296         I1 = NHEP+1
28297 C  fill /POEVT1/
28298         DO 200 I=1,2
28299           K = 3-I
28300           IF((IFL(I).EQ.92).OR.(IFL(I).EQ.91)) THEN
28301 C  pi+/pi- isotropic background
28302             IGEN = 3
28303             CALL PHO_REGPAR(1,113,0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
28304      &        P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
28305             ICOLOR(I,ICPOS) = IPOS
28306             CALL PHO_SDECAY(IPOS,0,-2)
28307           ELSE
28308 C  registration
28309             IGEN = 2
28310             if(IFL(I).ne.IDHEP(NPOSD(I))) IGEN = 3
28311             CALL PHO_REGPAR(1,IFL(I),0,NPOSD(I),NPOSD(K),P(1,I),P(2,I),
28312      &        P(3,I),P(4,I),0,IGEN,0,0,IPOS,1)
28313             ICOLOR(I,ICPOS) = IPOS
28314           ENDIF
28315  200    CONTINUE
28316         I2 = NHEP
28317 C  search for vector mesons
28318         DO 300 I=I1,I2
28319 C  decay according to polarization
28320           IF((IDHEP(JMOHEP(1,I)).EQ.22).AND.(ISWMDL(21).GE.0)) THEN
28321             ISP = IPAMDL(3)
28322             IF(ISWMDL(21).GE.1) ISP = IPAMDL(4)
28323             CALL PHO_SDECAY(I,ISP,2)
28324           ENDIF
28325  300    CONTINUE
28326         I2 = NHEP
28327 C  back transformation
28328         CALL PHO_LTRHEP(I1,I2,CODD,SIDD,COFD,SIFD,GAMBED(4),GAMBED(1),
28329      &              GAMBED(2),GAMBED(3))
28330
28331 C  initialization of tables
28332       ELSE IF(IPROC.EQ.-1) THEN
28333         DO 10 I=1,4
28334           DO 20 J=1,4
28335             ISAMVM(I,J) = 0
28336  20       CONTINUE
28337  10     CONTINUE
28338         ISAMEL = 0
28339         ISAMQE = 0
28340         IF(IFPAP(1).NE.22) VMESA(1) = PHO_PNAME(IFPAP(1),1)
28341         IF(IFPAP(2).NE.22) VMESB(1) = PHO_PNAME(IFPAP(2),1)
28342         CALL PHO_SAMASS(-1,RMASS(1))
28343         ICALL = 0
28344
28345 C  output of statistics
28346       ELSE IF(IPROC.EQ.-2) THEN
28347         IF(ICALL.LT.10) RETURN
28348         WRITE(LO,'(/,1X,A,I10/,1X,A)')
28349      &    'PHO_QELAST: statistics of (quasi-)elastic processes',ICALL,
28350      &    '---------------------------------------------------'
28351         WRITE(LO,'(1X,A,I10)')
28352      &    'sampled elastic processes:',ISAMEL
28353         WRITE(LO,'(1X,A,I10)')
28354      &    'sampled quasi-elastic vectormeson production:',ISAMQE
28355         WRITE(LO,'(15X,4(4X,A))') (VMESB(I),I=1,4)
28356         DO 30 I=1,4
28357           WRITE(LO,'(5X,A,4I12)') VMESA(I),(ISAMVM(I,K),K=1,4)
28358  30     CONTINUE
28359         CALL PHO_SAMASS(-2,RMASS(1))
28360       ELSE
28361         WRITE(LO,'(/1X,2A,I3)') 'PHO_QELAST:ERROR: ',
28362      &    'unknown process ID',IPROC
28363         CALL PHO_ABORT
28364       ENDIF
28365
28366       END
28367
28368 *$ CREATE PHO_CDIFF.FOR
28369 *COPY PHO_CDIFF
28370 CDECK  ID>, PHO_CDIFF
28371       SUBROUTINE PHO_CDIFF(IMOTH1,IMOTH2,MSOFT,MHARD,IMODE,IREJ)
28372 C**********************************************************************
28373 C
28374 C     preparation of /POEVT1/ for double-pomeron scattering
28375 C
28376 C     input:   IMOTH1/2   index of mother particles in /POEVT1/
28377 C
28378 C              IMODE   1  sampling of pomeron-pomeron scattering
28379 C                     -1  initialization
28380 C                     -2  output of statistics
28381 C
28382 C     output:   MSOFT     number of generated soft strings
28383 C               MHARD     number of generated hard strings
28384 C               IREJ      0  accepted
28385 C                         1  rejected
28386 C                        50  user rejection
28387 C
28388 C**********************************************************************
28389       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28390       SAVE
28391
28392       PARAMETER ( EPS  = 1.D-10,
28393      &            DEPS = 1.D-10)
28394
28395 C  input/output channels
28396       INTEGER LI,LO
28397       COMMON /POINOU/ LI,LO
28398 C  event debugging information
28399       INTEGER NMAXD
28400       PARAMETER (NMAXD=100)
28401       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28402      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28403       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28404      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28405 C  internal rejection counters
28406       INTEGER NMXJ
28407       PARAMETER (NMXJ=60)
28408       CHARACTER*10 REJTIT
28409       INTEGER IFAIL
28410       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
28411 C  model switches and parameters
28412       CHARACTER*8 MDLNA
28413       INTEGER ISWMDL,IPAMDL
28414       DOUBLE PRECISION PARMDL
28415       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28416 C  general process information
28417       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
28418       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
28419 C  Reggeon phenomenology parameters
28420       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
28421      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
28422       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
28423      &                ALREG,ALREGP,GR(2),B0REG(2),
28424      &                GPPP,GPPR,B0PPP,B0PPR,
28425      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
28426 C  parameters of 2x2 channel model
28427       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
28428       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
28429 C  some constants
28430       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28431       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28432      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28433 C  energy-interpolation table
28434       INTEGER IEETA2
28435       PARAMETER ( IEETA2 = 20 )
28436       INTEGER ISIMAX
28437       DOUBLE PRECISION SIGTAB,SIGECM
28438       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
28439 C  table of particle indices for recursive PHOJET calls
28440       INTEGER MAXIPX
28441       PARAMETER ( MAXIPX = 100 )
28442       INTEGER IPOPOS,IPORES,IPOIX1,IPOIX2,IPOIX3
28443       COMMON /PORECU/ IPOPOS(2,MAXIPX),IPORES(MAXIPX),
28444      &                IPOIX1,IPOIX2,IPOIX3
28445 C  standard particle data interface
28446       INTEGER NMXHEP
28447       PARAMETER (NMXHEP=4000)
28448       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28449       DOUBLE PRECISION PHEP,VHEP
28450       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28451      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28452      &                VHEP(4,NMXHEP)
28453 C  extension to standard particle data interface (PHOJET specific)
28454       INTEGER IMPART,IPHIST,ICOLOR
28455       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28456
28457       DIMENSION PD(4)
28458
28459       if(IMODE.ne.1) return
28460
28461       IREJ = 0
28462       IP = 4
28463 C  select first diffraction
28464       IF(DT_RNDM(DUM).GT.0.5D0) THEN
28465         IPAR1 = 1
28466         IPAR2 = 0
28467       ELSE
28468         IPAR1 = 0
28469         IPAR2 = 1
28470       ENDIF
28471       ITRY2 = 0
28472       ITRYM = 1000
28473
28474 C  save current status
28475       MSOFT = 0
28476       MHARD = 0
28477       KHPOMS = KHPOM
28478       KSPOMS = KSPOM
28479       KSREGS = KSREG
28480       KHDIRS = KHDIR
28481       IPOIS1 = IPOIX1
28482       IPOIS2 = IPOIX2
28483       IPOIS3 = IPOIX3
28484       JDA11 = JDAHEP(1,IMOTH1)
28485       JDA21 = JDAHEP(2,IMOTH1)
28486       JDA12 = JDAHEP(1,IMOTH2)
28487       JDA22 = JDAHEP(2,IMOTH2)
28488       ISTH1 = ISTHEP(IMOTH1)
28489       ISTH2 = ISTHEP(IMOTH2)
28490       NHEPS = NHEP
28491
28492 C  find mother particle production process
28493       IGEN = IPHIST(2,IMOTH1)
28494       if(IGEN.eq.0) IGEN = 4
28495
28496 C  main generation loop
28497  60   CONTINUE
28498
28499       KSPOM = KSPOMS
28500       KHPOM = KHPOMS
28501       KHDIR = KHDIRS
28502       KSREG = KSREGS
28503       I1 = IPAR1
28504       I2 = IPAR2
28505 C  reset mother-daugther relations
28506       NHEP = NHEPS
28507       JDAHEP(1,IMOTH1) = JDA11
28508       JDAHEP(2,IMOTH1) = JDA21
28509       JDAHEP(1,IMOTH2) = JDA12
28510       JDAHEP(2,IMOTH2) = JDA22
28511       ISTHEP(IMOTH1) = ISTH1
28512       ISTHEP(IMOTH2) = ISTH2
28513       IPOIX1 = IPOIS1
28514       IPOIX2 = IPOIS2
28515       IPOIX3 = IPOIS3
28516 C  rejection counter
28517       ITRY2 = ITRY2+1
28518       IF(ITRY2.GT.1) THEN
28519         IFAIL(39) = IFAIL(39)+1
28520         IF(ITRY2.GE.ITRYM) GOTO 50
28521       ENDIF
28522 C  generate two diffractive events
28523       CALL PHO_DIFDIS(I1,I2,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
28524       IF(IREJ.NE.0) GOTO 50
28525       CALL PHO_DIFDIS(I2,I1,IMOTH1,IMOTH2,1.D0,2,MSOFT,MHARD,IREJ)
28526       IF(IREJ.NE.0) GOTO 50
28527 C  mass of pomeron-pomeron system
28528       DO 100 I2 = NHEP,1,-1
28529         IF(IDHEP(I2).EQ.990) GOTO 110
28530  100  CONTINUE
28531  110  CONTINUE
28532       DO 120 I1 = I2-1,1,-1
28533         IF(IDHEP(I1).EQ.990) GOTO 130
28534  120  CONTINUE
28535  130  CONTINUE
28536       DO 140 I=1,4
28537         PD(I) = PHEP(I,I1)+PHEP(I,I2)
28538  140  CONTINUE
28539       XMASS = (PD(4)-PD(3))*(PD(4)+PD(3))-PD(1)**2-PD(2)**2
28540       IF(IDEB(59).GE.20) WRITE(LO,'(1X,A,2I3,E12.4)')
28541      &  'PHO_CDIFF: IPOM1,IPOM2,MASS**2',I1,I2,XMASS
28542       IF(XMASS.LT.0.1D0) GOTO 60
28543       XMASS = SQRT(XMASS)
28544       IF(XMASS.LT.PARMDL(71)) GOTO 60
28545
28546 C  sample pomeron-pomeron interaction process
28547       CALL PHO_DIFPRO(4,ISWMDL(17),990,990,XMASS,0.D0,0.D0,1.D0,
28548      &            IPROC,ISAM,JSAM,KSAM,IDIR)
28549
28550 C  non-diffractive pomeron-pomeron interactions
28551       IF((IPROC.EQ.1).OR.(IPROC.EQ.8)) THEN
28552  200    CONTINUE
28553         IF(ISAM+JSAM+KSAM+IDIR.EQ.0) JSAM = 1
28554 C  debug output
28555         IF(IDEB(59).GE.15) WRITE(LO,'(1X,A,/5X,I3,E12.4,4I5)')
28556      &    'PHO_CDIFF: IP,XMASS,ISAM,JSAM,KSAM,IDIR,',
28557      &    IP,XMASS,ISAM,JSAM,KSAM,IDIR
28558 C  store debug information
28559         IF(IDIR.GT.0) THEN
28560           IPAR = 4
28561         ELSE IF(KSAM.GT.0) THEN
28562           IPAR = 3
28563         ELSE IF(ISAM.GT.0) THEN
28564           IPAR = 2
28565         ELSE
28566           IPAR = 1
28567         ENDIF
28568         IDDPOM = IPAR
28569         IF(ISAM+JSAM.GT.0) KSDPO = 1
28570         IF(KSAM+IDIR.GT.0) KHDPO = 1
28571         KSPOM = ISAM
28572         KSREG = JSAM
28573         KHPOM = KSAM
28574         KHDIR = IDIR
28575         KSTRG = 0
28576         KSLOO = 0
28577 C  generate pomeron-pomeron interaction
28578         CALL PHO_STDPAR(I1,I2,IGEN,ISAM,JSAM,KSAM,IDIR,IREJ)
28579         IF(IREJ.NE.0) THEN
28580           IFAIL(3) = IFAIL(3)+1
28581           IF(IPAR.GT.1) THEN
28582             IF(IPAR.EQ.3) IFAIL(9) = IFAIL(9)+1
28583             IF(IDIR.GT.0) THEN
28584               IFAIL(10) = IFAIL(10)+1
28585               IDIR = 0
28586             ELSE IF(KSAM.GT.0) THEN
28587               KSAM = KSAM-1
28588             ELSE IF(ISAM.GT.0) THEN
28589               ISAM = ISAM-1
28590             ENDIF
28591             GOTO 200
28592           ELSE
28593             IF(IDEB(59).GE.2) WRITE(LO,'(1X,A,2I3,E11.3)')
28594      &        'PHO_CDIFF: rejection by PHO_STDPAR (I,IPAR,XM)',
28595      &        I,IPAR,XMASS
28596             GOTO 50
28597           ENDIF
28598         ENDIF
28599
28600 C  diffractive pomeron-pomeron interactions
28601       ELSE
28602         IPOIX2 = IPOIX2+1
28603         IPORES(IPOIX2)   = IPROC
28604         IPOPOS(1,IPOIX2) = I1
28605         IPOPOS(2,IPOIX2) = I2
28606         IPAR = 10+IPROC
28607         IDDPOM = IPAR
28608       ENDIF
28609
28610 C  update debug information
28611       KSPOM = KSPOMS+ISAM
28612       KSREG = KSREGS+JSAM
28613       KHPOM = KHPOMS+KSAM
28614       KHDIR = KHDIRS+IDIR
28615 C  comment line for central diffraction
28616       CALL PHO_REGPAR(40,4,IPAR,IMOTH1,IMOTH2,PD(1),PD(2),PD(3),PD(4),
28617      &            I1,I2,IDHEP(IMOTH1),IDHEP(IMOTH2),IPOS,1)
28618       PHEP(5,IPOS) = XMASS
28619 C  debug output
28620       IF(IDEB(59).GE.15) THEN
28621         WRITE(LO,'(2(/1X,A))') 'PHO_CDIFF: output of /POEVT1/',
28622      &                        '-----------------------------'
28623         CALL PHO_PREVNT(0)
28624       ENDIF
28625       RETURN
28626
28627 C  treatment of rejection
28628  50   CONTINUE
28629       IREJ = 1
28630       IFAIL(40) = IFAIL(40)+1
28631       IF(IDEB(59).GE.3) THEN
28632         WRITE(LO,'(1X,A)')
28633      &    'PHO_CDIFF: rejection (ITRY,ITRYM)',ITRY2,ITRYM
28634         IF(IDEB(59).GE.10) THEN
28635           CALL PHO_PREVNT(0)
28636         ELSE
28637           CALL PHO_PREVNT(-1)
28638         ENDIF
28639       ENDIF
28640
28641       END
28642
28643 *$ CREATE PHO_SAMASS.FOR
28644 *COPY PHO_SAMASS
28645 CDECK  ID>, PHO_SAMASS
28646       SUBROUTINE PHO_SAMASS(IFLA,RMASS)
28647 C**********************************************************************
28648 C
28649 C     resonance mass sampling of quasi elastic processes
28650 C
28651 C     input:   IFLA       PDG number of particle
28652 C              IFLA   -1  initialization
28653 C              IFLA   -2  output of statistics
28654 C
28655 C     output:  RMASS      particle mass (in GeV)
28656 C
28657 C**********************************************************************
28658       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28659       SAVE
28660
28661       PARAMETER(EPS  = 1.D-10 )
28662
28663 C  input/output channels
28664       INTEGER LI,LO
28665       COMMON /POINOU/ LI,LO
28666 C  event debugging information
28667       INTEGER NMAXD
28668       PARAMETER (NMAXD=100)
28669       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28670      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28671       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28672      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28673 C  model switches and parameters
28674       CHARACTER*8 MDLNA
28675       INTEGER ISWMDL,IPAMDL
28676       DOUBLE PRECISION PARMDL
28677       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28678 C  parameters of the "simple" Vector Dominance Model
28679       DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
28680       COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
28681
28682       PARAMETER(NTABM=50)
28683       DIMENSION XMA(4,NTABM),XMC(4,NTABM),RMA(4,NTABM)
28684       DIMENSION SUM(4),ICALL(4)
28685
28686 C*****************************************************************
28687 C  initialization of tables
28688       IF(IFLA.EQ.-1) THEN
28689 C
28690         NSTEP = NTABM
28691         DO 102 I=1,4
28692           ICALL(I) = 0
28693           DELTAM=(RMAX(I)-RMIN(I))/DBLE(NSTEP-1)
28694           DO 105 K=1,NSTEP
28695             RMA(I,K)=RMIN(I)+DELTAM*DBLE(K-1)
28696  105      CONTINUE
28697  102    CONTINUE
28698 C  calculate table of dsig/dm
28699         CALL PHO_DSIGDM(RMA,XMA,NSTEP)
28700 C  output of table
28701         IF(IDEB(35).GE.1) THEN
28702           WRITE(LO,'(/5X,A)') 'table:   mass (GeV)  DSIG/DM (mub/GeV)'
28703           WRITE(LO,'(1X,A,/1X,A)')
28704      &      '  (m,  rho,     m,  omega,      m,   phi,    m,  pi+pi-)',
28705      &      ' -------------------------------------------------------'
28706           DO 106 K=1,NSTEP
28707             WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMA(1,K),
28708      &        RMA(2,K),XMA(2,K),RMA(3,K),XMA(3,K),RMA(4,K),XMA(4,K)
28709  106      CONTINUE
28710         ENDIF
28711 C  make second table for sampling
28712         DO 109 I=1,4
28713           SUM(I) = 0.D0
28714           DO 108 K=2,NSTEP
28715             SUM(I) = SUM(I) + (XMA(I,K-1)+XMA(I,K))/2.D0
28716             XMC(I,K) = SUM(I)
28717  108      CONTINUE
28718  109    CONTINUE
28719 C  normalization
28720         DO 118 K=1,NSTEP
28721           DO 119 I=1,4
28722             XMC(I,K) = XMC(I,K)/XMC(I,NSTEP)
28723  119      CONTINUE
28724  118    CONTINUE
28725         IF(IDEB(35).GE.10) THEN
28726           WRITE(LO,'(/5X,A)') 'PHO_DSIGDM: normalized summed table:'
28727           WRITE(LO,'(1X,A,/1X,A)')
28728      &      '  (m,  rho,     m,  omega,      m,   phi,    m,  pi+pi-)',
28729      &      ' -------------------------------------------------------'
28730           DO 120 K=1,NSTEP
28731             WRITE(LO,'(1X,8E12.3)') RMA(1,K),XMC(1,K),
28732      &        RMA(2,K),XMC(2,K),RMA(3,K),XMC(3,K),RMA(4,K),XMC(4,K)
28733  120      CONTINUE
28734         ENDIF
28735 C
28736 C**************************************************
28737 C  output of statistics
28738       ELSE IF(IFLA.EQ.-2) THEN
28739         WRITE(LO,'(2(/1X,A))') 'PHO_SAMASS: statistics',
28740      &                        '----------------------'
28741         WRITE(LO,'(4(/8X,A,I10))') 'rho:   ',ICALL(1),
28742      &    'omega: ',ICALL(2),'phi:   ',ICALL(3),'pi+pi-:',ICALL(4)
28743 C
28744 C********************************************************
28745 C  sampling of RMASS
28746       ELSE
28747 C  quasi-elastic vector meson production
28748         IF(IFLA.EQ.113) THEN
28749           KP = 1
28750         ELSE IF(IFLA.EQ.223) THEN
28751           KP = 2
28752         ELSE IF(IFLA.EQ.333) THEN
28753           KP = 3
28754         ELSE IF(IFLA.EQ.92) THEN
28755           KP = 4
28756 C  quasi-elastic production of h*
28757         ELSE IF(IFLA.EQ.91) THEN
28758           RMASS = 0.35D0
28759           RETURN
28760 C  elastic hadron scattering
28761         ELSE
28762           RMASS = PHO_PMASS(IFLA,1)
28763           IF(IDEB(35).GE.20) WRITE(LO,'(1X,A,I7,E12.3)')
28764      &      'PHO_SAMASS: IFLA,MASS',IFLA,RMASS
28765           RETURN
28766         ENDIF
28767 C
28768 C  sample mass of vector mesonsn / two-pi background
28769         XI = DT_RNDM(RMASS) + EPS
28770 C  binary search
28771         IF((XMC(KP,1).LE.XI).AND.(XMC(KP,NSTEP).GE.XI)) THEN
28772           KMIN=1
28773           KMAX=NSTEP
28774  300      CONTINUE
28775           IF((KMAX-KMIN).EQ.1) GOTO 400
28776           KK=(KMAX+KMIN)/2
28777           IF(XI.LE.XMC(KP,KK)) THEN
28778             KMAX=KK
28779           ELSE
28780             KMIN=KK
28781           ENDIF
28782           GOTO 300
28783  400      CONTINUE
28784         ELSE
28785           WRITE(LO,'(1X,A)') 'PHO_SAMASS:ERROR:XI out of range'
28786           WRITE(LO,'(5X,A,I7,I6,3E12.4)') 'EVENT,IFLA,XI,XImin,XImax',
28787      &      KEVENT,IFLA,XI,XMC(KP,1),XMC(KP,NSTEP)
28788           CALL PHO_ABORT
28789         ENDIF
28790 C  fine interpolation
28791         RMASS = RMA(KP,KMIN)+
28792      &          (RMA(KP,KMAX)-RMA(KP,KMIN))/
28793      &          (XMC(KP,KMAX)-XMC(KP,KMIN))
28794      &          *(XI-XMC(KP,KMIN))
28795         IF(IDEB(35).GE.20) THEN
28796           IF(IDEB(35).GE.25) WRITE(LO,'(1X,A,3E15.3)')
28797      &      'PHO_SAMASS: MLEFT,MRIGHT,RMASS',
28798      &      RMA(KP,KMIN),RMA(KP,KMAX),RMASS
28799           WRITE(LO,'(1X,A,I7,E12.3)') 'PHO_SAMASS: IFLA,MASS',
28800      &      IFLA,RMASS
28801         ENDIF
28802         ICALL(KP) = ICALL(KP)+1
28803       ENDIF
28804       END
28805
28806 *$ CREATE PHO_DSIGDM.FOR
28807 *COPY PHO_DSIGDM
28808 CDECK  ID>, PHO_DSIGDM
28809       SUBROUTINE PHO_DSIGDM(RMA,XMA,NSTEP)
28810 C**********************************************************************
28811 C
28812 C     differential cross section DSIG/DM of low mass enhancement
28813 C
28814 C     input:   RMA(4,NTABM)   mass values
28815 C     output:  XMA(4,NTABM)   DSIG/DM of resonances
28816 C                  1          rho production
28817 C                  2          omega production
28818 C                  3          phi production
28819 C                  4          pi-pi continuum
28820 C
28821 C**********************************************************************
28822       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28823       SAVE
28824
28825       PARAMETER ( EPS  = 1.D-10 )
28826
28827       PARAMETER(NTABM=50)
28828       DIMENSION XMA(4,NTABM),RMA(4,NTABM)
28829
28830 C  input/output channels
28831       INTEGER LI,LO
28832       COMMON /POINOU/ LI,LO
28833 C  event debugging information
28834       INTEGER NMAXD
28835       PARAMETER (NMAXD=100)
28836       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28837      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28838       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28839      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28840 C  model switches and parameters
28841       CHARACTER*8 MDLNA
28842       INTEGER ISWMDL,IPAMDL
28843       DOUBLE PRECISION PARMDL
28844       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28845 C  parameters of the "simple" Vector Dominance Model
28846       DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
28847       COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
28848
28849       PIMASS = 0.135
28850 C  rho meson shape (mass dependent width)
28851       QRES = SQRT(VMAS(1)**2 - 4.D0*PIMASS**2)
28852       DO 100 I=1,NSTEP
28853         XMASS = RMA(1,I)
28854         QQ = SQRT(XMASS**2 - 4.D0*PIMASS**2)
28855         GAMMA = GAMM(1)*(QQ/QRES)**3
28856         XMA(1,I) = XMASS*GAMMA*(VMAS(1)/XMASS)**PARMDL(170)
28857      &             /((VMAS(1)**2-XMASS**2)**2+VMAS(1)**2*GAMMA**2)
28858  100  CONTINUE
28859 C  omega/phi meson (constant width)
28860       DO 200 K=2,3
28861         DO 300 I=1,NSTEP
28862           XMASS = RMA(K,I)
28863           XMA(K,I) = XMASS*GAMM(K)
28864      &               /((VMAS(K)**2-XMASS**2)**2+VMAS(K)**2*GAMM(K)**2)
28865  300    CONTINUE
28866  200  CONTINUE
28867 C  pi-pi continuum
28868       DO 400 I=1,NSTEP
28869         XMASS = RMA(4,I)
28870         XMA(4,I) = (XMASS-0.29D0)**2/XMASS
28871  400  CONTINUE
28872
28873       END
28874
28875 *$ CREATE PHO_SDECAY.FOR
28876 *COPY PHO_SDECAY
28877 CDECK  ID>, PHO_SDECAY
28878       SUBROUTINE PHO_SDECAY(NPOS,ISP,ILEV)
28879 C**********************************************************************
28880 C
28881 C     decay of single resonance of /POEVT1/:
28882 C       decay in helicity frame according to polarization, isotropic
28883 C       decay and decay with limited transverse phase space possible
28884 C
28885 C     ATTENTION:
28886 C     reference to particle number of CPC has to exist
28887 C
28888 C     input:   NPOS    position in /POEVT1/
28889 C              ISP     0  decay according to phase space
28890 C                      1  decay according to transversal polarization
28891 C                      2  decay according to longitudinal polarization
28892 C                      3  decay with limited phase space
28893 C              ILEV    decay mode to use
28894 C                      1 strong only
28895 C                      2 strong and ew of tau, charm, and bottom
28896 C                      3 strong and electro-weak decays
28897 C                      negative: remove mother resonance after decay
28898 C
28899 C     output:  /POEVT1/,/POEVT2/ final particles according to decay mode
28900 C
28901 C**********************************************************************
28902       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28903       SAVE
28904
28905       PARAMETER ( EPS  = 1.D-15,
28906      &            DEPS = 1.D-10 )
28907
28908 C  input/output channels
28909       INTEGER LI,LO
28910       COMMON /POINOU/ LI,LO
28911 C  event debugging information
28912       INTEGER NMAXD
28913       PARAMETER (NMAXD=100)
28914       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
28915      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28916       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
28917      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
28918 C  model switches and parameters
28919       CHARACTER*8 MDLNA
28920       INTEGER ISWMDL,IPAMDL
28921       DOUBLE PRECISION PARMDL
28922       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
28923 C  some constants
28924       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
28925       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
28926      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
28927 C  standard particle data interface
28928       INTEGER NMXHEP
28929       PARAMETER (NMXHEP=4000)
28930       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28931       DOUBLE PRECISION PHEP,VHEP
28932       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28933      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28934      &                VHEP(4,NMXHEP)
28935 C  extension to standard particle data interface (PHOJET specific)
28936       INTEGER IMPART,IPHIST,ICOLOR
28937       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28938 C  general particle data
28939       double precision xm_list,tau_list,gam_list,
28940      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
28941      &  xm_bb82_list,xm_bb102_list
28942       integer          ich3_list,iba3_list,iq_list,
28943      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
28944       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
28945      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
28946      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
28947      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
28948      &  ich3_list(300),iba3_list(300),iq_list(3,300),
28949      &  id_psm_list(6,6),id_vem_list(6,6),
28950      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
28951 C  particle decay data
28952       double precision wg_sec_list
28953       integer          idec_list,isec_list
28954       COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
28955      &  isec_list(3,500)
28956 C  auxiliary data for three particle decay
28957       DOUBLE PRECISION ECM,PCM,COD,COF,SIF
28958       COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
28959
28960       DIMENSION WGHD(20),KCH(20),ID(3)
28961
28962       IMODE = ABS(ILEV)
28963       IF(IDEB(36).GE.15) WRITE(LO,'(1X,A,3I5)')
28964      &  'PHO_SDECAY: NPOS,ISP,ILEV',NPOS,ISP,ILEV
28965
28966 C  comment entry
28967       IF(ISTHEP(NPOS).GT.11) RETURN
28968
28969 C  particle stable?
28970       IDcpc = IMPART(NPOS)
28971       IF(IDcpc.EQ.0) return
28972       IDabs = iabs(IDcpc)
28973       if(idec_list(1,IDabs).eq.0) return
28974
28975 C  different decay modi (times)
28976       IF(IMODE.EQ.1) THEN
28977         if(idec_list(1,IDabs).ne.1) return
28978       ELSE IF(IMODE.EQ.2) THEN
28979         if(idec_list(1,IDabs).gt.2) return
28980       ELSE IF(IMODE.EQ.3) THEN
28981         if(idec_list(1,IDabs).gt.3) return
28982       ELSE
28983         WRITE(LO,'(/1X,A,I5)') 'PHO_SDECAY: invalid mode (ILEV)',ILEV
28984         CALL PHO_ABORT
28985       ENDIF
28986
28987 C  decay products, check for mass limitations
28988       K = 0
28989       WGSUM = 0.D0
28990       AMIST = PHEP(5,NPOS)
28991       DO 100 I=idec_list(2,IDabs),idec_list(3,IDabs)
28992         AMSUM = 0.D0
28993         DO 200 L=1,3
28994           ID(L) = isec_list(L,I)
28995           IF(ID(L).NE.0) AMSUM = AMSUM+pho_pmass(ID(L),0)
28996  200    CONTINUE
28997         IF(AMSUM.LT.AMIST) THEN
28998           K = K+1
28999           WGHD(K) = wg_sec_list(I)
29000           KCH(K) = I
29001         ENDIF
29002  100  CONTINUE
29003       IF(K.EQ.0)THEN
29004         WRITE(LO,'(/1X,A,I6,3E12.4)')
29005      &    'PHO_SDECAY: particle mass too small (NPOS,MA,DCYM)',
29006      &    NPOS,AMIST,AMSUM
29007         CALL PHO_PREVNT(0)
29008         RETURN
29009       ENDIF
29010
29011 C  sample new decay channel
29012       XI = (DT_RNDM(AMSUM)-EPS)*WGSUM
29013       K = 0
29014       WGSUM = 0.D0
29015  500  CONTINUE
29016         K = K+1
29017         WGSUM = WGSUM+WGHD(K)
29018       IF(XI.GT.WGSUM) GOTO 500
29019       IK = KCH(K)
29020       ID(1) = isec_list(1,IK)
29021       ID(2) = isec_list(2,IK)
29022       ID(3) = isec_list(3,IK)
29023       if(IDcpc.lt.0) then
29024         ID(1) = ipho_anti(ID(1))
29025         ID(2) = ipho_anti(ID(2))
29026         if(ID(3).ne.0) ID(3) = ipho_anti(ID(3))
29027       endif
29028
29029 C  rotation
29030       PTOT = SQRT(PHEP(1,NPOS)**2+PHEP(2,NPOS)**2+PHEP(3,NPOS)**2)
29031       CXS = PHEP(1,NPOS)/PTOT
29032       CYS = PHEP(2,NPOS)/PTOT
29033       CZS = PHEP(3,NPOS)/PTOT
29034 C  boost
29035       GBET = PTOT/AMIST
29036       GAM = PHEP(4,NPOS)/AMIST
29037
29038       IF(ID(3).EQ.0) THEN
29039 C  two particle decay
29040         CALL PHO_SDECY2(AMIST,pho_pmass(ID(1),0),pho_pmass(ID(2),0),ISP)
29041       ELSE
29042 C  three particle decay
29043         CALL PHO_SDECY3(AMIST,pho_pmass(ID(1),0),pho_pmass(ID(2),0),
29044      &    pho_pmass(ID(3),0),ISP)
29045       ENDIF
29046
29047       IF(ILEV.LT.0) THEN
29048         IF(NHEP.NE.NPOS) THEN
29049           WRITE(LO,'(/1X,2A,2I5)') 'PHO_SDECAY:ERROR: ',
29050      &      'cannot remove resonance (NPOS,NHEP)',NPOS,NHEP
29051           CALL PHO_ABORT
29052         ENDIF
29053         IMO1 = JMOHEP(1,NPOS)
29054         IMO2 = JMOHEP(2,NPOS)
29055         NHEP = NHEP-1
29056       ELSE
29057         IMO1 = NPOS
29058         IMO2 = 0
29059       ENDIF
29060       IPH1 = IPHIST(1,NPOS)
29061       IPH2 = IPHIST(2,NPOS)
29062
29063 C  back transformation and registration
29064       DO 300 I=1,3
29065         IF(ID(I).NE.0) THEN
29066           CALL PHO_LTRANS(GAM,GBET,CXS,CYS,CZS,COD(I),COF(I),SIF(I),
29067      &      PCM(I),ECM(I),PTOT,CX,CY,CZ,EE)
29068           XX = PTOT*CX
29069           YY = PTOT*CY
29070           ZZ = PTOT*CZ
29071           CALL PHO_REGPAR(1,0,ID(I),IMO1,IMO2,XX,YY,ZZ,EE,
29072      &      IPH1,IPH2,0,0,IPOS,1)
29073         ENDIF
29074  300  CONTINUE
29075
29076  400  CONTINUE
29077 C  debug output
29078       IF(IDEB(36).GE.20) THEN
29079         WRITE(LO,'(2(/1X,A))') 'PHO_SDECAY: /POEVT1/',
29080      &                        '--------------------'
29081         CALL PHO_PREVNT(0)
29082       ENDIF
29083
29084       END
29085
29086 *$ CREATE PHO_SDECY2.FOR
29087 *COPY PHO_SDECY2
29088 CDECK  ID>, PHO_SDECY2
29089       SUBROUTINE PHO_SDECY2(UMO,AM1,AM2,ISP)
29090 C**********************************************************************
29091 C
29092 C     isotropic/anisotropic two particle decay in CM system,
29093 C     (transversely/longitudinally polarized boson into two
29094 C     pseudo-scalar mesons)
29095 C
29096 C**********************************************************************
29097       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29098       SAVE
29099
29100 C  input/output channels
29101       INTEGER LI,LO
29102       COMMON /POINOU/ LI,LO
29103 C  auxiliary data for three particle decay
29104       DOUBLE PRECISION ECM,PCM,COD,COF,SIF
29105       COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
29106
29107       UMO2=UMO*UMO
29108       AM11=AM1*AM1
29109       AM22=AM2*AM2
29110       ECM(1)=(UMO2+AM11-AM22)/(2.D0*UMO)
29111       ECM(2)=UMO-ECM(1)
29112       WAU=ECM(1)*ECM(1)-AM11
29113       IF(WAU.LT.0.D0) THEN
29114         WRITE(LO,'(/1X,A,E12.4)') 'PHO_SDECY2:ERROR:too small mass',WAU
29115         CALL PHO_ABORT
29116       ENDIF
29117       PCM(1)=SQRT(WAU)
29118       PCM(2)=PCM(1)
29119
29120       CALL PHO_SFECFE(SIF(1),COF(1))
29121       IF(ISP.EQ.0) THEN
29122 C  no polarization
29123         COD(1)  = 2.D0*DT_RNDM(UMO)-1.D0
29124       ELSE IF(ISP.EQ.1) THEN
29125 C  transverse polarization
29126  400    CONTINUE
29127           COD(1)  = 2.D0*DT_RNDM(AM22)-1.D0
29128           SID12 = 1.D0-COD(1)*COD(1)
29129         IF(SID12.LT.DT_RNDM(AM1)) GOTO 400
29130       ELSE IF(ISP.EQ.2) THEN
29131 C  longitudinal polarization
29132  500    CONTINUE
29133           COD(1)  = 2.D0*DT_RNDM(AM2)-1.D0
29134           COD12 = COD(1)*COD(1)
29135         IF(COD12.LT.DT_RNDM(AM11)) GOTO 500
29136       ELSE
29137         WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY2:ERROR: ',
29138      &    'invalid polarization',ISP
29139         CALL PHO_ABORT
29140       ENDIF
29141
29142       COD(2) = -COD(1)
29143       COF(2) = -COF(1)
29144       SIF(2) = -SIF(1)
29145
29146       END
29147
29148 *$ CREATE PHO_SDECY3.FOR
29149 *COPY PHO_SDECY3
29150 CDECK  ID>, PHO_SDECY3
29151       SUBROUTINE PHO_SDECY3(UMO,AM1,AM2,AM3,ISP)
29152 C**********************************************************************
29153 C
29154 C     isotropic/anisotropic three particle decay in CM system,
29155 C     (transversely/longitudinally polarized boson into three
29156 C     pseudo-scalar mesons)
29157 C
29158 C**********************************************************************
29159       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29160       SAVE
29161
29162       PARAMETER ( DEPS   = 1.D-30,
29163      &            EPS    = 1.D-15 )
29164
29165 C  input/output channels
29166       INTEGER LI,LO
29167       COMMON /POINOU/ LI,LO
29168 C  auxiliary data for three particle decay
29169       DOUBLE PRECISION ECM,PCM,COD,COF,SIF
29170       COMMON /PO3DCY/ ECM(3),PCM(3),COD(3),COF(3),SIF(3)
29171
29172       DIMENSION F(5),XX(5)
29173
29174 C  calculation of maximum of S2 phase space weight
29175       UMOO=UMO+UMO
29176       GU=(AM2+AM3)**2
29177       GO=(UMO-AM1)**2
29178       UFAK=1.0000000000001D0
29179       IF (GU.GT.GO) UFAK=0.99999999999999D0
29180       OFAK=2.D0-UFAK
29181       GU=GU*UFAK
29182       GO=GO*OFAK
29183       DS2=(GO-GU)/99.D0
29184       AM11=AM1*AM1
29185       AM22=AM2*AM2
29186       AM33=AM3*AM3
29187       UMO2=UMO*UMO
29188       RHO2=0.D0
29189       S22=GU
29190       DO 124 I=1,100
29191         S21=S22
29192         S22=GU+(I-1.D0)*DS2
29193         RHO1=RHO2
29194         RHO2=PHO_XLAM(S22,UMO2,AM11)*PHO_XLAM(S22,AM22,AM33)/(S22+EPS)
29195         IF(RHO2.LT.RHO1) GOTO 125
29196   124 CONTINUE
29197
29198   125 CONTINUE
29199       S2SUP=(S22-S21)/2.D0+S21
29200       SUPRHO=PHO_XLAM(S2SUP,UMO2,AM11)*PHO_XLAM(S2SUP,AM22,AM33)
29201      &       /(S2SUP+EPS)
29202       SUPRHO=SUPRHO*1.05D0
29203       XO=S21-DS2
29204       IF(GU.LT.GO.AND.XO.LT.GU) XO=GU
29205       IF(GU.GT.GO.AND.XO.GT.GU) XO=GU
29206       XX(1)=XO
29207       XX(3)=S22
29208       X1=(XO+S22)*0.5D0
29209       XX(2)=X1
29210       F(3)=RHO2
29211       F(1)=PHO_XLAM(XO,UMO2,AM11)*PHO_XLAM(XO,AM22,AM33)/(XO+EPS)
29212       F(2)=PHO_XLAM(X1,UMO2,AM11)*PHO_XLAM(X1,AM22,AM33)/(X1+EPS)
29213       DO 126 I=1,16
29214         X4=(XX(1)+XX(2))*0.5D0
29215         X5=(XX(2)+XX(3))*0.5D0
29216         F(4)=PHO_XLAM(X4,UMO2,AM11)*PHO_XLAM(X4,AM22,AM33)/(X4+EPS)
29217         F(5)=PHO_XLAM(X5,UMO2,AM11)*PHO_XLAM(X5,AM22,AM33)/(X5+EPS)
29218         XX(4)=X4
29219         XX(5)=X5
29220         DO 128 II=1,5
29221           IA=II
29222           DO 131 III=IA,5
29223             IF(F(II).LT.F(III)) THEN
29224               FH=F(II)
29225               F(II)=F(III)
29226               F(III)=FH
29227               FH=XX(II)
29228               XX(II)=XX(III)
29229               XX(III)=FH
29230             ENDIF
29231  131      CONTINUE
29232  128    CONTINUE
29233         SUPRHO=F(1)
29234         S2SUP=XX(1)
29235         DO 129 II=1,3
29236           IA=II
29237           DO 130 III=IA,3
29238             IF (XX(II).LT.XX(III)) THEN
29239               FH=F(II)
29240               F(II)=F(III)
29241               F(III)=FH
29242               FH=XX(II)
29243               XX(II)=XX(III)
29244               XX(III)=FH
29245             ENDIF
29246  130      CONTINUE
29247  129    CONTINUE
29248  126  CONTINUE
29249
29250       AM23=(AM2+AM3)**2
29251
29252 C  selection of S1
29253       ITH=0
29254  200  CONTINUE
29255         ITH=ITH+1
29256         IF(ITH.GT.200) THEN
29257           WRITE(LO,'(/1X,A,I10)')
29258      &      'PHO_SDECY3:ERROR: too many iterations',ITH
29259           CALL PHO_ABORT
29260         ENDIF
29261         S2=AM23+DT_RNDM(AM2)*((UMO-AM1)**2-AM23)
29262         Y=DT_RNDM(AM23)*SUPRHO
29263         RHO=PHO_XLAM(S2,UMO2,AM11)*PHO_XLAM(S2,AM22,AM33)/S2
29264       IF(Y.GT.RHO) GOTO 200
29265
29266 C  selection of S2
29267       S1=DT_RNDM(AM2)*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)
29268      &   /(2.D0*S2)-RHO/2.D0
29269       S3=UMO2+AM11+AM22+AM33-S1-S2
29270       ECM(1)=(UMO2+AM11-S2)/UMOO
29271       ECM(2)=(UMO2+AM22-S3)/UMOO
29272       ECM(3)=(UMO2+AM33-S1)/UMOO
29273       PCM(1)=SQRT((ECM(1)+AM1)*(ECM(1)-AM1))
29274       PCM(2)=SQRT((ECM(2)+AM2)*(ECM(2)-AM2))
29275       PCM(3)=SQRT((ECM(3)+AM3)*(ECM(3)-AM3))
29276
29277 C  calculation of angles: TH between p1,p2; TH1 p3,p1; TH2 p3,p2
29278       IF((PCM(1).LE.EPS).OR.(PCM(2).LE.EPS)) THEN
29279         COSTH=(DT_RNDM(S1)-0.5D0)*2.D0
29280       ELSE
29281         COSTH=(ECM(1)*ECM(2)+0.5D0*(AM11+AM22-S1))/(PCM(1)*PCM(2))
29282       ENDIF
29283       COSTH2=(PCM(3)*PCM(3)+PCM(2)*PCM(2)-PCM(1)*PCM(1))
29284      &        /(2.D0*PCM(2)*PCM(3))
29285       SINTH2=SQRT(1.D0-COSTH2*COSTH2)
29286       SINTH1=COSTH2*SQRT(1.D0-COSTH*COSTH)-COSTH*SINTH2
29287       COSTH1=COSTH*COSTH2+SINTH2*SQRT(1.D0-COSTH*COSTH)
29288
29289 C  selection of the sperical coordinates of particle 3
29290       CALL PHO_SFECFE(SIF(3),COF(3))
29291       IF(ISP.EQ.0) THEN
29292 C  no polarization
29293         COD(3)  = 2.D0*DT_RNDM(S2)-1.D0
29294       ELSE IF(ISP.EQ.1) THEN
29295 C  transverse polarization
29296  400    CONTINUE
29297           COD(3)  = 2.D0*DT_RNDM(S1)-1.D0
29298           SID32 = 1.D0-COD(3)*COD(3)
29299         IF(SID32.LT.DT_RNDM(COSTH)) GOTO 400
29300       ELSE IF(ISP.EQ.2) THEN
29301 C  longitudinal polarization
29302  500    CONTINUE
29303           COD(3)  = 2.D0*DT_RNDM(COSTH2)-1.D0
29304           COD32 = COD(3)*COD(3)
29305         IF(COD32.LT.DT_RNDM(SINTH1)) GOTO 500
29306       ELSE
29307         WRITE(LO,'(/1X,2A,I3)') 'PHO_SDECY3:ERROR: ',
29308      &    'invalid polarization',ISP
29309         CALL PHO_ABORT
29310       ENDIF
29311
29312 C  selection of the rotation angle of p1-p2 plane along p3
29313       IF(ISP.EQ.0) THEN
29314         CALL PHO_SFECFE(SFE,CFE)
29315       ELSE
29316         SFE = 0.D0
29317         CFE = 1.D0
29318       ENDIF
29319       CX11=-COSTH1
29320       CY11=SINTH1*CFE
29321       CZ11=SINTH1*SFE
29322       CX22=-COSTH2
29323       CY22=-SINTH2*CFE
29324       CZ22=-SINTH2*SFE
29325
29326       SID3 = SQRT((1.D0+COD(3))*(1.D0-COD(3)))
29327       COD(1)=CX11*COD(3)+CZ11*SID3
29328       IF((1.D0-COD(1)*COD(1)).LT.DEPS) THEN
29329         WRITE(LO,'(1X,A,5E12.4)') 'PHO_SDECY3: COS(TH1) > 1',
29330      &    COD(1),COF(3),SID3,CX11,CZ11
29331         CALL PHO_PREVNT(-1)
29332       ENDIF
29333
29334       SID1=SQRT((1.D0+COD(1))*(1.D0-COD(1)))
29335       COF(1)=(CX11*SID3*COF(3)-CY11*SIF(3)-CZ11*COD(3)*COF(3))/SID1
29336       SIF(1)=(CX11*SID3*SIF(3)+CY11*COF(3)-CZ11*COD(3)*SIF(3))/SID1
29337       COD(2)=CX22*COD(3)+CZ22*SID3
29338       SID2=SQRT((1.D0+COD(2))*(1.D0-COD(2)))
29339       COF(2)=(CX22*SID3*COF(3)-CY22*SIF(3)-CZ22*COD(3)*COF(3))/SID2
29340       SIF(2)=(CX22*SID3*SIF(3)+CY22*COF(3)-CZ22*COD(3)*SIF(3))/SID2
29341
29342       END
29343
29344 *$ CREATE PHO_DFMASS.FOR
29345 *COPY PHO_DFMASS
29346 CDECK  ID>, PHO_DFMASS
29347       DOUBLE PRECISION FUNCTION PHO_DFMASS(XMIN,XMAX,PREF2,PVIRT2,IMODE)
29348 C**********************************************************************
29349 C
29350 C     sampling of Mx diffractive mass distribution within
29351 C              limits XMIN, XMAX
29352 C
29353 C     input:    XMIN,XMAX     mass limitations (GeV)
29354 C               PREF2         original particle mass/ reference mass
29355 C                             (squared, GeV**2)
29356 C               PVIRT2        particle virtuality
29357 C               IMODE         M**2 mass distribution
29358 C                             1      1/(M**2+Q**2)
29359 C                             2      1/(M**2+Q**2)**alpha
29360 C                            -1      1/(M**2-Mref**2+Q**2)
29361 C                            -2      1/(M**2-Mref**2+Q**2)**alpha
29362 C
29363 C     output:   diffractive mass (GeV)
29364 C
29365 C**********************************************************************
29366       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29367       SAVE
29368
29369       PARAMETER(EPS  = 1.D-10)
29370
29371 C  input/output channels
29372       INTEGER LI,LO
29373       COMMON /POINOU/ LI,LO
29374 C  event debugging information
29375       INTEGER NMAXD
29376       PARAMETER (NMAXD=100)
29377       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29378      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29379       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29380      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29381 C  model switches and parameters
29382       CHARACTER*8 MDLNA
29383       INTEGER ISWMDL,IPAMDL
29384       DOUBLE PRECISION PARMDL
29385       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29386 C  some constants
29387       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29388       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29389      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29390
29391       IF((XMIN.GE.XMAX).OR.(XMIN.LE.0.3D0)) THEN
29392         WRITE(LO,'(/1X,2A,3E12.4)') 'PHO_DFMASS:ERROR: ',
29393      &    'invalid mass limits',XMIN,XMAX,PREF2
29394         CALL PHO_PREVNT(-1)
29395         PHO_DFMASS = 0.135D0
29396         RETURN
29397       ENDIF
29398
29399       IF(IMODE.GT.0) THEN
29400         PM2 = -PVIRT2
29401       ELSE
29402         PM2 = PREF2 - PVIRT2
29403       ENDIF
29404
29405 C  critical pomeron
29406       IF(ABS(IMODE).EQ.1) THEN
29407         XMIN2 = LOG(XMIN**2-PM2)
29408         XMAX2 = LOG(XMAX**2-PM2)
29409         XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
29410         XMA2 = EXP(XI)+PM2
29411
29412 C  supercritical pomeron
29413       ELSE IF(ABS(IMODE).EQ.2) THEN
29414         DDELTA = 1.D0-PARMDL(48)
29415         XMIN2 = (XMIN**2-PM2)**DDELTA
29416         XMAX2 = (XMAX**2-PM2)**DDELTA
29417         XI = (XMAX2-XMIN2)*DT_RNDM(PM2)+XMIN2
29418         XMA2 = XI**(1.D0/DDELTA)+PM2
29419       ELSE
29420         WRITE(LO,'(/,1X,A,I3)')
29421      &    'PHO_DFMASS:ERROR: unsupported mode',IMODE
29422         CALL PHO_ABORT
29423       ENDIF
29424
29425       PHO_DFMASS = SQRT(XMA2)
29426 C  debug output
29427       IF(IDEB(43).GE.15) THEN
29428         WRITE(LO,'(1X,A,4E12.3)') 'PHO_DFMASS:Mmin,Mmax,Mref,Mass',
29429      &    XMIN,XMAX,PREF2,SQRT(XMA2)
29430       ENDIF
29431
29432       END
29433
29434 *$ CREATE PHO_DIFSLP.FOR
29435 *COPY PHO_DIFSLP
29436 CDECK  ID>, PHO_DIFSLP
29437       SUBROUTINE PHO_DIFSLP(IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,XMX,
29438      &                  TT,SLWGHT,IREJ)
29439 C**********************************************************************
29440 C
29441 C     sampling of T  (Mandelstam variable) distribution within
29442 C     certain limits TMIN, TMAX
29443 C
29444 C     input:    IDF1,2     type of diffractive vertex
29445 C                           0   elastic/quasi-elastic scattering
29446 C                           1   diffraction dissociation
29447 C               IVEC1,2    vector meson IDs in case of quasi-elastic
29448 C                          scattering, otherwise 0
29449 C               XM1        mass of diffractive system 1 (GeV)
29450 C               XM2        mass of diffractive system 2 (GeV)
29451 C               XMX        max. mass of diffractive system (GeV)
29452 C
29453 C     output:   TT         squared momentum transfer ( < 0, GeV**2)
29454 C               SLWGHT     weight to allow for mass-dependent slope
29455 C               IREJ       0  successful sampling
29456 C                          1  masses too big for given T range
29457 C
29458 C**********************************************************************
29459       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29460       SAVE
29461
29462       PARAMETER(EPS  = 1.D-10)
29463
29464 C  input/output channels
29465       INTEGER LI,LO
29466       COMMON /POINOU/ LI,LO
29467 C  event debugging information
29468       INTEGER NMAXD
29469       PARAMETER (NMAXD=100)
29470       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29471      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29472       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29473      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29474 C  model switches and parameters
29475       CHARACTER*8 MDLNA
29476       INTEGER ISWMDL,IPAMDL
29477       DOUBLE PRECISION PARMDL
29478       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
29479 C  internal rejection counters
29480       INTEGER NMXJ
29481       PARAMETER (NMXJ=60)
29482       CHARACTER*10 REJTIT
29483       INTEGER IFAIL
29484       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
29485 C  c.m. kinematics of diffraction
29486       INTEGER NPOSD
29487       DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
29488      &                 SIDD,CODD,SIFD,COFD,PDCMS
29489       COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
29490      &                SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
29491 C  cross sections
29492       INTEGER IPFIL,IFAFIL,IFBFIL
29493       DOUBLE PRECISION SIGTOT,SIGELA,SIGVM,SIGINE,SIGNDF,SIGDIR,
29494      &                 SIGLSD,SIGHSD,SIGLDD,SIGHDD,SIGCDF,
29495      &                 SIGPOM,SIGREG,SIGHAR,SIGTR1,SIGTR2,SIGLOO,
29496      &                 SIGDPO,SIG1SO,SIG1HA,SLOEL,SLOVM,SIGCOR,
29497      &                 FSUP,FSUD,FSUH,ECMFIL,P2AFIL,P2BFIL
29498       COMMON /POCSEC/ SIGTOT,SIGELA,SIGVM(0:4,0:4),SIGINE,SIGNDF,SIGDIR,
29499      &                SIGLSD(2),SIGHSD(2),SIGLDD,SIGHDD,SIGCDF(0:4),
29500      &                SIGPOM,SIGREG,SIGHAR,SIGTR1(2),SIGTR2(2),SIGLOO,
29501      &                SIGDPO(4),SIG1SO,SIG1HA,SLOEL,SLOVM(4,4),SIGCOR,
29502      &                FSUP(2),FSUD(2),FSUH(2),ECMFIL,P2AFIL,P2BFIL,
29503      &                IPFIL,IFAFIL,IFBFIL
29504 C  Reggeon phenomenology parameters
29505       DOUBLE PRECISION ALPOM,ALPOMP,GP,B0POM,ALREG,ALREGP,GR,B0REG,
29506      &                 GPPP,GPPR,B0PPP,B0PPR,VDMFAC,VDMQ2F,B0HAR,AKFAC
29507       COMMON /POPREG/ ALPOM,ALPOMP,GP(2),B0POM(2),
29508      &                ALREG,ALREGP,GR(2),B0REG(2),
29509      &                GPPP,GPPR,B0PPP,B0PPR,
29510      &                VDMFAC(4),VDMQ2F(4),B0HAR,AKFAC
29511 C  parameters of 2x2 channel model
29512       DOUBLE PRECISION PHISUP,RMASS,VAR,AMPFAC,ELAFAC,VFAC
29513       COMMON /PO2CHA/ PHISUP(2),RMASS(2),VAR,AMPFAC(4),ELAFAC(4),VFAC
29514 C  parameters of the "simple" Vector Dominance Model
29515       DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
29516       COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
29517 C  some constants
29518       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29519       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29520      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29521
29522       IREJ = 0
29523       XM12 = XM1**2
29524       XM22 = XM2**2
29525       SS = ECMD**2
29526 C
29527 C  range of momentum transfer t
29528       TMIN = -PARMDL(68)
29529       TMAX = -PARMDL(69)
29530 C  determine min. abs(t) necessary to produce masses
29531       PCM2 = PCMD**2
29532       PCMP2 = PHO_XLAM(SS,XM12,XM22)**2/(4.D0*SS)
29533       IF(PCMP2.LE.0.D0) THEN
29534         IREJ = 1
29535         TT = 0.D0
29536         RETURN
29537       ENDIF
29538       TMINP = PMASSD(1)**2+XM12+2.D0*PCMD*SQRT(PCMP2)
29539      &        -2.D0*SQRT((PMASSD(1)**2+PCM2)*(XM12+PCMP2))
29540 C
29541       IF(TMINP.LT.TMAX) THEN
29542         IF(IDEB(44).GE.3) THEN
29543           WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
29544      &      'too large Tmin (XM1/2,TMIN,TMAX,TMINP)',
29545      &      XM1,XM2,TMIN,TMAX,TMINP
29546         ENDIF
29547         IFAIL(32) = IFAIL(32)+1
29548         IREJ = 1
29549         TT = 0.D0
29550         RETURN
29551       ENDIF
29552       TMINA = MIN(TMIN,TMINP)
29553 C
29554 C  calculation of slope (mass-dependent parametrization)
29555       IF(IDF1+IDF2.GT.0) THEN
29556 C  diffraction dissociation
29557         XMP12 = XM1**2+PVIRTD(1)
29558         XMP22 = XM2**2+PVIRTD(2)
29559         XMX1 = SQRT(XMP12)
29560         XMX2 = SQRT(XMP22)
29561         CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
29562         FAC = 4.D0*(PMASSD(1)*PMASSD(2))**2
29563         SLOPE = DBLE(IDF1+IDF2)*B0PPP
29564      &    +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
29565      &    /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
29566         SLOPE = MAX(SLOPE,1.D0)
29567 C
29568         XMA1 = XMX
29569         XMA2 = XMX
29570         IF(IDF1.EQ.0) THEN
29571           XMA1 = XM1
29572         ELSE IF(IDF1.EQ.0) THEN
29573           XMA2 = XM2
29574         ENDIF
29575         XMP12 = XMA1**2+PVIRTD(1)
29576         XMP22 = XMA2**2+PVIRTD(2)
29577         XMX1 = SQRT(XMP12)
29578         XMX2 = SQRT(XMP22)
29579         CALL PHO_SCALES(PMASSD(1),PMASSD(2),XMX1,XMX2,SC1,SC2,SB1,SB2)
29580         SLMIN = DBLE(IDF1+IDF2)*B0PPP
29581      &    +2.D0*(B0POM(1)*SB1+B0POM(2)*SB2+ALPOMP*LOG(SS*FAC
29582      &    /((PMASSD(1)**2+XMP12)*(PMASSD(2)**2+XMP22))+PARMDL(47)))
29583         SLMIN = MAX(SLMIN,1.D0)
29584       ELSE
29585 C  elastic/quasi-elastic scattering
29586         IF(ISWMDL(13).EQ.0) THEN
29587 C  external slope values
29588           WRITE(LO,*) 'PHO_DIFSLP:ERROR: this option is not installed !'
29589           CALL PHO_ABORT
29590         ELSE IF(ISWMDL(13).EQ.1) THEN
29591 C  model slopes
29592           IF(IVEC1*IVEC2.EQ.0) THEN
29593             SLOPE = SLOEL
29594           ELSE
29595             SLOPE = SLOVM(IVEC1,IVEC2)
29596           ENDIF
29597           SLMIN = SLOPE
29598         ELSE
29599           WRITE(LO,'(/1X,A,I5)') 'SASDSDT:ERROR: invalid ISWMDL(13)',
29600      &      ISWMDL(13)
29601           CALL PHO_ABORT
29602         ENDIF
29603       ENDIF
29604 C
29605 C  determine max. abs(t) to avoid underflows
29606       TMAXP = -25.D0/SLOPE
29607       TMAXA = MAX(TMAX,TMAXP)
29608 C
29609       IF(TMINA.LT.TMAXA) THEN
29610         IF(IDEB(44).GE.3) THEN
29611           WRITE(LO,'(1X,2A,/5X,5E12.3)') 'PHO_DIFSLP:REJECTION: ',
29612      &      'too small Tmax (XM1/2,TMINA,TMAXA,SLOPE)',
29613      &      XM1,XM2,TMINA,TMAXA,SLOPE
29614         ENDIF
29615         IFAIL(32) = IFAIL(32)+1
29616         IREJ = 1
29617         TT = 0.D0
29618         RETURN
29619       ENDIF
29620 C
29621 C  sampling from corrected range of T
29622       TMINE = EXP(SLMIN*TMINA)
29623       TMAXE = EXP(SLMIN*TMAXA)
29624       XI = (TMINE-TMAXE)*DT_RNDM(SLMIN)+TMAXE
29625       TT = LOG(XI)/SLMIN
29626       SLWGHT = EXP((SLOPE-SLMIN)*TT)
29627 C
29628 C  debug output
29629       IF(IDEB(44).GE.15) THEN
29630         WRITE(LO,'(1X,A,1P,E12.3/5X,A,2I2,2X,2I2,2E10.2,/5X,A,5E10.2)')
29631      &    'PHO_DIFSLP: sampled momentum transfer:',TT,
29632      &    'IDF1/2,IVEC1/2,XM1/2:',IDF1,IDF2,IVEC1,IVEC2,XM1,XM2,
29633      &    'Tmi,Tmx,SLMIN,SLOPE,WGHT:',TMINP,TMAXP,SLMIN,SLOPE,SLWGHT
29634       ENDIF
29635       END
29636
29637 *$ CREATE PHO_DIFKIN.FOR
29638 *COPY PHO_DIFKIN
29639 CDECK  ID>, PHO_DIFKIN
29640       SUBROUTINE PHO_DIFKIN(XMP1,XMP2,TT,PMOM1,PMOM2,IREJ)
29641 C**********************************************************************
29642 C
29643 C     calculation of diffractive kinematics
29644 C
29645 C     input:    XMP1         mass of outgoing particle system 1 (GeV)
29646 C               XMP2         mass of outgoing particle system 2 (GeV)
29647 C               TT           momentum transfer    (GeV**2, negative)
29648 C
29649 C     output:   PMOM1(5)     four momentum of outgoing system 1
29650 C               PMOM2(5)     four momentum of outgoing system 2
29651 C               IREJ         0    kinematics consistent
29652 C                            1    kinematics inconsistent
29653 C
29654 C**********************************************************************
29655       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29656       SAVE
29657
29658       PARAMETER(EPS  = 1.D-10,
29659      &          DEPS = 0.001)
29660
29661 C  input/output channels
29662       INTEGER LI,LO
29663       COMMON /POINOU/ LI,LO
29664 C  event debugging information
29665       INTEGER NMAXD
29666       PARAMETER (NMAXD=100)
29667       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29668      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29669       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29670      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29671 C  c.m. kinematics of diffraction
29672       INTEGER NPOSD
29673       DOUBLE PRECISION ECMD,PCMD,PMASSD,PVIRTD,GAMBED,
29674      &                 SIDD,CODD,SIFD,COFD,PDCMS
29675       COMMON /PODCMS/ ECMD,PCMD,PMASSD(2),PVIRTD(2),GAMBED(4),
29676      &                SIDD,CODD,SIFD,COFD,PDCMS(4,2),NPOSD(2)
29677 C  some constants
29678       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29679       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29680      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29681
29682       DOUBLE PRECISION PMOM1,PMOM2
29683       DIMENSION PMOM1(5),PMOM2(5)
29684
29685 C  debug output
29686       IF(IDEB(49).GT.10) WRITE(LO,'(1X,A,/5X,5E12.4)')
29687      &    'PHO_DIFKIN: Ecmd,Pcmd,Mini-1,Mini-2,TT:',
29688      &    ECMD,PCMD,XMP1,XMP2,TT
29689
29690 C  general kinematic constraints
29691       IREJ = 1
29692       IF(ECMD.LE.1.1D0*(XMP1+XMP2)) RETURN
29693
29694 C  new squared cms momentum
29695       XMP12 = XMP1**2
29696       XMP22 = XMP2**2
29697       SS = ECMD**2
29698       PCM2 = PCMD**2
29699       PCMP2 = PHO_XLAM(SS,XMP12,XMP22)**2/(4.D0*SS)
29700
29701 C  new longitudinal/transverse momentum
29702       E1I = SQRT(PCM2+PMASSD(1)**2)
29703       E1F = SQRT(PCMP2+XMP12)
29704       E2F = SQRT(PCMP2+XMP22)
29705       PLONG = (TT+PCM2+PCMP2-(E1I-E1F)**2)/(2.D0*PCMD)
29706       PTRAN = PCMP2-PLONG**2
29707
29708 C  check consistency of kinematics
29709       IF(PTRAN.LT.0.D0) THEN
29710         IF(IDEB(49).GE.1) THEN
29711           WRITE(LO,'(1X,2A,I10)') 'PHO_DIFKIN: ',
29712      &      'inconsistent kinematics in event call: ',KEVENT
29713           WRITE(LO,'(1X,A,/5X,1p,6E11.3)')
29714      &      'PHO_DIFKIN: XMP1,XMP2,TT,PCMP,PLONG,PTRANS',
29715      &      XMP1,XMP2,TT,SQRT(PCMP2),PLONG,SIGN(SQRT(ABS(PTRAN)),PTRAN)
29716         ENDIF
29717         IREJ = 1
29718         RETURN
29719       ELSE
29720         PTRAN = SQRT(PTRAN)
29721       ENDIF
29722       XI = PI2*DT_RNDM(PTRAN)
29723
29724 C  outgoing momenta in cm. system
29725       PMOM1(4) = E1F
29726       PMOM1(1) = PTRAN*COS(XI)
29727       PMOM1(2) = PTRAN*SIN(XI)
29728       PMOM1(3) = PLONG
29729       PMOM1(5) = XMP1
29730
29731       PMOM2(4) = E2F
29732       PMOM2(1) = -PMOM1(1)
29733       PMOM2(2) = -PMOM1(2)
29734       PMOM2(3) = -PLONG
29735       PMOM2(5) = XMP2
29736       IREJ = 0
29737
29738 C  debug output / precision check
29739       IF(IDEB(49).GE.0) THEN
29740 C  check kinematics
29741         XM1 = (PMOM1(4)-PMOM1(3))*(PMOM1(4)+PMOM1(3))
29742      &        -PMOM1(1)**2-PMOM1(2)**2
29743         XM1 = SIGN(SQRT(ABS(XM1)),XM1)
29744         XM2 = (PMOM2(4)-PMOM2(3))*(PMOM2(4)+PMOM2(3))
29745      &        -PMOM2(1)**2-PMOM2(2)**2
29746         XM2 = SIGN(SQRT(ABS(XM2)),XM2)
29747         IF((ABS(XM1-XMP1).GT.DEPS).OR.(ABS(XM1-XMP1).GT.DEPS)) THEN
29748           WRITE(LO,'(1X,2A,/5X,4E11.4)') 'PHO_DIFKIN: ',
29749      &      'inconsistent masses: MINI-1,MOUT-1,MINI-2,MOUT-2',
29750      &      XMP1,XM1,XMP2,XM2
29751           CALL PHO_PREVNT(-1)
29752         ENDIF
29753 C  output
29754         IF(IDEB(49).GT.10) THEN
29755           WRITE(LO,'(1X,A,5E11.3,/1X,A,5E11.3)')
29756      &      'PHO_DIFKIN: P1',PMOM1,'                 P2',PMOM2
29757         ENDIF
29758       ENDIF
29759
29760       END
29761
29762 *$ CREATE PHO_VECRES.FOR
29763 *COPY PHO_VECRES
29764 CDECK  ID>, PHO_VECRES
29765       SUBROUTINE PHO_VECRES(IVEC,RMASS,IDPDG,IDBAM)
29766 C**********************************************************************
29767 C
29768 C     sampling of vector meson resonance in diffractive processes
29769 C     (nothing done for hadrons)
29770 C
29771 C     input:   /POSVDM/     VDMFAC factors
29772 C
29773 C     output:  IVEC         0   incoming hadron
29774 C                           1   rho 0
29775 C                           2   omega
29776 C                           3   phi
29777 C                           4   pi+/pi- background
29778 C              RMASS        mass of vector meson (GeV)
29779 C              IDPDG        particle ID according to PDG
29780 C              IDBAM        particle ID according to CPC
29781 C
29782 C**********************************************************************
29783       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29784       SAVE
29785
29786       PARAMETER(EPS  = 1.D-10)
29787
29788 C  input/output channels
29789       INTEGER LI,LO
29790       COMMON /POINOU/ LI,LO
29791 C  event debugging information
29792       INTEGER NMAXD
29793       PARAMETER (NMAXD=100)
29794       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29795      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29796       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29797      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29798 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
29799       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
29800       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
29801       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
29802      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
29803 C  parameters of the "simple" Vector Dominance Model
29804       DOUBLE PRECISION VMAS,GAMM,RMIN,RMAX,VMSL,VMFA
29805       COMMON /POSVDM/ VMAS(4),GAMM(4),RMIN(4),RMAX(4),VMSL(4),VMFA(4)
29806 C  some constants
29807       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
29808       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
29809      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
29810
29811 C  particle code translation
29812       DIMENSION ITRANS(4)
29813 C                  rho0,omega,phi,pi+/pi-
29814       DATA ITRANS /113, 223, 333, 92 /
29815
29816       IDPDO = IDPDG
29817 C
29818 C  vector meson production
29819       IF(IDPDG.EQ.22) THEN
29820         XI = DT_RNDM(RMASS)*(VMFA(1)+VMFA(2)+VMFA(3)+VMFA(4))
29821         SUM = 0.D0
29822         DO 55 K=1,4
29823           SUM = SUM + VMFA(K)
29824           IF(XI.LE.SUM) GOTO 65
29825  55     CONTINUE
29826  65     CONTINUE
29827 C
29828         IDPDG = ITRANS(K)
29829         IDBAM = ipho_pdg2id(IDPDG)
29830         IVEC  = K
29831 C  sample mass of vector meson
29832         CALL PHO_SAMASS(IDPDG,RMASS)
29833
29834 C  hadronic resonance of multi-pomeron coupling
29835       ELSE IF(IDPDG.EQ.990) THEN
29836         K = 4
29837         IDPDG = 91
29838         IDBAM = ipho_pdg2id(IDPDG)
29839         IVEC  = 4
29840 C  sample mass of two-pion system
29841         CALL PHO_SAMASS(IDPDG,RMASS)
29842
29843 C  hadron remnants in inucleus interactions
29844       ELSE IF(IDPDG.EQ.81) THEN
29845         IF(IHFLD(1,1).EQ.0) THEN
29846           CALL PHO_SEAFLA(1,IFL1,IFL2,RMASS)
29847           CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
29848         ELSE
29849           CALL PHO_HACODE(IHFLD(1,1),IHFLD(1,2),IDBA1,IDBA2)
29850         ENDIF
29851         RMAS1 = PHO_PMASS(IDBA1,0)
29852         RMAS2 = PHO_PMASS(IDBA2,0)
29853         IF((IDBA2.NE.0).AND.
29854      &    (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
29855           IDBAM = IDBA2
29856           RMASS = RMAS2
29857         ELSE
29858           IDBAM = IDBA1
29859           RMASS = RMAS1
29860         ENDIF
29861         IDPDG = IPHO_ID2PDG(IDBAM)
29862         IVEC = 0
29863       ELSE IF(IDPDG.EQ.82) THEN
29864         IF(IHFLD(2,1).EQ.0) THEN
29865           CALL PHO_SEAFLA(2,IFL1,IFL2,RMASS)
29866           CALL PHO_HACODE(IFL1,IFL2,IDBA1,IDBA2)
29867         ELSE
29868           CALL PHO_HACODE(IHFLD(2,1),IHFLD(2,2),IDBA1,IDBA2)
29869         ENDIF
29870         RMAS1 = PHO_PMASS(IDBA1,0)
29871         RMAS2 = PHO_PMASS(IDBA2,0)
29872         IF((IDBA2.NE.0).AND.
29873      &    (DT_RNDM(RMAS1).LT.(RMAS1/(RMAS1+RMAS2)))) THEN
29874           IDBAM = IDBA2
29875           RMASS = RMAS2
29876         ELSE
29877           IDBAM = IDBA1
29878           RMASS = RMAS1
29879         ENDIF
29880         IDPDG = IPHO_ID2PDG(IDBAM)
29881         IVEC = 0
29882       ENDIF
29883 C  debug output
29884       IF(IDEB(47).GE.5) THEN
29885         WRITE(LO,'(1X,A,/10X,3I7,E12.4)')
29886      &    'PHO_VECRES: IDPDG-OLD,IDPDG,IDBAM,MASS',
29887      &    IDPDO,IDPDG,IDBAM,RMASS
29888       ENDIF
29889
29890       END
29891
29892 *$ CREATE PHO_DIFRES.FOR
29893 *COPY PHO_DIFRES
29894 CDECK  ID>, PHO_DIFRES
29895       SUBROUTINE PHO_DIFRES(IDMOTH,IVAL1,IVAL2,
29896      &                  IDPDG,IDBAM,RMASS,RGAM,RWG,LISTL)
29897 C**********************************************************************
29898 C
29899 C     list of resonance states for low mass resonances
29900 C
29901 C     input:   IDMOTH       PDG ID of mother particle
29902 C              IVAL1,2      quarks (photon only)
29903 C
29904 C     output:  IDPDG        list of PDG IDs for possible resonances
29905 C              IDBAM        list of corresponding CPC IDs
29906 C              RMASS        mass
29907 C              RGAMS        decay width
29908 C              RMASS        additional weight factor
29909 C              LISTL        entries in current list
29910 C
29911 C**********************************************************************
29912       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29913       SAVE
29914
29915       DIMENSION  IDPDG(10),IDBAM(10),RMASS(10),RGAM(10),RWG(10)
29916
29917       PARAMETER (EPS    =  1.D-10,
29918      &           DEPS   =  1.D-15)
29919
29920 C  input/output channels
29921       INTEGER LI,LO
29922       COMMON /POINOU/ LI,LO
29923 C  event debugging information
29924       INTEGER NMAXD
29925       PARAMETER (NMAXD=100)
29926       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
29927      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29928       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
29929      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
29930 C  particle ID translation table
29931       integer         ID_pdg_list,ID_list,ID_pdg_max
29932       character*12    name_list
29933       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
29934      &                ID_pdg_max
29935 C  general particle data
29936       double precision xm_list,tau_list,gam_list,
29937      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
29938      &  xm_bb82_list,xm_bb102_list
29939       integer          ich3_list,iba3_list,iq_list,
29940      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
29941       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
29942      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
29943      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
29944      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
29945      &  ich3_list(300),iba3_list(300),iq_list(3,300),
29946      &  id_psm_list(6,6),id_vem_list(6,6),
29947      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
29948
29949       DIMENSION RWGHT(20),IRPDG(20),IRBAM(20)
29950       DATA IRPDG /113, 223, 333, 50223, 40113, 60223, 10333, 30113,
29951      &            12212, 42212, -12212, -42212,
29952      &            8*0 /
29953       DATA RWGHT /1.D0, 0.11D0, 0.1D0, 0.11D0, 1.D0, 0.11D0, 0.1D0,
29954      &            1.D0, 1.D0, 1.D0, 1.D0, 1.D0,
29955      &            8*1.D0 /
29956
29957       DATA init /0/
29958
29959 C  initialize table
29960       if(init.eq.0) then
29961         do i=1,20
29962           if(IRPDG(i).ne.0) then
29963             IRBAM(i) = ipho_pdg2id(IRPDG(i))
29964           endif
29965         enddo
29966         init = 1
29967       endif
29968
29969 C  copy table with particles and isospin weights
29970       LISTL = 0
29971       IF(IDMOTH.EQ.22) THEN
29972         I1 = 4
29973         I2 = 8
29974       ELSE IF(IDMOTH.EQ.2212) THEN
29975         I1 = 9
29976         I2 = 10
29977       ELSE IF(IDMOTH.EQ.-2212) THEN
29978         I1 = 11
29979         I2 = 12
29980       ELSE
29981         RETURN
29982       ENDIF
29983
29984       DO 100 I=I1,I2
29985         LISTL = LISTL+1
29986         IDBAM(LISTL) = IRBAM(I)
29987         IDPDG(LISTL) = IRPDG(I)
29988         RMASS(LISTL) = xm_list(iabs(IDBAM(LISTL)))
29989         RGAM(LISTL)  = gam_list(iabs(IDBAM(LISTL)))
29990         RWG(LISTL)   = RWGHT(I)
29991  100  CONTINUE
29992
29993 C  debug output
29994       IF(IDEB(85).GE.20) THEN
29995         WRITE(LO,'(1X,A,3I7)') 'PHO_DIFRES: mother,quarks',IDMOTH,
29996      &    IVAL1,IVAL2
29997         DO 200 I=1,LISTL
29998           WRITE(LO,'(1X,I3,2I7,E12.4)') I,IDBAM(I),IDPDG(I),RMASS(I)
29999  200    CONTINUE
30000       ENDIF
30001
30002       END
30003
30004 *$ CREATE PHO_MASSAD.FOR
30005 *COPY PHO_MASSAD
30006 CDECK  ID>, PHO_MASSAD
30007       SUBROUTINE PHO_MASSAD(IFLMO,IFL1,IFL2,
30008      &                     PMASS,XMCON,XMOUT,IDPDG,IDcpc)
30009 C***********************************************************************
30010 C
30011 C    fine-correction of low mass strings to mass of corresponding
30012 C    resonance or two particle threshold
30013 C
30014 C    input:     IFLMO         PDG ID of mother particle
30015 C               IFL1,2        requested parton flavours
30016 C                             (not used at the moment)
30017 C               PMASS         reference mass (mass of mother particle)
30018 C               XMCON         conjecture of mass
30019 C
30020 C    output:    XMOUT         output mass (adjusted input mass)
30021 C                             moved ot nearest mass possible
30022 C               IDPDG         PDG resonance ID
30023 C               IDcpc         CPC resonance ID
30024 C
30025 C**********************************************************************
30026       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30027       SAVE
30028
30029       PARAMETER ( DEPS   =  1.D-8 )
30030
30031 C  input/output channels
30032       INTEGER LI,LO
30033       COMMON /POINOU/ LI,LO
30034 C  event debugging information
30035       INTEGER NMAXD
30036       PARAMETER (NMAXD=100)
30037       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30038      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30039       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30040      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30041 C  model switches and parameters
30042       CHARACTER*8 MDLNA
30043       INTEGER ISWMDL,IPAMDL
30044       DOUBLE PRECISION PARMDL
30045       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
30046 C  general particle data
30047       double precision xm_list,tau_list,gam_list,
30048      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
30049      &  xm_bb82_list,xm_bb102_list
30050       integer          ich3_list,iba3_list,iq_list,
30051      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
30052       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
30053      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
30054      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
30055      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
30056      &  ich3_list(300),iba3_list(300),iq_list(3,300),
30057      &  id_psm_list(6,6),id_vem_list(6,6),
30058      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
30059 C  particle decay data
30060       double precision wg_sec_list
30061       integer          idec_list,isec_list
30062       COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
30063      &  isec_list(3,500)
30064
30065       DIMENSION XWG(10),RMA(10),RGA(10),RWG(10),IRPDG(10),IRBAM(10)
30066
30067       XMINP = XMCON
30068       IDPDG = 0
30069       IDcpc = 0
30070       XMOUT = XMINP
30071
30072 C  resonance treatment activated?
30073       IF(ISWMDL(23).EQ.0) RETURN
30074
30075       CALL PHO_DIFRES(IFLMO,IFL1,IFL2,IRPDG,IRBAM,RMA,RGA,RWG,LISTL)
30076       IF(LISTL.LT.1) THEN
30077         IF(IDEB(7).GE.2) WRITE(LO,'(1X,A,3I7)')
30078      &    'PHO_MASSAD: no resonances for (IFMO,IF1,IF2)',
30079      &    IFLMO,IFL1,IFL2
30080         GOTO 50
30081       ENDIF
30082 C  mass small?
30083       PMASSL = (PMASS+0.15D0)**2
30084       XMINP2 = XMINP**2
30085 C  determine resonance probability
30086       DM2 = 1.1D0
30087       RPROB = (PMASSL+DM2)*(XMINP2-PMASSL)/(DM2*XMINP2)
30088       IF(RPROB.LT.DT_RNDM(PMASSL)) THEN
30089 C  sample new resonance
30090         XWGSUM = 0.D0
30091         DO 100 I=1,LISTL
30092           XWG(I) = RWG(I)/RMA(I)**2
30093           XWGSUM = XWGSUM+XWG(I)
30094  100    CONTINUE
30095
30096         ITER = 0
30097  150    CONTINUE
30098         ITER = ITER+1
30099         IF(ITER.GE.5) THEN
30100           IDcpc = 0
30101           IDPDG = 0
30102           XMOUT = XMINP
30103           GOTO 50
30104         ENDIF
30105
30106         I = 0
30107         XI = XWGSUM*DT_RNDM(XMOUT)
30108  200    CONTINUE
30109           I = I+1
30110           XWGSUM = XWGSUM-XWG(I)
30111         IF((XI.LT.XWGSUM).AND.(I.LT.LISTL)) GOTO 200
30112         IDPDG = IRPDG(I)
30113         IDcpc = IRBAM(I)
30114         GARES = RGA(I)
30115         XMRES = RMA(I)
30116         XMRES2 = XMRES**2
30117 C  sample new mass (from Breit-Wigner cross section)
30118         ALO = ATAN((PMASSL-XMRES2)/(XMRES*GARES))
30119         AHI = ATAN((5.D0-XMRES2)/(XMRES*GARES))
30120         XI = (AHI-ALO)*DT_RNDM(XMRES)+ALO
30121         XMOUT = XMRES*GARES*TAN(XI)+XMRES2
30122         XMOUT = SQRT(XMOUT)
30123
30124 C  check mass for decay
30125         AMDCY = 2.D0*XMRES
30126         ID = abs(IDcpc)
30127         DO 250 IK=idec_list(2,ID),idec_list(3,ID)
30128           AMSUM = 0.D0
30129           DO 275 I=1,3
30130             IF(isec_list(I,IK).NE.0)
30131      &        AMSUM = AMSUM + xm_list(iabs(isec_list(I,IK)))
30132  275      CONTINUE
30133           AMDCY = MIN(AMDCY,AMSUM)
30134  250    CONTINUE
30135         IF(AMDCY.GE.XMOUT) GOTO 150
30136
30137 C  debug output
30138         IF(IDEB(7).GE.10)
30139      &    WRITE(LO,'(1X,2A,/1X,3I6,2E10.3,2I7,2E10.3)')
30140      &    'PHO_MASSAD: ',
30141      &    'IFMO,IF1,IF2,XMCON,XMOUT,IDPDG,IDcpc,RMA,RGA',
30142      &    IFLMO,IFL1,IFL2,XMCON,XMOUT,IDPDG,IDcpc,RMA(I),RGA(I)
30143         RETURN
30144       ENDIF
30145
30146  50   CONTINUE
30147 C  debug output
30148       IF(IDEB(7).GE.15)
30149      &  WRITE(LO,'(1X,A,/1X,3I6,2E10.3)')
30150      &    'PHO_MASSAD: string sampled: IFMO,IF1,IF2,XMCON,XMOUT',
30151      &    IFLMO,IFL1,IFL2,XMCON,XMOUT
30152
30153       END
30154
30155 *$ CREATE PHO_PDF.FOR
30156 *COPY PHO_PDF
30157 CDECK  ID>, PHO_PDF
30158       SUBROUTINE PHO_PDF(NPAR,X,SCALE2,P2VIR,PD)
30159 C***************************************************************
30160 C
30161 C     call different PDF sets for different particle types
30162 C
30163 C     input:      NPAR     1     IGRP(1),ISET(1)
30164 C                          2     IGRP(2),ISET(2)
30165 C                 X        momentum fraction
30166 C                 SCALE2   squared scale (GeV**2)
30167 C                 P2VIR    particle virtuality (positive, GeV**2)
30168 C
30169 C     output      PD(-6:6) field containing the x*PDF fractions
30170 C
30171 C***************************************************************
30172       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30173       SAVE
30174
30175       DIMENSION PD(-6:6)
30176
30177 C  input/output channels
30178       INTEGER LI,LO
30179       COMMON /POINOU/ LI,LO
30180 C  currently activated parton density parametrizations
30181       CHARACTER*8 PDFNAM
30182       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
30183       DOUBLE PRECISION PDFLAM,PDFQ2M
30184       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
30185      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
30186 C  event debugging information
30187       INTEGER NMAXD
30188       PARAMETER (NMAXD=100)
30189       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30190      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30191       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30192      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30193 C  model switches and parameters
30194       CHARACTER*8 MDLNA
30195       INTEGER ISWMDL,IPAMDL
30196       DOUBLE PRECISION PARMDL
30197       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
30198
30199       DIMENSION PARAM(20),VALUE(20)
30200       CHARACTER*20 PARAM
30201
30202       REAL XR,P2R,Q2R,F2GM,XPDFGM
30203       DIMENSION XPDFGM(-6:6)
30204
30205 C  check of kinematic boundaries
30206       XI = X
30207       IF(X.GT.1.D0) THEN
30208         IF(IDEB(37).GE.0) THEN
30209           WRITE(LO,'(/,1X,A,E15.8/)')
30210      &      'PHO_PDF: x>1 (corrected to x=1)',X
30211           CALL PHO_PREVNT(-1)
30212         ENDIF
30213         XI = 0.99999999999D0
30214       ELSE IF(X.LE.0.D0) THEN
30215         IF(IDEB(37).GE.0) THEN
30216           WRITE(LO,'(/,1X,A,E15.8/)') 'PHO_PDF: X <= 0 ',X
30217           CALL PHO_PREVNT(-1)
30218         ENDIF
30219         XI = 0.0001D0
30220       ENDIF
30221
30222       DO 100 I=-6,6
30223         PD(I) = 0.D0
30224  100  CONTINUE
30225       IRET = 1
30226
30227       IF((NPAR.EQ.1).OR.(NPAR.EQ.2)) THEN
30228
30229 C  internal PDFs
30230
30231         IF(IEXT(NPAR).EQ.0) THEN
30232           IF(ITYPE(NPAR).EQ.1) THEN
30233 C  proton PDFs
30234             IF(IGRP(NPAR).EQ.5) THEN
30235               IF(ISET(NPAR).EQ.3) THEN
30236                 CALL PHO_DOR92HO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
30237                 UV = UDV-DV
30238                 UDB = 2.D0*UDB
30239                 DEL = 0.D0
30240                 IRET = 0
30241               ELSE IF(ISET(NPAR).EQ.4) THEN
30242                 CALL PHO_DOR92LO(XI,SCALE2,UDV,DV,GL,UDB,SB,CB,BB)
30243                 UV = UDV-DV
30244                 UDB = 2.D0*UDB
30245                 DEL = 0.D0
30246                 IRET = 0
30247               ELSE IF(ISET(NPAR).EQ.5) THEN
30248                 CALL PHO_DOR94HO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
30249 C  heavy quarks from GRV92-HO
30250                 AMU2  = 0.3
30251                 ALAM2 = 0.248 * 0.248
30252                 S  = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30253                 SC  =  0.820
30254                 ALC =   0.98
30255                 BEC =   0.0
30256                 AKC = -0.625 - 0.523 * S
30257                 AGC =   0.0
30258                 BC  =  1.896 + 1.616 * S
30259                 DC  =   4.12 + 0.683 * S
30260                 EC  =   4.36 + 1.328 * S
30261                 ESC =  0.677 + 0.679 * S
30262                 CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30263                 SBO =  1.297
30264                 ALB =   0.99
30265                 BEB =   0.0
30266                 AKB =   0.0  - 0.193 * S
30267                 AGB =   0.0
30268                 BBO =   0.0
30269                 DB  =  3.447 + 0.927 * S
30270                 EB  =   4.68 + 1.259 * S
30271                 ESB =  1.892 + 2.199 * S
30272                 BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30273                 IRET = 0
30274               ELSE IF(ISET(NPAR).EQ.6) THEN
30275                 CALL PHO_DOR94LO(XI,SCALE2,UV,DV,DEL,UDB,SB,GL)
30276 C  heavy quarks from GRV92-LO
30277                 AMU2  = 0.25
30278                 ALAM2 = 0.232D0**2
30279                 S  = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30280                 SC  =  0.888
30281                 ALC =   1.01
30282                 BEC =   0.37
30283                 AKC =   0.0
30284                 AGC =   0.0
30285                 BC  =   4.24 - 0.804 * S
30286                 DC  =   3.46 + 1.076 * S
30287                 EC  =   4.61 + 1.490 * S
30288                 ESC =  2.555 + 1.961 * S
30289                 CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30290                 SBO =  1.351
30291                 ALB =   1.00
30292                 BEB =   0.51
30293                 AKB =   0.0
30294                 AGB =   0.0
30295                 BBO =  1.848
30296                 DB  =  2.929 + 1.396 * S
30297                 EB  =   4.71 + 1.514 * S
30298                 ESB =   4.02 + 1.239 * S
30299                 BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30300                 IRET = 0
30301               ELSE IF(ISET(NPAR).EQ.7) THEN
30302                 CALL PHO_DOR94DI(XI,SCALE2, UV, DV, DEL, UDB, SB, GL)
30303 C  heavy quarks from GRV92-HO
30304                 AMU2  = 0.3
30305                 ALAM2 = 0.248 * 0.248
30306                 S  = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30307                 SC  =  0.820
30308                 ALC =   0.98
30309                 BEC =   0.0
30310                 AKC = -0.625 - 0.523 * S
30311                 AGC =   0.0
30312                 BC  =  1.896 + 1.616 * S
30313                 DC  =   4.12 + 0.683 * S
30314                 EC  =   4.36 + 1.328 * S
30315                 ESC =  0.677 + 0.679 * S
30316                 CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30317                 SBO =  1.297
30318                 ALB =   0.99
30319                 BEB =   0.0
30320                 AKB =   0.0  - 0.193 * S
30321                 AGB =   0.0
30322                 BBO =   0.0
30323                 DB  =  3.447 + 0.927 * S
30324                 EB  =   4.68 + 1.259 * S
30325                 ESB =  1.892 + 2.199 * S
30326                 BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30327                 IRET = 0
30328               ELSE IF(ISET(NPAR).EQ.8) THEN
30329                 CALL PHO_DOR98LO(XI,SCALE2,UV,DV,US,DS,SB,GL)
30330                 DEL = DS-US
30331                 UDB = DS+US
30332 C  heavy quarks from GRV92-LO
30333                 AMU2  = 0.25
30334                 ALAM2 = 0.232D0**2
30335                 S  = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30336                 SC  =  0.888
30337                 ALC =   1.01
30338                 BEC =   0.37
30339                 AKC =   0.0
30340                 AGC =   0.0
30341                 BC  =   4.24 - 0.804 * S
30342                 DC  =   3.46 + 1.076 * S
30343                 EC  =   4.61 + 1.490 * S
30344                 ESC =  2.555 + 1.961 * S
30345                 CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30346                 SBO =  1.351
30347                 ALB =   1.00
30348                 BEB =   0.51
30349                 AKB =   0.0
30350                 AGB =   0.0
30351                 BBO =  1.848
30352                 DB  =  2.929 + 1.396 * S
30353                 EB  =   4.71 + 1.514 * S
30354                 ESB =   4.02 + 1.239 * S
30355                 BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30356                 IRET = 0
30357               ELSE IF(ISET(NPAR).EQ.9) THEN
30358 *               CALL PHO_DOR98SC(XI,SCALE2,UV,DV,US,DS,SB,GL)
30359                 DEL = DS-US
30360                 UDB = DS+US
30361 C  heavy quarks from GRV92-LO
30362                 AMU2  = 0.25
30363                 ALAM2 = 0.232D0**2
30364                 S  = LOG (LOG(SCALE2/ALAM2) / LOG(AMU2/ALAM2))
30365                 SC  =  0.888
30366                 ALC =   1.01
30367                 BEC =   0.37
30368                 AKC =   0.0
30369                 AGC =   0.0
30370                 BC  =   4.24 - 0.804 * S
30371                 DC  =   3.46 + 1.076 * S
30372                 EC  =   4.61 + 1.490 * S
30373                 ESC =  2.555 + 1.961 * S
30374                 CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
30375                 SBO =  1.351
30376                 ALB =   1.00
30377                 BEB =   0.51
30378                 AKB =   0.0
30379                 AGB =   0.0
30380                 BBO =  1.848
30381                 DB  =  2.929 + 1.396 * S
30382                 EB  =   4.71 + 1.514 * S
30383                 ESB =   4.02 + 1.239 * S
30384                 BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
30385                 IRET = 0
30386               ENDIF
30387               PD(-5) = BB
30388               PD(-4) = CB
30389               PD(-3) = SB
30390               PD(-2) = 0.5D0*(UDB-DEL)
30391               PD(-1) = 0.5D0*(UDB+DEL)
30392               PD(0)  = GL
30393               PD(1)  = DV+PD(-1)
30394               PD(2)  = UV+PD(-2)
30395               PD(3)  = PD(-3)
30396               PD(4)  = PD(-4)
30397               PD(5)  = PD(-5)
30398             ENDIF
30399           ELSE IF(ITYPE(NPAR).EQ.2) THEN
30400 C  pion PDFs (default for pi+)
30401             IF(IGRP(NPAR).EQ.5) THEN
30402               IF(ISET(NPAR).EQ.1) THEN
30403                 CALL PHO_DORPHO (XI,SCALE2,VA,GL,QB,CB,BB)
30404                 IRET = 0
30405               ELSE IF(ISET(NPAR).EQ.2) THEN
30406                 CALL PHO_DORPLO (XI,SCALE2,VA,GL,QB,CB,BB)
30407                 IRET = 0
30408               ENDIF
30409               PD(-5) = BB
30410               PD(-4) = CB
30411               PD(-3) = QB
30412               PD(-2) = QB
30413               PD(-1) = QB+VA
30414               PD(0)  = GL
30415               PD(1)  = QB
30416               PD(2)  = VA+QB
30417               PD(3)  = QB
30418               PD(4)  = CB
30419               PD(5)  = BB
30420             ENDIF
30421           ELSE IF(ITYPE(NPAR).EQ.3) THEN
30422 C  photon PDFs
30423             IF(IGRP(NPAR).EQ.5) THEN
30424               IF(ISET(NPAR).EQ.1) THEN
30425                 CALL PHO_DORGH0 (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30426                 IRET = 0
30427               ELSE IF(ISET(NPAR).EQ.2) THEN
30428                 CALL PHO_DORGHO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30429                 IRET = 0
30430               ELSE IF(ISET(NPAR).EQ.3) THEN
30431                 CALL PHO_DORGLO (XI,SCALE2,UB,DB,SB,CB,BB,GL)
30432                 IRET = 0
30433               ENDIF
30434 C  reweight with Drees-Godbole factor
30435               WGX = 1.D0
30436               IF(P2VIR.GT.0.001D0) THEN
30437                 WGX = LOG(SCALE2/(P2VIR+PARMDL(144)))
30438      &               /LOG(SCALE2/PARMDL(144))
30439                 WGX = MAX(WGX,0.D0)
30440               ENDIF
30441               PD(-5) = BB*WGX/137.D0
30442               PD(-4) = CB*WGX/137.D0
30443               PD(-3) = SB*WGX/137.D0
30444               PD(-2) = UB*WGX/137.D0
30445               PD(-1) = DB*WGX/137.D0
30446               PD(0)  = GL*WGX*WGX/137.D0
30447               PD(1)  = PD(-1)
30448               PD(2)  = PD(-2)
30449               PD(3)  = PD(-3)
30450               PD(4)  = PD(-4)
30451               PD(5)  = PD(-5)
30452             ELSE IF(IGRP(NPAR).EQ.8) THEN
30453               IF(ISET(NPAR).EQ.1) THEN
30454                 CALL PHO_PHGAL (XI,SCALE2,PD)
30455                 IRET = 0
30456               ENDIF
30457             ENDIF
30458           ELSE IF(ITYPE(NPAR).EQ.20) THEN
30459 C  Pomeron PDFs
30460             MODE = IGRP(NPAR)
30461             IF(MODE.EQ.1) THEN
30462               PD(0) = 6.D0*(1.D0-XI)**5*PARMDL(26)*PARMDL(78)
30463               IRET = 0
30464             ELSE IF(MODE.EQ.2) THEN
30465               PD(0) = 6.D0*XI*(1.D0-XI)*PARMDL(26)*PARMDL(78)
30466               IRET = 0
30467             ELSE IF(MODE.EQ.3) THEN
30468               PD(0) = (0.18D0/XI+5.46D0)*(1.D0-XI)*PARMDL(26)*PARMDL(78)
30469               IRET = 0
30470             ELSE IF(MODE.EQ.4) THEN
30471               CALL PHO_CKMTPD(990,XI,SCALE2,PD)
30472               DO 105 I=-4,4
30473                 PD(I) = PD(I)*PARMDL(78)
30474  105          CONTINUE
30475               IRET = 0
30476             ENDIF
30477           ENDIF
30478
30479 C  external PDFs
30480
30481         ELSE IF(IEXT(NPAR).EQ.2) THEN
30482 C  PDFLIB call: new PDF numbering
30483           IF(NPAR.NE.NPAOLD) THEN
30484             PARAM(1) = 'NPTYPE'
30485             PARAM(2) = 'NGROUP'
30486             PARAM(3) = 'NSET'
30487             PARAM(4) = ' '
30488             VALUE(1) = ITYPE(NPAR)
30489             VALUE(2) = ABS(IGRP(NPAR))
30490             VALUE(3) = ISET(NPAR)
30491             CALL PDFSET(PARAM,VALUE)
30492           ENDIF
30493           IF(ITYPE(NPAR).EQ.3) THEN
30494             IP2 = 0
30495             CALL STRUCTP(XI,SCALE2,P2VIR,IP2,PD(2),PD(1),PD(-2),PD(-1),
30496      &                   PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
30497           ELSE
30498             SCALE = SQRT(SCALE2)
30499             CALL STRUCTM(XI,SCALE,PD(2),PD(1),PD(-2),PD(-1),
30500      &                   PD(-3),PD(-4),PD(-5),PD(-6),PD(0))
30501           ENDIF
30502           DO 115 I=3,6
30503             PD(I) = PD(-I)
30504  115      CONTINUE
30505           IF(ITYPE(NPAR).EQ.1) THEN
30506 C  proton valence quarks
30507             PD(1) = PD(1)+PD(-1)
30508             PD(2) = PD(2)+PD(-2)
30509           ELSE IF(ITYPE(NPAR).EQ.2) THEN
30510 C  pi+ valences
30511             DVAL = PD(1)
30512             PD(1) = PD(-1)
30513             PD(-1) = DVAL+PD(1)
30514             PD(2) = PD(2)+PD(-2)
30515           ELSE IF(ITYPE(NPAR).EQ.3) THEN
30516 C  photon conventions
30517             PD(1) = PD(-1)
30518             PD(2) = PD(-2)
30519           ENDIF
30520           IRET = 0
30521
30522         ELSE IF(IEXT(NPAR).EQ.3) THEN
30523 C  PHOLIB call: version 2.0
30524           CALL PHVAL(IGRP(NPAR),ISET(NPAR),XI,SCALE2,PD,IRET)
30525           IF(IRET.LT.0) THEN
30526             WRITE(LO,'(/1X,A,I2)')
30527      &        'PHO_PDF:ERROR: non-vanishing PHVAL return code',IRET
30528             CALL PHO_ABORT
30529           ENDIF
30530           IRET = 0
30531
30532 C  photon PDFs depending on photon virtuality
30533
30534         ELSE IF(IEXT(NPAR).EQ.4) THEN
30535           IF(IGRP(NPAR).EQ.1) THEN
30536 C  Schuler/Sjostrand PDF (interface to single precision)
30537             XR = XI
30538             Q2R = SCALE2
30539             P2R = P2VIR
30540             IP2 = 0
30541             CALL PHO_SASGAM(ISET(NPAR),XR,Q2R,P2R,IP2,F2GM,XPDFGM)
30542             DO 120 I=-6,6
30543               PD(I) = DBLE(XPDFGM(I))
30544  120        CONTINUE
30545             IRET = 0
30546           ELSE IF(IGRP(NPAR).EQ.5) THEN
30547 C  Gluck/Reya/Stratmann
30548             IF(ISET(NPAR).EQ.4) THEN
30549               CALL PHO_DORGLV (XI,SCALE2,P2VIR, UB, DB, SB, GL)
30550               CALL PHO_QPMPDF(4,XI,SCALE2,0.D0,P2VIR,CB)
30551               IRET = 0
30552               PD(-5) = 0.D0
30553               PD(-4) = CB
30554               PD(-3) = SB/137.D0
30555               PD(-2) = UB/137.D0
30556               PD(-1) = DB/137.D0
30557               PD(0)  = GL/137.D0
30558               PD(1)  = PD(-1)
30559               PD(1)  = PD(-1)
30560               PD(2)  = PD(-2)
30561               PD(3)  = PD(-3)
30562               PD(4)  = PD(-4)
30563               PD(5)  = PD(-5)
30564             ENDIF
30565           ENDIF
30566         ENDIF
30567
30568 C  check for errors
30569
30570         IF(IRET.NE.0) THEN
30571           WRITE(LO,'(/1X,A,/10X,5I6)')
30572      &      'PHO_PDF:ERROR:unsupported PDF(NPAR,IEXT,ITYPE,IGRP,ISET)',
30573      &      NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
30574           CALL PHO_ABORT
30575         ENDIF
30576 C  error in NPAR
30577       ELSE
30578         WRITE(LO,'(/1X,A,I5)') 'PHO_PDF:ERROR:invalid NPAR(1,2) ',NPAR
30579         CALL PHO_ABORT
30580       ENDIF
30581       NPAOLD = NPAR
30582
30583 C  valence quark treatment
30584
30585       IF(ITYPE(NPAR).EQ.2) THEN
30586 C  meson conventions
30587         IF(IPARID(NPAR).EQ.111) THEN
30588 C  pi0 valence quarks
30589           PD(-1) = (PD(1)+PD(-1))/2.D0
30590           PD(1)  = PD(-1)
30591           PD(-2) = (PD(2)+PD(-2))/2.D0
30592           PD(2)  = PD(-2)
30593         ELSE IF(ABS(IPARID(NPAR)).EQ.321) THEN
30594 C  K+/-
30595           VALS = PD(-1)-PD(1)
30596           PD(-1) = PD(1)
30597           PD(-3) = PD(-3)+VALS
30598         ELSE IF(    (IPARID(NPAR).EQ.311)
30599      &          .OR.(IPARID(NPAR).EQ.310)
30600      &          .OR.(IPARID(NPAR).EQ.130)) THEN
30601 C  neutral kaons
30602           VALS = PD(-1)-PD(1)
30603           VALU = PD(2)-PD(-2)
30604           PD(-1) = PD(1)
30605           PD(2) = PD(-2)
30606           PD(2)  = PD(2)+VALU/2.D0
30607           PD(-2) = PD(-2)+VALU/2.D0
30608           PD(3)  = PD(3)+VALS/2.D0
30609           PD(-3) = PD(-3)+VALS/2.D0
30610         ENDIF
30611       ELSE IF(ITYPE(NPAR).EQ.1) THEN
30612 C  nucleon conventions
30613         IF(ABS(IPARID(NPAR)).EQ.2112) THEN
30614 C  neutron valence quarks
30615           DUM = PD(1)
30616           PD(1) = PD(2)
30617           PD(2) = DUM
30618         ELSE IF(ABS(IPARID(NPAR)).EQ.3222) THEN
30619 C  (anti-)sigma+
30620           VALS = PD(1)-PD(-1)
30621           PD(1) = PD(-1)
30622           PD(3) = PD(3)+VALS
30623         ELSE IF(ABS(IPARID(NPAR)).EQ.3112) THEN
30624 C  (anti-)sigma-
30625           VALS = PD(1)-PD(-1)
30626           VALD = PD(2)-PD(-2)
30627           PD(1) = PD(-1)
30628           PD(2) = PD(-2)
30629           PD(1) = PD(1)+VALD
30630           PD(3) = PD(3)+VALS
30631         ELSE IF(    (ABS(IPARID(NPAR)).EQ.3122)
30632      &          .OR.(ABS(IPARID(NPAR)).EQ.3212)) THEN
30633 C  (anti-)sigma0 and (anti-)lambda
30634           VALS = PD(1)-PD(-1)
30635           VALD = (PD(2)-PD(-2))/2.D0
30636           PD(1) = PD(-1)
30637           PD(2) = PD(-2)
30638           PD(1) = PD(1)+VALD
30639           PD(2) = PD(2)+VALD
30640           PD(3) = PD(3)+VALS
30641         ENDIF
30642       ENDIF
30643
30644 C  antiparticle
30645       IF(IPARID(NPAR).LT.0) THEN
30646         DO 190 I=1,4
30647           DUM=PD(I)
30648           PD(I)=PD(-I)
30649           PD(-I)=DUM
30650  190    CONTINUE
30651       ENDIF
30652
30653 C  optionally remove valence quarks
30654       IF(IPAVA(NPAR).EQ.0) THEN
30655         DO 200 I=1,4
30656           PD(I) = MIN(PD(-I),PD(I))
30657           PD(-I) = PD(I)
30658  200    CONTINUE
30659       ENDIF
30660
30661 C  debug information
30662       IF(IDEB(37).GE.30) WRITE(LO,
30663      &  '(1X,A,I4,1P,3E12.4/,2X,A,6E10.3,/2X,A,E10.3,/2X,A,6E10.3)')
30664      &  'PHO_PDF: NPAR,X,SCALE**2,P2VIR',
30665      &  NPAR,X,SCALE2,P2VIR,'PD(-6..-1)',(PD(I),I=-6,-1),
30666      &  'PD(0)     ',PD(0),'PD(1..6)  ',(PD(I),I=1,6)
30667
30668       END
30669
30670 *$ CREATE PHO_QPMPDF.FOR
30671 *COPY PHO_QPMPDF
30672 CDECK  ID>, PHO_QPMPDF
30673       SUBROUTINE PHO_QPMPDF(IQ,X,SCALE2,PTREF,PVIRT,FXP)
30674 C***************************************************************
30675 C
30676 C     contribution to photon PDF from box graph
30677 C     (Bethe-Heitler process)
30678 C
30679 C     input:      IQ       quark flavour
30680 C                 SCALE2   scale (GeV**2, positive)
30681 C                 PTREF    reference scale (GeV, positive)
30682 C                 X        parton momentum fraction
30683 C                 PVIRT    photon virtuality (GeV**2, positive)
30684 C                 FXP      x*f(x,Q**2), x times parton density
30685 C
30686 C***************************************************************
30687       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30688       SAVE
30689
30690 C  input/output channels
30691       INTEGER LI,LO
30692       COMMON /POINOU/ LI,LO
30693 C  event debugging information
30694       INTEGER NMAXD
30695       PARAMETER (NMAXD=100)
30696       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30697      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30698       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30699      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30700 C  internal rejection counters
30701       INTEGER NMXJ
30702       PARAMETER (NMXJ=60)
30703       CHARACTER*10 REJTIT
30704       INTEGER IFAIL
30705       COMMON /POLOOP/ IFAIL(NMXJ),REJTIT(NMXJ)
30706 C  some constants
30707       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
30708       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
30709      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
30710
30711       DIMENSION QM(6)
30712       DATA QM / 0.2D0,0.25D0,0.5D0,1.5D0,4.5D0,174.D0 /
30713
30714       FXP = 0.D0
30715       I = ABS(IQ)
30716 C
30717 *     QM2 = MAX(QM(I),PTREF)**2
30718 *     QM2 = MAX(QM2,PVIRT)
30719 *     BBE = (1.D0-X)*SCALE2
30720 *     IF(BBE.LE.0.D0) THEN
30721 *       IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
30722 *    &    'PHO_QPMPDF: over mass limit (X,Q2,P2,QM)',X,SCALE2,
30723 *    &    PVIRT,QM(I)
30724 *     ENDIF
30725 *     FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(2.D0*137.D0*PI)
30726 *    &  *((X**2+(1.D0-X)**2)*LOG(BBE/(QM2*X))+8.D0*X*(1.D0-X)-1.D0)
30727 C  Bethe-Heitler process approximation for 2*x*p2/q2 << 1
30728       QM2 = MAX(QM(I),PTREF)**2
30729       W2 = SCALE2/X*(1.D0-X-X*PVIRT/SCALE2)
30730       IF(W2.GT.4.D0*QM2) THEN
30731         BE = SQRT(1.D0-4.D0*QM2/W2)
30732         BP = SQRT(1.D0+BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
30733         BM = SQRT(1.D0-BE*(1.D0-4.D0*X*X*PVIRT/SCALE2))
30734 *       FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(137.D0*PI)*(BE*(-1.D0
30735         FXP = X*Q_ch2(I)*3.D0/(137.D0*PI)*(BE*(-1.D0
30736      &         +6.D0*X-6.D0*X*X)+2.D0*X*X*((2.D0*QM2-PVIRT)/SCALE2
30737      &         -4.D0*QM2*QM2/SCALE2**2)*(1.D0/BM-1.D0/BP)
30738      &         +(X*X+(1.D0-X)**2+X*(1-3.D0*X)*4.D0*QM2/SCALE2
30739      &         -X*X*8.D0*QM2*QM2/SCALE2**2)*LOG(BP/BM))
30740       ELSE
30741         IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
30742      &    'PHO_QPMPDF: under mass limit (X,Q2,P2,QM)',X,SCALE2,
30743      &    PVIRT,QM(I)
30744       ENDIF
30745 C  debug output
30746       IF(IDEB(27).GE.20) WRITE(LO,'(1X,A,I3,1P,5E10.3)')
30747      &  'PHO_QPMPDF: X,Q2,P2,QM',I,X,SCALE2,PVIRT,QM(I),FXP
30748       END
30749
30750 *$ CREATE PHO_SETPDF.FOR
30751 *COPY PHO_SETPDF
30752 CDECK  ID>, PHO_SETPDF
30753       SUBROUTINE PHO_SETPDF(IDPDG,ITYP,IPAR,ISET,IEXT,IPAVAL,MODE)
30754 C***************************************************************
30755 C
30756 C     assigns  PDF numbers to particles
30757 C
30758 C     input:      IDPDG    PDG number of particle
30759 C                 ITYP     particle type
30760 C                 IPAR     PDF paramertization
30761 C                 ISET     number of set
30762 C                 IEXT     library number for PDF calculation
30763 C                 IPAVAL   (only output)
30764 C                          1 PDF with valence quarks
30765 C                          0 PDF without valence quarks
30766 C                 MODE     -1   add entry to table
30767 C                           1   read from table
30768 C                           2   output of table
30769 C
30770 C***************************************************************
30771       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30772       SAVE
30773
30774 C  input/output channels
30775       INTEGER LI,LO
30776       COMMON /POINOU/ LI,LO
30777 C  event debugging information
30778       INTEGER NMAXD
30779       PARAMETER (NMAXD=100)
30780       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
30781      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30782       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
30783      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
30784 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
30785       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
30786       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
30787       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
30788      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
30789
30790       DIMENSION IPDFS(5,50)
30791       DATA IENTRY / 0 /
30792
30793       IF(MODE.EQ.1) THEN
30794         I = 1
30795         IF(IDPDG.EQ.81) THEN
30796           IDCMP = IDEQP(1)
30797           IPAVAL = IHFLS(1)
30798         ELSE IF(IDPDG.EQ.82) THEN
30799           IDCMP = IDEQP(2)
30800           IPAVAL = IHFLS(2)
30801         ELSE
30802           IDCMP = IDPDG
30803           IPAVAL = 1
30804         ENDIF
30805 200     CONTINUE
30806           IF(IDCMP.EQ.IPDFS(1,I)) THEN
30807             ITYP = IPDFS(2,I)
30808             IPAR = IPDFS(3,I)
30809             ISET = IPDFS(4,I)
30810             IEXT = IPDFS(5,I)
30811             IF(IDEB(80).GE.15) WRITE(LO,'(1X,A,I7,5X,3I4)')
30812      &        'PHO_SETPDF: ID,IPAR,ISET,IEXT',IDCMP,IPAR,ISET,IEXT
30813             RETURN
30814           ENDIF
30815           I = I+1
30816           IF(I.GT.IENTRY) THEN
30817             WRITE(LO,'(/1X,A,I7)')
30818      &        'PHO_SETPDF: no PDF assigned to ',IDCMP
30819             CALL PHO_ABORT
30820           ENDIF
30821         GOTO 200
30822       ELSE IF(MODE.EQ.-1) THEN
30823         DO 50 I=1,IENTRY
30824           IF(IDPDG.EQ.IPDFS(1,I)) THEN
30825             WRITE(LO,'(/1X,A,5I6)')
30826      &        'PHO_SETPDF: overwrite old particle PDF',
30827      &        IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
30828             GOTO 100
30829           ENDIF
30830  50     CONTINUE
30831         I = IENTRY+1
30832         IF(I.GT.50) THEN
30833           WRITE(LO,'(/1X,A,/1x,6I6)')
30834      &      'PHO_SETPDF:ERROR: no space left in IPDFS:',
30835      &      I,IDPDG,IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
30836           STOP
30837         ENDIF
30838         IENTRY = I
30839  100    CONTINUE
30840         IPDFS(1,I) = IDPDG
30841         IF(IDPDG.EQ.990) THEN
30842           ITYP1 = 20
30843         ELSE IF(IDPDG.EQ.22) THEN
30844           ITYP1 = 3
30845         ELSE IF(ABS(IDPDG).LT.1000) THEN
30846           ITYP1 = 2
30847         ELSE
30848           ITYP1 = 1
30849         ENDIF
30850         IPDFS(2,I) = ITYP1
30851         IPDFS(3,I) = IPAR
30852         IPDFS(4,I) = ISET
30853         IPDFS(5,I) = IEXT
30854       ELSE IF(MODE.EQ.-2) THEN
30855         WRITE(LO,'(/1X,A)') 'PHO_SETPDF: PDFs assigned by user:'
30856         DO 150 I=1,IENTRY
30857           WRITE(LO,'(5X,I4,A,I7,A,4I5)') I,'  particle:',IPDFS(1,I),
30858      &      '   PDF-set  ',IPDFS(2,I),IPDFS(3,I),IPDFS(4,I),IPDFS(5,I)
30859  150    CONTINUE
30860       ELSE
30861         WRITE(LO,'(/1X,A,I5)') 'PHO_SETPDF:ERROR: invalid mode ',MODE
30862       ENDIF
30863       END
30864
30865 *$ CREATE PHO_GETPDF.FOR
30866 *COPY PHO_GETPDF
30867 CDECK  ID>, PHO_GETPDF
30868       SUBROUTINE PHO_GETPDF(NPAR,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
30869 C***************************************************************
30870 C
30871 C     get PDF information
30872 C
30873 C     input:      NPAR     1  first PDF in /POPPDF/
30874 C                          2  second PDF in /POPPDF/
30875 C
30876 C     output:     PDFNA    name of PDf parametrization
30877 C                 ALA      QCD LAMBDA (4 flavours, in GeV)
30878 C                 Q2MI     minimal Q2
30879 C                 Q2MA     maximal Q2
30880 C                 XMI      minimal X
30881 C                 XMA      maximal X
30882 C
30883 C***************************************************************
30884       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30885       SAVE
30886
30887       CHARACTER*8 PDFNA
30888
30889 C  input/output channels
30890       INTEGER LI,LO
30891       COMMON /POINOU/ LI,LO
30892
30893 C  PHOLIB 4.15 common
30894       COMMON /W50512/ QCDL4,QCDL5
30895       COMMON /W50513/ XMIN,XMAX,Q2MIN,Q2MAX
30896
30897 C  PHOPDF version 2.0 common
30898       PARAMETER (MAXS=6,MAXP=10)
30899       CHARACTER*4 CHPAR
30900       COMMON/PHCOM1/ XLIM(MAXP,0:MAXS,2), Q2LIM(MAXP,0:MAXS,2),
30901      & NSET(MAXP,2),NFL(MAXP)
30902       COMMON/PHCOM2/ ALM(MAXP,0:MAXS),CHPAR(MAXP),IORD(MAXP,-MAXS:MAXS)
30903
30904 C  currently activated parton density parametrizations
30905       CHARACTER*8 PDFNAM
30906       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
30907       DOUBLE PRECISION PDFLAM,PDFQ2M
30908       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
30909      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
30910
30911       DIMENSION PARAM(20),VALUE(20)
30912       CHARACTER*20 PARAM
30913
30914       IF((NPAR.NE.1).AND.(NPAR.NE.2)) THEN
30915         WRITE(LO,'(/1X,A,I6)')
30916      &    'PHO_GETPDF:ERROR: invalid PDF number (1,2)',NPAR
30917         CALL PHO_ABORT
30918       ENDIF
30919       ALA = 0.D0
30920
30921       IF(IEXT(NPAR).EQ.0) THEN
30922
30923 C  internal parametrizations
30924
30925         IF(ITYPE(NPAR).EQ.1) THEN
30926 C  proton PDFs
30927           IF(IGRP(NPAR).EQ.5) THEN
30928             IF(ISET(NPAR).EQ.3) THEN
30929               ALA    = 0.2D0
30930               Q2MI   = 0.3D0
30931               PDFNA  = 'GRV92 HO'
30932             ELSE IF(ISET(NPAR).EQ.4) THEN
30933               ALA    = 0.2D0
30934               Q2MI   = 0.25D0
30935               PDFNA  = 'GRV92 LO'
30936             ELSE IF(ISET(NPAR).EQ.5) THEN
30937               ALA    = 0.2D0
30938               Q2MI   = 0.4D0
30939               PDFNA  = 'GRV94 HO'
30940             ELSE IF(ISET(NPAR).EQ.6) THEN
30941               ALA    = 0.2D0
30942               Q2MI   = 0.4D0
30943               PDFNA  = 'GRV94 LO'
30944             ELSE IF(ISET(NPAR).EQ.7) THEN
30945               ALA    = 0.2D0
30946               Q2MI   = 0.4D0
30947               PDFNA  = 'GRV94 DI'
30948             ELSE IF(ISET(NPAR).EQ.8) THEN
30949               ALA    = 0.175D0
30950               Q2MI   = 0.8D0
30951               PDFNA  = 'GRV98 LO'
30952             ELSE IF(ISET(NPAR).EQ.9) THEN
30953               ALA    = 0.175D0
30954               Q2MI   = 0.8D0
30955               PDFNA  = 'GRV98 SC'
30956             ENDIF
30957           ENDIF
30958         ELSE IF(ITYPE(NPAR).EQ.2) THEN
30959 C  pion PDFs
30960           IF(IGRP(NPAR).EQ.5) THEN
30961             IF(ISET(NPAR).EQ.1) THEN
30962               ALA    = 0.2D0
30963               Q2MI   = 0.3D0
30964               PDFNA  = 'GRV-P HO'
30965             ELSE IF(ISET(NPAR).EQ.2) THEN
30966               ALA    = 0.2D0
30967               Q2MI   = 0.25D0
30968               PDFNA  = 'GRV-P LO'
30969             ENDIF
30970           ENDIF
30971         ELSE IF(ITYPE(NPAR).EQ.3) THEN
30972 C  photon PDFs
30973           IF(IGRP(NPAR).EQ.5) THEN
30974             IF(ISET(NPAR).EQ.1) THEN
30975               ALA    = 0.2D0
30976               Q2MI   = 0.3D0
30977               PDFNA  = 'GRV-G LH'
30978             ELSE IF(ISET(NPAR).EQ.2) THEN
30979               ALA    = 0.2D0
30980               Q2MI   = 0.3D0
30981               PDFNA  = 'GRV-G HO'
30982             ELSE IF(ISET(NPAR).EQ.3) THEN
30983               ALA    = 0.2D0
30984               Q2MI   = 0.25D0
30985               PDFNA  = 'GRV-G LO'
30986             ENDIF
30987           ELSE IF(IGRP(NPAR).EQ.8) THEN
30988             IF(ISET(NPAR).EQ.1) THEN
30989               ALA    = 0.2D0
30990               Q2MI   = 4.D0
30991               PDFNA  = 'AGL-G LO'
30992             ENDIF
30993           ENDIF
30994         ELSE IF(ITYPE(NPAR).EQ.20) THEN
30995 C  pomeron PDFs
30996           IF(IGRP(NPAR).EQ.4) THEN
30997             CALL PHO_CKMTPA(990,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
30998           ELSE
30999             ALA    = 0.3D0
31000             Q2MI   = 2.D0
31001             PDFNA  = 'POM-PDF1'
31002           ENDIF
31003         ENDIF
31004
31005 C  external parametrizations
31006
31007       ELSE IF(IEXT(NPAR).EQ.1) THEN
31008 C  PDFLIB call: old numbering
31009         PARAM(1) = 'MODE'
31010         PARAM(2) = ' '
31011         VALUE(1) = IGRP(NPAR)
31012         CALL PDFSET(PARAM,VALUE)
31013         Q2MI = Q2MIN
31014         Q2MA = Q2MAX
31015         XMI  = XMIN
31016         XMA  = XMAX
31017         ALA  = QCDL4
31018         PDFNA = 'PDFLIB1'
31019       ELSE IF(IEXT(NPAR).EQ.2) THEN
31020 C  PDFLIB call: new numbering
31021         PARAM(1) = 'NPTYPE'
31022         PARAM(2) = 'NGROUP'
31023         PARAM(3) = 'NSET'
31024         PARAM(4) = ' '
31025         VALUE(1) = ITYPE(NPAR)
31026         VALUE(2) = IGRP(NPAR)
31027         VALUE(3) = ISET(NPAR)
31028         CALL PDFSET(PARAM,VALUE)
31029         Q2MI = Q2MIN
31030         Q2MA = Q2MAX
31031         XMI  = XMIN
31032         XMA  = XMAX
31033         ALA  = QCDL4
31034         PDFNA = 'PDFLIB2'
31035       ELSE IF(IEXT(NPAR).EQ.3) THEN
31036 C  PHOLIB interface
31037         ALA  = ALM(IGRP(NPAR),ISET(NPAR))
31038         Q2MI = 2.D0
31039         PDFNA = CHPAR(IGRP(NPAR))
31040
31041 C  some special internal parametrizations
31042
31043       ELSE IF(IEXT(NPAR).EQ.4) THEN
31044 C  photon PDFs depending on virtualities
31045         IF(IGRP(NPAR).EQ.1) THEN
31046 C  Schuler/Sjostrand parametrization
31047           ALA = 0.2D0
31048           IF(ISET(NPAR).EQ.1) THEN
31049             Q2MI = 0.2D0
31050             PDFNA = 'SaS-1D  '
31051           ELSE IF(ISET(NPAR).EQ.2) THEN
31052             Q2MI = 0.2D0
31053             PDFNA = 'SaS-1M  '
31054           ELSE IF(ISET(NPAR).EQ.3) THEN
31055             Q2MI = 2.D0
31056             PDFNA = 'SaS-2D  '
31057           ELSE IF(ISET(NPAR).EQ.4) THEN
31058             Q2MI = 2.D0
31059             PDFNA = 'SaS-2M  '
31060           ENDIF
31061         ELSE IF(IGRP(NPAR).EQ.5) THEN
31062 C  Gluck/Reya/Stratmann parametrization
31063           IF(ISET(NPAR).EQ.4) THEN
31064             ALA = 0.2D0
31065             Q2MI = 0.6D0
31066             PDFNA = 'GRS-G LO'
31067           ENDIF
31068         ENDIF
31069       ELSE IF(IEXT(NPAR).EQ.5) THEN
31070 C  Schuler/Sjostrand anomalous only
31071         ALA   = 0.2D0
31072         Q2MI  = 0.2D0
31073         PDFNA = 'SaS anom'
31074       ENDIF
31075       IF(ALA.LT.0.01D0) THEN
31076         WRITE(LO,'(/1X,2A,/10X,5I6)')
31077      &    'PHO_GETPDF:ERROR: ',
31078      &    'unsupported PDF (NPAR,IEXT,ITYPE,IGRP,ISET)',
31079      &    NPAR,IEXT(NPAR),ITYPE(NPAR),IGRP(NPAR),ISET(NPAR)
31080         CALL PHO_ABORT
31081       ENDIF
31082
31083       END
31084
31085 *$ CREATE PHO_ACTPDF.FOR
31086 *COPY PHO_ACTPDF
31087 CDECK  ID>, PHO_ACTPDF
31088       SUBROUTINE PHO_ACTPDF(IDPDG,K)
31089 C***************************************************************
31090 C
31091 C     activate PDF for QCD calculations
31092 C
31093 C     input:      IDPDG    PDG particle number
31094 C                 K        1  first PDF in /POPPDF/
31095 C                          2  second PDF in /POPPDF/
31096 C                         -2  write current settings
31097 C
31098 C     output:     /POPPDF/
31099 C
31100 C***************************************************************
31101       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31102       SAVE
31103
31104 C  input/output channels
31105       INTEGER LI,LO
31106       COMMON /POINOU/ LI,LO
31107 C  event debugging information
31108       INTEGER NMAXD
31109       PARAMETER (NMAXD=100)
31110       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31111      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31112       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31113      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31114 C  currently activated parton density parametrizations
31115       CHARACTER*8 PDFNAM
31116       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
31117       DOUBLE PRECISION PDFLAM,PDFQ2M
31118       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
31119      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
31120
31121       IF(K.GT.0) THEN
31122
31123 C  read PDF from table
31124         CALL PHO_SETPDF(IDPDG,ITYPE(K),IGRP(K),ISET(K),IEXT(K),
31125      &                 IPAVA(K),1)
31126         IPARID(K) = IDPDG
31127 C  get PDF parameters
31128         CALL PHO_GETPDF(K,PDFNAM(K),PDFLAM(K),PDFQ2M(K),Q2MA,XMI,XMA)
31129 C  initialize alpha_s calculation
31130         alam2 = PDFLAM(K)*PDFLAM(K)
31131         DUMMY = PHO_ALPHAS(alam2,-K)
31132
31133         IF(IDEB(2).GE.20) THEN
31134           WRITE(LO,'(1X,A)')
31135      &      'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
31136           WRITE(LO,'(1X,A,I2,2E12.3,2X,A8,4I4,I7)') 'SIDE',K,
31137      &      PDFLAM(K),PDFQ2M(K),PDFNAM(K),ITYPE(K),IGRP(K),ISET(K),
31138      &      IEXT(K),IPARID(K)
31139         ENDIF
31140         NPAOLD = K
31141
31142       ELSE IF(K.EQ.-2) THEN
31143
31144 C  write table of current PDFs
31145         WRITE(LO,'(1X,A)')
31146      &    'PHO_ACTPDF: LAMBDA,Q2MIN,NAME,ITYPE,IPAR,ISET,IEXT,PAR'
31147         WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 1:',PDFLAM(1),
31148      &    PDFQ2M(1),PDFNAM(1),ITYPE(1),IGRP(1),ISET(1),IEXT(1),
31149      &    IPARID(1)
31150         WRITE(LO,'(1X,A,2E12.3,2X,A8,4I4,I7)') 'SIDE 2:',PDFLAM(2),
31151      &    PDFQ2M(2),PDFNAM(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),
31152      &    IPARID(2)
31153
31154       ELSE
31155
31156         WRITE(LO,'(/1X,A,2I4)')
31157      &    'PHO_ACTPDF:ERROR: invalid arguments',IDPDG,K
31158         CALL PHO_ABORT
31159
31160       ENDIF
31161
31162       END
31163
31164 *$ CREATE PHO_PDFTST.FOR
31165 *COPY PHO_PDFTST
31166 CDECK  ID>, PHO_PDFTST
31167       SUBROUTINE PHO_PDFTST(IDPDG,SCALE2,P2MASS)
31168 C*********************************************************************
31169 C
31170 C     structure function test utility
31171 C
31172 C     input:    IDPDG    PDG ID of particle
31173 C               SCALE2   squared scale (GeV**2)
31174 C               P2MASS   particle virtuality (pos, GeV**2)
31175 C
31176 C     output:   tables of PDF, sum rule checking, table of F2
31177 C
31178 C*********************************************************************
31179       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31180       SAVE
31181
31182 C  input/output channels
31183       INTEGER LI,LO
31184       COMMON /POINOU/ LI,LO
31185 C  currently activated parton density parametrizations
31186       CHARACTER*8 PDFNAM
31187       INTEGER IPARID,IPAVA,ITYPE,IGRP,ISET,IEXT,NPAOLD
31188       DOUBLE PRECISION PDFLAM,PDFQ2M
31189       COMMON /POPPDF/ PDFLAM(2),PDFQ2M(2),PDFNAM(2),IPARID(2),
31190      &                IPAVA(2),ITYPE(2),IGRP(2),ISET(2),IEXT(2),NPAOLD
31191 C  some constants
31192       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
31193       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
31194      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
31195
31196       DIMENSION PD(-6:6),PDSUM(-6:6),PDAVE(-6:6),FXP(4)
31197       CHARACTER*8 PDFNA
31198
31199       CALL PHO_ACTPDF(IDPDG,1)
31200       CALL PHO_GETPDF(1,PDFNA,ALA,Q2MI,Q2MA,XMI,XMA)
31201
31202       WRITE(LO,'(/,A)') ' *** Structure Function Test Utility ***'
31203       WRITE(LO,'(A)') ' ======================================='
31204
31205       WRITE(LO,'(/,A,3I10)')
31206      &  ' used structure function:',ITYPE(1),IGRP(1),ISET(1)
31207       WRITE(LO,'(A,A)')     ' corresponds to ',PDFNA
31208       WRITE(LO,'(A,E12.3)') '  used squared scale (GeV**2):',SCALE2
31209       WRITE(LO,'(A,E12.3)') ' particle virtuality (GeV**2):',P2MASS
31210       WRITE(LO,'(/1X,A)') 'x times parton densities'
31211       WRITE(LO,'(1X,A)') '    X         PD(-4 - 4)'
31212       WRITE(LO,'(1X,A)')
31213      &   ' ============================================================'
31214
31215 C  logarithmic loop over x values
31216 C  upper bound
31217       XUPPER=0.9999D0
31218 C  lower bound
31219       XLOWER=1.D-4
31220 C  number of steps
31221       NSTEP=50
31222
31223       XFIRST=LOG(XLOWER)
31224       XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
31225       DO 100 I=1,NSTEP
31226         X=EXP(XFIRST)
31227         XCONTR=X
31228         CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
31229         IF(X.NE.XCONTR) THEN
31230           WRITE(LO,*) ' x changed! old: ',XCONTR,' new: ',X
31231         ENDIF
31232         WRITE(LO,'(1X,1P,10E11.4)') XCONTR,(PD(K),K=-4,4)
31233         XFIRST=XFIRST+XDELTA
31234  100  CONTINUE
31235
31236       IF(IDPDG.EQ.22) THEN
31237         WRITE(LO,'(/1X,A)')
31238      &   'comparison PDF to contribution due to box diagram'
31239         WRITE(LO,'(1X,A)') '    X   PD(1),PB(1), .... ,PD(4),PB(4)'
31240         WRITE(LO,'(1X,A)')
31241      &   ' ============================================================'
31242         XFIRST=LOG(XLOWER)
31243         XDELTA=LOG(XUPPER/XLOWER)/DBLE(NSTEP-1)
31244         DO 110 I=1,NSTEP
31245           X=EXP(XFIRST)
31246           CALL PHO_PDF(1,X,SCALE2,P2MASS,PD)
31247           DO 120 K=1,4
31248             CALL PHO_QPMPDF(K,X,SCALE2,0.D0,P2MASS,FXP(K))
31249  120      CONTINUE
31250           WRITE(LO,'(1X,1P,9E11.4)') X,(PD(K),FXP(K),K=1,4)
31251           XFIRST=XFIRST+XDELTA
31252  110    CONTINUE
31253       ENDIF
31254
31255 C  check momentum sum rule
31256
31257       WRITE(LO,'(/1X,A)') 'PHO_PDFTST: estimate of quark sum rules'
31258       DO 199 I=-6,6
31259         PDSUM(I) = 0.D0
31260         PDAVE(I) = 0.D0
31261  199  CONTINUE
31262       ITER=5000
31263       DO 200 I=1,ITER
31264         XX=DBLE(I)/DBLE(ITER)
31265         IF(XX.EQ.1.D0) XX = 0.999999D0
31266         CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
31267         DO 202 K=-6,6
31268           PDSUM(K) = PDSUM(K)+PD(K)/XX
31269           PDAVE(K) = PDAVE(K)+PD(K)
31270  202    CONTINUE
31271  200  CONTINUE
31272       WRITE(LO,'(1X,A)')
31273      &  'Table: parton-ID, dx-integral over Q(X,Q**2), X*Q(X,Q**2)'
31274       XSUM = 0.D0
31275       DO 204 I=-6,6
31276         PDSUM(I) = PDSUM(I)/DBLE(ITER)
31277         PDAVE(I) = PDAVE(I)/DBLE(ITER)
31278         XSUM = XSUM+PDAVE(I)
31279         WRITE(LO,'(9X,I3,3X,2E15.4)') I,PDSUM(I),PDAVE(I)
31280  204  CONTINUE
31281       WRITE(LO,'(1X,A)') 'PHO_PDFTST: valence flavours'
31282       DO 205 I=1,6
31283         WRITE(LO,'(9X,I3,E12.4)') I,PDSUM(I)-PDSUM(-I)
31284  205  CONTINUE
31285       WRITE(LO,'(1X,A,E12.4)') 'momentum sum rule',XSUM
31286       WRITE(LO,'(A/)') ' ============================================='
31287
31288 C  table of F2
31289
31290       WRITE(LO,'(/1X,A,E12.4,/1X,A)')
31291      &  'PHO_PDFTST: TABLE OF X, F2(X,Q**2) FOR Q**2',SCALE2,
31292      &  '-----------------------------------------------------'
31293       ITER=100
31294       DO 300 I=1,ITER
31295         XX=DBLE(I)/DBLE(ITER)
31296         IF(XX.EQ.1.D0) XX = 0.9999D0
31297         CALL PHO_PDF(1,XX,SCALE2,P2MASS,PD)
31298         F2 = 0.D0
31299         DO 302 K=-6,6
31300           IF(K.NE.0) F2 = F2 + Q_ch2(K)*PD(K)
31301  302    CONTINUE
31302         WRITE(LO,'(5X,1P,2E14.5)') XX,F2
31303  300  CONTINUE
31304       WRITE(LO,'(A/)') ' ============================================='
31305       END
31306
31307 *$ CREATE PHO_REGPAR.FOR
31308 *COPY PHO_REGPAR
31309 CDECK  ID>, PHO_REGPAR
31310       SUBROUTINE PHO_REGPAR(ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4,
31311      &                  IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE)
31312 C**********************************************************************
31313 C
31314 C     registration of particle in /POEVT1/ and /POEVT2/
31315 C
31316 C     input:    ISTH             status code of particle
31317 C                                 -2     initial parton hard scattering
31318 C                                 -1     parton
31319 C                                  0     string
31320 C                                  1     visible particle (no color)
31321 C                                  2     decayed particle
31322 C               IDPDG            PDG particle ID code
31323 C               IDBAM            CPC particle ID code
31324 C               JM1,JM2          first and second mother index
31325 C               P1..P4           four momentum
31326 C               IPHIS1           extended history information
31327 C                                  IPHIS1<100: JM1 from particle 1
31328 C                                  IPHIS1>100: JM1 from particle 2
31329 C                                  1    valence quark
31330 C                                  2    valence diquark
31331 C                                  3    sea quark
31332 C                                  4    sea diquark
31333 C                                  (neg. for antipartons)
31334 C               IPHIS2           extended history information
31335 C                                  positive: JM2 from particle 1
31336 C                                  negative: JM2 from particle 2
31337 C                                  (see IPHIS1)
31338 C               IC1,IC2          color labels for partons
31339 C               IMODE            1  register given parton
31340 C                                0  reset /POEVT1/ and /POEVT2/
31341 C                                2  return data of entry IPOS
31342 C
31343 C               IPOS             position of particle in /POEVT1/
31344 C
31345 C**********************************************************************
31346       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31347       SAVE
31348
31349       PARAMETER (DEPS = 1.D-20)
31350
31351 C  input/output channels
31352       INTEGER LI,LO
31353       COMMON /POINOU/ LI,LO
31354 C  event debugging information
31355       INTEGER NMAXD
31356       PARAMETER (NMAXD=100)
31357       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31358      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31359       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31360      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31361 C  standard particle data interface
31362       INTEGER NMXHEP
31363       PARAMETER (NMXHEP=4000)
31364       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
31365       DOUBLE PRECISION PHEP,VHEP
31366       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
31367      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
31368      &                VHEP(4,NMXHEP)
31369 C  extension to standard particle data interface (PHOJET specific)
31370       INTEGER IMPART,IPHIST,ICOLOR
31371       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
31372
31373       IF(IMODE.EQ.1) THEN
31374         IF(IDEB(76).GE.26) THEN
31375           WRITE(LO,'(1X,A,/2X,I3,I6,3I4,4E10.3)')
31376      &      'PHO_REGPAR: ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4',
31377      &      ISTH,IDPDG,IDBAM,JM1,JM2,P1,P2,P3,P4
31378           WRITE(LO,'(1X,A,/2X,6I6)')
31379      &      'PHO_REGPAR: IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE',
31380      &      IPHIS1,IPHIS2,IC1,IC2,IPOS,IMODE
31381         ENDIF
31382         IF(NHEP.EQ.NMXHEP) THEN
31383           WRITE(LO,'(/1X,2A,2I6/)') 'PHO_REGPAR: ',
31384      &      'no space left in /POEVT1/ (NHEP,NMXHEP):',NHEP,NMXHEP
31385           CALL PHO_ABORT
31386         ENDIF
31387         NHEP = NHEP+1
31388         IDBAMI = IDBAM
31389         IDPDGI = IDPDG
31390         IF(ABS(ISTH).LE.2) THEN
31391           IF((IDBAM.NE.0).AND.(IDPDG.EQ.0)) THEN
31392             IDPDGI = ipho_id2pdg(IDBAM)
31393           ELSE IF((IDBAM.EQ.0).AND.(IDPDG.NE.0)) THEN
31394             IDBAMI = ipho_pdg2id(IDPDG)
31395           ENDIF
31396         ENDIF
31397 C  standard data
31398         ISTHEP(NHEP) = ISTH
31399         IDHEP(NHEP)  = IDPDGI
31400         JMOHEP(1,NHEP) = JM1
31401         JMOHEP(2,NHEP) = JM2
31402 C  update of mother-daugther relations
31403         IF(ABS(ISTH).LE.1) THEN
31404           IF(JM1.GT.0) THEN
31405             IF(JDAHEP(1,JM1).EQ.0) THEN
31406               JDAHEP(1,JM1) = NHEP
31407               ISTHEP(JM1) = 2
31408             ENDIF
31409             JDAHEP(2,JM1) = NHEP
31410           ENDIF
31411           IF((JM2.NE.JM1).AND.(JM2.GT.0)) THEN
31412             IF(JDAHEP(1,JM2).EQ.0) THEN
31413               JDAHEP(1,JM2) = NHEP
31414               ISTHEP(JM2) = 2
31415             ENDIF
31416             JDAHEP(2,JM2) = NHEP
31417           ELSE IF(JM2.LT.0) THEN
31418             DO 100 II=JM1+1,-JM2
31419               IF(JDAHEP(1,II).EQ.0) THEN
31420                 JDAHEP(1,II) = NHEP
31421                 ISTHEP(II) = 2
31422               ENDIF
31423               JDAHEP(2,II) = NHEP
31424 100         CONTINUE
31425           ENDIF
31426         ENDIF
31427         PHEP(1,NHEP) = P1
31428         PHEP(2,NHEP) = P2
31429         PHEP(3,NHEP) = P3
31430         PHEP(4,NHEP) = P4
31431         IF((ABS(ISTH).LE.3).OR.(ISTH.EQ.20).OR.(ISTH.EQ.21)) THEN
31432           TMP=(P4-P3)*(P4+P3)-P1**2-P2**2
31433           PHEP(5,NHEP) = SIGN(SQRT(ABS(TMP)),TMP)
31434         ELSE
31435           PHEP(5,NHEP) = 0.D0
31436         ENDIF
31437         JDAHEP(1,NHEP) = 0
31438         JDAHEP(2,NHEP) = 0
31439 C  extended information
31440         IMPART(NHEP) = IDBAMI
31441 C  extended history information
31442         IPHIST(1,NHEP) = IPHIS1
31443         IPHIST(2,NHEP) = IPHIS2
31444 C  charge/baryon number or color labels
31445         IF(ISTH.EQ.1) THEN
31446           ICOLOR(1,NHEP) = IPHO_CHR3(NHEP,2)
31447           ICOLOR(2,NHEP) = IPHO_BAR3(NHEP,2)
31448         ELSE
31449           ICOLOR(1,NHEP) = IC1
31450           ICOLOR(2,NHEP) = IC2
31451         ENDIF
31452
31453         IPOS = NHEP
31454         IF(IDEB(76).GE.26) THEN
31455           WRITE(LO,'(1X,A,2I4,2X,2I4,E12.3,I5)')
31456      &      'PHO_REGPAR: IPHIST1/2,IC1/2,MASS,IPOS',IPHIST(1,NHEP),
31457      &      IPHIST(2,NHEP),ICOLOR(1,NHEP),ICOLOR(2,NHEP),
31458      &      PHEP(5,NHEP),IPOS
31459         ENDIF
31460
31461       ELSE IF(IMODE.EQ.0) THEN
31462         NHEP   = 0
31463       ELSE IF(IMODE.EQ.2) THEN
31464         IF((IPOS.LT.1).OR.(IPOS.GT.NHEP)) THEN
31465           WRITE(LO,'(1X,2A,2I8)') 'PHO_REGPAR: ',
31466      &      'index out of bounds (NHEP,IPOS)',NHEP,IPOS
31467           RETURN
31468         ENDIF
31469         ISTH  = ISTHEP(IPOS)
31470         IDPDG = IDHEP(IPOS)
31471         IDBAM = IMPART(IPOS)
31472         JM1   = JMOHEP(1,IPOS)
31473         JM2   = JMOHEP(2,IPOS)
31474         P1    = PHEP(1,IPOS)
31475         P2    = PHEP(2,IPOS)
31476         P3    = PHEP(3,IPOS)
31477         P4    = PHEP(4,IPOS)
31478         IPHIS1= IPHIST(1,IPOS)
31479         IPHIS2= IPHIST(2,IPOS)
31480         IC1   = ICOLOR(1,IPOS)
31481         IC2   = ICOLOR(2,IPOS)
31482       ELSE
31483         WRITE(LO,'(1X,A,I8)') 'PHO_REGPAR: invalid mode',IMODE
31484       ENDIF
31485       END
31486
31487 *$ CREATE IPHO_CNV1.FOR
31488 *COPY IPHO_CNV1
31489 CDECK  ID>, IPHO_CNV1
31490       INTEGER FUNCTION IPHO_CNV1(IPART)
31491 C*********************************************************************
31492 C
31493 C     conversion of quark numbering scheme to PARTICLE DATA GROUP
31494 C                                             convention
31495 C
31496 C     input:   old internal particle code of hard scattering
31497 C                    0   gluon
31498 C                    1   d
31499 C                    2   u
31500 C                    3   s
31501 C                    4   c
31502 C     valence quarks changed to standard numbering
31503 C
31504 C     output:  standard particle codes
31505 C
31506 C*********************************************************************
31507       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31508       SAVE
31509 C
31510       II = ABS(IPART)
31511 C  change gluon number
31512       IF(II.EQ.0) THEN
31513         IPHO_CNV1 = 21
31514 C  change valence quark
31515       ELSE IF((II.GT.6).AND.(II.LT.13)) THEN
31516         IPHO_CNV1 = SIGN(II-6,IPART)
31517       ELSE
31518         IPHO_CNV1 = IPART
31519       ENDIF
31520       END
31521
31522 *$ CREATE PHO_HACODE.FOR
31523 *COPY PHO_HACODE
31524 CDECK  ID>, PHO_HACODE
31525       SUBROUTINE PHO_HACODE(ID1,ID2,IDcpc1,IDcpc2)
31526 C*********************************************************************
31527 C
31528 C     determination of hadron index from quarks
31529 C
31530 C     input:   ID1,ID2   parton code according to PDG conventions
31531 C
31532 C     output:  IDcpc1,2  CPC particle codes
31533 C
31534 C*********************************************************************
31535       IMPLICIT NONE
31536       SAVE
31537
31538       integer ID1,ID2,IDcpc1,IDcpc2
31539
31540 C  input/output channels
31541       INTEGER LI,LO
31542       COMMON /POINOU/ LI,LO
31543 C  event debugging information
31544       INTEGER NMAXD
31545       PARAMETER (NMAXD=100)
31546       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
31547      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31548       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
31549      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
31550 C  general particle data
31551       double precision xm_list,tau_list,gam_list,
31552      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
31553      &  xm_bb82_list,xm_bb102_list
31554       integer          ich3_list,iba3_list,iq_list,
31555      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
31556       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
31557      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
31558      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
31559      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
31560      &  ich3_list(300),iba3_list(300),iq_list(3,300),
31561      &  id_psm_list(6,6),id_vem_list(6,6),
31562      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
31563
31564 C  local variables
31565       integer ii,jj,kk,i1,i2
31566
31567       IDcpc1 = 0
31568       IDcpc2 = 0
31569
31570       if(ID1*ID2.lt.0) then
31571 C  meson
31572         if(ID1.gt.0) then
31573           ii = ID1
31574           jj = -ID2
31575         else
31576           ii = ID2
31577           jj = -ID1
31578         endif
31579         IDcpc1 = ID_psm_list(ii,jj)
31580         IDcpc2 = ID_vem_list(ii,jj)
31581
31582       else
31583 C  baryon
31584         i1 = abs(ID1)
31585         i2 = abs(ID2)
31586         if(i1.gt.6) then
31587           ii = i1/1000
31588           jj = (i1-ii*1000)/100
31589           kk = i2
31590         else
31591           ii = i1
31592           jj = i2/1000
31593           kk = (i2-jj*1000)/100
31594         endif
31595         IDcpc1 = sign(ID_b8_list(ii,jj,kk),ID1)
31596         IDcpc2 = sign(ID_b10_list(ii,jj,kk),ID1)
31597
31598       endif
31599
31600       END
31601
31602 *$ CREATE PHO_ID2STR.FOR
31603 *COPY PHO_ID2STR
31604 CDECK  ID>, PHO_ID2STR
31605       SUBROUTINE PHO_ID2STR(ID1,ID2,NOBAM,IBAM1,IBAM2,IBAM3,IBAM4)
31606 C*********************************************************************
31607 C
31608 C     conversion of quark numbering scheme
31609 C
31610 C     input:   standard particle codes:
31611 C                       ID1
31612 C                       ID2
31613 C
31614 C     output:  NOBAM    CPC string code
31615 C              quark codes (PDG convention):
31616 C                       IBAM1
31617 C                       IBAM2
31618 C                       IBAM3
31619 C                       IBAM4
31620 C
31621 C              NOBAM = -1 invalid flavour combinations
31622 C
31623 C*********************************************************************
31624       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31625       SAVE
31626
31627 C  input/output channels
31628       INTEGER LI,LO
31629       COMMON /POINOU/ LI,LO
31630
31631       IDA1 = ABS(ID1)
31632       IDA2 = ABS(ID2)
31633
31634 C  quark-antiquark string
31635       IF((IDA1.LE.6).AND.(IDA2.LE.6)) THEN
31636         IF((ID1*ID2).GE.0) GOTO 100
31637         IBAM1 = ID1
31638         IBAM2 = ID2
31639         IBAM3 = 0
31640         IBAM4 = 0
31641         NOBAM = 3
31642 C  quark-diquark string
31643       ELSE IF((IDA2.GT.6).AND.(IDA1.LE.6)) THEN
31644         IF((ID1*ID2).LE.0) GOTO 100
31645         IBAM1 = ID1
31646         IBAM2 = ID2/1000
31647         IBAM3 = (ID2-IBAM2*1000)/100
31648         IBAM4 = 0
31649         NOBAM = 4
31650 C  diquark-quark string
31651       ELSE IF((IDA1.GT.6).AND.(IDA2.LE.6)) THEN
31652         IF((ID1*ID2).LE.0) GOTO 100
31653         IBAM1 = ID1/1000
31654         IBAM2 = (ID1-IBAM1*1000)/100
31655         IBAM3 = ID2
31656         IBAM4 = 0
31657         NOBAM = 6
31658 C  gluon-gluon string
31659       ELSE IF((IDA1.EQ.21).AND.(IDA2.EQ.21)) THEN
31660         IBAM1 = 21
31661         IBAM2 = 21
31662         IBAM3 = 0
31663         IBAM4 = 0
31664         NOBAM = 7
31665 C  diquark-antidiquark string
31666       ELSE IF((IDA1.GT.6).AND.(IDA2.GT.6)) THEN
31667         IF((ID1*ID2).GE.0) GOTO 100
31668         IBAM1 = ID1/1000
31669         IBAM2 = (ID1-IBAM1*1000)/100
31670         IBAM3 = ID2/1000
31671         IBAM4 = (ID2-IBAM3*1000)/100
31672         NOBAM = 5
31673       ENDIF
31674       RETURN
31675
31676 C  invalid combination
31677  100  CONTINUE
31678         WRITE(LO,'(//1X,A,2I10)')
31679      &    'PHO_ID2STR: invalid flavors for string (ID1,ID2)',ID1,ID2
31680         CALL PHO_ABORT
31681
31682       END
31683
31684 *$ CREATE PHO_MKSLTR.FOR
31685 *COPY PHO_MKSLTR
31686 CDECK  ID>, PHO_MKSLTR
31687       SUBROUTINE PHO_MKSLTR(P1,P2,GAM,GAMB)
31688 C********************************************************************
31689 C
31690 C     calculate successive Lorentz boots for arbitrary Lorentz trans.
31691 C
31692 C     input:   P1                initial 4 vector
31693 C              GAM(3),GAMB(3)    Lorentz boost parameters
31694 C
31695 C     output:  P2                final  4 vector
31696 C
31697 C********************************************************************
31698       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31699       SAVE
31700
31701       DIMENSION P1(4),P2(4),GAM(3),GAMB(3)
31702
31703       P2(4) = P1(4)
31704       DO 150 I=1,3
31705         P2(I)=GAM(I)*P1(I)+GAMB(I)*P2(4)
31706         P2(4)=GAM(I)*P2(4)+GAMB(I)*P1(I)
31707  150  CONTINUE
31708       END
31709
31710 *$ CREATE PHO_GETLTR.FOR
31711 *COPY PHO_GETLTR
31712 CDECK  ID>, PHO_GETLTR
31713       SUBROUTINE PHO_GETLTR(P1,P2,GAM,GAMB,DELE,IREJ)
31714 C********************************************************************
31715 C
31716 C     calculate Lorentz boots for arbitrary Lorentz transformation
31717 C
31718 C     input:   P1    initial 4 vector
31719 C              P2    final 4 vector
31720 C
31721 C     output:  GAM(3),GAMB(3)
31722 C              DELE   energy deviation
31723 C              IREJ   0 success
31724 C                     1 failure
31725 C
31726 C********************************************************************
31727       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31728       SAVE
31729
31730       PARAMETER ( DREL = 0.001D0 )
31731
31732 C  input/output channels
31733       INTEGER LI,LO
31734       COMMON /POINOU/ LI,LO
31735
31736       DIMENSION P1(4),P2(4),GAM(3),GAMB(3),PA(4),PP(4)
31737
31738       IREJ = 1
31739       DO 50 K=1,4
31740         PA(K) = P1(K)
31741         PP(K) = P1(K)
31742  50   CONTINUE
31743       PM1 = P1(4)**2-P1(1)**2-P1(2)**2-P1(3)**2
31744       DO 100 I=1,3
31745         PP(I) = P2(I)
31746         PP(4) = PM1+PP(1)**2+PP(2)**2+PP(3)**2
31747         IF(PP(4).LE.0.D0) RETURN
31748         PP(4) = SQRT(PP(4))
31749         GAMB(I) = (SQRT(PA(4)**2-PA(I)**2+PP(I)**2)*PP(I)
31750      &             -PA(4)*PA(I))/(PA(4)**2+PP(I)**2)
31751         GAM(I) = 1.D0/SQRT(1.D0-GAMB(I)**2)
31752         GAMB(I) = GAMB(I)*GAM(I)
31753         DO 150 K=1,4
31754           PA(K) = PP(K)
31755  150    CONTINUE
31756  100  CONTINUE
31757       DELE = P2(4)-PP(4)
31758       IREJ = 0
31759 C  consistency check
31760 *     IF(ABS(P2(4)-PP(4))/MAX(P2(4),PP(4)).GT.DREL) THEN
31761 *       PM2 = P2(4)**2-P2(1)**2-P2(2)**2-P2(3)**2
31762 *       WRITE(LO,'(/1X,A,2E12.5)')
31763 *    &    'PHO_GETLTR: INCONSISTENT ENERGIES',P2(4),PP(4)
31764 *       WRITE(LO,'(1X,A,2E12.4)') 'INPUT MASSES',PM1,PM2
31765 *       WRITE(LO,'(1X,A,4E12.4)') 'INPUT ',P1
31766 *       WRITE(LO,'(1X,A,4E12.4)') 'OUTPUT',P2
31767 *       WRITE(LO,'(1X,A,4E12.4)') 'INTERN',PP
31768 *     ENDIF
31769       END
31770
31771 *$ CREATE PHO_ALTRA.FOR
31772 *COPY PHO_ALTRA
31773 CDECK  ID>, PHO_ALTRA
31774       SUBROUTINE PHO_ALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
31775 C*********************************************************************
31776 C
31777 C    arbitrary Lorentz transformation
31778 C
31779 C*********************************************************************
31780       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31781       SAVE
31782
31783       EP=PCX*BGX+PCY*BGY+PCZ*BGZ
31784       PE=EP/(GA+1.D0)+EC
31785       PX=PCX+BGX*PE
31786       PY=PCY+BGY*PE
31787       PZ=PCZ+BGZ*PE
31788       P=SQRT(PX*PX+PY*PY+PZ*PZ)
31789       E=GA*EC+EP
31790
31791       END
31792
31793 *$ CREATE PHO_LTRANS.FOR
31794 *COPY PHO_LTRANS
31795 CDECK  ID>, PHO_LTRANS
31796       SUBROUTINE PHO_LTRANS(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
31797      &                 PL,CXL,CYL,CZL,EL)
31798 C**********************************************************************
31799 C
31800 C     Lorentz transformation into lab - system
31801 C
31802 C**********************************************************************
31803       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31804       SAVE
31805
31806       PARAMETER ( TINY=1.D-08,TINY2=1.D-30 )
31807
31808 C  input/output channels
31809       INTEGER LI,LO
31810       COMMON /POINOU/ LI,LO
31811
31812       SID=SQRT(1.D0-COD*COD)
31813       PLX=P*SID*COF
31814       PLY=P*SID*SIF
31815       PCMZ=P*COD
31816       PLZ=GAM*PCMZ+BGAM*ECM
31817       PL=SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
31818       EL=GAM*ECM+BGAM*PCMZ
31819
31820 C  rotation into the original direction
31821       COZ=PLZ/PL
31822       SIZ=SQRT(MAX((1.D0-COZ)*(1.D0+COZ),0.D0))
31823
31824 *      CALL PHO_DTRANS(CX,CY,CZ,COZ,SIZ,COF,SIF,CXL,CYL,CZL)
31825
31826       AX=ABS(CX)
31827       AY=ABS(CY)
31828       IF(AX.LT.AY) THEN
31829         AMAX=AY
31830         AMIN=AX
31831       ELSE
31832         AMAX=AX
31833         AMIN=AY
31834       ENDIF
31835       IF (ABS(CX)-TINY) 1,1,2
31836     1 IF (ABS(CY)-TINY) 3,3,2
31837
31838     3 CONTINUE
31839 *     WRITE(LO,*) ' PHO_DTRANS CX CY CZ =',CX,CY,CZ
31840       CXL=SIZ*COF
31841       CYL=SIZ*SIF
31842       CZL=COZ*CZ
31843 *     WRITE(LO,*) ' PHO_DTRANS CXL=SIZ*COF CYL=SIZ*SIF CZL=COZ'
31844 *     WRITE(LO,*) CXL,CYL,CZL
31845       RETURN
31846
31847     2 CONTINUE
31848       IF(AMAX.GT.TINY2) THEN
31849         AR=AMIN/AMAX
31850         AR=AR*AR
31851         A=AMAX*SQRT(1.D0+AR)
31852       ELSE
31853 *       WRITE(LO,*) ' PHO_DTRANS AMAX LE TINY2 '
31854         GOTO 3
31855       ENDIF
31856       XI=SIZ*COF
31857       YI=SIZ*SIF
31858       ZI=COZ
31859       CXL=-CY*XI/A-CZ*CX*YI/A+CX*ZI
31860       CYL=CX*XI/A-CZ*CY*YI/A+CY*ZI
31861       CZL=A*YI+CZ*ZI
31862
31863       END
31864
31865 *$ CREATE PHO_TRANS.FOR
31866 *COPY PHO_TRANS
31867 CDECK  ID>, PHO_TRANS
31868       SUBROUTINE PHO_TRANS(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
31869 C**********************************************************************
31870 C
31871 C  rotation of coordinate frame (1) de rotation around y axis
31872 C                               (2) fe rotation around z axis
31873 C  (inverse rotation to PHO_TRANI)
31874 C
31875 C**********************************************************************
31876       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31877       SAVE
31878
31879       X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
31880       Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
31881       Z=-SDE    *XO       +CDE    *ZO
31882
31883       END
31884
31885 *$ CREATE PHO_TRANI.FOR
31886 *COPY PHO_TRANI
31887 CDECK  ID>, PHO_TRANI
31888       SUBROUTINE PHO_TRANI(XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
31889 C**********************************************************************
31890 C
31891 C  rotation of coordinate frame (1) -fe rotation around z axis
31892 C                               (2) -de rotation around y axis
31893 C  (inverse rotation to PHO_TRANS)
31894 C
31895 C**********************************************************************
31896       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31897       SAVE
31898
31899       X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
31900       Y=-SFE    *XO+CFE*    YO
31901       Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
31902
31903       END
31904
31905 *$ CREATE pho_cpcini.FOR
31906 *COPY pho_cpcini
31907 CDECK  ID>, pho_cpcini
31908       SUBROUTINE pho_cpcini(Nrows,Number,List)
31909 C***********************************************************************
31910 C
31911 C     initialization of particle hash table
31912 C
31913 C     input:   Number     vector with Nrows entries according to PDG
31914 C                         convention
31915 C
31916 C     output:  List       vector with hash table
31917 C
31918 C     (this code is based on the function initpns written by
31919 C      Gerry Lynch, LBL, January 1990)
31920 C
31921 C***********************************************************************
31922       IMPLICIT NONE
31923       SAVE
31924
31925 C  input/output channels
31926       INTEGER LI,LO
31927       COMMON /POINOU/ LI,LO
31928
31929       integer Number(*),List(*),Nrows
31930
31931       Integer Nin,Nout,Ip,I
31932
31933       do I = 1,577
31934         List(I) = 0
31935       enddo
31936
31937 C    Loop over all of the elements in the Number vector
31938
31939         Do 500 Ip = 1,Nrows
31940             Nin = Number(Ip)
31941
31942 C    Calculate a list number for this particle id number
31943             If(Nin.Gt.99999.or.Nin.Le.0) Then
31944                  Nout = -1
31945             Else If(Nin.Le.577) Then
31946                  Nout = Nin
31947             Else
31948                  Nout = Mod(Nin,577)
31949             End If
31950
31951  200        continue
31952
31953             If(Nout.Lt.0) Then
31954 C    Count the bad entries
31955                 WRITE(LO,'(1x,a,i10)')
31956      &            'pho_cpcini: invalid particle ID',Nin
31957                 Go to 500
31958             End If
31959             If(List(Nout).eq.0) Then
31960                 List(Nout) = Ip
31961             Else
31962                 If(Nin.eq.Number(List(Nout))) Then
31963                   WRITE(LO,'(1x,a,i10)')
31964      &              'pho_cpcini: double particle ID',Nin
31965                 End If
31966                 Nout = Nout + 5
31967                 If(Nout.Gt.577) Nout = Mod(Nout, 577)
31968
31969                 Go to 200
31970             End If
31971  500      Continue
31972
31973       END
31974
31975 *$ CREATE ipho_pdg2id.FOR
31976 *COPY ipho_pdg2id
31977 CDECK  ID>, ipho_pdg2id
31978       INTEGER FUNCTION ipho_pdg2id(IDpdg)
31979 C**********************************************************************
31980 C
31981 C     calculation internal particle code using the particle index i
31982 C     according to the PDG proposal.
31983 C
31984 C     input:  IDpdg          PDG particle number
31985 C     output: ipho_pdg2id    internal particle code
31986 C                            (0 for invalid IDpdg)
31987 C
31988 C     the hash algorithm is based on a program by Gerry Lynch
31989 C
31990 C**********************************************************************
31991       IMPLICIT NONE
31992       SAVE
31993
31994       integer IDpdg
31995
31996 C  input/output channels
31997       INTEGER LI,LO
31998       COMMON /POINOU/ LI,LO
31999 C  event debugging information
32000       INTEGER NMAXD
32001       PARAMETER (NMAXD=100)
32002       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32003      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32004       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32005      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32006 C  particle ID translation table
32007       integer         ID_pdg_list,ID_list,ID_pdg_max
32008       character*12    name_list
32009       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32010      &                ID_pdg_max
32011
32012       integer Nin,Nout
32013
32014       Nin = abs(IDpdg)
32015
32016       if((Nin.gt.99999).or.(Nin.eq.0)) then
32017 C  invalid particle number
32018         if(ideb(71).gt.5) WRITE(LO,'(1x,A,I10)')
32019      &    'ipho_pdg2id: invalid PDG ID number ',IDpdg
32020         ipho_pdg2id = 0
32021         return
32022       else If(Nin.le.577) then
32023 C  simple case
32024         Nout = Nin
32025       else
32026 C  use hash algorithm
32027         Nout = mod(Nin,577)
32028       endif
32029
32030  100  continue
32031
32032 C  particle not in table
32033       if(ID_list(Nout).Eq.0) then
32034         if(ideb(71).ge.0) WRITE(LO,'(1x,A,I10)')
32035      &    'ipho_pdg2id: particle not in table ',IDpdg
32036         ipho_pdg2id = 0
32037         return
32038       endif
32039
32040       if(ID_pdg_list(ID_list(Nout)).eq.Nin) then
32041 C  particle ID found
32042         ipho_pdg2id = sign(ID_list(Nout),IDpdg)
32043         return
32044       else
32045 C  increment and try again
32046         Nout = Nout + 5
32047         If(Nout.gt.577) Nout = Mod(Nout,577)
32048         goto 100
32049       endif
32050
32051       END
32052
32053 *$ CREATE IPHO_ID2PDG.FOR
32054 *COPY IPHO_ID2PDG
32055 CDECK  ID>, IPHO_ID2PDG
32056       INTEGER FUNCTION ipho_id2pdg(IDcpc)
32057 C**********************************************************************
32058 C
32059 C     conversion of internal particle code to PDG standard
32060 C
32061 C     input:     IDcpc        internal particle number
32062 C     output:    ipho_id2pdg  PDG particle number
32063 C                             (0 for invalid IDcpc)
32064 C
32065 C**********************************************************************
32066       IMPLICIT NONE
32067       SAVE
32068
32069       integer IDcpc
32070
32071 C  input/output channels
32072       INTEGER LI,LO
32073       COMMON /POINOU/ LI,LO
32074 C  event debugging information
32075       INTEGER NMAXD
32076       PARAMETER (NMAXD=100)
32077       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32078      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32079       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32080      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32081 C  particle ID translation table
32082       integer         ID_pdg_list,ID_list,ID_pdg_max
32083       character*12    name_list
32084       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32085      &                ID_pdg_max
32086
32087       integer IDabs
32088
32089       IDabs = abs(IDcpc)
32090       if((IDabs.lt.1).or.(IDabs.gt.ID_pdg_max)) then
32091         ipho_id2pdg = 0
32092         return
32093       endif
32094
32095       ipho_id2pdg = sign(ID_pdg_list(IDabs),IDcpc)
32096
32097       END
32098
32099 *$ CREATE IPHO_LU2PDG.FOR
32100 *COPY IPHO_LU2PDG
32101 CDECK  ID>, IPHO_LU2PDG
32102       INTEGER FUNCTION IPHO_LU2PDG(LUKF)
32103 C**********************************************************************
32104 C
32105 C    conversion of JETSET KF code to PDG code
32106 C
32107 C**********************************************************************
32108       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32109       SAVE
32110       PARAMETER (NTAB=10)
32111       DIMENSION LU2PD(2,NTAB)
32112       DATA LU2PD / 4232, 4322,
32113      &             4322, 4232,
32114      &             3212, 3122,
32115      &             3122, 3212,
32116      &            30553, 20553,
32117      &            30443, 20443,
32118      &            20443, 10443,
32119      &            10443, 0,
32120      &            511,   0,
32121      &            10551, 551 /
32122 C
32123       DO 100 I=1,NTAB
32124         IF(LU2PD(1,I).EQ.LUKF) THEN
32125           IPHO_LU2PDG=LU2PD(2,I)
32126           RETURN
32127         ENDIF
32128  100  CONTINUE
32129       IPHO_LU2PDG=LUKF
32130
32131       END
32132
32133 *$ CREATE IPHO_PDG2LU.FOR
32134 *COPY IPHO_PDG2LU
32135 CDECK  ID>, IPHO_PDG2LU
32136       INTEGER FUNCTION IPHO_PDG2LU(IPDG)
32137 C**********************************************************************
32138 C
32139 C    conversion of PDG code to JETSET code
32140 C
32141 C**********************************************************************
32142       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32143       SAVE
32144       PARAMETER (NTAB=8)
32145       DIMENSION LU2PD(2,NTAB)
32146       DATA LU2PD / 4232, 4322,
32147      &             4322, 4232,
32148      &             3212, 3122,
32149      &             3122, 3212,
32150      &            30553, 20553,
32151      &            30443, 20443,
32152      &            20443, 10443,
32153      &            10551, 551 /
32154 C
32155       DO 100 I=1,NTAB
32156         IF(LU2PD(2,I).EQ.IPDG) THEN
32157           IPHO_PDG2LU=LU2PD(1,I)
32158           RETURN
32159         ENDIF
32160  100  CONTINUE
32161       IPHO_PDG2LU=IPDG
32162
32163       END
32164
32165 *$ CREATE pho_pname.FOR
32166 *COPY pho_pname
32167 CDECK  ID>, pho_pname
32168       CHARACTER*15 FUNCTION pho_pname(ID,mode)
32169 C***********************************************************************
32170 C
32171 C     returns particle name for given ID number
32172 C
32173 C     input:  ID      particle ID number
32174 C             mode    0:   ID treated as compressed particle code
32175 C                     1:   ID treated as PDG number
32176 C
32177 C***********************************************************************
32178       IMPLICIT NONE
32179       SAVE
32180
32181       integer ID,mode
32182
32183 C  input/output channels
32184       INTEGER LI,LO
32185       COMMON /POINOU/ LI,LO
32186 C  standard particle data interface
32187       INTEGER NMXHEP
32188       PARAMETER (NMXHEP=4000)
32189       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32190       DOUBLE PRECISION PHEP,VHEP
32191       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32192      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32193      &                VHEP(4,NMXHEP)
32194 C  extension to standard particle data interface (PHOJET specific)
32195       INTEGER IMPART,IPHIST,ICOLOR
32196       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32197 C  particle ID translation table
32198       integer         ID_pdg_list,ID_list,ID_pdg_max
32199       character*12    name_list
32200       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32201      &                ID_pdg_max
32202 C  general particle data
32203       double precision xm_list,tau_list,gam_list,
32204      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32205      &  xm_bb82_list,xm_bb102_list
32206       integer          ich3_list,iba3_list,iq_list,
32207      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
32208       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32209      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
32210      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32211      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32212      &  ich3_list(300),iba3_list(300),iq_list(3,300),
32213      &  id_psm_list(6,6),id_vem_list(6,6),
32214      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
32215
32216 C  external functions
32217       integer ipho_id2pdg,ipho_pdg2id
32218
32219 C  local variables
32220       integer  IDpdg,i,ii,k,l,ichar,i_anti
32221       character*15 name
32222
32223       pho_pname = '(?????????????)'
32224
32225       if(mode.eq.0) then
32226         i = ID
32227         IDpdg = ipho_id2pdg(ID)
32228         if(IDpdg.eq.0) return
32229       else if(mode.eq.1) then
32230         i = ipho_pdg2id(ID)
32231         if(i.eq.0) return
32232         IDpdg = ID
32233       else if(mode.eq.2) then
32234         if(ISTHEP(ID).gt.11) then
32235           if(ISTHEP(ID).eq.20) then
32236             pho_pname = 'hard ini. part.'
32237           else if(ISTHEP(ID).eq.21) then
32238             pho_pname = 'hard fin. part.'
32239           else if(ISTHEP(ID).eq.25) then
32240             pho_pname = 'hard scattering'
32241           else if(ISTHEP(ID).eq.30) then
32242             pho_pname = 'diff. diss.    '
32243           else if(ISTHEP(ID).eq.35) then
32244             pho_pname = 'elastic scatt. '
32245           else if(ISTHEP(ID).eq.40) then
32246             pho_pname = 'central scatt. '
32247           endif
32248           return
32249         endif
32250         IDpdg = IDHEP(ID)
32251         i     = IMPART(ID)
32252       else
32253         WRITE(LO,'(1x,a,2i4)')
32254      &    'pho_pname: invalid arguments (ID,mode): ',ID,mode
32255         return
32256       endif
32257
32258       ii = abs(i)
32259       if((ii.eq.0).or.(ii.gt.ID_pdg_max)) return
32260
32261       name = name_list(ii)
32262       ichar = ich3_list(ii)*sign(1,i)
32263       if(mod(ichar,3).ne.0) then
32264         ichar = 0
32265       else
32266         ichar = ichar/3
32267       endif
32268
32269 C  find position of first blank character
32270       k = 1
32271  100  continue
32272         k = k+1
32273       if(name(k:k).ne.' ') goto 100
32274
32275 C  append anti-particle sign
32276       if(i.lt.0) then
32277         i_anti = 0
32278         do l=1,3
32279           i_anti = i_anti+iq_list(l,ii)
32280         enddo
32281         if(iba3_list(ii).ne.0) then
32282           name(k:k) = '~'
32283           k = K+1
32284         else if(((i_anti.ne.0).and.(ichar.eq.0))
32285      &          .or.(IDpdg.eq.-12)
32286      &          .or.(IDpdg.eq.-14)
32287      &          .or.(IDpdg.eq.-16)) then
32288           name(k:k) = '~'
32289           k = K+1
32290         endif
32291       endif
32292
32293 C  append charge sign
32294       if(ichar.eq.-2) then
32295         name(k:k+1) = '--'
32296       else if(ichar.eq.-1) then
32297         name(k:k) = '-'
32298       else if(ichar.eq.1) then
32299         name(k:k) = '+'
32300       else if(ichar.eq.2) then
32301         name(k:k+1) = '++'
32302       endif
32303
32304       pho_pname = name
32305
32306       END
32307
32308 *$ CREATE ipho_anti.FOR
32309 *COPY ipho_anti
32310 CDECK  ID>, ipho_anti
32311       INTEGER FUNCTION ipho_anti(ID)
32312 C**********************************************************************
32313 C
32314 C     determine antiparticle for given ID
32315 C
32316 C     input:  ID gives CPC particle number
32317 C
32318 C     output: ipho_anti antiparticle code
32319 C
32320 C**********************************************************************
32321       IMPLICIT NONE
32322       SAVE
32323
32324       integer ID
32325
32326 C  input/output channels
32327       INTEGER LI,LO
32328       COMMON /POINOU/ LI,LO
32329 C  event debugging information
32330       INTEGER NMAXD
32331       PARAMETER (NMAXD=100)
32332       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32333      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32334       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32335      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32336 C  particle ID translation table
32337       integer         ID_pdg_list,ID_list,ID_pdg_max
32338       character*12    name_list
32339       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32340      &                ID_pdg_max
32341 C  general particle data
32342       double precision xm_list,tau_list,gam_list,
32343      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32344      &  xm_bb82_list,xm_bb102_list
32345       integer          ich3_list,iba3_list,iq_list,
32346      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
32347       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32348      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
32349      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32350      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32351      &  ich3_list(300),iba3_list(300),iq_list(3,300),
32352      &  id_psm_list(6,6),id_vem_list(6,6),
32353      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
32354 C  standard particle data interface
32355       INTEGER NMXHEP
32356       PARAMETER (NMXHEP=4000)
32357       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32358       DOUBLE PRECISION PHEP,VHEP
32359       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32360      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32361      &                VHEP(4,NMXHEP)
32362 C  extension to standard particle data interface (PHOJET specific)
32363       INTEGER IMPART,IPHIST,ICOLOR
32364       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32365
32366 C  external functions
32367       integer ipho_id2pdg,ipho_pdg2id
32368
32369 C  local variables
32370       integer IDabs,IDpdg,i_anti,l
32371
32372       ipho_anti = -ID
32373       IDabs = abs(ID)
32374
32375 C  baryons
32376       if(iba3_list(IDabs).ne.0) return
32377
32378 C  charged particles
32379       if(ich3_list(IDabs).ne.0) return
32380
32381 C  K0_s and K0_l
32382       IDpdg = ipho_id2pdg(ID)
32383       if(IDpdg.eq.310) then
32384         ID = ipho_pdg2id(130)
32385         return
32386       else if(IDpdg.eq.130) then
32387         ID = ipho_pdg2id(310)
32388         return
32389       endif
32390
32391 C  neutral mesons with open strangeness, charm, or beauty
32392       i_anti = 0
32393       do l=1,3
32394         i_anti = i_anti+iq_list(l,IDabs)
32395       enddo
32396       if(i_anti.ne.0) return
32397
32398 C  neutrinos
32399       IDpdg = abs(IDpdg)
32400       if((IDpdg.eq.12).or.(IDpdg.eq.14).or.(IDpdg.eq.16)) return
32401
32402       ipho_anti = ID
32403
32404       END
32405
32406 *$ CREATE ipho_chr3.FOR
32407 *COPY ipho_chr3
32408 CDECK  ID>, ipho_chr3
32409       INTEGER FUNCTION ipho_chr3(ID,mode)
32410 C**********************************************************************
32411 C
32412 C     output of three times the electric charge
32413 C
32414 C     input:  mode
32415 C             0   ID gives CPC particle number
32416 C             1   ID gives PDG particle number
32417 C             2   ID gives position of particle in /POEVT1/
32418 C
32419 C**********************************************************************
32420       IMPLICIT NONE
32421       SAVE
32422
32423       integer ID,mode
32424
32425 C  input/output channels
32426       INTEGER LI,LO
32427       COMMON /POINOU/ LI,LO
32428 C  event debugging information
32429       INTEGER NMAXD
32430       PARAMETER (NMAXD=100)
32431       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32432      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32433       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32434      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32435 C  standard particle data interface
32436       INTEGER NMXHEP
32437       PARAMETER (NMXHEP=4000)
32438       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32439       DOUBLE PRECISION PHEP,VHEP
32440       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32441      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32442      &                VHEP(4,NMXHEP)
32443 C  extension to standard particle data interface (PHOJET specific)
32444       INTEGER IMPART,IPHIST,ICOLOR
32445       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32446 C  particle ID translation table
32447       integer         ID_pdg_list,ID_list,ID_pdg_max
32448       character*12    name_list
32449       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32450      &                ID_pdg_max
32451 C  general particle data
32452       double precision xm_list,tau_list,gam_list,
32453      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32454      &  xm_bb82_list,xm_bb102_list
32455       integer          ich3_list,iba3_list,iq_list,
32456      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
32457       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32458      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
32459      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32460      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32461      &  ich3_list(300),iba3_list(300),iq_list(3,300),
32462      &  id_psm_list(6,6),id_vem_list(6,6),
32463      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
32464
32465 C  external functions
32466       integer ipho_pdg2id
32467
32468 C  local variables
32469       integer i,IDpdg
32470
32471       ipho_chr3 = 0
32472
32473       if(mode.eq.0) then
32474         i = ID
32475       else if(mode.eq.1) then
32476         i = ipho_pdg2id(ID)
32477         if(i.eq.0) return
32478         IDpdg = ID
32479       else if(mode.eq.2) then
32480         if(ISTHEP(ID).gt.11) return
32481         i     = IMPART(ID)
32482         IDpdg = IDHEP(ID)
32483         IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32484           ipho_chr3 = ICOLOR(1,ID)
32485           return
32486         endif
32487       else
32488         WRITE(LO,'(1x,a,2i4)')
32489      &    'ipho_chr3: invalid mode (ID,mode): ',ID,mode
32490         return
32491       endif
32492
32493       if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32494         WRITE(LO,'(1x,a,3i8)')
32495      &    'ipho_chr3: invalid arguments (ID,mode,i): ',ID,mode,i
32496         ipho_chr3 = 1.D0/dble(i)
32497         call pho_prevnt(0)
32498         return
32499       endif
32500
32501       ipho_chr3 = ich3_list(iabs(i))*sign(1,i)
32502
32503       END
32504
32505 *$ CREATE ipho_bar3.FOR
32506 *COPY ipho_bar3
32507 CDECK  ID>, ipho_bar3
32508       INTEGER FUNCTION ipho_bar3(ID,mode)
32509 C**********************************************************************
32510 C
32511 C     output of three times the baryon charge
32512 C
32513 C     index:  MODE
32514 C             0   ID gives CPC particle number
32515 C             1   ID gives PDG particle number
32516 C             2   ID gives position of particle in /POEVT1/
32517 C
32518 C**********************************************************************
32519       IMPLICIT NONE
32520       SAVE
32521
32522       integer ID,mode
32523
32524 C  input/output channels
32525       INTEGER LI,LO
32526       COMMON /POINOU/ LI,LO
32527 C  event debugging information
32528       INTEGER NMAXD
32529       PARAMETER (NMAXD=100)
32530       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32531      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32532       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32533      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32534 C  standard particle data interface
32535       INTEGER NMXHEP
32536       PARAMETER (NMXHEP=4000)
32537       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32538       DOUBLE PRECISION PHEP,VHEP
32539       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32540      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32541      &                VHEP(4,NMXHEP)
32542 C  extension to standard particle data interface (PHOJET specific)
32543       INTEGER IMPART,IPHIST,ICOLOR
32544       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32545 C  particle ID translation table
32546       integer         ID_pdg_list,ID_list,ID_pdg_max
32547       character*12    name_list
32548       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32549      &                ID_pdg_max
32550 C  general particle data
32551       double precision xm_list,tau_list,gam_list,
32552      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32553      &  xm_bb82_list,xm_bb102_list
32554       integer          ich3_list,iba3_list,iq_list,
32555      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
32556       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32557      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
32558      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32559      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32560      &  ich3_list(300),iba3_list(300),iq_list(3,300),
32561      &  id_psm_list(6,6),id_vem_list(6,6),
32562      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
32563
32564 C  external functions
32565       integer ipho_pdg2id
32566
32567 C  local variables
32568       integer i,IDpdg
32569
32570       ipho_bar3 = 0
32571
32572       if(mode.eq.0) then
32573         i = ID
32574       else if(mode.eq.1) then
32575         i = ipho_pdg2id(ID)
32576         if(i.eq.0) return
32577         IDpdg = ID
32578       else if(mode.eq.2) then
32579         if(ISTHEP(ID).gt.11) return
32580         i     = IMPART(ID)
32581         IDpdg = IDHEP(ID)
32582         IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32583           ipho_bar3 = ICOLOR(2,ID)
32584           return
32585         endif
32586       else
32587         WRITE(LO,'(1x,a,2i4)')
32588      &    'ipho_bar3: invalid mode (ID,mode): ',ID,mode
32589         return
32590       endif
32591
32592       if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32593         WRITE(LO,'(1x,a,3i8)')
32594      &    'ipho_bar3: invalid arguments (ID,mode,i): ',ID,mode,i
32595         ipho_bar3 = 1.D0/dble(i)
32596         return
32597       endif
32598
32599       ipho_bar3 = iba3_list(iabs(i))*sign(1,i)
32600
32601       END
32602
32603 *$ CREATE pho_pmass.FOR
32604 *COPY pho_pmass
32605 CDECK  ID>, pho_pmass
32606       DOUBLE PRECISION FUNCTION pho_pmass(ID,mode)
32607 C***********************************************************************
32608 C
32609 C     particle mass
32610 C
32611 C     input:  mode  -1   initialization
32612 C                    0   ID gives CPC particle number
32613 C                    1   ID gives PDG particle number,
32614 C                        (for quarks current masses are returned)
32615 C                    2   ID gives position of particle in /POEVT1/
32616 C                    3   ID gives PDG parton number,
32617 C                        (for quarks constituent masses are returned)
32618 C
32619 C     output: average particle mass (in GeV)
32620 C
32621 C***********************************************************************
32622       IMPLICIT NONE
32623       SAVE
32624
32625       integer ID,mode,MSTJ24
32626
32627 C  input/output channels
32628       INTEGER LI,LO
32629       COMMON /POINOU/ LI,LO
32630 C  event debugging information
32631       INTEGER NMAXD
32632       PARAMETER (NMAXD=100)
32633       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32634      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32635       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32636      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32637 C  model switches and parameters
32638       CHARACTER*8 MDLNA
32639       INTEGER ISWMDL,IPAMDL
32640       DOUBLE PRECISION PARMDL
32641       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
32642 C  standard particle data interface
32643       INTEGER NMXHEP
32644       PARAMETER (NMXHEP=4000)
32645       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
32646       DOUBLE PRECISION PHEP,VHEP
32647       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
32648      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
32649      &                VHEP(4,NMXHEP)
32650 C  extension to standard particle data interface (PHOJET specific)
32651       INTEGER IMPART,IPHIST,ICOLOR
32652       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
32653 C  particle ID translation table
32654       integer         ID_pdg_list,ID_list,ID_pdg_max
32655       character*12    name_list
32656       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32657      &                ID_pdg_max
32658 C  general particle data
32659       double precision xm_list,tau_list,gam_list,
32660      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32661      &  xm_bb82_list,xm_bb102_list
32662       integer          ich3_list,iba3_list,iq_list,
32663      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
32664       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32665      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
32666      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32667      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32668      &  ich3_list(300),iba3_list(300),iq_list(3,300),
32669      &  id_psm_list(6,6),id_vem_list(6,6),
32670      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
32671       INTEGER MSTU,MSTJ
32672       DOUBLE PRECISION PARU,PARJ
32673       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32674
32675 C  external functions
32676       integer ipho_pdg2id,ipho_id2pdg
32677       DOUBLE PRECISION PYMASS
32678
32679 C  local variables
32680       integer i,IDpdg
32681
32682       pho_pmass = 0.D0
32683
32684       if(mode.eq.0) then
32685         i = ID
32686       else if(mode.eq.1) then
32687         i = ipho_pdg2id(ID)
32688         if(i.eq.0) return
32689       else if(mode.eq.2) then
32690         if(ISTHEP(ID).gt.11) return
32691         i     = IMPART(ID)
32692         IDpdg = IDHEP(ID)
32693         IF((IDpdg.eq.90).or.(IDpdg.eq.91).or.(IDpdg.eq.92)) then
32694           pho_pmass = PHEP(5,ID)
32695           return
32696         endif
32697       else if(mode.eq.3) then
32698         i = abs(ID)
32699         if((i.gt.0).and.(i.le.6)) then
32700           pho_pmass = PARMDL(150+i)
32701           return
32702         else
32703           i = ipho_pdg2id(ID)
32704           if(i.eq.0) return
32705         endif
32706       else if(mode.eq.-1) then
32707 C  initialization: take masses for quarks and di-quarks from JETSET
32708         MSTJ24 = MSTJ(24)
32709         MSTJ(24) = 0
32710         do i=1,22
32711           IDpdg = ipho_id2pdg(i)
32712           xm_list(i) = PYMASS(IDpdg)
32713         enddo
32714         MSTJ(24) = MSTJ24
32715         return
32716       else
32717         WRITE(LO,'(1x,a,2i4)')
32718      &    'pho_pmass: invalid arguments (ID,mode): ',ID,mode
32719         return
32720       endif
32721
32722       if((i.eq.0).or.(iabs(i).gt.ID_pdg_max)) then
32723         WRITE(LO,'(1x,a,2i8)')
32724      &    'pho_pmass: invalid arguments (ID,mode): ',ID,mode
32725         pho_pmass = 1.D0/dble(i)
32726         return
32727       endif
32728
32729       pho_pmass = xm_list(iabs(i))
32730
32731       END
32732
32733 *$ CREATE PHO_MEMASS.FOR
32734 *COPY PHO_MEMASS
32735 CDECK  ID>, PHO_MEMASS
32736       SUBROUTINE PHO_MEMASS(I,J,AMPS,AMPS2,AMVE,AMVE2,IPS,IVE)
32737 C**********************************************************************
32738 C
32739 C     determine meson masses corresponding to the input flavours
32740 C
32741 C     input: I,J,K     quark flavours (PDG convention)
32742 C
32743 C     output: AMPS     pseudo scalar meson mass
32744 C             AMPS2    next possible two particle configuration
32745 C                      (two pseudo scalar  mesons)
32746 C             AMVE     vector meson mass
32747 C             AMVE2    next possible two particle configuration
32748 C                      (two vector mesons)
32749 C             IPS,IVE  meson numbers in CPC
32750 C
32751 C**********************************************************************
32752       IMPLICIT NONE
32753       SAVE
32754
32755       integer I,J,IPS,IVE
32756       double precision AMPS,AMPS2,AMVE,AMVE2
32757
32758 C  input/output channels
32759       INTEGER LI,LO
32760       COMMON /POINOU/ LI,LO
32761 C  event debugging information
32762       INTEGER NMAXD
32763       PARAMETER (NMAXD=100)
32764       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32765      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32766       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32767      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32768 C  particle ID translation table
32769       integer         ID_pdg_list,ID_list,ID_pdg_max
32770       character*12    name_list
32771       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32772      &                ID_pdg_max
32773 C  general particle data
32774       double precision xm_list,tau_list,gam_list,
32775      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32776      &  xm_bb82_list,xm_bb102_list
32777       integer          ich3_list,iba3_list,iq_list,
32778      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
32779       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32780      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
32781      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32782      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32783      &  ich3_list(300),iba3_list(300),iq_list(3,300),
32784      &  id_psm_list(6,6),id_vem_list(6,6),
32785      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
32786
32787 C  local variables
32788       integer ii,jj
32789
32790       IF(I.GT.0) THEN
32791         ii = I
32792         jj = -J
32793       ELSE
32794         ii = J
32795         jj = -I
32796       ENDIF
32797
32798 C  particle ID's
32799       IPS = id_psm_list(ii,jj)
32800       IVE = id_vem_list(ii,jj)
32801 C  masses
32802       if(IPS.ne.0) then
32803         AMPS = xm_list(iabs(IPS))
32804       else
32805         AMPS = 0.D0
32806       endif
32807       if(IVE.ne.0) then
32808         AMVE = xm_list(iabs(IVE))
32809       else
32810         AMVE = 0.D0
32811       endif
32812
32813 C  next possible two-particle configurations (add phase space)
32814       AMPS2 = xm_psm2_list(ii,jj)*1.5D0
32815       AMVE2 = xm_vem2_list(ii,jj)*1.1D0
32816
32817       END
32818
32819 *$ CREATE PHO_BAMASS.FOR
32820 *COPY PHO_BAMASS
32821 CDECK  ID>, PHO_BAMASS
32822       SUBROUTINE PHO_BAMASS(I,J,K,AM8,AM82,AM10,AM102,I8,I10)
32823 C**********************************************************************
32824 C
32825 C     determine baryon masses corresponding to the input flavours
32826 C
32827 C     input: I,J,K     quark flavours (PDG convention)
32828 C
32829 C     output: AM8      octett baryon mass
32830 C             AM82     next possible two particle configuration
32831 C                      (octett baryon and meson)
32832 C             AM10     decuplett baryon mass
32833 C             AM102    next possible two particle configuration
32834 C                      (decuplett baryon and meson,
32835 C                       baryon built up from first two quarks)
32836 C             I8,I10   internal baryon numbers
32837 C
32838 C**********************************************************************
32839       IMPLICIT NONE
32840       SAVE
32841
32842       integer I,J,K,I8,I10
32843       double precision AM8,AM82,AM10,AM102
32844
32845 C  input/output channels
32846       INTEGER LI,LO
32847       COMMON /POINOU/ LI,LO
32848 C  event debugging information
32849       INTEGER NMAXD
32850       PARAMETER (NMAXD=100)
32851       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32852      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32853       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32854      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32855 C  particle ID translation table
32856       integer         ID_pdg_list,ID_list,ID_pdg_max
32857       character*12    name_list
32858       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
32859      &                ID_pdg_max
32860 C  general particle data
32861       double precision xm_list,tau_list,gam_list,
32862      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32863      &  xm_bb82_list,xm_bb102_list
32864       integer          ich3_list,iba3_list,iq_list,
32865      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
32866       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32867      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
32868      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32869      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32870      &  ich3_list(300),iba3_list(300),iq_list(3,300),
32871      &  id_psm_list(6,6),id_vem_list(6,6),
32872      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
32873
32874 C  local variables
32875       integer ii,jj,kk
32876
32877 C  find particle ID's
32878       ii = iabs(I)
32879       jj = iabs(J)
32880       kk = iabs(K)
32881       I8  = id_b8_list(ii,jj,kk)
32882       I10 = id_b10_list(ii,jj,kk)
32883
32884 C  masses (if combination possible)
32885       if(I8.ne.0) then
32886         AM8 = xm_list(I8)
32887         I8  = sign(I8,i)
32888       else
32889         AM8 = 0.D0
32890       endif
32891       if(I10.ne.0) then
32892         AM10 = xm_list(I10)
32893         I10  = sign(I10,i)
32894       else
32895         AM10 = 0.D0
32896       endif
32897
32898 C  next possible two-particle configurations (add phase space)
32899       AM82  = xm_b82_list(ii,jj,kk)*1.5D0
32900       AM102 = xm_b102_list(ii,jj,kk)*1.1D0
32901
32902       END
32903
32904 *$ CREATE PHO_DQMASS.FOR
32905 *COPY PHO_DQMASS
32906 CDECK  ID>, PHO_DQMASS
32907       SUBROUTINE PHO_DQMASS(I,J,K,L,AM82,AM102)
32908 C**********************************************************************
32909 C
32910 C     determine minimal masses corresponding to the input flavours
32911 C     (diquark a-diquark string system)
32912 C
32913 C     input: I,J,K,L   quark flavours (PDG convention)
32914 C
32915 C     output: AM82     mass of two octett baryons
32916 C             AM102    mass of two decuplett baryons
32917 C
32918 C**********************************************************************
32919       IMPLICIT NONE
32920       SAVE
32921
32922       integer I,J,K,L
32923       double precision AM82,AM102
32924
32925 C  input/output channels
32926       INTEGER LI,LO
32927       COMMON /POINOU/ LI,LO
32928 C  event debugging information
32929       INTEGER NMAXD
32930       PARAMETER (NMAXD=100)
32931       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32932      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32933       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32934      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32935 C  general particle data
32936       double precision xm_list,tau_list,gam_list,
32937      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
32938      &  xm_bb82_list,xm_bb102_list
32939       integer          ich3_list,iba3_list,iq_list,
32940      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
32941       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
32942      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
32943      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
32944      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
32945      &  ich3_list(300),iba3_list(300),iq_list(3,300),
32946      &  id_psm_list(6,6),id_vem_list(6,6),
32947      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
32948
32949 C  local variables
32950       integer ii,jj,kk,ll
32951
32952       ii = iabs(i)
32953       kk = iabs(k)
32954       jj = iabs(j)
32955       ll = iabs(l)
32956
32957       AM82  = xm_bb82_list(ii,jj,kk,ll)
32958       AM102 = xm_bb102_list(ii,jj,kk,ll)
32959
32960       END
32961
32962 *$ CREATE PHO_CHECK.FOR
32963 *COPY PHO_CHECK
32964 CDECK  ID>, PHO_CHECK
32965       SUBROUTINE PHO_CHECK(MD,IDEV)
32966 C**********************************************************************
32967 C
32968 C     check quantum numbers of entries in /POEVT1/ and /POEVT2/
32969 C           (energy, momentum, charge, baryon number conservation)
32970 C
32971 C     input:    MD      -1  check overall momentum conservation
32972 C                           and perform detailed check only in case of
32973 C                           deviations
32974 C                        1  test all branchings, mother-daughter
32975 C                           relations
32976 C
32977 C     output:   IDEV     0  no deviations
32978 C                        1  deviations found
32979 C
32980 C**********************************************************************
32981       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32982       SAVE
32983
32984 C  input/output channels
32985       INTEGER LI,LO
32986       COMMON /POINOU/ LI,LO
32987 C  event debugging information
32988       INTEGER NMAXD
32989       PARAMETER (NMAXD=100)
32990       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
32991      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32992       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
32993      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
32994 C  model switches and parameters
32995       CHARACTER*8 MDLNA
32996       INTEGER ISWMDL,IPAMDL
32997       DOUBLE PRECISION PARMDL
32998       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
32999 C  global event kinematics and particle IDs
33000       INTEGER IFPAP,IFPAB
33001       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
33002       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
33003 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
33004       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
33005       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
33006       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
33007      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
33008 C  standard particle data interface
33009       INTEGER NMXHEP
33010       PARAMETER (NMXHEP=4000)
33011       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33012       DOUBLE PRECISION PHEP,VHEP
33013       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33014      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33015      &                VHEP(4,NMXHEP)
33016 C  extension to standard particle data interface (PHOJET specific)
33017       INTEGER IMPART,IPHIST,ICOLOR
33018       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33019 C  color string configurations including collapsed strings and hadrons
33020       INTEGER MSTR
33021       PARAMETER (MSTR=500)
33022       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33023       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33024      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33025      &                NNCH(MSTR),IBHAD(MSTR),ISTR
33026
33027 C  count number of errors to avoid disk overflow
33028       DATA IERR / 0 /
33029
33030       IDEV = 0
33031 C  conservation check suppressed
33032       IF((IPAMDL(15).EQ.0).OR.(IDEB(20).LE.-10)) RETURN
33033
33034       IF(IPAMDL(13).GT.0) THEN
33035
33036 C  DPMJET call with x limitations
33037         MODE = -1
33038         ECM1 = SQRT(XPSUB*XTSUB)*ECM
33039
33040       ELSE
33041
33042 C  standard call
33043         MODE = MD
33044 C  first two entries are considered as scattering particles
33045         EE1 = PHEP(4,1) + PHEP(4,2)
33046         PX1 = PHEP(1,1) + PHEP(1,2)
33047         PY1 = PHEP(2,1) + PHEP(2,2)
33048         PZ1 = PHEP(3,1) + PHEP(3,2)
33049
33050       ENDIF
33051
33052       DDREL = PARMDL(75)
33053       DDABS = PARMDL(76)
33054       IF(MODE.EQ.-1) GOTO 500
33055
33056  50   CONTINUE
33057
33058       I = 1
33059  100  CONTINUE
33060
33061 C  recognize only decayed particles as mothers
33062         IF(ISTHEP(I).EQ.2) THEN
33063 C  search for other mother particles
33064           K = JDAHEP(1,I)
33065           IF(K.EQ.0) THEN
33066             IF(IPAMDL(178).NE.0)
33067      &        WRITE(LO,'(1X,2A,I4)') 'PHO_CHECK: ',
33068      &        'entry marked as decayed but no dauther given:',I
33069             GOTO 99
33070           ENDIF
33071           K1 = JMOHEP(1,K)
33072           K2 = JMOHEP(2,K)
33073 C  sum over mother particles
33074           ICH1 = IPHO_CHR3(K1,2)
33075           IBA1 = IPHO_BAR3(K1,2)
33076           EE1 = PHEP(4,K1)
33077           PX1 = PHEP(1,K1)
33078           PY1 = PHEP(2,K1)
33079           PZ1 = PHEP(3,K1)
33080           IF(K2.LT.0) THEN
33081             K2 = -K2
33082             IF((K1.GT.I).OR.(K2.LT.I)) THEN
33083               WRITE(LO,'(/,1X,2A,3I4)') 'PHO_CHECK: ',
33084      &          'inconsistent mother/daughter relation found',I,K1,K2
33085               CALL PHO_PREVNT(-1)
33086             ENDIF
33087             DO 400 II=K1+1,K2
33088               IF(ABS(ISTHEP(II)).LE.2) THEN
33089                 ICH1 = ICH1 + IPHO_CHR3(II,2)
33090                 IBA1 = IBA1 + IPHO_BAR3(II,2)
33091                 EE1 = EE1 + PHEP(4,II)
33092                 PX1 = PX1 + PHEP(1,II)
33093                 PY1 = PY1 + PHEP(2,II)
33094                 PZ1 = PZ1 + PHEP(3,II)
33095               ENDIF
33096  400        CONTINUE
33097           ELSE IF((K2.GT.0).AND.(K2.NE.K1)) THEN
33098             ICH1 = ICH1 + IPHO_CHR3(K2,2)
33099             IBA1 = IBA1 + IPHO_BAR3(K2,2)
33100             EE1 = EE1 + PHEP(4,K2)
33101             PX1 = PX1 + PHEP(1,K2)
33102             PY1 = PY1 + PHEP(2,K2)
33103             PZ1 = PZ1 + PHEP(3,K2)
33104           ENDIF
33105
33106 C  sum over daughter particles
33107           ICH2 = 0.D0
33108           IBA2 = 0.D0
33109           EE2 = 0.D0
33110           PX2 = 0.D0
33111           PY2 = 0.D0
33112           PZ2 = 0.D0
33113           DO 200 II=JDAHEP(1,I),JDAHEP(2,I)
33114             IF(ABS(ISTHEP(II)).LE.2) THEN
33115               ICH2 = ICH2 + IPHO_CHR3(II,2)
33116               IBA2 = IBA2 + IPHO_BAR3(II,2)
33117               EE2 = EE2 + PHEP(4,II)
33118               PX2 = PX2 + PHEP(1,II)
33119               PY2 = PY2 + PHEP(2,II)
33120               PZ2 = PZ2 + PHEP(3,II)
33121             ENDIF
33122  200      CONTINUE
33123
33124 C  conservation check
33125           ESC = MAX(MAX(EE1,EE2)*DDREL,DDABS)
33126           IF(ABS(EE1-EE2).GT.ESC) THEN
33127             WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E10.3)')
33128      &        'PHO_CHECK: energy conservation violated for',
33129      &        'entry,initial,final:',I,EE1,EE2
33130             IDEV = 1
33131           ENDIF
33132           ESC = MAX(MAX(ABS(PX1),ABS(PX2))*DDREL,DDABS)
33133           IF(ABS(PX1-PX2).GT.ESC) THEN
33134             WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33135      &        'PHO_CHECK: x-momentum conservation violated for',
33136      &        'entry,initial,final:',I,PX1,PX2
33137             IDEV = 1
33138           ENDIF
33139           ESC = MAX(MAX(ABS(PY1),ABS(PY2))*DDREL,DDABS)
33140           IF(ABS(PY1-PY2).GT.ESC) THEN
33141             WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33142      &        'PHO_CHECK: y-momentum conservation violated for',
33143      &        'entry,initial,final:',I,PY1,PY2
33144             IDEV = 1
33145           ENDIF
33146           ESC = MAX(MAX(ABS(PZ1),ABS(PZ2))*DDREL,DDABS)
33147           IF(ABS(PZ1-PZ2).GT.ESC) THEN
33148             WRITE(LO,'(1X,A,/,5X,A,I3,2X,1P,2E12.3)')
33149      &        'PHO_CHECK: z-momentum conservation violated for',
33150      &        'entry,initial,final:',I,PZ1,PZ2
33151             IDEV = 1
33152           ENDIF
33153           IF(ICH1.NE.ICH2) THEN
33154             WRITE(LO,'(1X,A,/,5X,A,I3,2X,2I5)')
33155      &        'PHO_CHECK: charge conservation violated for',
33156      &        'entry,initial,final:',I,ICH1,ICH2
33157             IDEV = 1
33158           ENDIF
33159           IF(IBA1.NE.IBA2) THEN
33160             WRITE(LO,'(1X,2A,/,5X,A,I3,2X,2I5)') 'PHO_CHECK: ',
33161      &        'baryon charge conservation violated for',
33162      &        'entry,initial,final:',I,IBA1,IBA2
33163             IDEV = 1
33164           ENDIF
33165           IF(IDEB(20).GE.35) THEN
33166             WRITE(LO,
33167      &        '(/,1X,A,A,2(2X,I4,A,I4),2(/,5X,A,4E13.4),/5X,A,4I5)')
33168      &      'PHO_CHECK diagnostics:',
33169      &      '(1.mother/l.mother,1.daughter/l.daughter):',
33170      &      K1,'/',K2,JDAHEP(1,I),'/',JDAHEP(2,I),
33171      &      'mother momenta   ',PX1,PY1,PZ1,EE1,
33172      &      'daughter momenta ',PX2,PY2,PZ2,EE2,
33173      &      'charge,baryon no ',ICH1,ICH2,IBA1,IBA2
33174           ENDIF
33175         ENDIF
33176  99     CONTINUE
33177         I = I+1
33178       IF(I.LE.NHEP) GOTO 100
33179
33180  55   CONTINUE
33181
33182       IERR = IERR+IDEV
33183
33184 C  write complete event in case of deviations
33185       IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
33186         CALL PHO_PREVNT(1)
33187         IF(ISTR.GT.0) THEN
33188           CALL PHO_PRSTRG
33189           IF(ISWMDL(6).GE.0) CALL PYLIST(1)
33190         ENDIF
33191       ENDIF
33192
33193 C  stop after too many errors
33194       IF(IERR.GT.IPAMDL(179)) THEN
33195         WRITE(LO,'(////1X,2A,I6,////)') 'PHO_CHECK:ERROR:',
33196      &    'too many inconsistencies found, program terminated',IERR
33197         CALL PHO_ABORT
33198       ENDIF
33199
33200       RETURN
33201
33202 C  overall check only (less time consuming)
33203
33204  500  CONTINUE
33205
33206       ICH2 = 0.D0
33207       IBA2 = 0.D0
33208       EE2 = 0.D0
33209       PX2 = 0.D0
33210       PY2 = 0.D0
33211       PZ2 = 0.D0
33212
33213       DO 300 K=3,NHEP
33214 C  recognize only existing particles as possible daughters
33215         IF(ABS(ISTHEP(K)).EQ.1) THEN
33216           ICH2 = ICH2 + IPHO_CHR3(K,2)
33217           IBA2 = IBA2 + IPHO_BAR3(K,2)
33218           EE2 = EE2 + PHEP(4,K)
33219           PX2 = PX2 + PHEP(1,K)
33220           PY2 = PY2 + PHEP(2,K)
33221           PZ2 = PZ2 + PHEP(3,K)
33222         ENDIF
33223  300  CONTINUE
33224
33225 C  check energy-momentum conservation
33226       ESC = ECM*DDREL
33227
33228       IF(IPAMDL(13).GT.0) THEN
33229
33230 C  DPMJET call with x limitations
33231         ECM2 = SQRT((EE2-PZ2)*(EE2+PZ2)-PX2**2-PY2**2)
33232         IF(ABS(ECM1-ECM2).GT.ESC) THEN
33233           WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33234      &      'PHO_CHECK: c.m. energy conservation violated',
33235      &      'initial/final energy:',ECM1,ECM2
33236           IDEV = 1
33237         ENDIF
33238
33239       ELSE
33240
33241 C  standard call
33242         IF(ABS(EE1-EE2).GT.ESC) THEN
33243           WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33244      &      'PHO_CHECK: energy conservation violated',
33245      &      'initial/final energy:',EE1,EE2
33246           IDEV = 1
33247         ENDIF
33248         IF(ABS(PX1-PX2).GT.ESC) THEN
33249         WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33250      &      'PHO_CHECK: x-momentum conservation violated',
33251      &      'initial/final x-momentum:',PX1,PX2
33252           IDEV = 1
33253         ENDIF
33254         IF(ABS(PY1-PY2).GT.ESC) THEN
33255           WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33256      &      'PHO_CHECK: y-momentum conservation violated',
33257      &      'initial/final y-momentum:',PY1,PY2
33258           IDEV = 1
33259         ENDIF
33260         IF(ABS(PZ1-PZ2).GT.ESC) THEN
33261           WRITE(LO,'(1X,A,/,5X,A,1P,2E12.4)')
33262      &      'PHO_CHECK: z-momentum conservation violated',
33263      &      'initial/final z-momentum:',PZ1,PZ2
33264           IDEV = 1
33265         ENDIF
33266
33267 C  check of quantum number conservation
33268
33269         ICH1 = IPHO_CHR3(1,2) + IPHO_CHR3(2,2)
33270         IBA1 = IPHO_BAR3(1,2) + IPHO_BAR3(2,2)
33271
33272         IF(ICH1.NE.ICH2) THEN
33273           WRITE(LO,'(1X,A,/,5X,A,2I5)')
33274      &      'PHO_CHECK: charge conservation violated',
33275      &      'initial/final charge sum',ICH1,ICH2
33276           IDEV = 1
33277         ENDIF
33278         IF(IBA1.NE.IBA2) THEN
33279           WRITE(LO,'(1X,2A,/,5X,A,2I5)') 'PHO_CHECK: ',
33280      &      'baryonic charge conservation violated',
33281      &      'initial/final baryonic charge sum',IBA1,IBA2
33282           IDEV = 1
33283         ENDIF
33284
33285       ENDIF
33286
33287 C  perform detailed checks in case of deviations
33288       IF((IDEB(20).GE.0).AND.(IDEV.NE.0)) THEN
33289         IF(IPAMDL(13).GT.0) THEN
33290           GOTO 55
33291         ELSE
33292           DDREL = DDREL/2.D0
33293           DDABS = DDABS/2.D0
33294           WRITE(LO,'(/1X,2A,2E12.4)') 'PHO_CHECK: ',
33295      &      'increasing precision of tests to',DDREL,DDABS
33296           GOTO 50
33297         ENDIF
33298       ENDIF
33299
33300       END
33301
33302 *$ CREATE PHO_ABORT.FOR
33303 *COPY PHO_ABORT
33304 CDECK  ID>, PHO_ABORT
33305       SUBROUTINE PHO_ABORT
33306 C**********************************************************************
33307 C
33308 C     top MC event generation due to fatal error,
33309 C     print all information of event generation and history
33310 C
33311 C**********************************************************************
33312       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33313       SAVE
33314
33315 C  input/output channels
33316       INTEGER LI,LO
33317       COMMON /POINOU/ LI,LO
33318 C  event debugging information
33319       INTEGER NMAXD
33320       PARAMETER (NMAXD=100)
33321       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33322      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33323       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33324      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33325 C  model switches and parameters
33326       CHARACTER*8 MDLNA
33327       INTEGER ISWMDL,IPAMDL
33328       DOUBLE PRECISION PARMDL
33329       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33330 C  standard particle data interface
33331       INTEGER NMXHEP
33332       PARAMETER (NMXHEP=4000)
33333       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33334       DOUBLE PRECISION PHEP,VHEP
33335       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33336      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33337      &                VHEP(4,NMXHEP)
33338 C  extension to standard particle data interface (PHOJET specific)
33339       INTEGER IMPART,IPHIST,ICOLOR
33340       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33341 C  color string configurations including collapsed strings and hadrons
33342       INTEGER MSTR
33343       PARAMETER (MSTR=500)
33344       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33345       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33346      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33347      &                NNCH(MSTR),IBHAD(MSTR),ISTR
33348 C  light-cone x fractions and c.m. momenta of soft cut string ends
33349       INTEGER MAXSOF
33350       PARAMETER ( MAXSOF = 50 )
33351       INTEGER IJSI2,IJSI1
33352       DOUBLE PRECISION XS1,XS2,PSOFT1,PSOFT2
33353       COMMON /POSOFT/ XS1(MAXSOF),XS2(MAXSOF),
33354      &                PSOFT1(4,MAXSOF),PSOFT2(4,MAXSOF),
33355      &                IJSI1(MAXSOF),IJSI2(MAXSOF)
33356 C  hard scattering data
33357       INTEGER MSCAHD
33358       PARAMETER ( MSCAHD = 50 )
33359       INTEGER LSCAHD,LSC1HD,LSIDX,
33360      &        NINHD,N0INHD,NIVAL,N0IVAL,NOUTHD,NBRAHD,NPROHD
33361       DOUBLE PRECISION PPH,PTHD,ETAHD,Q2SCA,PDFVA,XHD,VHD,X0HD
33362       COMMON /POHSLT/ LSCAHD,LSC1HD,LSIDX(MSCAHD),
33363      &                PPH(8*MSCAHD,2),PTHD(MSCAHD),ETAHD(MSCAHD,2),
33364      &                Q2SCA(MSCAHD,2),PDFVA(MSCAHD,2),
33365      &                XHD(MSCAHD,2),VHD(MSCAHD),X0HD(MSCAHD,2),
33366      &                NINHD(MSCAHD,2),N0INHD(MSCAHD,2),
33367      &                NIVAL(MSCAHD,2),N0IVAL(MSCAHD,2),
33368      &                NOUTHD(MSCAHD,2),NBRAHD(MSCAHD,2),NPROHD(MSCAHD)
33369
33370       WRITE(LO,'(//,1X,A,/,1X,A)')
33371      &  'PHO_ABORT: program execution stopped',
33372      &  '===================================='
33373       WRITE(LO,'(/,1X,A,/,1X,A)') 'listing of available data follows:'
33374 C
33375       CALL PHO_SETMDL(0,0,-2)
33376       CALL PHO_PREVNT(-1)
33377       CALL PHO_ACTPDF(0,-2)
33378 C  print selected parton flavours
33379       WRITE(LO,'(1X,A,I4)') 'selected soft flavours: ',KSOFT
33380       DO 700 I=1,KSOFT
33381         WRITE(LO,'(10X,2I5)') IJSI1(I),IJSI2(I)
33382  700  CONTINUE
33383       WRITE(LO,'(1X,A,I4)') 'selected hard flavours: ',KHARD
33384       DO 750 K=1,KHARD
33385         I = LSIDX(K)
33386         WRITE(LO,'(10X,A,I5)') 'process:',NPROHD(I)
33387         WRITE(LO,'(10X,A,2I4,7X,A,2I4)') 'initial:',NINHD(I,1),
33388      &    NINHD(I,2),'final:',NOUTHD(I,1),NOUTHD(I,2)
33389  750  CONTINUE
33390 C  print selected parton momenta
33391       WRITE(LO,'(1X,A,I4)') 'selected soft momenta: ',KSOFT
33392       DO 300 I=1,KSOFT
33393         WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PSOFT1(II,I),II=1,4)
33394         WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PSOFT2(II,I),II=1,4)
33395  300  CONTINUE
33396       WRITE(LO,'(1X,A,I4)') 'selected hard momenta: ',KHARD
33397       DO 350 K=1,KHARD
33398         I = LSIDX(K)
33399         I3 = 8*I-4
33400         WRITE(LO,'(10X,A,4E12.3)') 'par.1',(PPH(I3+II,1),II=1,4)
33401         WRITE(LO,'(10X,A,4E12.3)') 'par.2',(PPH(I3+II,2),II=1,4)
33402  350  CONTINUE
33403
33404 C  print /POEVT1/
33405       CALL PHO_PREVNT(0)
33406
33407 C  fragmentation process
33408       IF(ISTR.GT.0) THEN
33409 C  print /POSTRG/
33410         CALL PHO_PRSTRG
33411         IF(ISWMDL(6).GE.0) CALL PYLIST(1)
33412       ENDIF
33413
33414 C  last message
33415       WRITE(LO,'(////5X,A,///5X,A,///)')
33416      &  'PHO_ABORT: execution terminated due to fatal error',
33417      &'*** Simulating division by zero to get traceback information ***'
33418       ISTR = 100/IPAMDL(100)
33419
33420       END
33421
33422 *$ CREATE PHO_TRACE.FOR
33423 *COPY PHO_TRACE
33424 CDECK  ID>, PHO_TRACE
33425       SUBROUTINE PHO_TRACE(ISTART,ISWI,LEVEL)
33426 C**********************************************************************
33427 C
33428 C     trace program subroutines according to level,
33429 C                          original output levels will be saved
33430 C
33431 C     input:   ISTART      first event to trace
33432 C              ISWI        number of events to trace
33433 C                                0   loop call, use old values
33434 C                               -1   restore original output levels
33435 C                                1   store level and wait for event
33436 C              LEVEL       desired output level
33437 C                                0   standard output
33438 C                                3   internal rejections
33439 C                                5   cross sections, slopes etc.
33440 C                               10   parameter of subroutines and
33441 C                                    results
33442 C                               20   huge amount of debug output
33443 C                               30   maximal possible output
33444 C
33445 C**********************************************************************
33446       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33447       SAVE
33448
33449 C  input/output channels
33450       INTEGER LI,LO
33451       COMMON /POINOU/ LI,LO
33452 C  event debugging information
33453       INTEGER NMAXD
33454       PARAMETER (NMAXD=100)
33455       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33456      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33457       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33458      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33459
33460       DIMENSION IMEM(NMAXD)
33461
33462 C  protect ISWI
33463       ISW = ISWI
33464  10   CONTINUE
33465       IF(ISW.EQ.0) THEN
33466         IF(KEVENT.LT.ION) THEN
33467           RETURN
33468         ELSE IF(KEVENT.EQ.ION) THEN
33469           WRITE(LO,'(///,1X,A,///)')
33470      &      'PHO_TRACE: trace mode switched on'
33471           DO 100 I=1,NMAXD
33472             IMEM(I) = IDEB(I)
33473             IDEB(I) = MAX(ILEVEL,IMEM(I))
33474  100      CONTINUE
33475         ELSE IF(KEVENT.EQ.IOFF) THEN
33476           WRITE(LO,'(//,1X,A,///)')
33477      &      'PHO_TRACE: trace mode switched off'
33478           DO 200 I=1,NMAXD
33479             IDEB(I) = IMEM(I)
33480  200      CONTINUE
33481         ENDIF
33482       ELSE IF(ISW.EQ.-1) THEN
33483         DO 300 I=1,NMAXD
33484           IDEB(I) = IMEM(I)
33485  300    CONTINUE
33486       ELSE
33487 C  save information
33488         ION = ISTART
33489         IOFF = ISTART+ISW
33490         ILEVEL = LEVEL
33491       ENDIF
33492 C  check coincidence
33493       IF(ISW.GT.0) THEN
33494         ISW=0
33495         ILEVEL = LEVEL
33496         GOTO 10
33497       ENDIF
33498
33499       END
33500
33501 *$ CREATE PHO_PRSTRG.FOR
33502 *COPY PHO_PRSTRG
33503 CDECK  ID>, PHO_PRSTRG
33504       SUBROUTINE PHO_PRSTRG
33505 C**********************************************************************
33506 C
33507 C     print information of /POSTRG/
33508 C
33509 C**********************************************************************
33510       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33511       SAVE
33512
33513 C  input/output channels
33514       INTEGER LI,LO
33515       COMMON /POINOU/ LI,LO
33516 C  event debugging information
33517       INTEGER NMAXD
33518       PARAMETER (NMAXD=100)
33519       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33520      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33521       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33522      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33523 C  standard particle data interface
33524       INTEGER NMXHEP
33525       PARAMETER (NMXHEP=4000)
33526       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33527       DOUBLE PRECISION PHEP,VHEP
33528       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33529      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33530      &                VHEP(4,NMXHEP)
33531 C  extension to standard particle data interface (PHOJET specific)
33532       INTEGER IMPART,IPHIST,ICOLOR
33533       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33534 C  color string configurations including collapsed strings and hadrons
33535       INTEGER MSTR
33536       PARAMETER (MSTR=500)
33537       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
33538       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
33539      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
33540      &                NNCH(MSTR),IBHAD(MSTR),ISTR
33541
33542       WRITE(LO,'(/,1X,A,I5)')
33543      &  'PHO_PRSTRG: number of strings soft+hard:',ISTR
33544       WRITE(LO,'(/,1X,A/,1X,A)') 'COMMON /POSTRG/:',
33545      &  ' NOBAM  ID1  ID2  ID3  ID4     NPO1/2/3/4        MASS'
33546       WRITE(LO,'(1X,A)')
33547      &  ' ======================================================='
33548       DO 800 I=1,ISTR
33549         WRITE(LO,'(1X,9I5,1P,E11.3)')
33550      &         NCODE(I),IPAR1(I),IPAR2(I),IPAR3(I),IPAR4(I),NPOS(1,I),
33551      &         NPOS(2,I),NPOS(3,I),NPOS(4,I),PHEP(5,NPOS(1,I))
33552  800  CONTINUE
33553
33554       END
33555
33556 *$ CREATE PHO_PREVNT.FOR
33557 *COPY PHO_PREVNT
33558 CDECK  ID>, PHO_PREVNT
33559       SUBROUTINE PHO_PREVNT(NPART)
33560 C**********************************************************************
33561 C
33562 C     print all information of event generation and history
33563 C
33564 C     input:        NPART  -1   minimal output: process IDs
33565 C                           0   additional output of /POEVT1/
33566 C                           1   additional output of /POSTRG/
33567 C                           2   additional output of /HEPEVT/
33568 C                               (call LULIST(1))
33569 C
33570 C**********************************************************************
33571       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33572       SAVE
33573
33574 C  input/output channels
33575       INTEGER LI,LO
33576       COMMON /POINOU/ LI,LO
33577 C  event debugging information
33578       INTEGER NMAXD
33579       PARAMETER (NMAXD=100)
33580       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33581      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33582       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33583      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33584 C  model switches and parameters
33585       CHARACTER*8 MDLNA
33586       INTEGER ISWMDL,IPAMDL
33587       DOUBLE PRECISION PARMDL
33588       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
33589 C  global event kinematics and particle IDs
33590       INTEGER IFPAP,IFPAB
33591       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
33592       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
33593 C  general process information
33594       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
33595       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
33596 C  standard particle data interface
33597       INTEGER NMXHEP
33598       PARAMETER (NMXHEP=4000)
33599       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33600       DOUBLE PRECISION PHEP,VHEP
33601       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33602      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33603      &                VHEP(4,NMXHEP)
33604 C  extension to standard particle data interface (PHOJET specific)
33605       INTEGER IMPART,IPHIST,ICOLOR
33606       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33607 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
33608       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
33609       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
33610       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
33611      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
33612
33613       CHARACTER*15 PHO_PNAME
33614
33615       IF(NPART.GE.0) WRITE(LO,'(/)')
33616       WRITE(LO,'(1X,A,1PE10.3)')
33617      &  'PHO_PREVNT: c.m. energy',ECM
33618       CALL PHO_SETPAR(-2,IH,NPART,0.D0)
33619       WRITE(LO,'(6X,A,A,/1X,I10,10I6)')
33620      &  'EV-CALL,ISPOM,IHPOM,ISREG,IHDIR,KSTRG,',
33621      &  'KHTRG,KSLOO,KHLOO,KSDPO,KHDPO',
33622      &  KEVENT,KSPOM,KHPOM,KSREG,KHDIR,KSTRG,KHTRG,KSLOO,KHLOO,KSDPO,
33623      &  KHDPO
33624       WRITE(LO,'(6X,A,I4,4I3)')
33625      &  'PROCESS-ID,IDNODF,IDIFF1,IDIFF2,IDDPOM',IPROCE,IDNODF,IDIFR1,
33626      &  IDIFR2,IDDPOM
33627
33628       IF(IPAMDL(13).GT.0) THEN
33629         WRITE(LO,'(1X,A)') 'PHO_PREVNT: DPMJET special settings:'
33630         WRITE(LO,'(5X,A,1P,4E11.3)') 'ECMN,PCMN,SECM,SPCM',
33631      &    ECMN,PCMN,SECM,SPCM
33632         WRITE(LO,'(5X,A,1P,2E11.3)') 'XPSUB,XTSUB',XPSUB,XTSUB
33633       ENDIF
33634
33635       IF(NPART.LT.0) RETURN
33636
33637       IF(NPART.GE.1) CALL PHO_PRSTRG
33638
33639       WRITE(LO,'(/1X,A)') 'COMMON /POEVT1/:'
33640       ICHAS  = 0
33641       IBARFS = 0
33642       IMULC  = 0
33643       IMUL   = 0
33644       WRITE(LO,'(/1X,A,A,/,1X,A,A)')
33645      &  '   NO  IST    NAME         MO-1 MO-2 DA-1 DA-2  CHA  BAR',
33646      &  '  IH1  IH2  CO1  CO2',
33647      &  '========================================================',
33648      &  '===================='
33649       DO 20 IH=1,NHEP
33650         CH = DBLE(IPHO_CHR3(IH,2)/3.D0)
33651         BA = DBLE(IPHO_BAR3(IH,2)/3.D0)
33652         WRITE(LO,'(1X,2I5,1X,A15,4I5,2F5.1,2I5,2I5)')
33653      &    IH,ISTHEP(IH),PHO_PNAME(IH,2),
33654      &    JMOHEP(1,IH),JMOHEP(2,IH),JDAHEP(1,IH),JDAHEP(2,IH),
33655      &    CH,BA,IPHIST(1,IH),IPHIST(2,IH),
33656      &    ICOLOR(1,IH),ICOLOR(2,IH)
33657         IF(ABS(ISTHEP(IH)).EQ.1) THEN
33658           ICHAS  = ICHAS  + IPHO_CHR3(IH,2)
33659           IBARFS = IBARFS + IPHO_BAR3(IH,2)
33660         ENDIF
33661         IF(ABS(ISTHEP(IH)).EQ.1) THEN
33662           IF(IPHO_CHR3(IH,2).NE.0) IMULC = IMULC+1
33663           IMUL = IMUL+1
33664         ENDIF
33665    20 CONTINUE
33666       WRITE(LO,'(1X,2(3X,A,I3),2X,2(5X,A,I5))') 'sum charge:',ICHAS/3,
33667      &  'baryon:',IBARFS/3,'chr.mult:',IMULC,'tot.mult:',IMUL
33668
33669       WRITE(LO,7)
33670       PXS    = 0.D0
33671       PYS    = 0.D0
33672       PZS    = 0.D0
33673       P0S    = 0.D0
33674       DO 30 IN=1,NHEP
33675         IF(     (ABS(PHEP(3,IN)).LT.99999.D0)
33676      &     .AND.(PHEP(4,IN).LT.99999.D0)) THEN
33677           WRITE(LO,8) IN,ISTHEP(IN),PHO_PNAME(IN,2),
33678      &      (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
33679         ELSE
33680           WRITE(LO,11) IN,ISTHEP(IN),PHO_PNAME(IN,2),
33681      &      (PHEP(J,IN),J=1,5),SQRT(PHEP(1,IN)**2+PHEP(2,IN)**2)
33682         ENDIF
33683         IF(ABS(ISTHEP(IN)).EQ.1) THEN
33684           PXS = PXS + PHEP(1,IN)
33685           PYS = PYS + PHEP(2,IN)
33686           PZS = PZS + PHEP(3,IN)
33687           P0S = P0S + PHEP(4,IN)
33688         ENDIF
33689    30 CONTINUE
33690       AMFS = P0S**2-PXS**2-PYS**2-PZS**2
33691       AMFS = SIGN(SQRT(ABS(AMFS)),AMFS)
33692       IF(P0S.LT.99999.D0) THEN
33693         WRITE(LO,10) '      sum:    ',PXS,PYS,PZS,P0S,AMFS
33694       ELSE
33695         WRITE(LO,12) '      sum:    ',PXS,PYS,PZS,P0S,AMFS
33696       ENDIF
33697       WRITE(LO,'(//)')
33698
33699     5 FORMAT(2X,8H NUMBER ,8H STATUS ,8H IDENT. ,
33700      &  8H 1.MOTH.,8H 2.MOTH.,8H 1.DAUG.,8H L.DAUG.,
33701      &  8H CHARGE ,8H BARYON ,/)
33702     6 FORMAT(7I8,2F8.3)
33703     7 FORMAT(/,2X,' NR STAT NAME        X-MOMENTA',
33704      &  ' Y-MOMENTA Z-MOMENTA  ENERGY    MASS     PT',/,
33705      &         2X,'-------------------------------',
33706      &  '--------------------------------------------')
33707     8 FORMAT(I5,I4,1X,A15,2F8.3,3F10.3,F8.3)
33708     9 FORMAT(I10,14X,5F10.3)
33709    10 FORMAT(10X,A14,1X,2F8.3,3F10.3)
33710    11 FORMAT(I5,I4,1X,A15,2F8.2,2F10.1,F10.3,F8.3)
33711    12 FORMAT(10X,A14,1X,2F8.2,2F10.1,F10.3)
33712
33713       IF(NPART.GE.2) CALL PYLIST(1)
33714
33715       END
33716
33717 *$ CREATE PHO_LTRHEP.FOR
33718 *COPY PHO_LTRHEP
33719 CDECK  ID>, PHO_LTRHEP
33720       SUBROUTINE PHO_LTRHEP(I1,I2,COD,SID,COF,SIF,GAM,BGX,BGY,BGZ)
33721 C*******************************************************************
33722 C
33723 C     Lorentz transformation of entries I1 to I2 in /POEVT1/
33724 C
33725 C********************************************************************
33726       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33727       SAVE
33728
33729       PARAMETER ( DIFF = 0.001D0,
33730      &            EPS  = 1.D-5 )
33731
33732 C  input/output channels
33733       INTEGER LI,LO
33734       COMMON /POINOU/ LI,LO
33735 C  event debugging information
33736       INTEGER NMAXD
33737       PARAMETER (NMAXD=100)
33738       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33739      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33740       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33741      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33742 C  standard particle data interface
33743       INTEGER NMXHEP
33744       PARAMETER (NMXHEP=4000)
33745       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
33746       DOUBLE PRECISION PHEP,VHEP
33747       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
33748      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
33749      &                VHEP(4,NMXHEP)
33750 C  extension to standard particle data interface (PHOJET specific)
33751       INTEGER IMPART,IPHIST,ICOLOR
33752       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
33753
33754       DO 100 I=I1,MIN(I2,NHEP)
33755         IF((ABS(ISTHEP(I)).LE.10).OR.(ISTHEP(I).EQ.21)) THEN
33756           CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
33757      &      XX,YY,ZZ)
33758           EE=PHEP(4,I)
33759           CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
33760      &      PHEP(1,I),PHEP(2,I),PHEP(3,I),PHEP(4,I))
33761         ELSE IF(ISTHEP(I).EQ.20) THEN
33762           EE=SQRT(PHEP(1,I)**2+PHEP(2,I)**2+PHEP(3,I)**2)
33763           CALL PHO_TRANS(PHEP(1,I),PHEP(2,I),PHEP(3,I),COD,SID,COF,SIF,
33764      &      XX,YY,ZZ)
33765           CALL PHO_ALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE,PTOT,
33766      &      PHEP(1,I),PHEP(2,I),PHEP(3,I),PMASS)
33767         ENDIF
33768  100  CONTINUE
33769
33770 C  debug precision
33771       IF(IDEB(70).LT.1) RETURN
33772       DO 200 I=I1,MIN(NHEP,I2)
33773         IF(ABS(ISTHEP(I)).GT.10) GOTO 190
33774         PMASS = PHEP(4,I)**2-PHEP(1,I)**2-PHEP(2,I)**2-PHEP(3,I)**2
33775         PMASS = SIGN(SQRT(ABS(PMASS)),PMASS)
33776         IF((ABS(PMASS-PHEP(5,I))/MAX(PHEP(5,I),1.D0)).GT.DIFF) THEN
33777           WRITE(LO,'(1X,A,I5,2E13.4)')
33778      &      'PHO_LTRHEP: inconsistent masses:',I,PMASS,PHEP(5,I)
33779         ENDIF
33780  190    CONTINUE
33781  200  CONTINUE
33782
33783       END
33784
33785 *$ CREATE PHO_PECMS.FOR
33786 *COPY PHO_PECMS
33787 CDECK  ID>, PHO_PECMS
33788       SUBROUTINE PHO_PECMS(ID,PMASS1,PMASS2,ECM,PP,EE)
33789 C*******************************************************************
33790 C
33791 C     calculation of cms momentum and energy of massive particle
33792 C     (ID=  1 using PMASS1,  2 using PMASS2)
33793 C
33794 C     output:  PP    cms momentum
33795 C              EE    energy in CMS of particle ID
33796 C
33797 C********************************************************************
33798       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33799       SAVE
33800
33801 C  input/output channels
33802       INTEGER LI,LO
33803       COMMON /POINOU/ LI,LO
33804 C  event debugging information
33805       INTEGER NMAXD
33806       PARAMETER (NMAXD=100)
33807       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
33808      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33809       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
33810      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
33811 C  some constants
33812       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
33813       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
33814      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
33815
33816       S=ECM**2
33817       PM1 = SIGN(PMASS1**2,PMASS1)
33818       PM2 = SIGN(PMASS2**2,PMASS2)
33819       PP = SQRT(S**2 - 2.D0*PM1*S - 2.D0*PM2*S - 2.D0*PM1*PM2
33820      &          + PM1**2 + PM2**2)/(2.D0*ECM)
33821
33822       IF(ID.EQ.1) THEN
33823         EE = SQRT( PM1 + PP**2 )
33824       ELSE IF(ID.EQ.2) THEN
33825         EE = SQRT( PM2 + PP**2 )
33826       ELSE
33827         WRITE(LO,'(/1X,A,I3,/)')
33828      &    'PHO_PECMS:ERROR: invalid ID number:',ID
33829         EE = PP
33830       ENDIF
33831
33832       END
33833
33834 *$ CREATE PHO_FRAINI.FOR
33835 *COPY PHO_FRAINI
33836 CDECK  ID>, PHO_FRAINI
33837       SUBROUTINE PHO_FRAINI(IDEFAU)
33838 C***********************************************************************
33839 C
33840 C     initialization of fragmentation packages
33841 C      (currently LUND JETSET)
33842 C
33843 C     initialization for JETSET call in DTUNUC 1.04 (J.R. 6/93)
33844 C                      changed to work in PHOJET   (R.E. 1/94)
33845 C
33846 C     input:  IDEFAU    0  no hadronization at all
33847 C                       1  do not touch any parameter of JETSET
33848 C                       2  default parameters kept, decay length 10mm to
33849 C                          define stable particles
33850 C                       3  load tuned parameters for JETSET 7.3
33851 C             neg. value:  prevent strange/charm hadrons from decaying
33852 C
33853 C***********************************************************************
33854       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33855       SAVE
33856
33857       PARAMETER (EPS=1.D-10)
33858
33859 C  input/output channels
33860       INTEGER LI,LO
33861       COMMON /POINOU/ LI,LO
33862       INTEGER N,NPAD,K
33863       DOUBLE PRECISION P,V
33864       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
33865       INTEGER MSTU,MSTJ
33866       DOUBLE PRECISION PARU,PARJ
33867       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33868       INTEGER KCHG
33869       DOUBLE PRECISION  PMAS,PARF,VCKM
33870       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33871       INTEGER MDCY,MDME,KFDP
33872       DOUBLE PRECISION  BRAT
33873       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
33874
33875       INTEGER PYCOMP
33876
33877       IDEFAB = ABS(IDEFAU)
33878
33879       IF(IDEFAB.EQ.0) THEN
33880         WRITE(LO,'(/1X,A)') 'PHO_FRAINI: hadronization switched off'
33881         RETURN
33882       ENDIF
33883 C  defaults
33884       DEF2  = PARJ(2)
33885       IDEF12 = MSTJ(12)
33886       DEF19 = PARJ(19)
33887       DEF41 = PARJ(41)
33888       DEF42 = PARJ(42)
33889       DEF21 = PARJ(21)
33890
33891 C  declare stable particles
33892 c     IF(IDEFAB.GE.2) MSTJ(22) = 2
33893
33894 C  load optimized parameters
33895       IF(IDEFAB.GE.3) THEN
33896 *       PARJ(19)=0.19
33897 C  Lund a-parameter
33898 C  (default=0.3)
33899         PARJ(41)=0.3
33900 C  Lund b-parameter
33901 C  (default=1.0)
33902         PARJ(42)=1.0
33903 C  Lund sigma parameter in pt distribution
33904 C  (default=0.36)
33905         PARJ(21)=0.36
33906       ENDIF
33907 C
33908 C  prevent particles decaying
33909       IF(IDEFAU.LT.0) THEN
33910 C                 K0S
33911         KC=PYCOMP(310)
33912         MDCY(KC,1)=0
33913 C                 PI0
33914         KC=PYCOMP(111)
33915         MDCY(KC,1)=0
33916 C                 LAMBDA
33917         KC=PYCOMP(3122)
33918         MDCY(KC,1)=0
33919 C                 ALAMBDA
33920         KC=PYCOMP(-3122)
33921         MDCY(KC,1)=0
33922 C                 SIG+
33923         KC=PYCOMP(3222)
33924         MDCY(KC,1)=0
33925 C                 ASIG+
33926         KC=PYCOMP(-3222)
33927         MDCY(KC,1)=0
33928 C                 SIG-
33929         KC=PYCOMP(3112)
33930         MDCY(KC,1)=0
33931 C                 ASIG-
33932         KC=PYCOMP(-3112)
33933         MDCY(KC,1)=0
33934 C                 SIG0
33935         KC=PYCOMP(3212)
33936         MDCY(KC,1)=0
33937 C                 ASIG0
33938         KC=PYCOMP(-3212)
33939         MDCY(KC,1)=0
33940 C                 TET0
33941         KC=PYCOMP(3322)
33942         MDCY(KC,1)=0
33943 C                 ATET0
33944         KC=PYCOMP(-3322)
33945         MDCY(KC,1)=0
33946 C                 TET-
33947         KC=PYCOMP(3312)
33948         MDCY(KC,1)=0
33949 C                 ATET-
33950         KC=PYCOMP(-3312)
33951         MDCY(KC,1)=0
33952 C                 OMEGA-
33953         KC=PYCOMP(3334)
33954         MDCY(KC,1)=0
33955 C                 AOMEGA-
33956         KC=PYCOMP(-3334)
33957         MDCY(KC,1)=0
33958 C                 D+
33959         KC=PYCOMP(411)
33960         MDCY(KC,1)=0
33961 C                 D-
33962         KC=PYCOMP(-411)
33963         MDCY(KC,1)=0
33964 C                 D0
33965         KC=PYCOMP(421)
33966         MDCY(KC,1)=0
33967 C                 A-D0
33968         KC=PYCOMP(-421)
33969         MDCY(KC,1)=0
33970 C                 DS+
33971         KC=PYCOMP(431)
33972         MDCY(KC,1)=0
33973 C                 A-DS+
33974         KC=PYCOMP(-431)
33975         MDCY(KC,1)=0
33976 C                ETAC
33977         KC=PYCOMP(441)
33978         MDCY(KC,1)=0
33979 C                LAMBDAC+
33980         KC=PYCOMP(4122)
33981         MDCY(KC,1)=0
33982 C                A-LAMBDAC+
33983         KC=PYCOMP(-4122)
33984         MDCY(KC,1)=0
33985 C                SIGMAC++
33986         KC=PYCOMP(4222)
33987         MDCY(KC,1)=0
33988 C                SIGMAC+
33989         KC=PYCOMP(4212)
33990         MDCY(KC,1)=0
33991 C                SIGMAC0
33992         KC=PYCOMP(4112)
33993         MDCY(KC,1)=0
33994 C                A-SIGMAC++
33995         KC=PYCOMP(-4222)
33996         MDCY(KC,1)=0
33997 C                A-SIGMAC+
33998         KC=PYCOMP(-4212)
33999         MDCY(KC,1)=0
34000 C                A-SIGMAC0
34001         KC=PYCOMP(-4112)
34002         MDCY(KC,1)=0
34003 C                KSIC+
34004         KC=PYCOMP(4232)
34005         MDCY(KC,1)=0
34006 C                KSIC0
34007         KC=PYCOMP(4132)
34008         MDCY(KC,1)=0
34009 C                A-KSIC+
34010         KC=PYCOMP(-4232)
34011         MDCY(KC,1)=0
34012 C                A-KSIC0
34013         KC=PYCOMP(-4132)
34014         MDCY(KC,1)=0
34015       ENDIF
34016
34017       WRITE(LO,2355) IDEFAU,DEF2,PARJ(2),IDEF12,MSTJ(12),
34018      &  DEF19,PARJ(19),DEF41,PARJ(41),DEF42,PARJ(42),DEF21,PARJ(21)
34019  2355 FORMAT(/' PHO_FRAINI: fragmentation initialization ISWMDL(6)',I3/,
34020      &        ' --------------------------------------------------',/,
34021      & 5X,'parameter description               default / current',/,
34022      & 5X,'PARJ( 2) strangeness suppression : ',2F7.3,/,
34023      & 5X,'MSTJ(12) popcorn                 : ',2I7,/,
34024      & 5X,'PARJ(19) popcorn                 : ',2F7.3,/,
34025      & 5X,'PARJ(41) Lund a                  : ',2F7.3,/,
34026      & 5X,'PARJ(42) Lund b                  : ',2F7.3,/,
34027      & 5X,'PARJ(21) sigma in pt distribution: ',2F7.3,/)
34028
34029       END
34030
34031 *$ CREATE PHO_SETPAR.FOR
34032 *COPY PHO_SETPAR
34033 CDECK  ID>, PHO_SETPAR
34034       SUBROUTINE pho_setpar(Iside,IDpdg,IDcpc,Pvir)
34035 C**********************************************************************
34036 C
34037 C     assign a particle to either side 1 or 2
34038 C     (including special treatment for remnants)
34039 C
34040 C     input:    Iside      1,2  side selected for the particle
34041 C                          -2   output of current settings
34042 C               IDpdg      PDG number
34043 C               IDcpc      CPC number
34044 C                          0     CPC determination in subroutine
34045 C                          -1    special particle remnant, IDPDG
34046 C                                is the particle number the remnant
34047 C                                corresponds to (see /POHDFL/)
34048 C
34049 C**********************************************************************
34050       IMPLICIT NONE
34051       SAVE
34052
34053       integer Iside,IDpdg,IDcpc
34054       double precision Pvir
34055
34056 C  input/output channels
34057       INTEGER LI,LO
34058       COMMON /POINOU/ LI,LO
34059 C  event debugging information
34060       INTEGER NMAXD
34061       PARAMETER (NMAXD=100)
34062       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
34063      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34064       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
34065      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
34066 C  global event kinematics and particle IDs
34067       INTEGER IFPAP,IFPAB
34068       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
34069       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
34070 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
34071       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
34072       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
34073       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
34074      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
34075 C  particle ID translation table
34076       integer         ID_pdg_list,ID_list,ID_pdg_max
34077       character*12    name_list
34078       COMMON /POPAR1/ ID_pdg_list(300),ID_list(577),name_list(300),
34079      &                ID_pdg_max
34080 C  general particle data
34081       double precision xm_list,tau_list,gam_list,
34082      &  xm_psm2_list,xm_vem2_list,xm_b82_list,xm_b102_list,
34083      &  xm_bb82_list,xm_bb102_list
34084       integer          ich3_list,iba3_list,iq_list,
34085      &                 id_psm_list,id_vem_list,id_b8_list,id_b10_list
34086       COMMON /POPAR2/ xm_list(300),tau_list(300),gam_list(300),
34087      &  xm_psm2_list(6,6),xm_vem2_list(6,6),
34088      &  xm_b82_list(6,6,6),xm_b102_list(6,6,6),
34089      &  xm_bb82_list(6,6,6,6),xm_bb102_list(6,6,6,6),
34090      &  ich3_list(300),iba3_list(300),iq_list(3,300),
34091      &  id_psm_list(6,6),id_vem_list(6,6),
34092      &  id_b8_list(6,6,6),id_b10_list(6,6,6)
34093 C  particle decay data
34094       double precision wg_sec_list
34095       integer          idec_list,isec_list
34096       COMMON /POPAR3/ wg_sec_list(500),idec_list(3,300),
34097      &  isec_list(3,500)
34098
34099 C  external functions
34100       integer ipho_pdg2id,ipho_chr3,ipho_bar3
34101       double precision pho_pmass
34102
34103 C  local variables
34104       integer i,IDcpcN,IDcpcR,IDpdgN,IDpdgR,IDB,IFL1,IFL2,IFL3
34105
34106       IF((Iside.EQ.1).OR.(Iside.EQ.2)) THEN
34107         IDcpcN = IDcpc
34108 C  remnant?
34109         IF(IDcpc.EQ.-1) THEN
34110           IF(Iside.EQ.1) THEN
34111             IDpdgR = 81
34112           ELSE
34113             IDpdgR = 82
34114           ENDIF
34115           IDcpcR = ipho_pdg2id(IDpdgR)
34116           IDEQB(Iside) = ipho_pdg2id(IDpdg)
34117           IDEQP(Iside) = IDpdg
34118 C  copy particle properties
34119           IDB = abs(IDEQB(Iside))
34120           xm_list(IDcpcR)  = xm_list(IDB)
34121           tau_list(IDcpcR) = tau_list(IDB)
34122           gam_list(IDcpcR) = gam_list(IDB)
34123           IF(IHFLS(Iside).EQ.1) THEN
34124             ich3_list(IDcpcR) = ipho_chr3(IDEQB(Iside),0)
34125             iba3_list(IDcpcR) = ipho_bar3(IDEQB(Iside),0)
34126           ELSE
34127             ich3_list(IDcpcR) = 0
34128             iba3_list(IDcpcR) = 0
34129           ENDIF
34130 C  quark content
34131           IFL1 = IHFLD(Iside,1)
34132           IFL2 = IHFLD(Iside,2)
34133           IFL3 = 0
34134           IF(IHFLS(Iside).EQ.1) THEN
34135             IF(ABS(IHFLD(Iside,1)).GT.1000) THEN
34136               IFL1 = IHFLD(Iside,1)/1000
34137               IFL2 = MOD(IHFLD(Iside,1)/100,10)
34138               IFL3 = IHFLD(Iside,2)
34139             ELSE IF(ABS(IHFLD(Iside,2)).GT.1000) THEN
34140               IFL1 = IHFLD(Iside,1)
34141               IFL2 = IHFLD(Iside,2)/1000
34142               IFL3 = MOD(IHFLD(Iside,2)/100,10)
34143             ENDIF
34144           ENDIF
34145           iq_list(1,IDcpcR) = IFL1
34146           iq_list(2,IDcpcR) = IFL2
34147           iq_list(3,IDcpcR) = IFL3
34148
34149           IDcpcN = IDcpcR
34150           IDPDGN = IDPDGR
34151
34152           IF(IDEB(87).GE.5) THEN
34153             WRITE(LO,'(1X,A,I2,/5X,A,I7,4I6)')
34154      &        'pho_setpar: remnant assignment side',Iside,
34155      &        'IDPDG,IFL1,2,3,IVAL',IDPDGN,IFL1,IFL2,IFL3,IHFLS(Iside)
34156           ENDIF
34157         ELSE IF(IDcpc.EQ.0) THEN
34158 C  ordinary hadron
34159           IHFLS(Iside) = 1
34160           IHFLD(Iside,1) = 0
34161           IHFLD(Iside,2) = 0
34162           IDcpcN = ipho_pdg2id(IDpdg)
34163           IDpdgN = IDpdg
34164         ENDIF
34165
34166 C initialize /POGCMS/
34167         IFPAP(Iside) = IDpdgN
34168         IFPAB(Iside) = IDcpcN
34169         PMASS(Iside) = pho_pmass(IDcpcN,0)
34170         IF(IFPAP(Iside).EQ.22) THEN
34171           PVIRT(Iside) = ABS(PVIR)
34172         ELSE
34173           PVIRT(Iside) = 0.D0
34174         ENDIF
34175
34176       ELSE IF(Iside.EQ.-2) THEN
34177 C  output of current settings
34178         DO 100 I=1,2
34179           WRITE(LO,'(1X,A,I2,1X,A,I7,I4,1X,1P2E10.3)')
34180      &      'PHO_SETPAR: side',
34181      &      I,'IDPDG,IDcpc,PMASS,PVIRT',IFPAP(I),IFPAB(I),PMASS(I),
34182      &      PVIRT(I)
34183           IF((IFPAP(I).EQ.81).OR.(IFPAP(I).EQ.82)) THEN
34184             WRITE(LO,'(5X,A,I7,I4,I2,3I5)')
34185      &        'remnant:IDPDG,IDcpc,IVAL,IFLA1,2',IDEQP(I),IDEQB(I),
34186      &        IHFLS(I),IHFLD(I,1),IHFLD(I,2)
34187           ENDIF
34188  100    CONTINUE
34189       ELSE
34190         WRITE(LO,'(/1X,A,I8)')
34191      &    'pho_setpar: invalid argument (Iside)',Iside
34192       ENDIF
34193
34194       END
34195
34196 *$ CREATE PHO_XLAM.FOR
34197 *COPY PHO_XLAM
34198 CDECK  ID>, PHO_XLAM
34199       DOUBLE PRECISION FUNCTION PHO_XLAM(X,Y,Z)
34200 C**********************************************************************
34201 C
34202 C     auxiliary function for two/three particle decay mode
34203 C     (standard LAMBDA**(1/2) function)
34204 C
34205 C**********************************************************************
34206       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34207       SAVE
34208 C
34209       YZ=Y-Z
34210       XLAM=X*X-2.D0*X*(Y+Z)+YZ*YZ
34211       IF(XLAM.LT.0.D0) XLAM=-XLAM
34212       PHO_XLAM=SQRT(XLAM)
34213       END
34214
34215 *$ CREATE PHO_BESSJ0.FOR
34216 *COPY PHO_BESSJ0
34217 CDECK  ID>, PHO_BESSJ0
34218       DOUBLE PRECISION FUNCTION PHO_BESSJ0(DX)
34219 C**********************************************************************
34220 C
34221 C     CERN (KERN) LIB function C312
34222 C
34223 C     modified by R. Engel (03/02/93)
34224 C
34225 C**********************************************************************
34226       DOUBLE PRECISION DX
34227       DOUBLE PRECISION X,Y,V,H,ALFA,EIGHT
34228       DOUBLE PRECISION PI1,PI2,C1(0:14),C2(0:9),C3(0:10),B0,B1,B2,P,Q,R
34229       SAVE
34230
34231       DATA EIGHT /8.0D0/
34232       DATA PI1 /0.79788 45608 0287D0/, PI2 /0.78539 81633 9745D0/
34233
34234       DATA C1( 0) /+0.15772 79714 7489D0/
34235       DATA C1( 1) /-0.00872 34423 5285D0/
34236       DATA C1( 2) /+0.26517 86132 0334D0/
34237       DATA C1( 3) /-0.37009 49938 7265D0/
34238       DATA C1( 4) /+0.15806 71023 3210D0/
34239       DATA C1( 5) /-0.03489 37694 1141D0/
34240       DATA C1( 6) /+0.00481 91800 6947D0/
34241       DATA C1( 7) /-0.00046 06261 6621D0/
34242       DATA C1( 8) /+0.00003 24603 2882D0/
34243       DATA C1( 9) /-0.00000 17619 4691D0/
34244       DATA C1(10) /+0.00000 00760 8164D0/
34245       DATA C1(11) /-0.00000 00026 7925D0/
34246       DATA C1(12) /+0.00000 00000 7849D0/
34247       DATA C1(13) /-0.00000 00000 0194D0/
34248       DATA C1(14) /+0.00000 00000 0004D0/
34249
34250       DATA C2( 0) /+0.99946 03493 4752D0/
34251       DATA C2( 1) /-0.00053 65220 4681D0/
34252       DATA C2( 2) /+0.00000 30751 8479D0/
34253       DATA C2( 3) /-0.00000 00517 0595D0/
34254       DATA C2( 4) /+0.00000 00016 3065D0/
34255       DATA C2( 5) /-0.00000 00000 7864D0/
34256       DATA C2( 6) /+0.00000 00000 0517D0/
34257       DATA C2( 7) /-0.00000 00000 0043D0/
34258       DATA C2( 8) /+0.00000 00000 0004D0/
34259       DATA C2( 9) /-0.00000 00000 0001D0/
34260
34261       DATA C3( 0) /-0.01555 58546 05337D0/
34262       DATA C3( 1) /+0.00006 83851 99426D0/
34263       DATA C3( 2) /-0.00000 07414 49841D0/
34264       DATA C3( 3) /+0.00000 00179 72457D0/
34265       DATA C3( 4) /-0.00000 00007 27192D0/
34266       DATA C3( 5) /+0.00000 00000 42201D0/
34267       DATA C3( 6) /-0.00000 00000 03207D0/
34268       DATA C3( 7) /+0.00000 00000 00301D0/
34269       DATA C3( 8) /-0.00000 00000 00033D0/
34270       DATA C3( 9) /+0.00000 00000 00004D0/
34271       DATA C3(10) /-0.00000 00000 00001D0/
34272
34273       X=DX
34274       V=ABS(X)
34275       IF(V .LT. EIGHT) THEN
34276        Y=V/EIGHT
34277        H=2.D0*Y**2-1.D0
34278        ALFA=-2.D0*H
34279        B1=0.D0
34280        B2=0.D0
34281        DO 1 I = 14,0,-1
34282        B0=C1(I)-ALFA*B1-B2
34283        B2=B1
34284     1  B1=B0
34285        B1=B0-H*B2
34286       ELSE
34287        R=1.D0/V
34288        Y=EIGHT*R
34289        H=2.D0*Y**2-1.D0
34290        ALFA=-2.D0*H
34291        B1=0.D0
34292        B2=0.D0
34293        DO 2 I = 9,0,-1
34294        B0=C2(I)-ALFA*B1-B2
34295        B2=B1
34296     2  B1=B0
34297        P=B0-H*B2
34298        B1=0.D0
34299        B2=0.D0
34300        DO 3 I = 10,0,-1
34301        B0=C3(I)-ALFA*B1-B2
34302        B2=B1
34303     3  B1=B0
34304        Q=Y*(B0-H*B2)
34305        B0=V-PI2
34306        B1=PI1*SQRT(R)*(P*COS(B0)-Q*SIN(B0))
34307       ENDIF
34308       PHO_BESSJ0=B1
34309       RETURN
34310       END
34311
34312 *$ CREATE PHO_BESSI0.FOR
34313 *COPY PHO_BESSI0
34314 CDECK  ID>, PHO_BESSI0
34315       DOUBLE PRECISION FUNCTION PHO_BESSI0(X)
34316 C**********************************************************************
34317 C
34318 C      Bessel Function I0
34319 C
34320 C**********************************************************************
34321       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34322       SAVE
34323
34324       AX = ABS(X)
34325       IF (AX .LT. 3.75D0) THEN
34326         Y = (X/3.75D0)**2
34327         PHO_BESSI0 =
34328      &    1.0D0+Y*(3.5156229D0+Y*(3.0899424D0+Y*(1.2067492D0
34329      &    +Y*(0.2659732D0+Y*(0.360768D-1+Y*0.45813D-2)))))
34330       ELSE
34331         Y = 3.75D0/AX
34332         PHO_BESSI0 =
34333      &    (EXP(AX)/SQRT(AX))*(0.39894228D0+Y*(0.1328592D-1
34334      &    +Y*(0.225319D-2+Y*(-0.157565D-2+Y*(0.916281D-2
34335      &    +Y*(-0.2057706D-1+Y*(0.2635537D-1+Y*(-0.1647633D-1
34336      &    +Y*0.392377D-2))))))))
34337       ENDIF
34338
34339       END
34340
34341 *$ CREATE PHO_BESSI1.FOR
34342 *COPY PHO_BESSI1
34343 CDECK  ID>, PHO_BESSI1
34344       DOUBLE PRECISION FUNCTION PHO_BESSI1(X)
34345 C**********************************************************************
34346 C
34347 C      Bessel Function I1
34348 C
34349 C**********************************************************************
34350       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34351       SAVE
34352
34353       AX = ABS(X)
34354
34355       IF (AX .LT. 3.75D0) THEN
34356         Y = (X/3.75D0)**2
34357         BESLI1 =
34358      &    AX*(0.5D0+Y*(0.87890594D0+Y*(0.51498869D0+Y*(0.15084934D0
34359      &    +Y*(0.2658733D-1+Y*(0.301532D-2+Y*0.32411D-3))))))
34360       ELSE
34361         Y = 3.75D0/AX
34362         BESLI1 =
34363      &    0.2282967D-1+Y*(-0.2895312D-1+Y*(0.1787654D-1
34364      &    -Y*0.420059D-2))
34365         BESLI1 =
34366      &    0.39894228D0+Y*(-0.3988024D-1+Y*(-0.362018D-2
34367      &    +Y*(0.163801D-2+Y*(-0.1031555D-1+Y*BESLI1))))
34368         BESLI1 = BESLI1 * EXP(AX)/SQRT(AX)
34369       ENDIF
34370       IF (X .LT. 0.D0) BESLI1 = -BESLI1
34371
34372       PHO_BESSI1 = BESLI1
34373
34374       END
34375
34376 *$ CREATE PHO_BESSK0.FOR
34377 *COPY PHO_BESSK0
34378 CDECK  ID>, PHO_BESSK0
34379       DOUBLE PRECISION FUNCTION PHO_BESSK0(X)
34380 C**********************************************************************
34381 C
34382 C      Modified Bessel Function K0
34383 C
34384 C**********************************************************************
34385       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34386       SAVE
34387
34388       IF (X .LT. 2.D0) THEN
34389         Y = X**2/4.D0
34390         PHO_BESSK0 =
34391      &    (-LOG(X/2.D0)*PHO_BESSI0(X))+(-.57721566D0+Y*(0.42278420D0
34392      &    +Y*(0.23069756D0+Y*(0.3488590D-1+Y*(0.262698D-2
34393      &    +Y*(0.10750D-3+Y*0.740D-5))))))
34394       ELSE
34395         Y = 2.D0/X
34396         PHO_BESSK0 =
34397      &    (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(-0.7832358D-1
34398      &    +Y*(0.2189568D-1+Y*(-0.1062446D-1+Y*(0.587872D-2
34399      &    +Y*(-0.251540D-2+Y*0.53208D-3))))))
34400       ENDIF
34401
34402       END
34403
34404 *$ CREATE PHO_BESSK1.FOR
34405 *COPY PHO_BESSK1
34406 CDECK  ID>, PHO_BESSK1
34407       DOUBLE PRECISION FUNCTION PHO_BESSK1(X)
34408 C**********************************************************************
34409 C
34410 C      Modified Bessel Function K1
34411 C
34412 C**********************************************************************
34413       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34414       SAVE
34415
34416       IF (X .LT. 2.D0) THEN
34417         Y = X**2/4.D0
34418         PHO_BESSK1 =
34419      &    (LOG(X/2.D0)*PHO_BESSI1(X))+(1.D0/X)*(1.D0+Y*(0.15443144D0
34420      &    +Y*(-0.67278579D0+Y*(-0.18156897D0+Y*(-0.1919402D-1
34421      &    +Y*(-0.110404D-2+Y*(-0.4686D-4)))))))
34422       ELSE
34423         Y=2.D0/X
34424         PHO_BESSK1 =
34425      &    (EXP(-X)/SQRT(X))*(1.25331414D0+Y*(0.23498619D0
34426      &    +Y*(-0.3655620D-1+Y*(0.1504268D-1+Y*(-0.780353D-2
34427      &    +Y*(0.325614D-2+Y*(-0.68245D-3)))))))
34428       ENDIF
34429
34430       END
34431
34432 *$ CREATE PHO_GAUSET.FOR
34433 *COPY PHO_GAUSET
34434 CDECK  ID>, PHO_GAUSET
34435       SUBROUTINE PHO_GAUSET(AX,BX,NX,Z,W)
34436 C********************************************************************
34437 C
34438 C     N-point gauss zeros and weights for the interval (AX,BX) are
34439 C           stored in  arrays Z and W respectively.
34440 C
34441 C*********************************************************************
34442       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34443       SAVE
34444
34445       COMMON /POGDAT/A(273),X(273),KTAB(96)
34446       DIMENSION Z(NX),W(NX)
34447
34448       ALPHA=0.5*(BX+AX)
34449       BETA=0.5*(BX-AX)
34450       N=NX
34451
34452 C  the N=1 case:
34453       IF(N.NE.1) GO TO 1
34454       Z(1)=ALPHA
34455       W(1)=BX-AX
34456       RETURN
34457
34458 C  the Gauss cases:
34459     1 IF((N.LE.16).AND.(N.GT.1)) GO TO 2
34460       IF(N.EQ.20) GO TO 2
34461       IF(N.EQ.24) GO TO 2
34462       IF(N.EQ.32) GO TO 2
34463       IF(N.EQ.40) GO TO 2
34464       IF(N.EQ.48) GO TO 2
34465       IF(N.EQ.64) GO TO 2
34466       IF(N.EQ.80) GO TO 2
34467       IF(N.EQ.96) GO TO 2
34468
34469 C  the extended Gauss cases:
34470       IF((N/96)*96.EQ.N) GO TO 3
34471
34472 C  jump to center of intervall intrgration:
34473       GO TO 100
34474
34475 C  get Gauss point array
34476
34477     2 CALL PHO_GAUDAT
34478 C  extract real points
34479       K=KTAB(N)
34480       M=N/2
34481       DO 21 J=1,M
34482 C       extract values from big array
34483         JTAB=K-1+J
34484         WTEMP=BETA*A(JTAB)
34485         DELTA=BETA*X(JTAB)
34486 C       store them backward
34487         Z(J)=ALPHA-DELTA
34488         W(J)=WTEMP
34489 C       store them forward
34490         JP=N+1-J
34491         Z(JP)=ALPHA+DELTA
34492         W(JP)=WTEMP
34493    21 CONTINUE
34494 C     store central point (odd N)
34495       IF((N-M-M).EQ.0) RETURN
34496       Z(M+1)=ALPHA
34497       JMID=K+M
34498       W(M+1)=BETA*A(JMID)
34499       RETURN
34500
34501 C  get ND96 times chained 96 Gauss point array
34502
34503     3 CALL PHO_GAUDAT
34504 C  print out message
34505 C     -extract real points
34506       K=KTAB(96)
34507       ND96=N/96
34508       DO 31 J=1,48
34509 C       extract values from big array
34510         JTAB=K-1+J
34511         WTEMP=BETA*A(JTAB)
34512         DELTA=BETA*X(JTAB)
34513         WTeMP=WTEMP/ND96
34514         DeLTA=DELTA/ND96
34515         DO 32 JD96=0,ND96-1
34516           ZCNTR= (ALPHA-BETA)+ BETA*FLOAT(2*JD96+1)/FLOAT(ND96)
34517 C         store them backward
34518           Z(J+JD96*96)=ZCNTR-DELTA
34519           W(J+JD96*96)=WTEMP
34520 C         store them forward
34521           JP=96+1-J
34522           Z(JP+JD96*96)=ZCNTR+DELTA
34523           W(JP+JD96*96)=WTEMP
34524    32   CONTINUE
34525    31 CONTINUE
34526       RETURN
34527
34528 C  the center of intervall cases:
34529   100 CONTINUE
34530 C  put in constant weight and equally spaced central points
34531       N=IABS(N)
34532       DO 111 IN=1,N
34533         WIN=(BX-AX)/FLOAT(N)
34534         Z(IN)=AX  + (FLOAT(IN)-.5)*WIN
34535   111 W(IN)=WIN
34536
34537       END
34538
34539 *$ CREATE PHO_GAUDAT.FOR
34540 *COPY PHO_GAUDAT
34541 CDECK  ID>, PHO_GAUDAT
34542       SUBROUTINE PHO_GAUDAT
34543 C*********************************************************************
34544 C
34545 C     store big arrays needed for Gauss integral, CERNLIB D106BD
34546 C     (arrays A,X,ITAB copied on B,Y,LTAB)
34547 C
34548 C*********************************************************************
34549       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34550
34551       SAVE
34552       COMMON /POGDAT/ B(273),Y(273),LTAB(96)
34553       DIMENSION       A(273),X(273),KTAB(96)
34554
34555 C-----TABLE OF INITIAL SUBSCRIPTS FOR N=2(1)16(4)96
34556       DATA KTAB(2)/1/
34557       DATA KTAB(3)/2/
34558       DATA KTAB(4)/4/
34559       DATA KTAB(5)/6/
34560       DATA KTAB(6)/9/
34561       DATA KTAB(7)/12/
34562       DATA KTAB(8)/16/
34563       DATA KTAB(9)/20/
34564       DATA KTAB(10)/25/
34565       DATA KTAB(11)/30/
34566       DATA KTAB(12)/36/
34567       DATA KTAB(13)/42/
34568       DATA KTAB(14)/49/
34569       DATA KTAB(15)/56/
34570       DATA KTAB(16)/64/
34571       DATA KTAB(20)/72/
34572       DATA KTAB(24)/82/
34573       DATA KTAB(28)/82/
34574       DATA KTAB(32)/94/
34575       DATA KTAB(36)/94/
34576       DATA KTAB(40)/110/
34577       DATA KTAB(44)/110/
34578       DATA KTAB(48)/130/
34579       DATA KTAB(52)/130/
34580       DATA KTAB(56)/130/
34581       DATA KTAB(60)/130/
34582       DATA KTAB(64)/154/
34583       DATA KTAB(68)/154/
34584       DATA KTAB(72)/154/
34585       DATA KTAB(76)/154/
34586       DATA KTAB(80)/186/
34587       DATA KTAB(84)/186/
34588       DATA KTAB(88)/186/
34589       DATA KTAB(92)/186/
34590       DATA KTAB(96)/226/
34591 C
34592 C-----TABLE OF ABSCISSAE (X) AND WEIGHTS (A) FOR INTERVAL (-1,+1).
34593 C
34594 C-----N=2
34595       DATA X(1)/0.577350269189626D0  /, A(1)/1.000000000000000D0  /
34596 C-----N=3
34597       DATA X(2)/0.774596669241483D0  /, A(2)/0.555555555555556D0  /
34598       DATA X(3)/0.000000000000000D0  /, A(3)/0.888888888888889D0  /
34599 C-----N=4
34600       DATA X(4)/0.861136311594053D0  /, A(4)/0.347854845137454D0  /
34601       DATA X(5)/0.339981043584856D0  /, A(5)/0.652145154862546D0  /
34602 C-----N=5
34603       DATA X(6)/0.906179845938664D0  /, A(6)/0.236926885056189D0  /
34604       DATA X(7)/0.538469310105683D0  /, A(7)/0.478628670499366D0  /
34605       DATA X(8)/0.000000000000000D0  /, A(8)/0.568888888888889D0  /
34606 C-----N=6
34607       DATA X(9)/0.932469514203152D0  /, A(9)/0.171324492379170D0  /
34608       DATA X(10)/0.661209386466265D0 /, A(10)/0.360761573048139D0 /
34609       DATA X(11)/0.238619186083197D0 /, A(11)/0.467913934572691D0 /
34610 C-----N=7
34611       DATA X(12)/0.949107912342759D0 /, A(12)/0.129484966168870D0 /
34612       DATA X(13)/0.741531185599394D0 /, A(13)/0.279705391489277D0 /
34613       DATA X(14)/0.405845151377397D0 /, A(14)/0.381830050505119D0 /
34614       DATA X(15)/0.000000000000000D0 /, A(15)/0.417959183673469D0 /
34615 C-----N=8
34616       DATA X(16)/0.960289856497536D0 /, A(16)/0.101228536290376D0 /
34617       DATA X(17)/0.796666477413627D0 /, A(17)/0.222381034453374D0 /
34618       DATA X(18)/0.525532409916329D0 /, A(18)/0.313706645877887D0 /
34619       DATA X(19)/0.183434642495650D0 /, A(19)/0.362683783378362D0 /
34620 C-----N=9
34621       DATA X(20)/0.968160239507626D0 /, A(20)/0.081274388361574D0 /
34622       DATA X(21)/0.836031107326636D0 /, A(21)/0.180648160694857D0 /
34623       DATA X(22)/0.613371432700590D0 /, A(22)/0.260610696402935D0 /
34624       DATA X(23)/0.324253423403809D0 /, A(23)/0.312347077040003D0 /
34625       DATA X(24)/0.000000000000000D0 /, A(24)/0.330239355001260D0 /
34626 C-----N=10
34627       DATA X(25)/0.973906528517172D0 /, A(25)/0.066671344308688D0 /
34628       DATA X(26)/0.865063366688985D0 /, A(26)/0.149451349150581D0 /
34629       DATA X(27)/0.679409568299024D0 /, A(27)/0.219086362515982D0 /
34630       DATA X(28)/0.433395394129247D0 /, A(28)/0.269266719309996D0 /
34631       DATA X(29)/0.148874338981631D0 /, A(29)/0.295524224714753D0 /
34632 C-----N=11
34633       DATA X(30)/0.978228658146057D0 /, A(30)/0.055668567116174D0 /
34634       DATA X(31)/0.887062599768095D0 /, A(31)/0.125580369464905D0 /
34635       DATA X(32)/0.730152005574049D0 /, A(32)/0.186290210927734D0 /
34636       DATA X(33)/0.519096129206812D0 /, A(33)/0.233193764591990D0 /
34637       DATA X(34)/0.269543155952345D0 /, A(34)/0.262804544510247D0 /
34638       DATA X(35)/0.000000000000000D0 /, A(35)/0.272925086777901D0 /
34639 C-----N=12
34640       DATA X(36)/0.981560634246719D0 /, A(36)/0.047175336386512D0 /
34641       DATA X(37)/0.904117256370475D0 /, A(37)/0.106939325995318D0 /
34642       DATA X(38)/0.769902674194305D0 /, A(38)/0.160078328543346D0 /
34643       DATA X(39)/0.587317954286617D0 /, A(39)/0.203167426723066D0 /
34644       DATA X(40)/0.367831498998180D0 /, A(40)/0.233492536538355D0 /
34645       DATA X(41)/0.125233408511469D0 /, A(41)/0.249147045813403D0 /
34646 C-----N=13
34647       DATA X(42)/0.984183054718588D0 /, A(42)/0.040484004765316D0 /
34648       DATA X(43)/0.917598399222978D0 /, A(43)/0.092121499837728D0 /
34649       DATA X(44)/0.801578090733310D0 /, A(44)/0.138873510219787D0 /
34650       DATA X(45)/0.642349339440340D0 /, A(45)/0.178145980761946D0 /
34651       DATA X(46)/0.448492751036447D0 /, A(46)/0.207816047536889D0 /
34652       DATA X(47)/0.230458315955135D0 /, A(47)/0.226283180262897D0 /
34653       DATA X(48)/0.000000000000000D0 /, A(48)/0.232551553230874D0 /
34654 C-----N=14
34655       DATA X(49)/0.986283808696812D0 /, A(49)/0.035119460331752D0 /
34656       DATA X(50)/0.928434883663574D0 /, A(50)/0.080158087159760D0 /
34657       DATA X(51)/0.827201315069765D0 /, A(51)/0.121518570687903D0 /
34658       DATA X(52)/0.687292904811685D0 /, A(52)/0.157203167158194D0 /
34659       DATA X(53)/0.515248636358154D0 /, A(53)/0.185538397477938D0 /
34660       DATA X(54)/0.319112368927890D0 /, A(54)/0.205198463721296D0 /
34661       DATA X(55)/0.108054948707344D0 /, A(55)/0.215263853463158D0 /
34662 C-----N=15
34663       DATA X(56)/0.987992518020485D0 /, A(56)/0.030753241996117D0 /
34664       DATA X(57)/0.937273392400706D0 /, A(57)/0.070366047488108D0 /
34665       DATA X(58)/0.848206583410427D0 /, A(58)/0.107159220467172D0 /
34666       DATA X(59)/0.724417731360170D0 /, A(59)/0.139570677926154D0 /
34667       DATA X(60)/0.570972172608539D0 /, A(60)/0.166269205816994D0 /
34668       DATA X(61)/0.394151347077563D0 /, A(61)/0.186161000015562D0 /
34669       DATA X(62)/0.201194093997435D0 /, A(62)/0.198431485327111D0 /
34670       DATA X(63)/0.000000000000000D0 /, A(63)/0.202578241925561D0 /
34671 C-----N=16
34672       DATA X(64)/0.989400934991650D0 /, A(64)/0.027152459411754D0 /
34673       DATA X(65)/0.944575023073233D0 /, A(65)/0.062253523938648D0 /
34674       DATA X(66)/0.865631202387832D0 /, A(66)/0.095158511682493D0 /
34675       DATA X(67)/0.755404408355003D0 /, A(67)/0.124628971255534D0 /
34676       DATA X(68)/0.617876244402644D0 /, A(68)/0.149595988816577D0 /
34677       DATA X(69)/0.458016777657227D0 /, A(69)/0.169156519395003D0 /
34678       DATA X(70)/0.281603550779259D0 /, A(70)/0.182603415044924D0 /
34679       DATA X(71)/0.095012509837637D0 /, A(71)/0.189450610455069D0 /
34680 C-----N=20
34681       DATA X(72)/0.993128599185094D0 /, A(72)/0.017614007139152D0 /
34682       DATA X(73)/0.963971927277913D0 /, A(73)/0.040601429800386D0 /
34683       DATA X(74)/0.912234428251325D0 /, A(74)/0.062672048334109D0 /
34684       DATA X(75)/0.839116971822218D0 /, A(75)/0.083276741576704D0 /
34685       DATA X(76)/0.746331906460150D0 /, A(76)/0.101930119817240D0 /
34686       DATA X(77)/0.636053680726515D0 /, A(77)/0.118194531961518D0 /
34687       DATA X(78)/0.510867001950827D0 /, A(78)/0.131688638449176D0 /
34688       DATA X(79)/0.373706088715419D0 /, A(79)/0.142096109318382D0 /
34689       DATA X(80)/0.227785851141645D0 /, A(80)/0.149172986472603D0 /
34690       DATA X(81)/0.076526521133497D0 /, A(81)/0.152753387130725D0 /
34691 C-----N=24
34692       DATA X(82)/0.995187219997021D0 /, A(82)/0.012341229799987D0 /
34693       DATA X(83)/0.974728555971309D0 /, A(83)/0.028531388628933D0 /
34694       DATA X(84)/0.938274552002732D0 /, A(84)/0.044277438817419D0 /
34695       DATA X(85)/0.886415527004401D0 /, A(85)/0.059298584915436D0 /
34696       DATA X(86)/0.820001985973902D0 /, A(86)/0.073346481411080D0 /
34697       DATA X(87)/0.740124191578554D0 /, A(87)/0.086190161531953D0 /
34698       DATA X(88)/0.648093651936975D0 /, A(88)/0.097618652104113D0 /
34699       DATA X(89)/0.545421471388839D0 /, A(89)/0.107444270115965D0 /
34700       DATA X(90)/0.433793507626045D0 /, A(90)/0.115505668053725D0 /
34701       DATA X(91)/0.315042679696163D0 /, A(91)/0.121670472927803D0 /
34702       DATA X(92)/0.191118867473616D0 /, A(92)/0.125837456346828D0 /
34703       DATA X(93)/0.064056892862605D0 /, A(93)/0.127938195346752D0 /
34704 C-----N=32
34705       DATA X(94)/0.997263861849481D0 /, A(94)/0.007018610009470D0 /
34706       DATA X(95)/0.985611511545268D0 /, A(95)/0.016274394730905D0 /
34707       DATA X(96)/0.964762255587506D0 /, A(96)/0.025392065309262D0 /
34708       DATA X(97)/0.934906075937739D0 /, A(97)/0.034273862913021D0 /
34709       DATA X(98)/0.896321155766052D0 /, A(98)/0.042835898022226D0 /
34710       DATA X(99)/0.849367613732569D0 /, A(99)/0.050998059262376D0 /
34711       DATA X(100)/0.794483795967942D0/, A(100)/0.058684093478535D0/
34712       DATA X(101)/0.732182118740289D0/, A(101)/0.065822222776361D0/
34713       DATA X(102)/0.663044266930215D0/, A(102)/0.072345794108848D0/
34714       DATA X(103)/0.587715757240762D0/, A(103)/0.078193895787070D0/
34715       DATA X(104)/0.506899908932229D0/, A(104)/0.083311924226946D0/
34716       DATA X(105)/0.421351276130635D0/, A(105)/0.087652093004403D0/
34717       DATA X(106)/0.331868602282127D0/, A(106)/0.091173878695763D0/
34718       DATA X(107)/0.239287362252137D0/, A(107)/0.093844399080804D0/
34719       DATA X(108)/0.144471961582796D0/, A(108)/0.095638720079274D0/
34720       DATA X(109)/0.048307665687738D0/, A(109)/0.096540088514727D0/
34721 C-----N=40
34722       DATA X(110)/0.998237709710559D0/, A(110)/0.004521277098533D0/
34723       DATA X(111)/0.990726238699457D0/, A(111)/0.010498284531152D0/
34724       DATA X(112)/0.977259949983774D0/, A(112)/0.016421058381907D0/
34725       DATA X(113)/0.957916819213791D0/, A(113)/0.022245849194166D0/
34726       DATA X(114)/0.932812808278676D0/, A(114)/0.027937006980023D0/
34727       DATA X(115)/0.902098806968874D0/, A(115)/0.033460195282547D0/
34728       DATA X(116)/0.865959503212259D0/, A(116)/0.038782167974472D0/
34729       DATA X(117)/0.824612230833311D0/, A(117)/0.043870908185673D0/
34730       DATA X(118)/0.778305651426519D0/, A(118)/0.048695807635072D0/
34731       DATA X(119)/0.727318255189927D0/, A(119)/0.053227846983936D0/
34732       DATA X(120)/0.671956684614179D0/, A(120)/0.057439769099391D0/
34733       DATA X(121)/0.612553889667980D0/, A(121)/0.061306242492928D0/
34734       DATA X(122)/0.549467125095128D0/, A(122)/0.064804013456601D0/
34735       DATA X(123)/0.483075801686178D0/, A(123)/0.067912045815233D0/
34736       DATA X(124)/0.413779204371605D0/, A(124)/0.070611647391286D0/
34737       DATA X(125)/0.341994090825758D0/, A(125)/0.072886582395804D0/
34738       DATA X(126)/0.268152185007253D0/, A(126)/0.074723169057968D0/
34739       DATA X(127)/0.192697580701371D0/, A(127)/0.076110361900626D0/
34740       DATA X(128)/0.116084070675255D0/, A(128)/0.077039818164247D0/
34741       DATA X(129)/0.038772417506050D0/, A(129)/0.077505947978424D0/
34742 C-----N=48
34743       DATA X(130)/0.998771007252426D0/, A(130)/0.003153346052305D0/
34744       DATA X(131)/0.993530172266350D0/, A(131)/0.007327553901276D0/
34745       DATA X(132)/0.984124583722826D0/, A(132)/0.011477234579234D0/
34746       DATA X(133)/0.970591592546247D0/, A(133)/0.015579315722943D0/
34747       DATA X(134)/0.952987703160430D0/, A(134)/0.019616160457355D0/
34748       DATA X(135)/0.931386690706554D0/, A(135)/0.023570760839324D0/
34749       DATA X(136)/0.905879136715569D0/, A(136)/0.027426509708356D0/
34750       DATA X(137)/0.876572020274247D0/, A(137)/0.031167227832798D0/
34751       DATA X(138)/0.843588261624393D0/, A(138)/0.034777222564770D0/
34752       DATA X(139)/0.807066204029442D0/, A(139)/0.038241351065830D0/
34753       DATA X(140)/0.767159032515740D0/, A(140)/0.041545082943464D0/
34754       DATA X(141)/0.724034130923814D0/, A(141)/0.044674560856694D0/
34755       DATA X(142)/0.677872379632663D0/, A(142)/0.047616658492490D0/
34756       DATA X(143)/0.628867396776513D0/, A(143)/0.050359035553854D0/
34757       DATA X(144)/0.577224726083972D0/, A(144)/0.052890189485193D0/
34758       DATA X(145)/0.523160974722233D0/, A(145)/0.055199503699984D0/
34759       DATA X(146)/0.466902904750958D0/, A(146)/0.057277292100403D0/
34760       DATA X(147)/0.408686481990716D0/, A(147)/0.059114839698395D0/
34761       DATA X(148)/0.348755886292160D0/, A(148)/0.060704439165893D0/
34762       DATA X(149)/0.287362487355455D0/, A(149)/0.062039423159892D0/
34763       DATA X(150)/0.224763790394689D0/, A(150)/0.063114192286254D0/
34764       DATA X(151)/0.161222356068891D0/, A(151)/0.063924238584648D0/
34765       DATA X(152)/0.097004699209462D0/, A(152)/0.064466164435950D0/
34766       DATA X(153)/0.032380170962869D0/, A(153)/0.064737696812683D0/
34767 C-----N=64
34768       DATA X(154)/0.999305041735772D0/, A(154)/0.001783280721696D0/
34769       DATA X(155)/0.996340116771955D0/, A(155)/0.004147033260562D0/
34770       DATA X(156)/0.991013371476744D0/, A(156)/0.006504457968978D0/
34771       DATA X(157)/0.983336253884625D0/, A(157)/0.008846759826363D0/
34772       DATA X(158)/0.973326827789910D0/, A(158)/0.011168139460131D0/
34773       DATA X(159)/0.961008799652053D0/, A(159)/0.013463047896718D0/
34774       DATA X(160)/0.946411374858402D0/, A(160)/0.015726030476024D0/
34775       DATA X(161)/0.929569172131939D0/, A(161)/0.017951715775697D0/
34776       DATA X(162)/0.910522137078502D0/, A(162)/0.020134823153530D0/
34777       DATA X(163)/0.889315445995114D0/, A(163)/0.022270173808383D0/
34778       DATA X(164)/0.865999398154092D0/, A(164)/0.024352702568710D0/
34779       DATA X(165)/0.840629296252580D0/, A(165)/0.026377469715054D0/
34780       DATA X(166)/0.813265315122797D0/, A(166)/0.028339672614259D0/
34781       DATA X(167)/0.783972358943341D0/, A(167)/0.030234657072402D0/
34782       DATA X(168)/0.752819907260531D0/, A(168)/0.032057928354851D0/
34783       DATA X(169)/0.719881850171610D0/, A(169)/0.033805161837141D0/
34784       DATA X(170)/0.685236313054233D0/, A(170)/0.035472213256882D0/
34785       DATA X(171)/0.648965471254657D0/, A(171)/0.037055128540240D0/
34786       DATA X(172)/0.611155355172393D0/, A(172)/0.038550153178615D0/
34787       DATA X(173)/0.571895646202634D0/, A(173)/0.039953741132720D0/
34788       DATA X(174)/0.531279464019894D0/, A(174)/0.041262563242623D0/
34789       DATA X(175)/0.489403145707052D0/, A(175)/0.042473515123653D0/
34790       DATA X(176)/0.446366017253464D0/, A(176)/0.043583724529323D0/
34791       DATA X(177)/0.402270157963991D0/, A(177)/0.044590558163756D0/
34792       DATA X(178)/0.357220158337668D0/, A(178)/0.045491627927418D0/
34793       DATA X(179)/0.311322871990210D0/, A(179)/0.046284796581314D0/
34794       DATA X(180)/0.264687162208767D0/, A(180)/0.046968182816210D0/
34795       DATA X(181)/0.217423643740007D0/, A(181)/0.047540165714830D0/
34796       DATA X(182)/0.169644420423992D0/, A(182)/0.047999388596458D0/
34797       DATA X(183)/0.121462819296120D0/, A(183)/0.048344762234802D0/
34798       DATA X(184)/0.072993121787799D0/, A(184)/0.048575467441503D0/
34799       DATA X(185)/0.024350292663424D0/, A(185)/0.048690957009139D0/
34800 C-----N=80
34801       DATA X(186)/0.999553822651630D0/, A(186)/0.001144950003186D0/
34802       DATA X(187)/0.997649864398237D0/, A(187)/0.002663533589512D0/
34803       DATA X(188)/0.994227540965688D0/, A(188)/0.004180313124694D0/
34804       DATA X(189)/0.989291302499755D0/, A(189)/0.005690922451403D0/
34805       DATA X(190)/0.982848572738629D0/, A(190)/0.007192904768117D0/
34806       DATA X(191)/0.974909140585727D0/, A(191)/0.008683945269260D0/
34807       DATA X(192)/0.965485089043799D0/, A(192)/0.010161766041103D0/
34808       DATA X(193)/0.954590766343634D0/, A(193)/0.011624114120797D0/
34809       DATA X(194)/0.942242761309872D0/, A(194)/0.013068761592401D0/
34810       DATA X(195)/0.928459877172445D0/, A(195)/0.014493508040509D0/
34811       DATA X(196)/0.913263102571757D0/, A(196)/0.015896183583725D0/
34812       DATA X(197)/0.896675579438770D0/, A(197)/0.017274652056269D0/
34813       DATA X(198)/0.878722567678213D0/, A(198)/0.018626814208299D0/
34814       DATA X(199)/0.859431406663111D0/, A(199)/0.019950610878141D0/
34815       DATA X(200)/0.838831473580255D0/, A(200)/0.021244026115782D0/
34816       DATA X(201)/0.816954138681463D0/, A(201)/0.022505090246332D0/
34817       DATA X(202)/0.793832717504605D0/, A(202)/0.023731882865930D0/
34818       DATA X(203)/0.769502420135041D0/, A(203)/0.024922535764115D0/
34819       DATA X(204)/0.744000297583597D0/, A(204)/0.026075235767565D0/
34820       DATA X(205)/0.717365185362099D0/, A(205)/0.027188227500486D0/
34821       DATA X(206)/0.689637644342027D0/, A(206)/0.028259816057276D0/
34822       DATA X(207)/0.660859898986119D0/, A(207)/0.029288369583267D0/
34823       DATA X(208)/0.631075773046871D0/, A(208)/0.030272321759557D0/
34824       DATA X(209)/0.600330622829751D0/, A(209)/0.031210174188114D0/
34825       DATA X(210)/0.568671268122709D0/, A(210)/0.032100498673487D0/
34826       DATA X(211)/0.536145920897131D0/, A(211)/0.032941939397645D0/
34827       DATA X(212)/0.502804111888784D0/, A(212)/0.033733214984611D0/
34828       DATA X(213)/0.468696615170544D0/, A(213)/0.034473120451753D0/
34829       DATA X(214)/0.433875370831756D0/, A(214)/0.035160529044747D0/
34830       DATA X(215)/0.398393405881969D0/, A(215)/0.035794393953416D0/
34831       DATA X(216)/0.362304753499487D0/, A(216)/0.036373749905835D0/
34832       DATA X(217)/0.325664370747701D0/, A(217)/0.036897714638276D0/
34833       DATA X(218)/0.288528054884511D0/, A(218)/0.037365490238730D0/
34834       DATA X(219)/0.250952358392272D0/, A(219)/0.037776364362001D0/
34835       DATA X(220)/0.212994502857666D0/, A(220)/0.038129711314477D0/
34836       DATA X(221)/0.174712291832646D0/, A(221)/0.038424993006959D0/
34837       DATA X(222)/0.136164022809143D0/, A(222)/0.038661759774076D0/
34838       DATA X(223)/0.097408398441584D0/, A(223)/0.038839651059051D0/
34839       DATA X(224)/0.058504437152420D0/, A(224)/0.038958395962769D0/
34840       DATA X(225)/0.019511383256793D0/, A(225)/0.039017813656306D0/
34841 C-----N=96
34842       DATA X(226)/0.999689503883230D0/, A(226)/0.000796792065552D0/
34843       DATA X(227)/0.998364375863181D0/, A(227)/0.001853960788946D0/
34844       DATA X(228)/0.995981842987209D0/, A(228)/0.002910731817934D0/
34845       DATA X(229)/0.992543900323762D0/, A(229)/0.003964554338444D0/
34846       DATA X(230)/0.988054126329623D0/, A(230)/0.005014202742927D0/
34847       DATA X(231)/0.982517263563014D0/, A(231)/0.006058545504235D0/
34848       DATA X(232)/0.975939174585136D0/, A(232)/0.007096470791153D0/
34849       DATA X(233)/0.968326828463264D0/, A(233)/0.008126876925698D0/
34850       DATA X(234)/0.959688291448742D0/, A(234)/0.009148671230783D0/
34851       DATA X(235)/0.950032717784437D0/, A(235)/0.010160770535008D0/
34852       DATA X(236)/0.939370339752755D0/, A(236)/0.011162102099838D0/
34853       DATA X(237)/0.927712456722308D0/, A(237)/0.012151604671088D0/
34854       DATA X(238)/0.915071423120898D0/, A(238)/0.013128229566961D0/
34855       DATA X(239)/0.901460635315852D0/, A(239)/0.014090941772314D0/
34856       DATA X(240)/0.886894517402420D0/, A(240)/0.015038721026994D0/
34857       DATA X(241)/0.871388505909296D0/, A(241)/0.015970562902562D0/
34858       DATA X(242)/0.854959033434601D0/, A(242)/0.016885479864245D0/
34859       DATA X(243)/0.837623511228187D0/, A(243)/0.017782502316045D0/
34860       DATA X(244)/0.819400310737931D0/, A(244)/0.018660679627411D0/
34861       DATA X(245)/0.800308744139140D0/, A(245)/0.019519081140145D0/
34862       DATA X(246)/0.780369043867433D0/, A(246)/0.020356797154333D0/
34863       DATA X(247)/0.759602341176647D0/, A(247)/0.021172939892191D0/
34864       DATA X(248)/0.738030643744400D0/, A(248)/0.021966644438744D0/
34865       DATA X(249)/0.715676812348967D0/, A(249)/0.022737069658329D0/
34866       DATA X(250)/0.692564536642171D0/, A(250)/0.023483399085926D0/
34867       DATA X(251)/0.668718310043916D0/, A(251)/0.024204841792364D0/
34868       DATA X(252)/0.644163403784967D0/, A(252)/0.024900633222483D0/
34869       DATA X(253)/0.618925840125468D0/, A(253)/0.025570036005349D0/
34870       DATA X(254)/0.593032364777572D0/, A(254)/0.026212340735672D0/
34871       DATA X(255)/0.566510418561397D0/, A(255)/0.026826866725591D0/
34872       DATA X(256)/0.539388108324357D0/, A(256)/0.027412962726029D0/
34873       DATA X(257)/0.511694177154667D0/, A(257)/0.027970007616848D0/
34874       DATA X(258)/0.483457973920596D0/, A(258)/0.028497411065085D0/
34875       DATA X(259)/0.454709422167743D0/, A(259)/0.028994614150555D0/
34876       DATA X(260)/0.425478988407300D0/, A(260)/0.029461089958167D0/
34877       DATA X(261)/0.395797649828908D0/, A(261)/0.029896344136328D0/
34878       DATA X(262)/0.365696861472313D0/, A(262)/0.030299915420827D0/
34879       DATA X(263)/0.335208522892625D0/, A(263)/0.030671376123669D0/
34880       DATA X(264)/0.304364944354496D0/, A(264)/0.031010332586313D0/
34881       DATA X(265)/0.273198812591049D0/, A(265)/0.031316425596861D0/
34882       DATA X(266)/0.241743156163840D0/, A(266)/0.031589330770727D0/
34883       DATA X(267)/0.210031310460567D0/, A(267)/0.031828758894411D0/
34884       DATA X(268)/0.178096882367618D0/, A(268)/0.032034456231992D0/
34885       DATA X(269)/0.145973714654896D0/, A(269)/0.032206204794030D0/
34886       DATA X(270)/0.113695850110665D0/, A(270)/0.032343822568575D0/
34887       DATA X(271)/0.081297495464425D0/, A(271)/0.032447163714064D0/
34888       DATA X(272)/0.048812985136049D0/, A(272)/0.032516118713868D0/
34889       DATA X(273)/0.016276744849602D0/, A(273)/0.032550614492363D0/
34890       DATA IBD/0/
34891       IF(IBD.NE.0) RETURN
34892       IBD=1
34893       DO 10 I=1,273
34894         B(I) = A(I)
34895         Y(I) = X(I)
34896  10   CONTINUE
34897       DO 20 I=1,96
34898         LTAB(I) = KTAB(I)
34899  20   CONTINUE
34900       END
34901
34902 *$ CREATE PHO_DZEROX.FOR
34903 *COPY PHO_DZEROX
34904 CDECK  ID>, PHO_DZEROX
34905       DOUBLE PRECISION FUNCTION PHO_DZEROX(A0,B0,EPS,MAXF,F,MODE)
34906 C**********************************************************************
34907 C
34908 C     Based on
34909 C
34910 C        J.C.P. Bus and T.J. Dekker, Two Efficient Algorithms with
34911 C        Guaranteed Convergence for Finding a Zero of a Function,
34912 C        ACM Trans. Math. Software 1 (1975) 330-345.
34913 C
34914 C        (MODE = 1: Algorithm M;    MODE = 2: Algorithm R)
34915 C
34916 C        CERNLIB C200
34917 C
34918 C***********************************************************************
34919       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34920       SAVE
34921
34922 C  input/output channels
34923       INTEGER LI,LO
34924       COMMON /POINOU/ LI,LO
34925
34926       CHARACTER NAME*(*)
34927       PARAMETER (NAME = 'PHO_DZEROX')
34928       LOGICAL LMT
34929       DIMENSION IM1(2),IM2(2),LMT(2)
34930       EXTERNAL F
34931
34932       PARAMETER (Z1 = 1, HALF = Z1/2)
34933
34934       DATA IM1 /2,3/, IM2 /-1,3/
34935
34936       IF(MODE .NE. 1 .AND. MODE .NE. 2) THEN
34937        C=-2D+10
34938        WRITE(LO,100) NAME,MODE
34939        GO TO 99
34940       ENDIF
34941       FA=F(B0)
34942       FB=F(A0)
34943       IF(FA*FB .GT. 0) THEN
34944        C=-3D+10
34945        WRITE(LO,101) NAME
34946        GO TO 99
34947       ENDIF
34948       ATL=ABS(EPS)
34949       B=A0
34950       A=B0
34951       LMT(2)=.TRUE.
34952       MF=2
34953     1 C=A
34954       FC=FA
34955     2 IE=0
34956     3 IF(ABS(FC) .LT. ABS(FB)) THEN
34957        IF(C .NE. A) THEN
34958         D=A
34959         FD=FA
34960        END IF
34961        A=B
34962        B=C
34963        C=A
34964        FA=FB
34965        FB=FC
34966        FC=FA
34967       END IF
34968       TOL=ATL*(1+ABS(C))
34969       H=HALF*(C+B)
34970       HB=H-B
34971       IF(ABS(HB) .GT. TOL) THEN
34972        IF(IE .GT. IM1(MODE)) THEN
34973         W=HB
34974        ELSE
34975         TOL=TOL*SIGN(Z1,HB)
34976         P=(B-A)*FB
34977         LMT(1)=IE .LE. 1
34978         IF(LMT(MODE)) THEN
34979          Q=FA-FB
34980          LMT(2)=.FALSE.
34981         ELSE
34982          FDB=(FD-FB)/(D-B)
34983          FDA=(FD-FA)/(D-A)
34984          P=FDA*P
34985          Q=FDB*FA-FDA*FB
34986         END IF
34987         IF(P .LT. 0) THEN
34988          P=-P
34989          Q=-Q
34990         END IF
34991         IF(IE .EQ. IM2(MODE)) P=P+P
34992         IF(P .EQ. 0 .OR. P .LE. Q*TOL) THEN
34993          W=TOL
34994         ELSEIF(P .LT. HB*Q) THEN
34995          W=P/Q
34996         ELSE
34997          W=HB
34998         END IF
34999        END IF
35000        D=A
35001        A=B
35002        FD=FA
35003        FA=FB
35004        B=B+W
35005        MF=MF+1
35006        IF(MF .GT. MAXF) THEN
35007         WRITE(LO,102) NAME
35008         GO TO 99
35009        ENDIF
35010        FB=F(B)
35011        IF(FB .EQ. 0 .OR. SIGN(Z1,FC) .EQ. SIGN(Z1,FB)) GO TO 1
35012        IF(W .EQ. HB) GO TO 2
35013        IE=IE+1
35014        GO TO 3
35015       END IF
35016    99 CONTINUE
35017       PHO_DZEROX=C
35018       RETURN
35019   100 FORMAT(1X,A,': mode = ',I3,' illegal')
35020   101 FORMAT(1X,A,': F(A) and F(B) have the same sign')
35021   102 FORMAT(1X,A,': too many function calls')
35022
35023       END
35024
35025 *$ CREATE PHO_EXPINT.FOR
35026 *COPY PHO_EXPINT
35027 CDECK  ID>, PHO_EXPINT
35028       DOUBLE PRECISION FUNCTION PHO_EXPINT(RXM)
35029 C***********************************************************************
35030 C
35031 C     function to calculate  E_i(x) = -E_1(-x)
35032 C
35033 C     based on CERNLIB C337   (changed by R.Engel 10/1993)
35034 C
35035 C***********************************************************************
35036       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35037       SAVE
35038
35039 C  input/output channels
35040       INTEGER LI,LO
35041       COMMON /POINOU/ LI,LO
35042
35043       DOUBLE PRECISION P1(5),Q1(5),P2(7),Q2(7),P3(6),Q3(6),P4(8),Q4(8)
35044       DOUBLE PRECISION A1(8),B1(8),A2(8),B2(8),A3(6),B3(6),XL(6)
35045       DOUBLE PRECISION X,Y,AP,BP,DP,AQ,BQ,DQ,X0,V
35046
35047       DATA  X0 /0.37250 74107 8137D0/
35048       DATA XL /-24.0D0,-12.0D0,-6.0D0,0.0D0,1.0D0,4.0D0/
35049       DATA P1
35050      1/+4.29312 52343 210D+0, +3.98941 53870 321D+1,
35051      2 +2.92525 18866 921D+2, +4.25696 82638 592D+2,
35052      3 -4.34981 43832 952D+2/
35053       DATA Q1
35054      1/+1.00000 00000 000D+0, +1.88992 88395 003D+1,
35055      2 +1.50950 38744 251D+2, +5.68052 52718 987D+2,
35056      3 +7.53585 64359 843D+2/
35057       DATA P2
35058      1/+4.30967 83946 939D-1, +6.90522 52278 444D+0,
35059      2 +2.30192 55939 133D+1, +2.43784 08879 132D+1,
35060      3 +9.04161 55694 633D+0, +9.99979 57705 159D-1,
35061      4 +4.65627 10797 510D-7/
35062       DATA Q2
35063      1/+1.03400 13040 487D-1, +3.31909 21359 330D+0,
35064      2 +2.04494 78501 379D+1, +4.12807 84189 142D+1,
35065      3 +3.24264 21069 514D+1, +1.00411 64382 905D+1,
35066      4 +1.00000 00000 000D+0/
35067       DATA P3
35068      1/-2.39099 64453 136D+0, -1.47982 19500 504D+2,
35069      2 -2.54376 33976 890D+2, -1.19557 61038 372D+2,
35070      3 -1.96304 08535 939D+1, -9.99999 99990 360D-1/
35071       DATA Q3
35072      1/+1.77600 70940 351D+2, +5.30685 09610 812D+2,
35073      2 +4.62230 27156 148D+2, +1.56818 43364 539D+2,
35074      3 +2.16304 08494 238D+1, +1.00000 00000 000D+0/
35075       DATA P4
35076      1/-8.66937 33995 107D+0, -5.49142 26552 109D+2,
35077      2 -4.21001 61535 707D+3, -2.49301 39345 865D+5,
35078      3 -1.19623 66934 925D+5, -2.21744 62775 885D+7,
35079      4 +3.89280 42131 120D+6, -3.91546 07380 910D+8/
35080       DATA Q4
35081      1/+3.41718 75000 000D+1, -1.60708 92658 722D+3,
35082      2 +3.57300 29805 851D+4, -4.83547 43616 216D+5,
35083      3 +4.28559 62461 175D+6, -2.49033 37574 054D+7,
35084      4 +8.91925 76757 561D+7, -1.65254 29972 521D+8/
35085       DATA A1
35086      1/-2.18086 38152 072D+0, -2.19010 23385 488D+1,
35087      2 +9.30816 38566 217D+0, +2.50762 81129 356D+1,
35088      3 -3.31842 53199 722D+1, +6.01217 99083 008D+1,
35089      4 -4.32531 13287 813D+1, +1.00443 10922 808D+0/
35090       DATA B1
35091      1/+0.00000 00000 000D+0, +3.93707 70185 272D+0,
35092      2 +3.00892 64837 292D+2, -6.25041 16167 188D+0,
35093      3 +1.00367 43951 673D+3, +1.43256 73812 194D+1,
35094      4 +2.73624 11988 933D+3, +5.27468 85196 291D-1/
35095       DATA A2
35096      1/-3.48334 65360 285D+0, -1.86545 45488 340D+1,
35097      2 -8.28561 99414 064D+0, -3.23467 33030 540D+1,
35098      3 +1.79601 68876 925D+1, +1.75656 31546 961D+0,
35099      4 -1.95022 32128 966D+0, +9.99994 29607 471D-1/
35100       DATA B2
35101      1/+0.00000 00000 000D+0, +6.95000 65588 743D+1,
35102      2 +5.72837 19383 732D+1, +2.57776 38423 844D+1,
35103      3 +7.60761 14800 773D+2, +2.89516 72792 514D+1,
35104      4 -3.43942 26689 987D+0, +1.00083 86740 264D+0/
35105       DATA A3
35106      1/-2.77809 28934 438D+1, -1.01047 90815 760D+1,
35107      2 -9.14830 08216 736D+0, -5.02233 17461 851D+0,
35108      3 -3.00000 77799 358D+0, +1.00000 00000 704D+0/
35109       DATA B3
35110      1/+0.00000 00000 000D+0, +1.22399 93926 823D+2,
35111      2 +2.72761 00778 779D+0, -7.18975 18395 045D+0,
35112      3 -2.99901 18065 262D+0, +1.99999 99428 260D+0/
35113 C
35114 C  conversion to E_i function
35115       X = -RXM
35116 C
35117       IF(X .LE. XL(1)) THEN
35118        AP=A3(1)-X
35119        DO 1 I = 2,5
35120     1  AP=A3(I)-X+B3(I)/AP
35121        Y=(EXP(-X)/X)*(1.D0-(A3(6)+B3(6)/AP)/X)
35122       ELSEIF(X .LE. XL(2)) THEN
35123        AP=A2(1)-X
35124        DO 2 I = 2,7
35125     2     AP=A2(I)-X+B2(I)/AP
35126        Y=(EXP(-X)/X)*(A2(8)+B2(8)/AP)
35127       ELSEIF(X .LE. XL(3)) THEN
35128        AP=A1(1)-X
35129        DO 3 I = 2,7
35130     3     AP=A1(I)-X+B1(I)/AP
35131        Y=(EXP(-X)/X)*(A1(8)+B1(8)/AP)
35132       ELSEIF(X .LT. XL(4)) THEN
35133        V=-2.D0*(X/3.D0+1.D0)
35134        BP=0.D0
35135        DP=P4(1)
35136        DO 4 I = 2,8
35137           AP=BP
35138           BP=DP
35139     4     DP=P4(I)-AP+V*BP
35140        BQ=0.D0
35141        DQ=Q4(1)
35142        DO 14 I = 2,8
35143           AQ=BQ
35144           BQ=DQ
35145    14     DQ=Q4(I)-AQ+V*BQ
35146        Y=-LOG(-X/X0)+(X+X0)*(DP-AP)/(DQ-AQ)
35147       ELSEIF(X .EQ. XL(4)) THEN
35148 *      CALL KERMTR('C337.1',LGFILE,MFLAG,RFLAG)
35149 *      IF(MFLAG) THEN
35150 *       IF(LGFILE .EQ. 0) THEN
35151 *        WRITE(LO,100) ENAME
35152 *       ELSE
35153 *        WRITE(LGFILE,100) ENAME
35154 *       ENDIF
35155 *      ENDIF
35156 *      IF(.NOT.RFLAG) CALL ABEND
35157        PHO_EXPINT=0.D0
35158        RETURN
35159       ELSEIF(X .LT. XL(5)) THEN
35160        AP=P1(1)
35161        AQ=Q1(1)
35162        DO 5 I = 2,5
35163           AP=P1(I)+X*AP
35164     5     AQ=Q1(I)+X*AQ
35165        Y=-LOG(X)+AP/AQ
35166       ELSEIF(X .LE. XL(6)) THEN
35167        Y=1.D0/X
35168        AP=P2(1)
35169        AQ=Q2(1)
35170        DO 6 I = 2,7
35171           AP=P2(I)+Y*AP
35172     6     AQ=Q2(I)+Y*AQ
35173        Y=EXP(-X)*AP/AQ
35174       ELSE
35175        Y=1.D0/X
35176        AP=P3(1)
35177        AQ=Q3(1)
35178        DO 7 I = 2,6
35179           AP=P3(I)+Y*AP
35180     7     AQ=Q3(I)+Y*AQ
35181        Y=EXP(-X)*Y*(1.D0+Y*AP/AQ)
35182       ENDIF
35183 C  sign conversion to E_i
35184       PHO_EXPINT=-Y
35185
35186       END
35187
35188 *$ CREATE PHO_RNDBET.FOR
35189 *COPY PHO_RNDBET
35190 CDECK  ID>, PHO_RNDBET
35191       DOUBLE PRECISION FUNCTION PHO_RNDBET(GAM,ETA)
35192 C********************************************************************
35193 C
35194 C     RANDOM NUMBER GENERATION FROM BETA
35195 C     DISTRIBUTION IN REGION  0 < X < 1.
35196 C     F(X) = X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM) / (GAMM(GAM
35197 C                                                        *GAMM(ETA))
35198 C
35199 C********************************************************************
35200       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35201       SAVE
35202
35203       Y = PHO_RNDGAM(1.D0,GAM)
35204       Z = PHO_RNDGAM(1.D0,ETA)
35205
35206       PHO_RNDBET = Y/(Y+Z)
35207
35208       END
35209
35210 *$ CREATE PHO_RNDGAM.FOR
35211 *COPY PHO_RNDGAM
35212 CDECK  ID>, PHO_RNDGAM
35213       DOUBLE PRECISION FUNCTION PHO_RNDGAM(ALAM,ETA)
35214 C********************************************************************
35215 C
35216 C     RANDOM NUMBER SELECTION FROM GAMMA DISTRIBUTION
35217 C     F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)
35218 C
35219 C********************************************************************
35220       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35221       SAVE
35222 C
35223       NCOU=0
35224       N = ETA
35225       F = ETA - N
35226       IF(F.EQ.0.D0) GOTO 20
35227    10 R = DT_RNDM(ETA)
35228       NCOU=NCOU+1
35229       IF (NCOU.GE.11) GOTO 20
35230       IF(R.LT.F/(F+2.71828D0)) GOTO 30
35231       YYY=LOG(DT_RNDM(F)+1.0D-9)/F
35232       IF(ABS(YYY).GT.50.D0) GOTO 20
35233       Y = EXP(YYY)
35234       IF(LOG(DT_RNDM(Y)+1.0D-9).GT.-Y) GOTO 10
35235       GOTO 40
35236    20 Y = 0.D0
35237       GOTO 50
35238    30 Y = 1.D0-LOG(DT_RNDM(R)+1.0D-9)
35239       IF(DT_RNDM(Y).GT.Y**(F-1.D0)) GOTO 10
35240    40 IF(N.EQ.0) GOTO 70
35241    50 Z = 1.D0
35242       DO 60 I = 1,N
35243    60 Z = Z*DT_RNDM(Y)
35244       Y = Y-LOG(Z+1.0D-9)
35245    70 PHO_RNDGAM = Y/ALAM
35246       RETURN
35247       END
35248
35249 *$ CREATE PHO_SFECFE.FOR
35250 *COPY PHO_SFECFE
35251 CDECK  ID>, PHO_SFECFE
35252       SUBROUTINE PHO_SFECFE(SFE,CFE)
35253 C**********************************************************************
35254 C
35255 C     fast random SIN(X) COS(X) selection
35256 C
35257 C**********************************************************************
35258       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35259       SAVE
35260 C
35261     1 CONTINUE
35262         X=DT_RNDM(XX)
35263         Y=DT_RNDM(YY)
35264         XX=X*X
35265         YY=Y*Y
35266         XY=XX+YY
35267       IF(XY.GT.1.D0) GOTO 1
35268       CFE=(XX-YY)/XY
35269       SFE=2.D0*X*Y/XY
35270       IF(DT_RNDM(XY).LT.0.5D0) THEN
35271         SFE=-SFE
35272       ENDIF
35273       END
35274
35275 *$ CREATE PHO_SWAPD.FOR
35276 *COPY PHO_SWAPD
35277 CDECK  ID>, PHO_SWAPD
35278       SUBROUTINE PHO_SWAPD(D1,D2)
35279 C********************************************************************
35280 C
35281 C     exchange of argument values (double precision)
35282 C
35283 C********************************************************************
35284       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35285       D = D1
35286       D1 = D2
35287       D2 = D
35288       END
35289
35290 *$ CREATE PHO_SWAPI.FOR
35291 *COPY PHO_SWAPI
35292 CDECK  ID>, PHO_SWAPI
35293       SUBROUTINE PHO_SWAPI(I1,I2)
35294 C********************************************************************
35295 C
35296 C     exchange of argument values (integer)
35297 C
35298 C********************************************************************
35299       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35300       K = I1
35301       I1 = I2
35302       I2 = K
35303       END
35304
35305 *$ CREATE PHO_HADCSL.FOR
35306 *COPY PHO_HADCSL
35307 CDECK  ID>, PHO_HADCSL
35308       SUBROUTINE PHO_HADCSL(ID1,ID2,ECM,PLAB,IMODE,
35309      &                     SIGTOT,SIGEL,SIGDIF,SLOPE,RHO)
35310 C***********************************************************************
35311 C
35312 C     low-energy cross section parametrizations
35313 C
35314 C     input:   ID1,ID2     PDG IDs of particles (meson first)
35315 C              ECM         c.m. energy (GeV)
35316 C              PLAB        lab. momentum (second particle at rest)
35317 C              IMODE       1    ECM given, PLAB ignored
35318 C                          2    PLAB given, ECM ignored
35319 C
35320 C     output:  SIGTOT      total cross section (mb)
35321 C              SIGEL       elastic cross section (mb)
35322 C              SIGDIF      diffracive cross section (sd-1,sd-2,dd), (mb)
35323 C              SLOPE       forward elastic slope (GeV**-2)
35324 C              RHO         real/imaginary part of elastic amplitude
35325 C
35326 C     comments:
35327 C
35328 C     - low-energy data interpolation uses PDG fits from 1992 issue
35329 C     - high-energy extrapolation by Donnachie-Landshoff like fit made
35330 C       by PDG 1996
35331 C     - analytic extension of amplitude to calculate rho
35332 C
35333 C***********************************************************************
35334       IMPLICIT NONE
35335       SAVE
35336
35337       INTEGER ID1,ID2,IMODE
35338       DOUBLE PRECISION ECM,PLAB,SIGTOT,SIGEL,SIGDIF(3),SLOPE,RHO
35339
35340 C  input/output channels
35341       INTEGER LI,LO
35342       COMMON /POINOU/ LI,LO
35343 C  some constants
35344       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
35345       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
35346      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
35347 C  model switches and parameters
35348       CHARACTER*8 MDLNA
35349       INTEGER ISWMDL,IPAMDL
35350       DOUBLE PRECISION PARMDL
35351       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
35352
35353       INTEGER K
35354       DOUBLE PRECISION SIGTO1,SIGTO2,SIGEL1,SIGEL2,
35355      &  SS,PL,PLL,E1,XP,YP,YM,PHR,PHP,X1,X2
35356
35357       DOUBLE PRECISION TPDG92(7,2,6),TPDG96(9,6),BURQ83(3,6),XMA(6)
35358
35359       DATA TPDG92  /
35360      &  3.D0, 2100.D0, 48.D0, 0.D0, 1.D0, 0.522D0, -4.51D0,
35361      &  3.D0, 2100.D0, 11.9D0, 26.9D0, -1.21D0, 0.169D0, -1.85D0,
35362      &  5.D0, 2100.D0, 38.4D0, 77.6D0, -0.64D0, 0.26D0, -1.2D0,
35363      &  5.D0, 2100.D0, 10.2D0, 52.7D0, -1.16D0, 0.125D0, -1.28D0,
35364      &  4.D0, 340.D0,  16.4D0, 19.3D0, -0.42D0, 0.19D0, 0.D0,
35365      &  4.D0, 340.D0,  0.D0, 11.4D0, -0.4D0, 0.079D0, 0.D0,
35366      &  2.5D0, 370.D0, 33.D0, 14.D0, -1.36D0, 0.456D0, -4.03D0,
35367      &  2.5D0, 370.D0, 1.76D0, 11.2D0, -0.64D0, 0.043D0, 0.D0,
35368      &  2.D0, 310.D0,  18.1D0, 0.D0, 1.D0, 0.26D0, -1.D0,
35369      &  2.D0, 310.D0,  5.D0, 8.1D0, -1.8D0, 0.16D0, -1.3D0,
35370      &  3.D0, 310.D0,  32.1D0, 0.D0, 1.D0, 0.66D0, -5.6D0,
35371      &  3.D0, 310.D0,  7.3D0, 0.D0, 1.D0, 0.29D0, -2.4D0  /
35372
35373       DATA TPDG96  /
35374      &  50.D0, 22.D0,0.079D0,0.25D0,0.D0,
35375      &         77.15D0,-21.05D0,0.46D0,0.9D0,
35376      &  50.D0, 22.D0,0.079D0,0.25D0,0.D0,
35377      &         77.15D0,21.05D0,0.46D0,0.9D0,
35378      &  10.D0, 13.70,0.079D0,0.25D0,0.D0,
35379      &         31.85D0,-4.05D0,0.45D0,0.9D0,
35380      &  10.D0, 13.70,0.079D0,0.25D0,0.D0,
35381      &         31.85D0,4.05D0,0.45D0,0.9D0,
35382      &  10.D0, 12.20,0.079D0,0.25D0,0.D0,
35383      &         17.35D0,-9.05D0,0.50D0,0.9D0,
35384      &  10.D0, 12.20,0.079D0,0.25D0,0.D0,
35385      &         17.35D0,9.05D0,0.50D0,0.9D0  /
35386
35387       DATA BURQ83 /
35388      &  11.13D0, -6.21D0, 0.30D0,
35389      &  11.13D0,  7.23D0, 0.30D0,
35390      &  9.11D0,  -0.73D0, 0.28D0,
35391      &  9.11D0,   0.65D0, 0.28D0,
35392      &  8.55D0,  -5.98D0, 0.28D0,
35393      &  8.55D0,   1.60D0, 0.28D0  /
35394
35395       DATA XMA /
35396      &  2*0.93956563D0, 2*0.13956995D0, 2*0.493677D0 /
35397
35398 C  find index
35399       IF(ID2.NE.2212) THEN
35400         GOTO 100
35401       ELSE IF(ID1.EQ.2212) THEN
35402         K = 1
35403       ELSE IF(ID1.EQ.-2212) THEN
35404         K = 2
35405       ELSE IF(ID1.EQ.211) THEN
35406         K = 3
35407       ELSE IF(ID1.EQ.-211) THEN
35408         K = 4
35409       ELSE IF(ID1.EQ.321) THEN
35410         K = 5
35411       ELSE IF(ID1.EQ.-321) THEN
35412         K = 6
35413       ELSE
35414         GOTO 100
35415       ENDIF
35416
35417 C  calculate lab momentum
35418       IF(IMODE.EQ.1) THEN
35419         SS = ECM**2
35420         E1 = 0.5D0/XMA(1)*(SS-XMA(1)**2-XMA(K)**2)
35421         PL = SQRT(E1*E1-XMA(K)**2)
35422       ELSE IF(IMODE.EQ.2) THEN
35423         PL = PLAB
35424         SS = XMA(1)**2+XMA(K)**2+2.D0*XMA(1)*SQRT(PL**2+XMA(K)**2)
35425         ECM = SQRT(SS)
35426       ELSE
35427         WRITE(LO,'(1X,A,I5)') 'PHO_HADCSL:ERROR: invalid IMODE: ',IMODE
35428         RETURN
35429       ENDIF
35430       PLL = LOG(PL)
35431
35432 C  check against lower limit
35433       IF(ECM.LE.XMA(1)+XMA(K)) GOTO 200
35434
35435       XP  = TPDG96(2,K)*SS**TPDG96(3,K)
35436       YP  = TPDG96(6,K)/SS**TPDG96(8,K)
35437       YM  = TPDG96(7,K)/SS**TPDG96(8,K)
35438
35439       PHR = TAN(PI/2.D0*(1.-TPDG96(8,K)))
35440       PHP = TAN(PI/2.D0*(1.+TPDG96(3,K)))
35441       RHO = (-YP/PHR + YM*PHR - XP/PHP)/(YP+YM+XP)
35442       SLOPE = BURQ83(1,K)+BURQ83(2,K)/SQRT(PL)+BURQ83(3,K)*PLL
35443
35444 C  select energy range and interpolation method
35445       IF(PL.LT.TPDG96(1,K)) THEN
35446         SIGTOT = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
35447      &          + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
35448         SIGEL  = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
35449      &          + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
35450       ELSE IF(PL.LT.TPDG92(2,1,K)) THEN
35451         SIGTO1 = TPDG92(3,1,K)+TPDG92(4,1,K)*PL**TPDG92(5,1,K)
35452      &          + TPDG92(6,1,K)*PLL**2+TPDG92(7,1,K)*PLL
35453         SIGEL1 = TPDG92(3,2,K)+TPDG92(4,2,K)*PL**TPDG92(5,2,K)
35454      &          + TPDG92(6,2,K)*PLL**2+TPDG92(7,2,K)*PLL
35455         SIGTO2 = YP+YM+XP
35456         SIGEL2 = SIGTO2**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
35457         X2 = LOG(PL/TPDG96(1,K))/LOG(TPDG92(2,1,K)/TPDG96(1,K))
35458         X1 = 1.D0 - X2
35459         SIGTOT = SIGTO2*X2 + SIGTO1*X1
35460         SIGEL  = SIGEL2*X2 + SIGEL1*X1
35461       ELSE
35462         SIGTOT = YP+YM+XP
35463         SIGEL  = SIGTOT**2/(16.D0*PI*SLOPE*GEV2MB)*(1.D0+RHO**2)
35464       ENDIF
35465
35466 C  no parametrization of diffraction implemented
35467       SIGDIF(1) = -1.D0
35468       SIGDIF(2) = -1.D0
35469       SIGDIF(3) = -1.D0
35470
35471       RETURN
35472
35473  100  CONTINUE
35474         WRITE(LO,'(1X,2A,2I7)') 'PHO_HADCSL:ERROR: ',
35475      &    'invalid particle combination: ',ID1,ID2
35476         RETURN
35477
35478  200  CONTINUE
35479         WRITE(LO,'(1X,2A,1P,2E12.4)') 'PHO_HADCSL:ERROR: ',
35480      &    'energy too small (Ecm,Plab): ',ECM,PLAB
35481
35482       END
35483
35484 *$ CREATE PHO_CSDIFF.FOR
35485 *COPY PHO_CSDIFF
35486 CDECK  ID>, PHO_CSDIFF
35487       SUBROUTINE PHO_CSDIFF(Id1,Id2,SS,Xi_min,Xi_max,
35488      &  sig_sd1,sig_sd2,sig_dd)
35489 C***********************************************************************
35490 C
35491 C     cross section for diffraction dissociation according to
35492 C     Goulianos' parametrization (Ref: PL B358 (1995) 379)
35493 C
35494 C     in addition rescaling for different particles is applied using
35495 C     internal rescaling tables (not implemented yet)
35496 C
35497 C     input:     Id1/2       PDG ID's of incoming particles
35498 C                SS          squared c.m. energy (GeV**2)
35499 C                Xi_min      min. diff mass (squared) = Xi_min*SS
35500 C                Xi_max      max. diff mass (squared) = Xi_max*SS
35501 C
35502 C     output:    sig_sd1     cross section for diss. of particle 1 (mb)
35503 C                sig_sd2     cross section for diss. of particle 2 (mb)
35504 C                sig_dd      cross section for diss. of both particles
35505 C
35506 C***********************************************************************
35507       IMPLICIT NONE
35508       SAVE
35509
35510       INTEGER Id1,Id2
35511       DOUBLE PRECISION SS,Xi_min,Xi_max,sig_sd1,sig_sd2,sig_dd
35512
35513 C  input/output channels
35514       INTEGER LI,LO
35515       COMMON /POINOU/ LI,LO
35516 C  some constants
35517       DOUBLE PRECISION PI,PI2,PI4,GEV2MB,Q_ch,Q_ch2,Q_ch4
35518       COMMON /POCONS/ PI,PI2,PI4,GEV2MB,
35519      &  Q_ch(-6:6),Q_ch2(-6:6),Q_ch4(-6:6)
35520
35521       DOUBLE PRECISION xpos1(96),xwgh1(96),xpos2(96),xwgh2(96)
35522       DOUBLE PRECISION delta,alphap,beta0,gpom0,xm_p,x_rad2,xm4_p2,
35523      &  fac,tt,t1,t2,tl,tu,Xnorm,xi,xil,xiu,w_xi,alpha_t,f2_t,
35524      &  xms_1,xms_2,CSdiff
35525
35526       INTEGER Ngau1,Ngau2,i1,i2
35527
35528 C  model parameters
35529
35530       DATA delta    / 0.104d0 /
35531       DATA alphap   / 0.25d0 /
35532       DATA beta0    / 6.56d0 /
35533       DATA gpom0    / 1.21d0 /
35534       DATA xm_p     / 0.938d0 /
35535       DATA x_rad2   / 0.71d0 /
35536
35537 C  integration precision
35538
35539       DATA Ngau1    / 96 /
35540       DATA Ngau2    / 96 /
35541
35542       sig_sd1 = 0.d0
35543       sig_sd2 = 0.d0
35544       sig_dd  = 0.d0
35545
35546       IF ((ABS(id1).EQ.2212).AND.(ABS(id2).EQ.2212)) THEN
35547
35548         xm4_p2 = 4.D0*xm_p**2
35549         fac = beta0**2/(16.D0*PI)
35550
35551         t1 = -5.D0
35552         t2 = 0.D0
35553         tl = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
35554         tu = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
35555
35556 C  flux renormalization and cross section
35557
35558         Xnorm  = 0.d0
35559
35560         xil = log(1.5d0/SS)
35561         xiu = log(0.1d0)
35562
35563         IF(xiu.LE.xil) goto 1000
35564
35565         CALL PHO_GAUSET(xil,xiu,Ngau1,xpos1,xwgh1)
35566         CALL PHO_GAUSET(tl,tu,Ngau2,xpos2,xwgh2)
35567
35568         do i1=1,Ngau1
35569
35570           xi = exp(xpos1(i1))
35571           w_xi = Xwgh1(i1)
35572
35573           do i2=1,Ngau2
35574
35575             tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
35576
35577             alpha_t =  1.D0+delta+alphap*tt
35578             f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
35579
35580             Xnorm = Xnorm
35581      &        + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
35582
35583           enddo
35584         enddo
35585
35586         Xnorm = Xnorm*fac
35587
35588  1000   continue
35589
35590         XIL = LOG(Xi_min)
35591         XIU = LOG(Xi_max)
35592
35593         T1 = -5.D0
35594         T2 = 0.D0
35595
35596         TL = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
35597         TU = x_rad2/3.D0/(1.D0-t2/x_rad2)**3
35598
35599 C  single diffraction diss. cross section
35600
35601         CSdiff = 0.d0
35602
35603         IF(XIU.LE.XIL) goto 2000
35604
35605         CALL PHO_GAUSET(XIL,XIU,NGAU1,XPOS1,XWGH1)
35606         CALL PHO_GAUSET(TL,TU,NGAU2,XPOS2,XWGH2)
35607
35608         do i1=1,Ngau1
35609
35610           xi = exp(xpos1(i1))
35611           w_xi = Xwgh1(i1)*beta0*gpom0*(xi*ss)**delta
35612
35613           do i2=1,Ngau2
35614
35615             tt = x_rad2-x_rad2*(x_rad2/(3.D0*xpos2(i2)))**(1.D0/3.D0)
35616
35617             alpha_t =  1.D0+delta+alphap*tt
35618             f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2
35619
35620             CSdiff = CSdiff
35621      &        + f2_t*xi**(2.D0-2.d0*alpha_t)*Xwgh2(i2)*w_xi
35622
35623           enddo
35624         enddo
35625
35626         CSdiff = CSdiff*fac*GEV2MB/MAX(1.d0,Xnorm)
35627
35628 *       WRITE(LO,'(1x,1p,4e14.3)')
35629 *    &    sqrt(SS),Xnorm,2.*CSdiff*MAX(1.d0,Xnorm),2.*CSdiff
35630
35631         sig_sd1 = CSdiff
35632         sig_sd2 = CSdiff
35633
35634  2000   continue
35635
35636 C  double diffraction dissociation cross section
35637
35638         CSdiff = 0.d0
35639
35640         xil = log(1.5d0/SS)
35641         xiu = log(Xi_max/1.5d0)
35642
35643         IF(xiu.LE.xil) goto 3000
35644
35645         fac = (beta0*gpom0*SS**delta
35646      &         /(4.d0*sqrt(PI)*MAX(1.d0,Xnorm)))**2
35647      &       /(2.d0*alphap)
35648
35649         CALL PHO_GAUSET(xil,xiu,ngau1,xpos1,xwgh1)
35650
35651         do i1=1,Ngau1
35652
35653           xi = exp(xpos1(i1))
35654           xms_1 = xi*SS
35655
35656           xiu = log(Xi_max/(xi*SS))
35657
35658           if(xil.lt.xiu) then
35659
35660             CALL PHO_GAUSET(xil,xiu,Ngau2,xpos2,xwgh2)
35661
35662             do i2=1,Ngau2
35663
35664               xms_2 = exp(xpos2(i2))*SS
35665               CSdiff = CSdiff
35666      &          + 1.d0/((xms_1*xms_2)**delta*log(SS/(xms_1*xms_2)))
35667      &            *xwgh1(i1)*xwgh2(i2)
35668
35669             enddo
35670
35671           endif
35672
35673         enddo
35674
35675         sig_dd = CSdiff*fac*GEV2MB
35676
35677  3000   continue
35678
35679       ELSE
35680
35681         WRITE(LO,'(1x,2a,2I8)') 'PHO_CSDIFF: ',
35682      &    'invalid particle combination (Id1/2)',Id1,Id2
35683
35684       ENDIF
35685
35686       END
35687
35688 *$ CREATE PHO_ALLM97.FOR
35689 *COPY PHO_ALLM97
35690 CDECK  ID>, PHO_ALLM97
35691       DOUBLE PRECISION FUNCTION PHO_ALLM97(Q2,W)
35692 C**********************************************************************
35693 C
35694 C     ALLM97 parametrization for gamma*-p cross section
35695 C     (for F2 see comments, code adapted from V. Shekelyan, H1)
35696 C
35697 C**********************************************************************
35698       IMPLICIT NONE
35699       SAVE
35700
35701 C  input/output channels
35702       INTEGER LI,LO
35703       COMMON /POINOU/ LI,LO
35704
35705       DOUBLE PRECISION Q2,W
35706       DOUBLE PRECISION M02,M12,LAM2,M22
35707       DOUBLE PRECISION S11,S12,S13,A11,A12,A13,B11,B12,B13
35708       DOUBLE PRECISION S21,S22,S23,A21,A22,A23,B21,B22,B23
35709       DOUBLE PRECISION ALFA,XMP2,W2,Q02,S,T,T0,Z,CIN,
35710      &                 AP,BP,AR,BR,XP,XR,SR,SP,F2P,F2R
35711       DATA ALFA,XMP2 /112.2D0 , .8802D0 /
35712
35713       W2=W*W
35714       PHO_ALLM97 = 0.D0
35715
35716 C  pomeron
35717       S11   =   0.28067D0
35718       S12   =   0.22291D0
35719       S13   =   2.1979D0
35720       A11   =  -0.0808D0
35721       A12   =  -0.44812D0
35722       A13   =   1.1709D0
35723       B11   =   0.60243D0
35724       B12   =   1.3754D0
35725       B13   =   1.8439D0
35726       M12   =  49.457D0
35727
35728 C  reggeon
35729       S21   =   0.80107D0
35730       S22   =   0.97307D0
35731       S23   =   3.4942D0
35732       A21   =   0.58400D0
35733       A22   =   0.37888D0
35734       A23   =   2.6063D0
35735       B21   =   0.10711D0
35736       B22   =   1.9386D0
35737       B23   =   0.49338D0
35738       M22   =   0.15052D0
35739 C
35740       M02   =   0.31985D0
35741       LAM2  =   0.065270D0
35742       Q02   =   0.46017D0 +LAM2
35743
35744 C
35745       S=0.
35746       T=LOG((Q2+Q02)/LAM2)
35747       T0=LOG(Q02/LAM2)
35748       IF(Q2.GT.0.D0) S=LOG(T/T0)
35749       Z=1.D0
35750
35751       IF(Q2.GT.0.D0) Z=(W2-XMP2)/(Q2+W2-XMP2)
35752
35753       IF(S.LT.0.01D0) THEN
35754
35755 C   pomeron part
35756
35757         XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
35758
35759         AP=A11
35760         BP=B11**2
35761
35762         SP=S11
35763         F2P=SP*XP**AP*Z**BP
35764
35765 C   reggeon part
35766
35767         XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
35768
35769         AR=A21
35770         BR=B21**2
35771
35772         SR=S21
35773         F2R=SR*XR**AR*Z**BR
35774
35775       ELSE
35776
35777 C   pomeron part
35778
35779         XP=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M12))
35780
35781         AP=A11+(A11-A12)*(1.D0 /(1.D0 +S**A13)-1.D0 )
35782
35783         BP=B11**2+B12**2*S**B13
35784
35785         SP=S11+(S11-S12)*(1.D0 /(1.D0 +S**S13)-1.D0 )
35786
35787         F2P=SP*XP**AP*Z**BP
35788
35789 C   reggeon part
35790
35791         XR=1.D0 /(1.D0 +(W2-XMP2)/(Q2+M22))
35792
35793         AR=A21+A22*S**A23
35794         BR=B21**2+B22**2*S**B23
35795
35796         SR=S21+S22*S**S23
35797         F2R=SR*XR**AR*Z**BR
35798
35799       ENDIF
35800
35801 *     F2 = (F2P+F2R)*Q2/(Q2+M02)
35802
35803       CIN=ALFA/(Q2+M02)*(1.D0 +4.D0*XMP2*Q2/(Q2+W2-XMP2)**2)/Z
35804       PHO_ALLM97 = CIN*(F2P+F2R)
35805
35806       END
35807
35808 *$ CREATE PHO_DOR98LO.FOR
35809 *COPY PHO_DOR98LO
35810 CDECK  ID>, PHO_DOR98LO
35811       SUBROUTINE PHO_DOR98LO (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
35812 C***********************************************************************
35813 C
35814 C   GRV98 parton densities, leading order set
35815 C
35816 C                  For a detailed explanation see
35817 C                   M. Glueck, E. Reya, A. Vogt :
35818 C        hep-ph/9806404  =  DO-TH 98/07  =  WUE-ITP-98-019
35819 C                  (To appear in Eur. Phys. J. C)
35820 C
35821 C   interpolation routine based on the original GRV98PA routine,
35822 C   adapted to define interpolation table as DATA statements
35823 C
35824 C                                                   (R.Engel, 09/98)
35825 C
35826 C
35827 C   INPUT:   X  =  Bjorken-x        (between  1.E-9 and 1.)
35828 C            Q2 =  scale in GeV**2  (between  0.8 and 1.E6)
35829 C
35830 C   OUTPUT:  UV = u - u(bar),  DV = d - d(bar),  US = u(bar),
35831 C            DS = d(bar),  SS = s = s(bar),  GL = gluon.
35832 C            Always x times the distribution is returned.
35833 C
35834 C******************************************************i****************
35835       IMPLICIT DOUBLE PRECISION (A-H, O-Z)
35836       SAVE
35837
35838 C  input/output channels
35839       INTEGER LI,LO
35840       COMMON /POINOU/ LI,LO
35841
35842       PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
35843       DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
35844      1          XSF(NX,NQ), XGF(NX,NQ),
35845      2          XT(NARG), NA(NARG), ARRF(NX+NQ)
35846
35847       DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
35848      &  XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
35849
35850       EQUIVALENCE (XUVF(1,1),XUVF_L(1))
35851       EQUIVALENCE (XDVF(1,1),XDVF_L(1))
35852       EQUIVALENCE (XDEF(1,1),XDEF_L(1))
35853       EQUIVALENCE (XUDF(1,1),XUDF_L(1))
35854       EQUIVALENCE (XSF(1,1),XSF_L(1))
35855       EQUIVALENCE (XGF(1,1),XGF_L(1))
35856
35857       DATA (ARRF(K),K=    1,   95) /
35858      &  -2.0723E+01,-2.0135E+01,-1.9560E+01,-1.8983E+01,-1.8421E+01,
35859      &  -1.7833E+01,-1.7258E+01,-1.6680E+01,-1.6118E+01,-1.5530E+01,
35860      &  -1.4955E+01,-1.4378E+01,-1.3816E+01,-1.3479E+01,-1.3122E+01,
35861      &  -1.2717E+01,-1.2311E+01,-1.1913E+01,-1.1513E+01,-1.1176E+01,
35862      &  -1.0820E+01,-1.0414E+01,-1.0009E+01,-9.6108E+00,-9.2103E+00,
35863      &  -8.8739E+00,-8.5172E+00,-8.1117E+00,-7.7063E+00,-7.3082E+00,
35864      &  -6.9078E+00,-6.5713E+00,-6.2146E+00,-5.8091E+00,-5.4037E+00,
35865      &  -5.0056E+00,-4.6052E+00,-4.2687E+00,-3.9120E+00,-3.5066E+00,
35866      &  -3.1011E+00,-2.8134E+00,-2.5257E+00,-2.3026E+00,-2.0794E+00,
35867      &  -1.8971E+00,-1.7430E+00,-1.6094E+00,-1.4917E+00,-1.3863E+00,
35868      &  -1.2910E+00,-1.2040E+00,-1.1239E+00,-1.0498E+00,-9.8083E-01,
35869      &  -9.1629E-01,-7.9851E-01,-6.9315E-01,-5.9784E-01,-5.1083E-01,
35870      &  -4.3078E-01,-3.5667E-01,-2.8768E-01,-2.2314E-01,-1.6252E-01,
35871      &  -1.0536E-01,-5.1293E-02, 0.0000E+00,-2.2314E-01, 0.0000E+00,
35872      &   2.6236E-01, 5.8779E-01, 9.9325E-01, 1.3863E+00, 1.8563E+00,
35873      &   2.3026E+00, 2.7726E+00, 3.2189E+00, 3.6889E+00, 4.1589E+00,
35874      &   4.6052E+00, 5.1930E+00, 5.7683E+00, 6.3456E+00, 6.9078E+00,
35875      &   7.4955E+00, 8.0709E+00, 8.6482E+00, 9.2103E+00, 9.9988E+00,
35876      &   1.0736E+01, 1.1513E+01, 1.2301E+01, 1.3039E+01, 1.3816E+01/
35877       DATA (XUVF_L(K),K=    1,  114) /
35878      &2.3186E+00,2.2915E+00,2.2645E+00,2.2385E+00,2.2140E+00,2.1876E+00,
35879      &2.1623E+00,2.1366E+00,2.1121E+00,2.0862E+00,2.0612E+00,2.0358E+00,
35880      &2.0110E+00,1.9963E+00,1.9806E+00,1.9624E+00,1.9446E+00,1.9263E+00,
35881      &1.9072E+00,1.8904E+00,1.8724E+00,1.8515E+00,1.8294E+00,1.8085E+00,
35882      &1.7865E+00,1.7680E+00,1.7483E+00,1.7249E+00,1.6993E+00,1.6715E+00,
35883      &1.6385E+00,1.6141E+00,1.5884E+00,1.5597E+00,1.5337E+00,1.5121E+00,
35884      &1.4985E+00,1.4980E+00,1.5116E+00,1.5555E+00,1.6432E+00,1.7434E+00,
35885      &1.8861E+00,2.0327E+00,2.2174E+00,2.4015E+00,2.5849E+00,2.7671E+00,
35886      &2.9488E+00,3.1308E+00,3.3142E+00,3.4998E+00,3.6885E+00,3.8826E+00,
35887      &4.0815E+00,4.2069E+00,4.5481E+00,4.8830E+00,5.2116E+00,5.5351E+00,
35888      &5.8553E+00,6.1665E+00,6.4745E+00,6.7767E+00,7.0735E+00,7.3628E+00,
35889      &7.6283E+00,0.0000E+00,2.3948E+00,2.3665E+00,2.3388E+00,2.3126E+00,
35890      &2.2860E+00,2.2592E+00,2.2327E+00,2.2065E+00,2.1810E+00,2.1541E+00,
35891      &2.1284E+00,2.1020E+00,2.0760E+00,2.0605E+00,2.0443E+00,2.0259E+00,
35892      &2.0068E+00,1.9873E+00,1.9676E+00,1.9500E+00,1.9312E+00,1.9081E+00,
35893      &1.8860E+00,1.8635E+00,1.8406E+00,1.8221E+00,1.8007E+00,1.7764E+00,
35894      &1.7489E+00,1.7195E+00,1.6855E+00,1.6600E+00,1.6332E+00,1.6031E+00,
35895      &1.5760E+00,1.5532E+00,1.5397E+00,1.5376E+00,1.5507E+00,1.5929E+00,
35896      &1.6784E+00,1.7759E+00,1.9129E+00,2.0531E+00,2.2292E+00,2.4032E+00/
35897       DATA (XUVF_L(K),K=  115,  228) /
35898      &2.5752E+00,2.7449E+00,2.9135E+00,3.0810E+00,3.2491E+00,3.4183E+00,
35899      &3.5898E+00,3.7650E+00,3.9437E+00,4.0443E+00,4.3402E+00,4.6262E+00,
35900      &4.9009E+00,5.1640E+00,5.4156E+00,5.6530E+00,5.8759E+00,6.0779E+00,
35901      &6.2540E+00,6.3836E+00,6.4062E+00,0.0000E+00,2.4808E+00,2.4513E+00,
35902      &2.4236E+00,2.3948E+00,2.3680E+00,2.3397E+00,2.3127E+00,2.2853E+00,
35903      &2.2585E+00,2.2307E+00,2.2026E+00,2.1762E+00,2.1490E+00,2.1332E+00,
35904      &2.1164E+00,2.0964E+00,2.0766E+00,2.0565E+00,2.0353E+00,2.0171E+00,
35905      &1.9969E+00,1.9738E+00,1.9501E+00,1.9258E+00,1.9026E+00,1.8821E+00,
35906      &1.8594E+00,1.8330E+00,1.8046E+00,1.7734E+00,1.7378E+00,1.7112E+00,
35907      &1.6829E+00,1.6514E+00,1.6228E+00,1.5994E+00,1.5840E+00,1.5808E+00,
35908      &1.5927E+00,1.6334E+00,1.7157E+00,1.8093E+00,1.9406E+00,2.0735E+00,
35909      &2.2394E+00,2.4019E+00,2.5615E+00,2.7178E+00,2.8718E+00,3.0246E+00,
35910      &3.1766E+00,3.3284E+00,3.4820E+00,3.6370E+00,3.7952E+00,3.8716E+00,
35911      &4.1225E+00,4.3580E+00,4.5798E+00,4.7847E+00,4.9730E+00,5.1395E+00,
35912      &5.2832E+00,5.3945E+00,5.4634E+00,5.4612E+00,5.2940E+00,0.0000E+00,
35913      &2.5823E+00,2.5527E+00,2.5226E+00,2.4928E+00,2.4650E+00,2.4358E+00,
35914      &2.4071E+00,2.3783E+00,2.3505E+00,2.3212E+00,2.2928E+00,2.2636E+00,
35915      &2.2360E+00,2.2185E+00,2.2005E+00,2.1801E+00,2.1591E+00,2.1376E+00,
35916      &2.1153E+00,2.0960E+00,2.0747E+00,2.0505E+00,2.0247E+00,1.9991E+00/
35917       DATA (XUVF_L(K),K=  229,  342) /
35918      &1.9746E+00,1.9523E+00,1.9287E+00,1.9000E+00,1.8693E+00,1.8361E+00,
35919      &1.7994E+00,1.7711E+00,1.7409E+00,1.7076E+00,1.6772E+00,1.6517E+00,
35920      &1.6345E+00,1.6302E+00,1.6408E+00,1.6789E+00,1.7574E+00,1.8457E+00,
35921      &1.9692E+00,2.0939E+00,2.2474E+00,2.3969E+00,2.5419E+00,2.6837E+00,
35922      &2.8216E+00,2.9573E+00,3.0915E+00,3.2246E+00,3.3583E+00,3.4917E+00,
35923      &3.6273E+00,3.6791E+00,3.8823E+00,4.0673E+00,4.2350E+00,4.3813E+00,
35924      &4.5072E+00,4.6083E+00,4.6757E+00,4.7055E+00,4.6825E+00,4.5674E+00,
35925      &4.2566E+00,0.0000E+00,2.7025E+00,2.6705E+00,2.6393E+00,2.6093E+00,
35926      &2.5790E+00,2.5484E+00,2.5184E+00,2.4880E+00,2.4590E+00,2.4277E+00,
35927      &2.3971E+00,2.3669E+00,2.3380E+00,2.3200E+00,2.3002E+00,2.2782E+00,
35928      &2.2557E+00,2.2331E+00,2.2092E+00,2.1887E+00,2.1660E+00,2.1400E+00,
35929      &2.1126E+00,2.0859E+00,2.0586E+00,2.0351E+00,2.0094E+00,1.9786E+00,
35930      &1.9453E+00,1.9096E+00,1.8707E+00,1.8406E+00,1.8084E+00,1.7728E+00,
35931      &1.7392E+00,1.7128E+00,1.6933E+00,1.6875E+00,1.6949E+00,1.7295E+00,
35932      &1.8023E+00,1.8845E+00,1.9991E+00,2.1134E+00,2.2525E+00,2.3868E+00,
35933      &2.5160E+00,2.6405E+00,2.7609E+00,2.8781E+00,2.9929E+00,3.1059E+00,
35934      &3.2180E+00,3.3292E+00,3.4407E+00,3.4675E+00,3.6225E+00,3.7573E+00,
35935      &3.8710E+00,3.9617E+00,4.0270E+00,4.0642E+00,4.0675E+00,4.0263E+00,
35936      &3.9240E+00,3.7262E+00,3.3217E+00,0.0000E+00,2.8135E+00,2.7813E+00/
35937       DATA (XUVF_L(K),K=  343,  456) /
35938      &2.7489E+00,2.7166E+00,2.6850E+00,2.6527E+00,2.6212E+00,2.5898E+00,
35939      &2.5592E+00,2.5267E+00,2.4943E+00,2.4636E+00,2.4320E+00,2.4129E+00,
35940      &2.3929E+00,2.3695E+00,2.3453E+00,2.3211E+00,2.2959E+00,2.2740E+00,
35941      &2.2496E+00,2.2221E+00,2.1931E+00,2.1653E+00,2.1356E+00,2.1112E+00,
35942      &2.0830E+00,2.0503E+00,2.0147E+00,1.9766E+00,1.9361E+00,1.9037E+00,
35943      &1.8696E+00,1.8318E+00,1.7966E+00,1.7677E+00,1.7459E+00,1.7378E+00,
35944      &1.7430E+00,1.7738E+00,1.8407E+00,1.9169E+00,2.0223E+00,2.1273E+00,
35945      &2.2537E+00,2.3742E+00,2.4892E+00,2.5990E+00,2.7043E+00,2.8056E+00,
35946      &2.9038E+00,3.0000E+00,3.0936E+00,3.1864E+00,3.2782E+00,3.2867E+00,
35947      &3.4021E+00,3.4971E+00,3.5691E+00,3.6188E+00,3.6422E+00,3.6335E+00,
35948      &3.5908E+00,3.5036E+00,3.3552E+00,3.1085E+00,2.6634E+00,0.0000E+00,
35949      &2.9406E+00,2.9062E+00,2.8726E+00,2.8385E+00,2.8060E+00,2.7720E+00,
35950      &2.7392E+00,2.7058E+00,2.6734E+00,2.6399E+00,2.6057E+00,2.5722E+00,
35951      &2.5390E+00,2.5194E+00,2.4975E+00,2.4728E+00,2.4471E+00,2.4216E+00,
35952      &2.3945E+00,2.3712E+00,2.3458E+00,2.3152E+00,2.2856E+00,2.2545E+00,
35953      &2.2237E+00,2.1966E+00,2.1672E+00,2.1312E+00,2.0926E+00,2.0521E+00,
35954      &2.0093E+00,1.9748E+00,1.9384E+00,1.8975E+00,1.8601E+00,1.8275E+00,
35955      &1.8036E+00,1.7924E+00,1.7948E+00,1.8206E+00,1.8808E+00,1.9499E+00,
35956      &2.0450E+00,2.1390E+00,2.2512E+00,2.3570E+00,2.4564E+00,2.5501E+00/
35957       DATA (XUVF_L(K),K=  457,  570) /
35958      &2.6391E+00,2.7240E+00,2.8053E+00,2.8834E+00,2.9590E+00,3.0326E+00,
35959      &3.1042E+00,3.0942E+00,3.1727E+00,3.2289E+00,3.2628E+00,3.2739E+00,
35960      &3.2574E+00,3.2103E+00,3.1297E+00,3.0047E+00,2.8211E+00,2.5467E+00,
35961      &2.0897E+00,0.0000E+00,3.0557E+00,3.0193E+00,2.9840E+00,2.9497E+00,
35962      &2.9150E+00,2.8801E+00,2.8454E+00,2.8109E+00,2.7771E+00,2.7412E+00,
35963      &2.7065E+00,2.6716E+00,2.6360E+00,2.6149E+00,2.5923E+00,2.5663E+00,
35964      &2.5395E+00,2.5120E+00,2.4834E+00,2.4589E+00,2.4330E+00,2.4011E+00,
35965      &2.3676E+00,2.3363E+00,2.3027E+00,2.2736E+00,2.2422E+00,2.2040E+00,
35966      &2.1629E+00,2.1194E+00,2.0750E+00,2.0384E+00,1.9996E+00,1.9565E+00,
35967      &1.9160E+00,1.8811E+00,1.8541E+00,1.8409E+00,1.8399E+00,1.8611E+00,
35968      &1.9143E+00,1.9764E+00,2.0622E+00,2.1459E+00,2.2457E+00,2.3385E+00,
35969      &2.4249E+00,2.5051E+00,2.5806E+00,2.6515E+00,2.7182E+00,2.7823E+00,
35970      &2.8427E+00,2.9008E+00,2.9564E+00,2.9332E+00,2.9828E+00,3.0094E+00,
35971      &3.0142E+00,2.9955E+00,2.9537E+00,2.8796E+00,2.7735E+00,2.6260E+00,
35972      &2.4242E+00,2.1388E+00,1.6900E+00,0.0000E+00,3.1718E+00,3.1348E+00,
35973      &3.0971E+00,3.0610E+00,3.0260E+00,2.9896E+00,2.9533E+00,2.9173E+00,
35974      &2.8818E+00,2.8449E+00,2.8072E+00,2.7709E+00,2.7340E+00,2.7121E+00,
35975      &2.6877E+00,2.6605E+00,2.6319E+00,2.6032E+00,2.5732E+00,2.5471E+00,
35976      &2.5180E+00,2.4851E+00,2.4511E+00,2.4170E+00,2.3817E+00,2.3505E+00/
35977       DATA (XUVF_L(K),K=  571,  684) /
35978      &2.3172E+00,2.2762E+00,2.2328E+00,2.1868E+00,2.1400E+00,2.1012E+00,
35979      &2.0601E+00,2.0136E+00,1.9704E+00,1.9335E+00,1.9035E+00,1.8868E+00,
35980      &1.8827E+00,1.8990E+00,1.9452E+00,2.0005E+00,2.0763E+00,2.1507E+00,
35981      &2.2377E+00,2.3179E+00,2.3917E+00,2.4592E+00,2.5218E+00,2.5799E+00,
35982      &2.6336E+00,2.6843E+00,2.7314E+00,2.7753E+00,2.8166E+00,2.7824E+00,
35983      &2.8054E+00,2.8081E+00,2.7893E+00,2.7474E+00,2.6818E+00,2.5888E+00,
35984      &2.4646E+00,2.3032E+00,2.0902E+00,1.8025E+00,1.3740E+00,0.0000E+00,
35985      &3.2793E+00,3.2385E+00,3.2014E+00,3.1643E+00,3.1270E+00,3.0888E+00,
35986      &3.0517E+00,3.0141E+00,2.9773E+00,2.9392E+00,2.9009E+00,2.8610E+00,
35987      &2.8230E+00,2.8000E+00,2.7754E+00,2.7459E+00,2.7163E+00,2.6858E+00,
35988      &2.6545E+00,2.6270E+00,2.5962E+00,2.5617E+00,2.5271E+00,2.4903E+00,
35989      &2.4527E+00,2.4207E+00,2.3851E+00,2.3421E+00,2.2960E+00,2.2476E+00,
35990      &2.1987E+00,2.1578E+00,2.1146E+00,2.0670E+00,2.0202E+00,1.9796E+00,
35991      &1.9468E+00,1.9282E+00,1.9203E+00,1.9319E+00,1.9712E+00,2.0197E+00,
35992      &2.0872E+00,2.1524E+00,2.2288E+00,2.2981E+00,2.3606E+00,2.4177E+00,
35993      &2.4692E+00,2.5159E+00,2.5591E+00,2.5981E+00,2.6339E+00,2.6669E+00,
35994      &2.6962E+00,2.6528E+00,2.6566E+00,2.6395E+00,2.6028E+00,2.5437E+00,
35995      &2.4622E+00,2.3555E+00,2.2200E+00,2.0488E+00,1.8335E+00,1.5506E+00,
35996      &1.1442E+00,0.0000E+00,3.3868E+00,3.3470E+00,3.3075E+00,3.2689E+00/
35997       DATA (XUVF_L(K),K=  685,  798) /
35998      &3.2300E+00,3.1909E+00,3.1517E+00,3.1129E+00,3.0747E+00,3.0335E+00,
35999      &2.9946E+00,2.9537E+00,2.9140E+00,2.8896E+00,2.8638E+00,2.8337E+00,
36000      &2.8021E+00,2.7705E+00,2.7373E+00,2.7075E+00,2.6767E+00,2.6403E+00,
36001      &2.6031E+00,2.5649E+00,2.5258E+00,2.4917E+00,2.4537E+00,2.4080E+00,
36002      &2.3597E+00,2.3091E+00,2.2580E+00,2.2150E+00,2.1692E+00,2.1186E+00,
36003      &2.0701E+00,2.0257E+00,1.9901E+00,1.9679E+00,1.9571E+00,1.9629E+00,
36004      &1.9955E+00,2.0378E+00,2.0963E+00,2.1529E+00,2.2178E+00,2.2766E+00,
36005      &2.3287E+00,2.3749E+00,2.4162E+00,2.4529E+00,2.4850E+00,2.5140E+00,
36006      &2.5392E+00,2.5617E+00,2.5798E+00,2.5298E+00,2.5151E+00,2.4811E+00,
36007      &2.4282E+00,2.3561E+00,2.2611E+00,2.1439E+00,2.0005E+00,1.8252E+00,
36008      &1.6091E+00,1.3345E+00,9.5375E-01,0.0000E+00,3.4912E+00,3.4507E+00,
36009      &3.4100E+00,3.3696E+00,3.3310E+00,3.2893E+00,3.2496E+00,3.2088E+00,
36010      &3.1686E+00,3.1278E+00,3.0865E+00,3.0438E+00,3.0020E+00,2.9766E+00,
36011      &2.9494E+00,2.9180E+00,2.8850E+00,2.8520E+00,2.8174E+00,2.7877E+00,
36012      &2.7550E+00,2.7169E+00,2.6762E+00,2.6369E+00,2.5958E+00,2.5594E+00,
36013      &2.5195E+00,2.4721E+00,2.4211E+00,2.3680E+00,2.3145E+00,2.2695E+00,
36014      &2.2214E+00,2.1684E+00,2.1154E+00,2.0706E+00,2.0303E+00,2.0058E+00,
36015      &1.9909E+00,1.9920E+00,2.0177E+00,2.0531E+00,2.1031E+00,2.1511E+00,
36016      &2.2060E+00,2.2548E+00,2.2972E+00,2.3339E+00,2.3655E+00,2.3927E+00/
36017       DATA (XUVF_L(K),K=  799,  912) /
36018      &2.4159E+00,2.4357E+00,2.4520E+00,2.4644E+00,2.4735E+00,2.4171E+00,
36019      &2.3878E+00,2.3397E+00,2.2743E+00,2.1907E+00,2.0861E+00,1.9611E+00,
36020      &1.8128E+00,1.6351E+00,1.4227E+00,1.1584E+00,8.0371E-01,0.0000E+00,
36021      &3.5892E+00,3.5473E+00,3.5055E+00,3.4637E+00,3.4230E+00,3.3809E+00,
36022      &3.3396E+00,3.2976E+00,3.2571E+00,3.2126E+00,3.1696E+00,3.1272E+00,
36023      &3.0840E+00,3.0569E+00,3.0286E+00,2.9959E+00,2.9619E+00,2.9273E+00,
36024      &2.8910E+00,2.8598E+00,2.8266E+00,2.7863E+00,2.7448E+00,2.7029E+00,
36025      &2.6598E+00,2.6219E+00,2.5804E+00,2.5305E+00,2.4773E+00,2.4214E+00,
36026      &2.3662E+00,2.3191E+00,2.2698E+00,2.2126E+00,2.1577E+00,2.1092E+00,
36027      &2.0674E+00,2.0393E+00,2.0210E+00,2.0173E+00,2.0367E+00,2.0654E+00,
36028      &2.1076E+00,2.1485E+00,2.1942E+00,2.2338E+00,2.2678E+00,2.2959E+00,
36029      &2.3193E+00,2.3386E+00,2.3539E+00,2.3660E+00,2.3738E+00,2.3789E+00,
36030      &2.3799E+00,2.3197E+00,2.2776E+00,2.2186E+00,2.1426E+00,2.0495E+00,
36031      &1.9397E+00,1.8097E+00,1.6583E+00,1.4814E+00,1.2736E+00,1.0200E+00,
36032      &6.8880E-01,0.0000E+00,3.7157E+00,3.6699E+00,3.6275E+00,3.5842E+00,
36033      &3.5420E+00,3.4972E+00,3.4542E+00,3.4107E+00,3.3678E+00,3.3234E+00,
36034      &3.2774E+00,3.2332E+00,3.1870E+00,3.1600E+00,3.1297E+00,3.0952E+00,
36035      &3.0595E+00,3.0231E+00,2.9850E+00,2.9534E+00,2.9160E+00,2.8740E+00,
36036      &2.8312E+00,2.7872E+00,2.7408E+00,2.7014E+00,2.6568E+00,2.6045E+00/
36037       DATA (XUVF_L(K),K=  913, 1026) /
36038      &2.5481E+00,2.4895E+00,2.4315E+00,2.3817E+00,2.3283E+00,2.2697E+00,
36039      &2.2106E+00,2.1591E+00,2.1128E+00,2.0807E+00,2.0578E+00,2.0477E+00,
36040      &2.0583E+00,2.0796E+00,2.1122E+00,2.1433E+00,2.1777E+00,2.2069E+00,
36041      &2.2299E+00,2.2483E+00,2.2618E+00,2.2718E+00,2.2778E+00,2.2803E+00,
36042      &2.2797E+00,2.2749E+00,2.2668E+00,2.2019E+00,2.1468E+00,2.0761E+00,
36043      &1.9902E+00,1.8883E+00,1.7711E+00,1.6370E+00,1.4847E+00,1.3103E+00,
36044      &1.1091E+00,8.7047E-01,5.6856E-01,0.0000E+00,3.8327E+00,3.7877E+00,
36045      &3.7424E+00,3.6981E+00,3.6540E+00,3.6083E+00,3.5637E+00,3.5184E+00,
36046      &3.4753E+00,3.4271E+00,3.3800E+00,3.3325E+00,3.2860E+00,3.2564E+00,
36047      &3.2258E+00,3.1893E+00,3.1519E+00,3.1135E+00,3.0738E+00,3.0389E+00,
36048      &3.0010E+00,2.9580E+00,2.9118E+00,2.8654E+00,2.8178E+00,2.7758E+00,
36049      &2.7289E+00,2.6738E+00,2.6146E+00,2.5530E+00,2.4924E+00,2.4399E+00,
36050      &2.3845E+00,2.3213E+00,2.2605E+00,2.2040E+00,2.1540E+00,2.1186E+00,
36051      &2.0908E+00,2.0749E+00,2.0772E+00,2.0914E+00,2.1145E+00,2.1368E+00,
36052      &2.1613E+00,2.1804E+00,2.1941E+00,2.2037E+00,2.2088E+00,2.2101E+00,
36053      &2.2083E+00,2.2031E+00,2.1942E+00,2.1826E+00,2.1665E+00,2.0987E+00,
36054      &2.0321E+00,1.9516E+00,1.8571E+00,1.7497E+00,1.6281E+00,1.4923E+00,
36055      &1.3406E+00,1.1697E+00,9.7635E-01,7.5209E-01,4.7638E-01,0.0000E+00,
36056      &3.9497E+00,3.9009E+00,3.8555E+00,3.8080E+00,3.7630E+00,3.7163E+00/
36057       DATA (XUVF_L(K),K= 1027, 1140) /
36058      &3.6699E+00,3.6231E+00,3.5765E+00,3.5285E+00,3.4807E+00,3.4305E+00,
36059      &3.3810E+00,3.3511E+00,3.3185E+00,3.2805E+00,3.2414E+00,3.2016E+00,
36060      &3.1598E+00,3.1244E+00,3.0837E+00,3.0383E+00,2.9908E+00,2.9424E+00,
36061      &2.8919E+00,2.8477E+00,2.7990E+00,2.7403E+00,2.6784E+00,2.6142E+00,
36062      &2.5507E+00,2.4960E+00,2.4362E+00,2.3710E+00,2.3058E+00,2.2463E+00,
36063      &2.1931E+00,2.1539E+00,2.1216E+00,2.0996E+00,2.0940E+00,2.1012E+00,
36064      &2.1154E+00,2.1294E+00,2.1444E+00,2.1543E+00,2.1597E+00,2.1610E+00,
36065      &2.1585E+00,2.1523E+00,2.1432E+00,2.1307E+00,2.1155E+00,2.0964E+00,
36066      &2.0742E+00,2.0035E+00,1.9273E+00,1.8396E+00,1.7387E+00,1.6273E+00,
36067      &1.5032E+00,1.3665E+00,1.2164E+00,1.0501E+00,8.6515E-01,6.5470E-01,
36068      &4.0284E-01,0.0000E+00,4.0572E+00,4.0093E+00,3.9616E+00,3.9140E+00,
36069      &3.8670E+00,3.8185E+00,3.7706E+00,3.7224E+00,3.6746E+00,3.6251E+00,
36070      &3.5744E+00,3.5233E+00,3.4720E+00,3.4406E+00,3.4062E+00,3.3671E+00,
36071      &3.3263E+00,3.2847E+00,3.2414E+00,3.2046E+00,3.1620E+00,3.1150E+00,
36072      &3.0653E+00,3.0145E+00,2.9619E+00,2.9153E+00,2.8641E+00,2.8032E+00,
36073      &2.7388E+00,2.6715E+00,2.6056E+00,2.5481E+00,2.4880E+00,2.4171E+00,
36074      &2.3496E+00,2.2862E+00,2.2282E+00,2.1865E+00,2.1502E+00,2.1217E+00,
36075      &2.1086E+00,2.1086E+00,2.1149E+00,2.1216E+00,2.1275E+00,2.1295E+00,
36076      &2.1273E+00,2.1212E+00,2.1119E+00,2.0992E+00,2.0837E+00,2.0653E+00/
36077       DATA (XUVF_L(K),K= 1141, 1254) /
36078      &2.0442E+00,2.0194E+00,1.9912E+00,1.9193E+00,1.8359E+00,1.7412E+00,
36079      &1.6366E+00,1.5214E+00,1.3956E+00,1.2594E+00,1.1115E+00,9.5033E-01,
36080      &7.7356E-01,5.7585E-01,3.4506E-01,0.0000E+00,4.1710E+00,4.1201E+00,
36081      &4.0712E+00,4.0213E+00,3.9730E+00,3.9228E+00,3.8734E+00,3.8233E+00,
36082      &3.7726E+00,3.7217E+00,3.6699E+00,3.6160E+00,3.5640E+00,3.5311E+00,
36083      &3.4960E+00,3.4549E+00,3.4121E+00,3.3689E+00,3.3237E+00,3.2848E+00,
36084      &3.2425E+00,3.1917E+00,3.1399E+00,3.0866E+00,3.0319E+00,2.9838E+00,
36085      &2.9306E+00,2.8668E+00,2.7992E+00,2.7291E+00,2.6605E+00,2.6007E+00,
36086      &2.5375E+00,2.4631E+00,2.3919E+00,2.3261E+00,2.2643E+00,2.2183E+00,
36087      &2.1772E+00,2.1426E+00,2.1222E+00,2.1155E+00,2.1135E+00,2.1130E+00,
36088      &2.1102E+00,2.1039E+00,2.0941E+00,2.0815E+00,2.0652E+00,2.0466E+00,
36089      &2.0251E+00,2.0014E+00,1.9746E+00,1.9450E+00,1.9116E+00,1.8381E+00,
36090      &1.7481E+00,1.6484E+00,1.5404E+00,1.4225E+00,1.2963E+00,1.1611E+00,
36091      &1.0161E+00,8.6047E-01,6.9193E-01,5.0691E-01,2.9581E-01,0.0000E+00,
36092      &4.2754E+00,4.2238E+00,4.1737E+00,4.1233E+00,4.0740E+00,4.0219E+00,
36093      &3.9713E+00,3.9196E+00,3.8675E+00,3.8160E+00,3.7618E+00,3.7060E+00,
36094      &3.6510E+00,3.6173E+00,3.5808E+00,3.5380E+00,3.4941E+00,3.4493E+00,
36095      &3.4027E+00,3.3623E+00,3.3163E+00,3.2647E+00,3.2114E+00,3.1563E+00,
36096      &3.0989E+00,3.0489E+00,2.9929E+00,2.9263E+00,2.8563E+00,2.7837E+00/
36097       DATA (XUVF_L(K),K= 1255, 1368) /
36098      &2.7122E+00,2.6501E+00,2.5825E+00,2.5073E+00,2.4327E+00,2.3623E+00,
36099      &2.2962E+00,2.2474E+00,2.2020E+00,2.1616E+00,2.1335E+00,2.1209E+00,
36100      &2.1113E+00,2.1034E+00,2.0929E+00,2.0795E+00,2.0634E+00,2.0439E+00,
36101      &2.0222E+00,1.9982E+00,1.9716E+00,1.9428E+00,1.9113E+00,1.8773E+00,
36102      &1.8394E+00,1.7649E+00,1.6692E+00,1.5658E+00,1.4547E+00,1.3360E+00,
36103      &1.2095E+00,1.0761E+00,9.3485E-01,7.8430E-01,6.2380E-01,4.5010E-01,
36104      &2.5625E-01,0.0000E+00,4.3798E+00,4.3275E+00,4.2762E+00,4.2239E+00,
36105      &4.1730E+00,4.1196E+00,4.0674E+00,4.0143E+00,3.9623E+00,3.9056E+00,
36106      &3.8502E+00,3.7935E+00,3.7370E+00,3.7018E+00,3.6642E+00,3.6200E+00,
36107      &3.5742E+00,3.5277E+00,3.4786E+00,3.4371E+00,3.3901E+00,3.3359E+00,
36108      &3.2800E+00,3.2235E+00,3.1639E+00,3.1115E+00,3.0537E+00,2.9847E+00,
36109      &2.9116E+00,2.8364E+00,2.7623E+00,2.6973E+00,2.6275E+00,2.5497E+00,
36110      &2.4705E+00,2.3972E+00,2.3281E+00,2.2747E+00,2.2253E+00,2.1793E+00,
36111      &2.1444E+00,2.1253E+00,2.1081E+00,2.0939E+00,2.0755E+00,2.0555E+00,
36112      &2.0332E+00,2.0081E+00,1.9814E+00,1.9522E+00,1.9205E+00,1.8875E+00,
36113      &1.8520E+00,1.8139E+00,1.7725E+00,1.6968E+00,1.5976E+00,1.4911E+00,
36114      &1.3772E+00,1.2577E+00,1.1320E+00,1.0005E+00,8.6242E-01,7.1750E-01,
36115      &5.6466E-01,4.0150E-01,2.2333E-01,0.0000E+00,4.4809E+00,4.4265E+00,
36116      &4.3735E+00,4.3193E+00,4.2670E+00,4.2128E+00,4.1585E+00,4.1039E+00/
36117       DATA (XUVF_L(K),K= 1369, 1482) /
36118      &4.0509E+00,3.9928E+00,3.9351E+00,3.8769E+00,3.8180E+00,3.7821E+00,
36119      &3.7434E+00,3.6974E+00,3.6501E+00,3.6019E+00,3.5513E+00,3.5093E+00,
36120      &3.4594E+00,3.4035E+00,3.3456E+00,3.2870E+00,3.2250E+00,3.1715E+00,
36121      &3.1110E+00,3.0396E+00,2.9639E+00,2.8863E+00,2.8096E+00,2.7429E+00,
36122      &2.6702E+00,2.5884E+00,2.5068E+00,2.4296E+00,2.3560E+00,2.3003E+00,
36123      &2.2464E+00,2.1951E+00,2.1530E+00,2.1283E+00,2.1045E+00,2.0843E+00,
36124      &2.0591E+00,2.0328E+00,2.0047E+00,1.9749E+00,1.9429E+00,1.9096E+00,
36125      &1.8740E+00,1.8369E+00,1.7978E+00,1.7560E+00,1.7116E+00,1.6360E+00,
36126      &1.5322E+00,1.4233E+00,1.3084E+00,1.1885E+00,1.0637E+00,9.3449E-01,
36127      &7.9961E-01,6.6020E-01,5.1453E-01,3.6103E-01,1.9641E-01,0.0000E+00,
36128      &4.6169E+00,4.5608E+00,4.5060E+00,4.4504E+00,4.3960E+00,4.3395E+00,
36129      &4.2837E+00,4.2262E+00,4.1710E+00,4.1106E+00,4.0517E+00,3.9908E+00,
36130      &3.9300E+00,3.8920E+00,3.8509E+00,3.8030E+00,3.7538E+00,3.7035E+00,
36131      &3.6494E+00,3.6055E+00,3.5556E+00,3.4966E+00,3.4351E+00,3.3738E+00,
36132      &3.3090E+00,3.2518E+00,3.1888E+00,3.1141E+00,3.0348E+00,2.9533E+00,
36133      &2.8730E+00,2.8020E+00,2.7264E+00,2.6400E+00,2.5551E+00,2.4732E+00,
36134      &2.3941E+00,2.3329E+00,2.2742E+00,2.2147E+00,2.1644E+00,2.1317E+00,
36135      &2.0986E+00,2.0700E+00,2.0363E+00,2.0021E+00,1.9668E+00,1.9299E+00,
36136      &1.8922E+00,1.8532E+00,1.8125E+00,1.7704E+00,1.7270E+00,1.6809E+00/
36137       DATA (XUVF_L(K),K= 1483, 1596) /
36138      &1.6327E+00,1.5570E+00,1.4497E+00,1.3373E+00,1.2215E+00,1.1020E+00,
36139      &9.7897E-01,8.5304E-01,7.2349E-01,5.9074E-01,4.5411E-01,3.1307E-01,
36140      &1.6547E-01,0.0000E+00,4.7403E+00,4.6834E+00,4.6262E+00,4.5696E+00,
36141      &4.5140E+00,4.4557E+00,4.3978E+00,4.3393E+00,4.2817E+00,4.2191E+00,
36142      &4.1578E+00,4.0941E+00,4.0310E+00,3.9917E+00,3.9492E+00,3.8995E+00,
36143      &3.8481E+00,3.7958E+00,3.7411E+00,3.6937E+00,3.6405E+00,3.5806E+00,
36144      &3.5171E+00,3.4520E+00,3.3840E+00,3.3254E+00,3.2596E+00,3.1812E+00,
36145      &3.0985E+00,3.0137E+00,2.9301E+00,2.8556E+00,2.7782E+00,2.6879E+00,
36146      &2.5974E+00,2.5119E+00,2.4281E+00,2.3629E+00,2.2982E+00,2.2324E+00,
36147      &2.1730E+00,2.1332E+00,2.0922E+00,2.0570E+00,2.0152E+00,1.9739E+00,
36148      &1.9323E+00,1.8902E+00,1.8474E+00,1.8039E+00,1.7589E+00,1.7129E+00,
36149      &1.6654E+00,1.6163E+00,1.5652E+00,1.4896E+00,1.3789E+00,1.2649E+00,
36150      &1.1487E+00,1.0300E+00,9.0896E-01,7.8619E-01,6.6149E-01,5.3498E-01,
36151      &4.0654E-01,2.7586E-01,1.4208E-01,0.0000E+00,4.8699E+00,4.8107E+00,
36152      &4.7518E+00,4.6928E+00,4.6350E+00,4.5750E+00,4.5152E+00,4.4524E+00,
36153      &4.3956E+00,4.3299E+00,4.2674E+00,4.2014E+00,4.1350E+00,4.0939E+00,
36154      &4.0503E+00,3.9982E+00,3.9448E+00,3.8905E+00,3.8328E+00,3.7846E+00,
36155      &3.7300E+00,3.6664E+00,3.5991E+00,3.5326E+00,3.4620E+00,3.3998E+00,
36156      &3.3311E+00,3.2494E+00,3.1632E+00,3.0752E+00,2.9881E+00,2.9120E+00/
36157       DATA (XUVF_L(K),K= 1597, 1710) /
36158      &2.8299E+00,2.7339E+00,2.6398E+00,2.5493E+00,2.4611E+00,2.3911E+00,
36159      &2.3215E+00,2.2482E+00,2.1812E+00,2.1342E+00,2.0854E+00,2.0427E+00,
36160      &1.9932E+00,1.9453E+00,1.8978E+00,1.8504E+00,1.8030E+00,1.7545E+00,
36161      &1.7059E+00,1.6565E+00,1.6056E+00,1.5535E+00,1.4989E+00,1.4245E+00,
36162      &1.3108E+00,1.1959E+00,1.0798E+00,9.6219E-01,8.4358E-01,7.2422E-01,
36163      &6.0451E-01,4.8425E-01,3.6380E-01,2.4286E-01,1.2189E-01,0.0000E+00,
36164      &4.9964E+00,4.9356E+00,4.8755E+00,4.8147E+00,4.7550E+00,4.6935E+00,
36165      &4.6315E+00,4.5697E+00,4.5062E+00,4.4406E+00,4.3752E+00,4.3061E+00,
36166      &4.2380E+00,4.1962E+00,4.1500E+00,4.0963E+00,4.0405E+00,3.9832E+00,
36167      &3.9245E+00,3.8728E+00,3.8172E+00,3.7504E+00,3.6811E+00,3.6108E+00,
36168      &3.5381E+00,3.4734E+00,3.4018E+00,3.3164E+00,3.2269E+00,3.1352E+00,
36169      &3.0446E+00,2.9657E+00,2.8794E+00,2.7800E+00,2.6821E+00,2.5867E+00,
36170      &2.4930E+00,2.4184E+00,2.3433E+00,2.2634E+00,2.1877E+00,2.1342E+00,
36171      &2.0772E+00,2.0279E+00,1.9713E+00,1.9172E+00,1.8642E+00,1.8120E+00,
36172      &1.7600E+00,1.7076E+00,1.6553E+00,1.6027E+00,1.5491E+00,1.4938E+00,
36173      &1.4374E+00,1.3637E+00,1.2481E+00,1.1325E+00,1.0166E+00,9.0047E-01,
36174      &7.8428E-01,6.6889E-01,5.5381E-01,4.3953E-01,3.2652E-01,2.1461E-01,
36175      &1.0498E-01,0.0000E+00,5.1134E+00,5.0511E+00,4.9886E+00,4.9273E+00,
36176      &4.8660E+00,4.8016E+00,4.7382E+00,4.6744E+00,4.6106E+00,4.5420E+00/
36177       DATA (XUVF_L(K),K= 1711, 1824) /
36178      &4.4742E+00,4.4028E+00,4.3320E+00,4.2892E+00,4.2413E+00,4.1858E+00,
36179      &4.1281E+00,4.0682E+00,4.0067E+00,3.9556E+00,3.8955E+00,3.8271E+00,
36180      &3.7556E+00,3.6829E+00,3.6071E+00,3.5401E+00,3.4662E+00,3.3777E+00,
36181      &3.2849E+00,3.1898E+00,3.0960E+00,3.0140E+00,2.9244E+00,2.8224E+00,
36182      &2.7183E+00,2.6191E+00,2.5219E+00,2.4431E+00,2.3628E+00,2.2767E+00,
36183      &2.1931E+00,2.1332E+00,2.0695E+00,2.0145E+00,1.9514E+00,1.8920E+00,
36184      &1.8340E+00,1.7775E+00,1.7215E+00,1.6664E+00,1.6108E+00,1.5553E+00,
36185      &1.4995E+00,1.4421E+00,1.3839E+00,1.3103E+00,1.1944E+00,1.0782E+00,
36186      &9.6271E-01,8.4822E-01,7.3481E-01,6.2240E-01,5.1184E-01,4.0291E-01,
36187      &2.9618E-01,1.9206E-01,9.1846E-02,0.0000E+00,5.2367E+00,5.1713E+00,
36188      &5.1071E+00,5.0425E+00,4.9800E+00,4.9141E+00,4.8489E+00,4.7833E+00,
36189      &4.7181E+00,4.6457E+00,4.5768E+00,4.5034E+00,4.4300E+00,4.3847E+00,
36190      &4.3353E+00,4.2782E+00,4.2182E+00,4.1570E+00,4.0921E+00,4.0385E+00,
36191      &3.9782E+00,3.9074E+00,3.8331E+00,3.7575E+00,3.6781E+00,3.6086E+00,
36192      &3.5313E+00,3.4401E+00,3.3439E+00,3.2455E+00,3.1483E+00,3.0623E+00,
36193      &2.9694E+00,2.8629E+00,2.7561E+00,2.6527E+00,2.5508E+00,2.4669E+00,
36194      &2.3816E+00,2.2887E+00,2.1979E+00,2.1317E+00,2.0613E+00,2.0002E+00,
36195      &1.9307E+00,1.8659E+00,1.8033E+00,1.7426E+00,1.6834E+00,1.6247E+00,
36196      &1.5668E+00,1.5085E+00,1.4504E+00,1.3916E+00,1.3311E+00,1.2591E+00/
36197       DATA (XUVF_L(K),K= 1825, 1836) /
36198      &1.1415E+00,1.0256E+00,9.1107E-01,7.9840E-01,6.8736E-01,5.7902E-01,
36199      &4.7260E-01,3.6895E-01,2.6838E-01,1.7161E-01,8.0264E-02,0.0000E+00/
36200       DATA (XDVF_L(K),K=    1,  114) /
36201      &1.4230E+00,1.4064E+00,1.3903E+00,1.3749E+00,1.3590E+00,1.3424E+00,
36202      &1.3271E+00,1.3114E+00,1.2962E+00,1.2803E+00,1.2647E+00,1.2492E+00,
36203      &1.2340E+00,1.2246E+00,1.2155E+00,1.2044E+00,1.1927E+00,1.1814E+00,
36204      &1.1695E+00,1.1589E+00,1.1479E+00,1.1347E+00,1.1214E+00,1.1080E+00,
36205      &1.0944E+00,1.0824E+00,1.0700E+00,1.0544E+00,1.0371E+00,1.0188E+00,
36206      &9.9884E-01,9.8287E-01,9.6563E-01,9.4645E-01,9.2847E-01,9.1313E-01,
36207      &9.0246E-01,8.9955E-01,9.0461E-01,9.2737E-01,9.7648E-01,1.0343E+00,
36208      &1.1168E+00,1.2030E+00,1.3129E+00,1.4240E+00,1.5357E+00,1.6492E+00,
36209      &1.7643E+00,1.8818E+00,2.0016E+00,2.1253E+00,2.2535E+00,2.3853E+00,
36210      &2.5225E+00,2.5620E+00,2.7906E+00,3.0230E+00,3.2574E+00,3.4983E+00,
36211      &3.7459E+00,4.0062E+00,4.2803E+00,4.5790E+00,4.9150E+00,5.3263E+00,
36212      &5.9228E+00,0.0000E+00,1.4698E+00,1.4526E+00,1.4360E+00,1.4199E+00,
36213      &1.4030E+00,1.3864E+00,1.3702E+00,1.3542E+00,1.3386E+00,1.3221E+00,
36214      &1.3059E+00,1.2896E+00,1.2740E+00,1.2644E+00,1.2544E+00,1.2425E+00,
36215      &1.2309E+00,1.2185E+00,1.2061E+00,1.1953E+00,1.1836E+00,1.1697E+00,
36216      &1.1558E+00,1.1417E+00,1.1275E+00,1.1154E+00,1.1011E+00,1.0844E+00,
36217      &1.0663E+00,1.0471E+00,1.0261E+00,1.0092E+00,9.9133E-01,9.7103E-01,
36218      &9.5184E-01,9.3560E-01,9.2380E-01,9.1922E-01,9.2378E-01,9.4563E-01,
36219      &9.9235E-01,1.0474E+00,1.1262E+00,1.2078E+00,1.3110E+00,1.4146E+00/
36220       DATA (XDVF_L(K),K=  115,  228) /
36221      &1.5192E+00,1.6241E+00,1.7298E+00,1.8375E+00,1.9471E+00,2.0592E+00,
36222      &2.1741E+00,2.2925E+00,2.4144E+00,2.4425E+00,2.6407E+00,2.8375E+00,
36223      &3.0361E+00,3.2345E+00,3.4343E+00,3.6388E+00,3.8488E+00,4.0682E+00,
36224      &4.3043E+00,4.5737E+00,4.9280E+00,0.0000E+00,1.5226E+00,1.5047E+00,
36225      &1.4874E+00,1.4702E+00,1.4530E+00,1.4363E+00,1.4193E+00,1.4023E+00,
36226      &1.3860E+00,1.3690E+00,1.3520E+00,1.3351E+00,1.3190E+00,1.3083E+00,
36227      &1.2983E+00,1.2858E+00,1.2733E+00,1.2606E+00,1.2476E+00,1.2362E+00,
36228      &1.2237E+00,1.2092E+00,1.1943E+00,1.1795E+00,1.1645E+00,1.1509E+00,
36229      &1.1365E+00,1.1185E+00,1.0994E+00,1.0784E+00,1.0566E+00,1.0388E+00,
36230      &1.0195E+00,9.9801E-01,9.7765E-01,9.6019E-01,9.4712E-01,9.4158E-01,
36231      &9.4524E-01,9.6454E-01,1.0088E+00,1.0604E+00,1.1346E+00,1.2112E+00,
36232      &1.3076E+00,1.4038E+00,1.4995E+00,1.5957E+00,1.6918E+00,1.7888E+00,
36233      &1.8877E+00,1.9877E+00,2.0896E+00,2.1940E+00,2.2999E+00,2.3168E+00,
36234      &2.4844E+00,2.6497E+00,2.8098E+00,2.9678E+00,3.1219E+00,3.2743E+00,
36235      &3.4260E+00,3.5742E+00,3.7237E+00,3.8717E+00,4.0300E+00,0.0000E+00,
36236      &1.5849E+00,1.5662E+00,1.5482E+00,1.5298E+00,1.5130E+00,1.4944E+00,
36237      &1.4769E+00,1.4593E+00,1.4423E+00,1.4243E+00,1.4066E+00,1.3894E+00,
36238      &1.3720E+00,1.3607E+00,1.3499E+00,1.3366E+00,1.3237E+00,1.3101E+00,
36239      &1.2963E+00,1.2840E+00,1.2709E+00,1.2553E+00,1.2396E+00,1.2232E+00/
36240       DATA (XDVF_L(K),K=  229,  342) /
36241      &1.2075E+00,1.1932E+00,1.1776E+00,1.1584E+00,1.1377E+00,1.1152E+00,
36242      &1.0922E+00,1.0729E+00,1.0524E+00,1.0294E+00,1.0074E+00,9.8843E-01,
36243      &9.7377E-01,9.6751E-01,9.6901E-01,9.8606E-01,1.0264E+00,1.0745E+00,
36244      &1.1435E+00,1.2136E+00,1.3018E+00,1.3894E+00,1.4758E+00,1.5619E+00,
36245      &1.6474E+00,1.7332E+00,1.8194E+00,1.9063E+00,1.9941E+00,2.0832E+00,
36246      &2.1725E+00,2.1789E+00,2.3166E+00,2.4460E+00,2.5708E+00,2.6884E+00,
36247      &2.7987E+00,2.9025E+00,2.9974E+00,3.0823E+00,3.1538E+00,3.2013E+00,
36248      &3.2043E+00,0.0000E+00,1.6586E+00,1.6391E+00,1.6202E+00,1.6014E+00,
36249      &1.5830E+00,1.5638E+00,1.5457E+00,1.5267E+00,1.5087E+00,1.4899E+00,
36250      &1.4711E+00,1.4517E+00,1.4340E+00,1.4224E+00,1.4107E+00,1.3972E+00,
36251      &1.3827E+00,1.3684E+00,1.3535E+00,1.3404E+00,1.3263E+00,1.3096E+00,
36252      &1.2927E+00,1.2758E+00,1.2575E+00,1.2422E+00,1.2250E+00,1.2046E+00,
36253      &1.1821E+00,1.1579E+00,1.1331E+00,1.1127E+00,1.0905E+00,1.0655E+00,
36254      &1.0415E+00,1.0207E+00,1.0042E+00,9.9612E-01,9.9507E-01,1.0089E+00,
36255      &1.0451E+00,1.0887E+00,1.1514E+00,1.2146E+00,1.2936E+00,1.3711E+00,
36256      &1.4469E+00,1.5220E+00,1.5960E+00,1.6694E+00,1.7428E+00,1.8159E+00,
36257      &1.8894E+00,1.9620E+00,2.0344E+00,2.0313E+00,2.1357E+00,2.2333E+00,
36258      &2.3215E+00,2.4009E+00,2.4706E+00,2.5292E+00,2.5750E+00,2.6036E+00,
36259      &2.6096E+00,2.5783E+00,2.4673E+00,0.0000E+00,1.7269E+00,1.7065E+00/
36260       DATA (XDVF_L(K),K=  343,  456) /
36261      &1.6866E+00,1.6676E+00,1.6480E+00,1.6279E+00,1.6089E+00,1.5891E+00,
36262      &1.5701E+00,1.5502E+00,1.5307E+00,1.5113E+00,1.4910E+00,1.4799E+00,
36263      &1.4673E+00,1.4526E+00,1.4373E+00,1.4221E+00,1.4060E+00,1.3922E+00,
36264      &1.3771E+00,1.3596E+00,1.3414E+00,1.3234E+00,1.3045E+00,1.2879E+00,
36265      &1.2689E+00,1.2468E+00,1.2227E+00,1.1966E+00,1.1706E+00,1.1487E+00,
36266      &1.1248E+00,1.0980E+00,1.0724E+00,1.0495E+00,1.0310E+00,1.0212E+00,
36267      &1.0181E+00,1.0291E+00,1.0609E+00,1.1002E+00,1.1563E+00,1.2136E+00,
36268      &1.2840E+00,1.3528E+00,1.4201E+00,1.4854E+00,1.5492E+00,1.6125E+00,
36269      &1.6751E+00,1.7368E+00,1.7981E+00,1.8579E+00,1.9157E+00,1.9057E+00,
36270      &1.9875E+00,2.0577E+00,2.1190E+00,2.1700E+00,2.2094E+00,2.2370E+00,
36271      &2.2484E+00,2.2403E+00,2.2047E+00,2.1261E+00,1.9567E+00,0.0000E+00,
36272      &1.8047E+00,1.7833E+00,1.7626E+00,1.7418E+00,1.7220E+00,1.7009E+00,
36273      &1.6810E+00,1.6603E+00,1.6403E+00,1.6193E+00,1.5986E+00,1.5775E+00,
36274      &1.5570E+00,1.5441E+00,1.5309E+00,1.5156E+00,1.4991E+00,1.4828E+00,
36275      &1.4658E+00,1.4510E+00,1.4350E+00,1.4160E+00,1.3966E+00,1.3772E+00,
36276      &1.3565E+00,1.3386E+00,1.3184E+00,1.2942E+00,1.2680E+00,1.2404E+00,
36277      &1.2125E+00,1.1887E+00,1.1631E+00,1.1342E+00,1.1064E+00,1.0813E+00,
36278      &1.0608E+00,1.0480E+00,1.0426E+00,1.0500E+00,1.0774E+00,1.1111E+00,
36279      &1.1608E+00,1.2107E+00,1.2719E+00,1.3315E+00,1.3886E+00,1.4445E+00/
36280       DATA (XDVF_L(K),K=  457,  570) /
36281      &1.4984E+00,1.5505E+00,1.6020E+00,1.6524E+00,1.7009E+00,1.7480E+00,
36282      &1.7926E+00,1.7763E+00,1.8327E+00,1.8794E+00,1.9154E+00,1.9405E+00,
36283      &1.9531E+00,1.9537E+00,1.9362E+00,1.8986E+00,1.8325E+00,1.7203E+00,
36284      &1.5163E+00,0.0000E+00,1.8755E+00,1.8533E+00,1.8314E+00,1.8106E+00,
36285      &1.7890E+00,1.7672E+00,1.7464E+00,1.7248E+00,1.7038E+00,1.6817E+00,
36286      &1.6601E+00,1.6385E+00,1.6160E+00,1.6033E+00,1.5889E+00,1.5721E+00,
36287      &1.5552E+00,1.5380E+00,1.5199E+00,1.5042E+00,1.4871E+00,1.4670E+00,
36288      &1.4463E+00,1.4249E+00,1.4036E+00,1.3843E+00,1.3630E+00,1.3364E+00,
36289      &1.3086E+00,1.2791E+00,1.2500E+00,1.2245E+00,1.1971E+00,1.1662E+00,
36290      &1.1361E+00,1.1090E+00,1.0858E+00,1.0721E+00,1.0641E+00,1.0676E+00,
36291      &1.0898E+00,1.1195E+00,1.1627E+00,1.2069E+00,1.2603E+00,1.3118E+00,
36292      &1.3607E+00,1.4079E+00,1.4534E+00,1.4968E+00,1.5392E+00,1.5794E+00,
36293      &1.6181E+00,1.6552E+00,1.6888E+00,1.6690E+00,1.7073E+00,1.7353E+00,
36294      &1.7530E+00,1.7595E+00,1.7531E+00,1.7338E+00,1.6988E+00,1.6428E+00,
36295      &1.5583E+00,1.4293E+00,1.2136E+00,0.0000E+00,1.9470E+00,1.9238E+00,
36296      &1.9021E+00,1.8782E+00,1.8570E+00,1.8343E+00,1.8123E+00,1.7898E+00,
36297      &1.7680E+00,1.7449E+00,1.7222E+00,1.6994E+00,1.6760E+00,1.6624E+00,
36298      &1.6469E+00,1.6299E+00,1.6118E+00,1.5933E+00,1.5742E+00,1.5574E+00,
36299      &1.5392E+00,1.5179E+00,1.4955E+00,1.4738E+00,1.4506E+00,1.4300E+00/
36300       DATA (XDVF_L(K),K=  571,  684) /
36301      &1.4069E+00,1.3792E+00,1.3492E+00,1.3178E+00,1.2868E+00,1.2597E+00,
36302      &1.2307E+00,1.1976E+00,1.1654E+00,1.1363E+00,1.1108E+00,1.0945E+00,
36303      &1.0840E+00,1.0845E+00,1.1017E+00,1.1268E+00,1.1637E+00,1.2016E+00,
36304      &1.2473E+00,1.2910E+00,1.3324E+00,1.3719E+00,1.4090E+00,1.4450E+00,
36305      &1.4784E+00,1.5109E+00,1.5404E+00,1.5681E+00,1.5925E+00,1.5689E+00,
36306      &1.5916E+00,1.6043E+00,1.6067E+00,1.5981E+00,1.5779E+00,1.5449E+00,
36307      &1.4949E+00,1.4262E+00,1.3303E+00,1.1932E+00,9.7657E-01,0.0000E+00,
36308      &2.0122E+00,1.9881E+00,1.9640E+00,1.9418E+00,1.9190E+00,1.8954E+00,
36309      &1.8721E+00,1.8492E+00,1.8262E+00,1.8024E+00,1.7784E+00,1.7550E+00,
36310      &1.7300E+00,1.7157E+00,1.6999E+00,1.6818E+00,1.6627E+00,1.6435E+00,
36311      &1.6233E+00,1.6058E+00,1.5866E+00,1.5643E+00,1.5417E+00,1.5178E+00,
36312      &1.4926E+00,1.4705E+00,1.4465E+00,1.4174E+00,1.3856E+00,1.3527E+00,
36313      &1.3198E+00,1.2914E+00,1.2605E+00,1.2257E+00,1.1915E+00,1.1601E+00,
36314      &1.1326E+00,1.1142E+00,1.1016E+00,1.0982E+00,1.1114E+00,1.1321E+00,
36315      &1.1637E+00,1.1958E+00,1.2352E+00,1.2722E+00,1.3071E+00,1.3397E+00,
36316      &1.3704E+00,1.3995E+00,1.4267E+00,1.4516E+00,1.4736E+00,1.4942E+00,
36317      &1.5100E+00,1.4848E+00,1.4955E+00,1.4964E+00,1.4873E+00,1.4675E+00,
36318      &1.4366E+00,1.3933E+00,1.3349E+00,1.2585E+00,1.1565E+00,1.0171E+00,
36319      &8.0601E-01,0.0000E+00,2.0789E+00,2.0539E+00,2.0294E+00,2.0053E+00/
36320       DATA (XDVF_L(K),K=  685,  798) /
36321      &1.9820E+00,1.9581E+00,1.9336E+00,1.9096E+00,1.8860E+00,1.8609E+00,
36322      &1.8367E+00,1.8106E+00,1.7860E+00,1.7706E+00,1.7543E+00,1.7350E+00,
36323      &1.7150E+00,1.6945E+00,1.6735E+00,1.6550E+00,1.6349E+00,1.6112E+00,
36324      &1.5864E+00,1.5617E+00,1.5356E+00,1.5128E+00,1.4868E+00,1.4555E+00,
36325      &1.4224E+00,1.3876E+00,1.3532E+00,1.3231E+00,1.2904E+00,1.2536E+00,
36326      &1.2173E+00,1.1838E+00,1.1545E+00,1.1338E+00,1.1185E+00,1.1113E+00,
36327      &1.1199E+00,1.1362E+00,1.1627E+00,1.1895E+00,1.2222E+00,1.2529E+00,
36328      &1.2813E+00,1.3080E+00,1.3324E+00,1.3546E+00,1.3756E+00,1.3938E+00,
36329      &1.4103E+00,1.4232E+00,1.4319E+00,1.4055E+00,1.4052E+00,1.3959E+00,
36330      &1.3768E+00,1.3480E+00,1.3084E+00,1.2576E+00,1.1928E+00,1.1110E+00,
36331      &1.0066E+00,8.6804E-01,6.6615E-01,0.0000E+00,2.1434E+00,2.1178E+00,
36332      &2.0930E+00,2.0676E+00,2.0440E+00,2.0184E+00,1.9935E+00,1.9686E+00,
36333      &1.9439E+00,1.9179E+00,1.8915E+00,1.8663E+00,1.8400E+00,1.8239E+00,
36334      &1.8067E+00,1.7863E+00,1.7654E+00,1.7440E+00,1.7219E+00,1.7025E+00,
36335      &1.6814E+00,1.6565E+00,1.6311E+00,1.6045E+00,1.5766E+00,1.5526E+00,
36336      &1.5250E+00,1.4925E+00,1.4574E+00,1.4213E+00,1.3849E+00,1.3532E+00,
36337      &1.3191E+00,1.2800E+00,1.2418E+00,1.2062E+00,1.1743E+00,1.1517E+00,
36338      &1.1338E+00,1.1237E+00,1.1272E+00,1.1399E+00,1.1608E+00,1.1828E+00,
36339      &1.2092E+00,1.2341E+00,1.2570E+00,1.2774E+00,1.2962E+00,1.3135E+00/
36340       DATA (XDVF_L(K),K=  799,  912) /
36341      &1.3280E+00,1.3406E+00,1.3511E+00,1.3588E+00,1.3613E+00,1.3335E+00,
36342      &1.3246E+00,1.3067E+00,1.2801E+00,1.2441E+00,1.1985E+00,1.1418E+00,
36343      &1.0724E+00,9.8806E-01,8.8293E-01,7.4746E-01,5.5665E-01,0.0000E+00,
36344      &2.2035E+00,2.1769E+00,2.1514E+00,2.1259E+00,2.1000E+00,2.0743E+00,
36345      &2.0488E+00,2.0226E+00,1.9973E+00,1.9702E+00,1.9428E+00,1.9166E+00,
36346      &1.8890E+00,1.8729E+00,1.8548E+00,1.8337E+00,1.8116E+00,1.7895E+00,
36347      &1.7662E+00,1.7461E+00,1.7239E+00,1.6980E+00,1.6714E+00,1.6436E+00,
36348      &1.6146E+00,1.5889E+00,1.5604E+00,1.5266E+00,1.4895E+00,1.4515E+00,
36349      &1.4138E+00,1.3806E+00,1.3448E+00,1.3040E+00,1.2638E+00,1.2261E+00,
36350      &1.1920E+00,1.1669E+00,1.1469E+00,1.1341E+00,1.1335E+00,1.1420E+00,
36351      &1.1583E+00,1.1760E+00,1.1971E+00,1.2168E+00,1.2343E+00,1.2501E+00,
36352      &1.2640E+00,1.2762E+00,1.2866E+00,1.2942E+00,1.2996E+00,1.3020E+00,
36353      &1.3003E+00,1.2725E+00,1.2557E+00,1.2312E+00,1.1982E+00,1.1569E+00,
36354      &1.1068E+00,1.0465E+00,9.7460E-01,8.8884E-01,7.8459E-01,6.5333E-01,
36355      &4.7359E-01,0.0000E+00,2.2800E+00,2.2524E+00,2.2256E+00,2.1987E+00,
36356      &2.1730E+00,2.1459E+00,2.1192E+00,2.0922E+00,2.0656E+00,2.0374E+00,
36357      &2.0100E+00,1.9802E+00,1.9520E+00,1.9346E+00,1.9156E+00,1.8937E+00,
36358      &1.8706E+00,1.8475E+00,1.8228E+00,1.8017E+00,1.7783E+00,1.7509E+00,
36359      &1.7221E+00,1.6937E+00,1.6627E+00,1.6354E+00,1.6050E+00,1.5688E+00/
36360       DATA (XDVF_L(K),K=  913, 1026) /
36361      &1.5301E+00,1.4898E+00,1.4503E+00,1.4150E+00,1.3772E+00,1.3339E+00,
36362      &1.2911E+00,1.2510E+00,1.2138E+00,1.1866E+00,1.1637E+00,1.1458E+00,
36363      &1.1403E+00,1.1441E+00,1.1548E+00,1.1669E+00,1.1817E+00,1.1950E+00,
36364      &1.2065E+00,1.2163E+00,1.2249E+00,1.2313E+00,1.2355E+00,1.2379E+00,
36365      &1.2379E+00,1.2348E+00,1.2275E+00,1.1987E+00,1.1744E+00,1.1427E+00,
36366      &1.1035E+00,1.0570E+00,1.0018E+00,9.3862E-01,8.6494E-01,7.7913E-01,
36367      &6.7747E-01,5.5266E-01,3.8741E-01,0.0000E+00,2.3524E+00,2.3243E+00,
36368      &2.2963E+00,2.2689E+00,2.2420E+00,2.2137E+00,2.1858E+00,2.1579E+00,
36369      &2.1301E+00,2.1011E+00,2.0718E+00,2.0424E+00,2.0120E+00,1.9937E+00,
36370      &1.9743E+00,1.9509E+00,1.9267E+00,1.9020E+00,1.8763E+00,1.8541E+00,
36371      &1.8295E+00,1.8006E+00,1.7713E+00,1.7402E+00,1.7077E+00,1.6794E+00,
36372      &1.6475E+00,1.6087E+00,1.5679E+00,1.5259E+00,1.4840E+00,1.4470E+00,
36373      &1.4072E+00,1.3615E+00,1.3163E+00,1.2738E+00,1.2336E+00,1.2045E+00,
36374      &1.1783E+00,1.1563E+00,1.1459E+00,1.1457E+00,1.1504E+00,1.1577E+00,
36375      &1.1662E+00,1.1742E+00,1.1807E+00,1.1857E+00,1.1886E+00,1.1902E+00,
36376      &1.1899E+00,1.1878E+00,1.1830E+00,1.1751E+00,1.1633E+00,1.1345E+00,
36377      &1.1039E+00,1.0667E+00,1.0230E+00,9.7228E-01,9.1417E-01,8.4905E-01,
36378      &7.7478E-01,6.9004E-01,5.9155E-01,4.7371E-01,3.2191E-01,0.0000E+00,
36379      &2.4233E+00,2.3947E+00,2.3653E+00,2.3365E+00,2.3090E+00,2.2800E+00/
36380       DATA (XDVF_L(K),K= 1027, 1140) /
36381      &2.2512E+00,2.2220E+00,2.1934E+00,2.1628E+00,2.1319E+00,2.1007E+00,
36382      &2.0700E+00,2.0512E+00,2.0301E+00,2.0057E+00,1.9809E+00,1.9549E+00,
36383      &1.9281E+00,1.9049E+00,1.8791E+00,1.8497E+00,1.8175E+00,1.7854E+00,
36384      &1.7507E+00,1.7209E+00,1.6878E+00,1.6474E+00,1.6047E+00,1.5603E+00,
36385      &1.5164E+00,1.4777E+00,1.4358E+00,1.3879E+00,1.3403E+00,1.2952E+00,
36386      &1.2523E+00,1.2206E+00,1.1913E+00,1.1661E+00,1.1505E+00,1.1462E+00,
36387      &1.1460E+00,1.1481E+00,1.1518E+00,1.1545E+00,1.1559E+00,1.1562E+00,
36388      &1.1548E+00,1.1523E+00,1.1478E+00,1.1414E+00,1.1331E+00,1.1212E+00,
36389      &1.1055E+00,1.0763E+00,1.0405E+00,9.9877E-01,9.5130E-01,8.9815E-01,
36390      &8.3813E-01,7.7188E-01,6.9792E-01,6.1492E-01,5.2020E-01,4.0920E-01,
36391      &2.7020E-01,0.0000E+00,2.4906E+00,2.4607E+00,2.4307E+00,2.4014E+00,
36392      &2.3730E+00,2.3427E+00,2.3127E+00,2.2828E+00,2.2528E+00,2.2213E+00,
36393      &2.1903E+00,2.1577E+00,2.1250E+00,2.1053E+00,2.0839E+00,2.0583E+00,
36394      &2.0318E+00,2.0051E+00,1.9771E+00,1.9527E+00,1.9259E+00,1.8935E+00,
36395      &1.8607E+00,1.8269E+00,1.7917E+00,1.7606E+00,1.7253E+00,1.6833E+00,
36396      &1.6387E+00,1.5925E+00,1.5465E+00,1.5061E+00,1.4624E+00,1.4121E+00,
36397      &1.3623E+00,1.3152E+00,1.2700E+00,1.2349E+00,1.2036E+00,1.1745E+00,
36398      &1.1544E+00,1.1457E+00,1.1410E+00,1.1389E+00,1.1378E+00,1.1357E+00,
36399      &1.1332E+00,1.1290E+00,1.1244E+00,1.1176E+00,1.1099E+00,1.0996E+00/
36400       DATA (XDVF_L(K),K= 1141, 1254) /
36401      &1.0875E+00,1.0729E+00,1.0538E+00,1.0249E+00,9.8511E-01,9.3994E-01,
36402      &8.8948E-01,8.3410E-01,7.7332E-01,7.0681E-01,6.3377E-01,5.5280E-01,
36403      &4.6214E-01,3.5755E-01,2.2965E-01,0.0000E+00,2.5589E+00,2.5291E+00,
36404      &2.4979E+00,2.4676E+00,2.4370E+00,2.4060E+00,2.3753E+00,2.3443E+00,
36405      &2.3135E+00,2.2809E+00,2.2486E+00,2.2146E+00,2.1810E+00,2.1602E+00,
36406      &2.1376E+00,2.1114E+00,2.0841E+00,2.0557E+00,2.0265E+00,2.0011E+00,
36407      &1.9730E+00,1.9392E+00,1.9055E+00,1.8697E+00,1.8327E+00,1.8003E+00,
36408      &1.7635E+00,1.7197E+00,1.6727E+00,1.6246E+00,1.5770E+00,1.5346E+00,
36409      &1.4890E+00,1.4363E+00,1.3841E+00,1.3341E+00,1.2867E+00,1.2492E+00,
36410      &1.2151E+00,1.1824E+00,1.1578E+00,1.1451E+00,1.1356E+00,1.1298E+00,
36411      &1.1233E+00,1.1169E+00,1.1105E+00,1.1027E+00,1.0940E+00,1.0840E+00,
36412      &1.0726E+00,1.0592E+00,1.0444E+00,1.0265E+00,1.0045E+00,9.7613E-01,
36413      &9.3249E-01,8.8451E-01,8.3193E-01,7.7510E-01,7.1373E-01,6.4749E-01,
36414      &5.7554E-01,4.9725E-01,4.1072E-01,3.1254E-01,1.9551E-01,0.0000E+00,
36415      &2.6244E+00,2.5927E+00,2.5615E+00,2.5299E+00,2.4990E+00,2.4671E+00,
36416      &2.4356E+00,2.4034E+00,2.3717E+00,2.3377E+00,2.3034E+00,2.2689E+00,
36417      &2.2340E+00,2.2126E+00,2.1892E+00,2.1616E+00,2.1331E+00,2.1040E+00,
36418      &2.0736E+00,2.0471E+00,2.0180E+00,1.9830E+00,1.9472E+00,1.9112E+00,
36419      &1.8717E+00,1.8375E+00,1.7996E+00,1.7538E+00,1.7053E+00,1.6548E+00/
36420       DATA (XDVF_L(K),K= 1255, 1368) /
36421      &1.6053E+00,1.5612E+00,1.5138E+00,1.4590E+00,1.4045E+00,1.3516E+00,
36422      &1.3023E+00,1.2626E+00,1.2251E+00,1.1889E+00,1.1601E+00,1.1441E+00,
36423      &1.1302E+00,1.1201E+00,1.1098E+00,1.0996E+00,1.0888E+00,1.0782E+00,
36424      &1.0659E+00,1.0531E+00,1.0388E+00,1.0228E+00,1.0047E+00,9.8480E-01,
36425      &9.6040E-01,9.3234E-01,8.8589E-01,8.3563E-01,7.8162E-01,7.2366E-01,
36426      &6.6215E-01,5.9658E-01,5.2617E-01,4.5043E-01,3.6787E-01,2.7575E-01,
36427      &1.6826E-01,0.0000E+00,2.6886E+00,2.6564E+00,2.6234E+00,2.5908E+00,
36428      &2.5600E+00,2.5268E+00,2.4943E+00,2.4612E+00,2.4283E+00,2.3924E+00,
36429      &2.3582E+00,2.3219E+00,2.2860E+00,2.2642E+00,2.2394E+00,2.2113E+00,
36430      &2.1817E+00,2.1512E+00,2.1198E+00,2.0920E+00,2.0618E+00,2.0268E+00,
36431      &1.9890E+00,1.9503E+00,1.9098E+00,1.8739E+00,1.8343E+00,1.7867E+00,
36432      &1.7365E+00,1.6843E+00,1.6329E+00,1.5870E+00,1.5377E+00,1.4807E+00,
36433      &1.4239E+00,1.3692E+00,1.3169E+00,1.2751E+00,1.2350E+00,1.1954E+00,
36434      &1.1624E+00,1.1425E+00,1.1247E+00,1.1110E+00,1.0963E+00,1.0827E+00,
36435      &1.0687E+00,1.0547E+00,1.0396E+00,1.0240E+00,1.0070E+00,9.8853E-01,
36436      &9.6834E-01,9.4569E-01,9.1962E-01,8.9220E-01,8.4321E-01,7.9105E-01,
36437      &7.3592E-01,6.7777E-01,6.1620E-01,5.5143E-01,4.8272E-01,4.0962E-01,
36438      &3.3102E-01,2.4455E-01,1.4574E-01,0.0000E+00,2.7496E+00,2.7153E+00,
36439      &2.6835E+00,2.6504E+00,2.6180E+00,2.5834E+00,2.5502E+00,2.5161E+00/
36440       DATA (XDVF_L(K),K= 1369, 1482) /
36441      &2.4824E+00,2.4466E+00,2.4095E+00,2.3736E+00,2.3360E+00,2.3124E+00,
36442      &2.2875E+00,2.2580E+00,2.2274E+00,2.1960E+00,2.1631E+00,2.1347E+00,
36443      &2.1032E+00,2.0670E+00,2.0277E+00,1.9882E+00,1.9458E+00,1.9086E+00,
36444      &1.8675E+00,1.8179E+00,1.7658E+00,1.7122E+00,1.6586E+00,1.6112E+00,
36445      &1.5600E+00,1.5010E+00,1.4420E+00,1.3855E+00,1.3294E+00,1.2858E+00,
36446      &1.2435E+00,1.2006E+00,1.1641E+00,1.1410E+00,1.1193E+00,1.1023E+00,
36447      &1.0837E+00,1.0664E+00,1.0496E+00,1.0329E+00,1.0157E+00,9.9745E-01,
36448      &9.7803E-01,9.5735E-01,9.3539E-01,9.1075E-01,8.8302E-01,8.5608E-01,
36449      &8.0509E-01,7.5168E-01,6.9580E-01,6.3743E-01,5.7619E-01,5.1233E-01,
36450      &4.4547E-01,3.7496E-01,2.9995E-01,2.1862E-01,1.2745E-01,0.0000E+00,
36451      &2.8331E+00,2.7978E+00,2.7648E+00,2.7299E+00,2.6960E+00,2.6609E+00,
36452      &2.6263E+00,2.5910E+00,2.5561E+00,2.5197E+00,2.4802E+00,2.4424E+00,
36453      &2.4030E+00,2.3791E+00,2.3526E+00,2.3216E+00,2.2897E+00,2.2570E+00,
36454      &2.2225E+00,2.1925E+00,2.1595E+00,2.1199E+00,2.0799E+00,2.0383E+00,
36455      &1.9938E+00,1.9551E+00,1.9121E+00,1.8601E+00,1.8054E+00,1.7494E+00,
36456      &1.6932E+00,1.6435E+00,1.5898E+00,1.5280E+00,1.4659E+00,1.4056E+00,
36457      &1.3471E+00,1.3010E+00,1.2550E+00,1.2078E+00,1.1652E+00,1.1383E+00,
36458      &1.1114E+00,1.0902E+00,1.0668E+00,1.0451E+00,1.0248E+00,1.0039E+00,
36459      &9.8353E-01,9.6205E-01,9.4076E-01,9.1705E-01,8.9229E-01,8.6577E-01/
36460       DATA (XDVF_L(K),K= 1483, 1596) /
36461      &8.3604E-01,8.0985E-01,7.5687E-01,7.0190E-01,6.4516E-01,5.8700E-01,
36462      &5.2660E-01,4.6452E-01,3.9995E-01,3.3310E-01,2.6289E-01,1.8826E-01,
36463      &1.0655E-01,0.0000E+00,2.9096E+00,2.8732E+00,2.8390E+00,2.8027E+00,
36464      &2.7690E+00,2.7325E+00,2.6961E+00,2.6597E+00,2.6231E+00,2.5833E+00,
36465      &2.5456E+00,2.5047E+00,2.4650E+00,2.4391E+00,2.4120E+00,2.3799E+00,
36466      &2.3462E+00,2.3123E+00,2.2763E+00,2.2451E+00,2.2108E+00,2.1692E+00,
36467      &2.1276E+00,2.0835E+00,2.0378E+00,1.9974E+00,1.9525E+00,1.8983E+00,
36468      &1.8413E+00,1.7827E+00,1.7243E+00,1.6725E+00,1.6166E+00,1.5520E+00,
36469      &1.4872E+00,1.4244E+00,1.3627E+00,1.3136E+00,1.2649E+00,1.2130E+00,
36470      &1.1663E+00,1.1352E+00,1.1040E+00,1.0787E+00,1.0514E+00,1.0264E+00,
36471      &1.0021E+00,9.7883E-01,9.5548E-01,9.3171E-01,9.0763E-01,8.8283E-01,
36472      &8.5596E-01,8.2732E-01,7.9601E-01,7.7056E-01,7.1598E-01,6.6027E-01,
36473      &6.0340E-01,5.4514E-01,4.8601E-01,4.2556E-01,3.6359E-01,2.9984E-01,
36474      &2.3396E-01,1.6486E-01,9.0844E-02,0.0000E+00,2.9880E+00,2.9510E+00,
36475      &2.9150E+00,2.8782E+00,2.8430E+00,2.8048E+00,2.7677E+00,2.7301E+00,
36476      &2.6924E+00,2.6517E+00,2.6110E+00,2.5696E+00,2.5280E+00,2.5017E+00,
36477      &2.4728E+00,2.4393E+00,2.4042E+00,2.3687E+00,2.3313E+00,2.2988E+00,
36478      &2.2631E+00,2.2204E+00,2.1768E+00,2.1312E+00,2.0828E+00,2.0405E+00,
36479      &1.9928E+00,1.9364E+00,1.8772E+00,1.8164E+00,1.7558E+00,1.7018E+00/
36480       DATA (XDVF_L(K),K= 1597, 1710) /
36481      &1.6434E+00,1.5762E+00,1.5084E+00,1.4432E+00,1.3783E+00,1.3261E+00,
36482      &1.2741E+00,1.2182E+00,1.1669E+00,1.1315E+00,1.0961E+00,1.0671E+00,
36483      &1.0360E+00,1.0071E+00,9.7992E-01,9.5371E-01,9.2801E-01,9.0200E-01,
36484      &8.7588E-01,8.4862E-01,8.2038E-01,7.9020E-01,7.5770E-01,7.3298E-01,
36485      &6.7721E-01,6.2090E-01,5.6394E-01,5.0631E-01,4.4841E-01,3.8970E-01,
36486      &3.3019E-01,2.6973E-01,2.0791E-01,1.4420E-01,7.7416E-02,0.0000E+00,
36487      &3.0661E+00,3.0288E+00,2.9911E+00,2.9537E+00,2.9160E+00,2.8778E+00,
36488      &2.8392E+00,2.8000E+00,2.7610E+00,2.7200E+00,2.6782E+00,2.6345E+00,
36489      &2.5900E+00,2.5625E+00,2.5329E+00,2.4982E+00,2.4617E+00,2.4247E+00,
36490      &2.3857E+00,2.3518E+00,2.3145E+00,2.2697E+00,2.2245E+00,2.1764E+00,
36491      &2.1269E+00,2.0819E+00,2.0331E+00,1.9746E+00,1.9126E+00,1.8497E+00,
36492      &1.7862E+00,1.7303E+00,1.6696E+00,1.5995E+00,1.5285E+00,1.4608E+00,
36493      &1.3929E+00,1.3377E+00,1.2826E+00,1.2228E+00,1.1669E+00,1.1279E+00,
36494      &1.0882E+00,1.0555E+00,1.0205E+00,9.8876E-01,9.5876E-01,9.2969E-01,
36495      &9.0171E-01,8.7356E-01,8.4551E-01,8.1668E-01,7.8701E-01,7.5564E-01,
36496      &7.2196E-01,6.9797E-01,6.4121E-01,5.8469E-01,5.2810E-01,4.7131E-01,
36497      &4.1460E-01,3.5783E-01,3.0063E-01,2.4338E-01,1.8544E-01,1.2660E-01,
36498      &6.6270E-02,0.0000E+00,3.1379E+00,3.0995E+00,3.0600E+00,3.0213E+00,
36499      &2.9840E+00,2.9442E+00,2.9047E+00,2.8641E+00,2.8239E+00,2.7813E+00/
36500       DATA (XDVF_L(K),K= 1711, 1824) /
36501      &2.7383E+00,2.6928E+00,2.6470E+00,2.6191E+00,2.5880E+00,2.5519E+00,
36502      &2.5145E+00,2.4761E+00,2.4357E+00,2.4004E+00,2.3615E+00,2.3153E+00,
36503      &2.2678E+00,2.2180E+00,2.1669E+00,2.1208E+00,2.0699E+00,2.0087E+00,
36504      &1.9447E+00,1.8795E+00,1.8139E+00,1.7558E+00,1.6930E+00,1.6205E+00,
36505      &1.5467E+00,1.4759E+00,1.4054E+00,1.3484E+00,1.2895E+00,1.2267E+00,
36506      &1.1663E+00,1.1242E+00,1.0808E+00,1.0449E+00,1.0065E+00,9.7194E-01,
36507      &9.3967E-01,9.0840E-01,8.7834E-01,8.4891E-01,8.1928E-01,7.8930E-01,
36508      &7.5803E-01,7.2562E-01,6.9124E-01,6.6796E-01,6.1058E-01,5.5392E-01,
36509      &4.9752E-01,4.4176E-01,3.8633E-01,3.3127E-01,2.7648E-01,2.2186E-01,
36510      &1.6735E-01,1.1268E-01,5.7652E-02,0.0000E+00,3.2129E+00,3.1726E+00,
36511      &3.1325E+00,3.0928E+00,3.0540E+00,3.0127E+00,2.9717E+00,2.9303E+00,
36512      &2.8887E+00,2.8449E+00,2.8001E+00,2.7537E+00,2.7060E+00,2.6766E+00,
36513      &2.6453E+00,2.6073E+00,2.5683E+00,2.5286E+00,2.4866E+00,2.4501E+00,
36514      &2.4107E+00,2.3628E+00,2.3125E+00,2.2620E+00,2.2079E+00,2.1597E+00,
36515      &2.1067E+00,2.0440E+00,1.9778E+00,1.9097E+00,1.8421E+00,1.7819E+00,
36516      &1.7169E+00,1.6416E+00,1.5664E+00,1.4922E+00,1.4189E+00,1.3583E+00,
36517      &1.2971E+00,1.2300E+00,1.1652E+00,1.1200E+00,1.0729E+00,1.0343E+00,
36518      &9.9254E-01,9.5513E-01,9.2006E-01,8.8711E-01,8.5555E-01,8.2426E-01,
36519      &7.9305E-01,7.6193E-01,7.2963E-01,6.9636E-01,6.6128E-01,6.3868E-01/
36520       DATA (XDVF_L(K),K= 1825, 1836) /
36521      &5.8093E-01,5.2428E-01,4.6858E-01,4.1372E-01,3.5972E-01,3.0648E-01,
36522      &2.5392E-01,2.0208E-01,1.5083E-01,1.0018E-01,5.0068E-02,0.0000E+00/
36523       DATA (XDEF_L(K),K=    1,  114) /
36524      &4.3007E-01,4.2474E-01,4.1967E-01,4.1458E-01,4.0970E-01,4.0443E-01,
36525      &3.9925E-01,3.9397E-01,3.8864E-01,3.8302E-01,3.7707E-01,3.7100E-01,
36526      &3.6470E-01,3.6080E-01,3.5639E-01,3.5109E-01,3.4531E-01,3.3914E-01,
36527      &3.3238E-01,3.2609E-01,3.1913E-01,3.1062E-01,3.0152E-01,2.9176E-01,
36528      &2.8100E-01,2.7114E-01,2.5952E-01,2.4467E-01,2.2784E-01,2.0937E-01,
36529      &1.9117E-01,1.7470E-01,1.5685E-01,1.3678E-01,1.1825E-01,1.0349E-01,
36530      &9.4854E-02,9.5054E-02,1.0589E-01,1.3527E-01,1.8584E-01,2.3426E-01,
36531      &2.9021E-01,3.3527E-01,3.7670E-01,4.0255E-01,4.1326E-01,4.0880E-01,
36532      &3.8831E-01,3.5045E-01,2.9287E-01,2.1298E-01,1.0773E-01,0.0000E+00,
36533      &0.0000E+00,2.0644E-01,1.5422E-01,1.0950E-01,7.3614E-02,4.6726E-02,
36534      &2.7433E-02,1.4144E-02,6.5080E-03,2.4719E-03,0.0000E+00,0.0000E+00,
36535      &0.0000E+00,0.0000E+00,4.4398E-01,4.3864E-01,4.3346E-01,4.2809E-01,
36536      &4.2290E-01,4.1747E-01,4.1205E-01,4.0650E-01,4.0098E-01,3.9480E-01,
36537      &3.8873E-01,3.8226E-01,3.7560E-01,3.7145E-01,3.6678E-01,3.6108E-01,
36538      &3.5488E-01,3.4833E-01,3.4123E-01,3.3464E-01,3.2718E-01,3.1811E-01,
36539      &3.0838E-01,2.9811E-01,2.8670E-01,2.7630E-01,2.6412E-01,2.4861E-01,
36540      &2.3110E-01,2.1209E-01,1.9355E-01,1.7681E-01,1.5878E-01,1.3870E-01,
36541      &1.2044E-01,1.0620E-01,9.8341E-02,9.9345E-02,1.1086E-01,1.4055E-01,
36542      &1.9033E-01,2.3696E-01,2.8983E-01,3.3137E-01,3.6834E-01,3.8982E-01/
36543       DATA (XDEF_L(K),K=  115,  228) /
36544      &3.9672E-01,3.8896E-01,3.6609E-01,3.2678E-01,2.6933E-01,1.9181E-01,
36545      &9.1683E-02,0.0000E+00,0.0000E+00,1.8955E-01,1.4041E-01,9.8873E-02,
36546      &6.5928E-02,4.1462E-02,2.3905E-02,1.2324E-02,5.6113E-03,2.1050E-03,
36547      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,4.5980E-01,4.5420E-01,
36548      &4.4884E-01,4.4319E-01,4.3780E-01,4.3208E-01,4.2642E-01,4.2053E-01,
36549      &4.1457E-01,4.0824E-01,4.0181E-01,3.9484E-01,3.8780E-01,3.8328E-01,
36550      &3.7831E-01,3.7223E-01,3.6559E-01,3.5853E-01,3.5072E-01,3.4400E-01,
36551      &3.3590E-01,3.2633E-01,3.1598E-01,3.0508E-01,2.9301E-01,2.8197E-01,
36552      &2.6915E-01,2.5289E-01,2.3470E-01,2.1511E-01,1.9623E-01,1.7918E-01,
36553      &1.6098E-01,1.4092E-01,1.2294E-01,1.0928E-01,1.0224E-01,1.0401E-01,
36554      &1.1623E-01,1.4620E-01,1.9488E-01,2.3948E-01,2.8894E-01,3.2681E-01,
36555      &3.5905E-01,3.7613E-01,3.7908E-01,3.6817E-01,3.4299E-01,3.0266E-01,
36556      &2.4596E-01,1.7115E-01,7.6792E-02,0.0000E+00,0.0000E+00,1.7267E-01,
36557      &1.2670E-01,8.8446E-02,5.8458E-02,3.6380E-02,2.0551E-02,1.0608E-02,
36558      &4.7732E-03,1.7670E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36559      &4.7845E-01,4.7258E-01,4.6687E-01,4.6107E-01,4.5540E-01,4.4938E-01,
36560      &4.4336E-01,4.3728E-01,4.3070E-01,4.2403E-01,4.1702E-01,4.0968E-01,
36561      &4.0210E-01,3.9723E-01,3.9181E-01,3.8522E-01,3.7808E-01,3.7047E-01,
36562      &3.6211E-01,3.5469E-01,3.4619E-01,3.3582E-01,3.2478E-01,3.1314E-01/
36563       DATA (XDEF_L(K),K=  229,  342) /
36564      &3.0021E-01,2.8848E-01,2.7488E-01,2.5781E-01,2.3886E-01,2.1865E-01,
36565      &1.9932E-01,1.8196E-01,1.6359E-01,1.4359E-01,1.2596E-01,1.1295E-01,
36566      &1.0678E-01,1.0933E-01,1.2234E-01,1.5242E-01,1.9969E-01,2.4187E-01,
36567      &2.8742E-01,3.2112E-01,3.4825E-01,3.6067E-01,3.5959E-01,3.4546E-01,
36568      &3.1813E-01,2.7719E-01,2.2151E-01,1.5037E-01,6.2862E-02,0.0000E+00,
36569      &0.0000E+00,1.5516E-01,1.1270E-01,7.7856E-02,5.0916E-02,3.1337E-02,
36570      &1.7279E-02,8.9355E-03,3.9672E-03,1.4465E-03,0.0000E+00,0.0000E+00,
36571      &0.0000E+00,0.0000E+00,5.0059E-01,4.9450E-01,4.8826E-01,4.8213E-01,
36572      &4.7610E-01,4.6972E-01,4.6326E-01,4.5655E-01,4.4999E-01,4.4265E-01,
36573      &4.3505E-01,4.2703E-01,4.1870E-01,4.1345E-01,4.0758E-01,4.0034E-01,
36574      &3.9260E-01,3.8434E-01,3.7539E-01,3.6725E-01,3.5804E-01,3.4696E-01,
36575      &3.3492E-01,3.2231E-01,3.0852E-01,2.9601E-01,2.8154E-01,2.6348E-01,
36576      &2.4363E-01,2.2272E-01,2.0295E-01,1.8526E-01,1.6669E-01,1.4678E-01,
36577      &1.2956E-01,1.1726E-01,1.1212E-01,1.1548E-01,1.2910E-01,1.5906E-01,
36578      &2.0458E-01,2.4395E-01,2.8508E-01,3.1418E-01,3.3593E-01,3.4343E-01,
36579      &3.3827E-01,3.2104E-01,2.9189E-01,2.5067E-01,1.9688E-01,1.3016E-01,
36580      &5.0498E-02,0.0000E+00,0.0000E+00,1.3742E-01,9.8602E-02,6.7357E-02,
36581      &4.3555E-02,2.6444E-02,1.4175E-02,7.3561E-03,3.2181E-03,1.1530E-03,
36582      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.2114E-01,5.1454E-01/
36583       DATA (XDEF_L(K),K=  343,  456) /
36584      &5.0806E-01,5.0160E-01,4.9520E-01,4.8843E-01,4.8165E-01,4.7456E-01,
36585      &4.6738E-01,4.5962E-01,4.5149E-01,4.4293E-01,4.3400E-01,4.2833E-01,
36586      &4.2194E-01,4.1420E-01,4.0580E-01,3.9678E-01,3.8741E-01,3.7848E-01,
36587      &3.6878E-01,3.5682E-01,3.4416E-01,3.3062E-01,3.1602E-01,3.0269E-01,
36588      &2.8749E-01,2.6857E-01,2.4798E-01,2.2641E-01,2.0626E-01,1.8828E-01,
36589      &1.6960E-01,1.4976E-01,1.3293E-01,1.2126E-01,1.1684E-01,1.2099E-01,
36590      &1.3505E-01,1.6471E-01,2.0841E-01,2.4521E-01,2.8248E-01,3.0770E-01,
36591      &3.2484E-01,3.2845E-01,3.1999E-01,3.0047E-01,2.7030E-01,2.2924E-01,
36592      &1.7739E-01,1.1482E-01,4.2174E-02,0.0000E+00,0.0000E+00,1.2330E-01,
36593      &8.7586E-02,5.9211E-02,3.7890E-02,2.2733E-02,1.1877E-02,6.1865E-03,
36594      &2.6713E-03,9.4247E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36595      &5.4423E-01,5.3740E-01,5.3068E-01,5.2385E-01,5.1700E-01,5.0982E-01,
36596      &5.0256E-01,4.9509E-01,4.8731E-01,4.7895E-01,4.7023E-01,4.6094E-01,
36597      &4.5130E-01,4.4506E-01,4.3820E-01,4.2973E-01,4.2069E-01,4.1108E-01,
36598      &4.0069E-01,3.9131E-01,3.8063E-01,3.6796E-01,3.5430E-01,3.3991E-01,
36599      &3.2433E-01,3.1014E-01,2.9407E-01,2.7418E-01,2.5281E-01,2.3056E-01,
36600      &2.0999E-01,1.9171E-01,1.7291E-01,1.5321E-01,1.3677E-01,1.2578E-01,
36601      &1.2220E-01,1.2696E-01,1.4132E-01,1.7056E-01,2.1212E-01,2.4603E-01,
36602      &2.7912E-01,3.0023E-01,3.1274E-01,3.1234E-01,3.0087E-01,2.7925E-01/
36603       DATA (XDEF_L(K),K=  457,  570) /
36604      &2.4820E-01,2.0782E-01,1.5841E-01,1.0056E-01,3.5470E-02,0.0000E+00,
36605      &0.0000E+00,1.0941E-01,7.6864E-02,5.1391E-02,3.2506E-02,1.9250E-02,
36606      &9.7741E-03,5.1192E-03,2.1775E-03,0.0000E+00,0.0000E+00,0.0000E+00,
36607      &0.0000E+00,0.0000E+00,5.6542E-01,5.5814E-01,5.5101E-01,5.4385E-01,
36608      &5.3670E-01,5.2913E-01,5.2140E-01,5.1352E-01,5.0533E-01,4.9639E-01,
36609      &4.8702E-01,4.7710E-01,4.6670E-01,4.6011E-01,4.5270E-01,4.4365E-01,
36610      &4.3394E-01,4.2383E-01,4.1271E-01,4.0253E-01,3.9137E-01,3.7783E-01,
36611      &3.6325E-01,3.4810E-01,3.3163E-01,3.1674E-01,2.9988E-01,2.7922E-01,
36612      &2.5706E-01,2.3429E-01,2.1333E-01,1.9484E-01,1.7592E-01,1.5634E-01,
36613      &1.4028E-01,1.2985E-01,1.2692E-01,1.3218E-01,1.4678E-01,1.7535E-01,
36614      &2.1492E-01,2.4628E-01,2.7582E-01,2.9349E-01,3.0215E-01,2.9865E-01,
36615      &2.8479E-01,2.6176E-01,2.3025E-01,1.9073E-01,1.4372E-01,9.0030E-02,
36616      &3.1431E-02,0.0000E+00,0.0000E+00,9.8561E-02,6.8571E-02,4.5400E-02,
36617      &2.8439E-02,1.6650E-02,8.2414E-03,4.3377E-03,1.8226E-03,0.0000E+00,
36618      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,5.8660E-01,5.7912E-01,
36619      &5.7170E-01,5.6412E-01,5.5660E-01,5.4858E-01,5.4040E-01,5.3194E-01,
36620      &5.2336E-01,5.1383E-01,5.0381E-01,4.9326E-01,4.8220E-01,4.7515E-01,
36621      &4.6719E-01,4.5756E-01,4.4719E-01,4.3619E-01,4.2441E-01,4.1376E-01,
36622      &4.0188E-01,3.8750E-01,3.7220E-01,3.5617E-01,3.3884E-01,3.2317E-01/
36623       DATA (XDEF_L(K),K=  571,  684) /
36624      &3.0561E-01,2.8413E-01,2.6132E-01,2.3801E-01,2.1667E-01,1.9794E-01,
36625      &1.7898E-01,1.5951E-01,1.4381E-01,1.3395E-01,1.3154E-01,1.3722E-01,
36626      &1.5183E-01,1.7978E-01,2.1726E-01,2.4615E-01,2.7227E-01,2.8668E-01,
36627      &2.9185E-01,2.8560E-01,2.6981E-01,2.4566E-01,2.1405E-01,1.7560E-01,
36628      &1.3093E-01,8.1317E-02,2.8821E-02,0.0000E+00,0.0000E+00,8.9016E-02,
36629      &6.1335E-02,4.0241E-02,2.4960E-02,1.4451E-02,6.9787E-03,3.6912E-03,
36630      &1.5320E-03,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36631      &6.0621E-01,5.9821E-01,5.9043E-01,5.8253E-01,5.7470E-01,5.6625E-01,
36632      &5.5768E-01,5.4870E-01,5.3948E-01,5.2962E-01,5.1919E-01,5.0796E-01,
36633      &4.9620E-01,4.8867E-01,4.8027E-01,4.7003E-01,4.5907E-01,4.4740E-01,
36634      &4.3484E-01,4.2392E-01,4.1127E-01,3.9627E-01,3.8010E-01,3.6326E-01,
36635      &3.4524E-01,3.2900E-01,3.1064E-01,2.8853E-01,2.6510E-01,2.4135E-01,
36636      &2.1970E-01,2.0080E-01,1.8175E-01,1.6242E-01,1.4701E-01,1.3753E-01,
36637      &1.3572E-01,1.4160E-01,1.5623E-01,1.8343E-01,2.1902E-01,2.4571E-01,
36638      &2.6885E-01,2.8059E-01,2.8292E-01,2.7441E-01,2.5704E-01,2.3223E-01,
36639      &2.0062E-01,1.6317E-01,1.2079E-01,7.4733E-02,2.7461E-02,0.0000E+00,
36640      &0.0000E+00,8.1334E-02,5.5577E-02,3.6150E-02,2.2243E-02,1.2749E-02,
36641      &6.0264E-03,3.2009E-03,1.3143E-03,0.0000E+00,0.0000E+00,0.0000E+00,
36642      &0.0000E+00,0.0000E+00,6.2581E-01,6.1778E-01,6.0953E-01,6.0134E-01/
36643       DATA (XDEF_L(K),K=  685,  798) /
36644      &5.9310E-01,5.8428E-01,5.7523E-01,5.6587E-01,5.5625E-01,5.4565E-01,
36645      &5.3457E-01,5.2280E-01,5.1030E-01,5.0236E-01,4.9350E-01,4.8267E-01,
36646      &4.7104E-01,4.5899E-01,4.4560E-01,4.3381E-01,4.2066E-01,4.0485E-01,
36647      &3.8801E-01,3.7047E-01,3.5165E-01,3.3476E-01,3.1574E-01,2.9293E-01,
36648      &2.6889E-01,2.4469E-01,2.2279E-01,2.0369E-01,1.8458E-01,1.6537E-01,
36649      &1.5025E-01,1.4125E-01,1.3980E-01,1.4589E-01,1.6046E-01,1.8686E-01,
36650      &2.2052E-01,2.4502E-01,2.6530E-01,2.7444E-01,2.7406E-01,2.6361E-01,
36651      &2.4491E-01,2.1954E-01,1.8819E-01,1.5193E-01,1.1170E-01,6.9146E-02,
36652      &2.6829E-02,0.0000E+00,0.0000E+00,7.4387E-02,5.0398E-02,3.2529E-02,
36653      &1.9840E-02,1.1260E-02,5.2109E-03,2.7796E-03,1.1291E-03,0.0000E+00,
36654      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,6.4510E-01,6.3663E-01,
36655      &6.2809E-01,6.1948E-01,6.1090E-01,6.0165E-01,5.9256E-01,5.8263E-01,
36656      &5.7237E-01,5.6121E-01,5.4960E-01,5.3710E-01,5.2390E-01,5.1555E-01,
36657      &5.0615E-01,4.9474E-01,4.8273E-01,4.6980E-01,4.5603E-01,4.4343E-01,
36658      &4.2983E-01,4.1325E-01,3.9561E-01,3.7731E-01,3.5765E-01,3.4017E-01,
36659      &3.2063E-01,2.9709E-01,2.7258E-01,2.4795E-01,2.2572E-01,2.0647E-01,
36660      &1.8735E-01,1.6824E-01,1.5339E-01,1.4470E-01,1.4366E-01,1.4990E-01,
36661      &1.6437E-01,1.8986E-01,2.2169E-01,2.4408E-01,2.6175E-01,2.6863E-01,
36662      &2.6585E-01,2.5363E-01,2.3397E-01,2.0813E-01,1.7714E-01,1.4205E-01/
36663       DATA (XDEF_L(K),K=  799,  912) /
36664      &1.0396E-01,6.4602E-02,2.6785E-02,0.0000E+00,0.0000E+00,6.8343E-02,
36665      &4.5962E-02,2.9434E-02,1.7812E-02,1.0015E-02,4.5458E-03,2.4331E-03,
36666      &9.7866E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36667      &6.6281E-01,6.5407E-01,6.4523E-01,6.3631E-01,6.2740E-01,6.1775E-01,
36668      &6.0821E-01,5.9770E-01,5.8724E-01,5.7535E-01,5.6321E-01,5.5021E-01,
36669      &5.3640E-01,5.2763E-01,5.1775E-01,5.0583E-01,4.9310E-01,4.7946E-01,
36670      &4.6520E-01,4.5225E-01,4.3811E-01,4.2074E-01,4.0247E-01,3.8355E-01,
36671      &3.6315E-01,3.4516E-01,3.2502E-01,3.0091E-01,2.7589E-01,2.5090E-01,
36672      &2.2842E-01,2.0903E-01,1.8987E-01,1.7087E-01,1.5631E-01,1.4790E-01,
36673      &1.4709E-01,1.5345E-01,1.6771E-01,1.9243E-01,2.2253E-01,2.4307E-01,
36674      &2.5846E-01,2.6327E-01,2.5857E-01,2.4493E-01,2.2441E-01,1.9832E-01,
36675      &1.6773E-01,1.3380E-01,9.7606E-02,6.1077E-02,2.7123E-02,4.1687E-04,
36676      &0.0000E+00,6.3316E-02,4.2290E-02,2.6899E-02,1.6166E-02,9.0143E-03,
36677      &4.0214E-03,2.1587E-03,8.6042E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36678      &0.0000E+00,0.0000E+00,6.8558E-01,6.7623E-01,6.6716E-01,6.5776E-01,
36679      &6.4840E-01,6.3825E-01,6.2778E-01,6.1697E-01,6.0589E-01,5.9350E-01,
36680      &5.8071E-01,5.6677E-01,5.5220E-01,5.4293E-01,5.3246E-01,5.1980E-01,
36681      &5.0630E-01,4.9221E-01,4.7690E-01,4.6348E-01,4.4839E-01,4.3024E-01,
36682      &4.1112E-01,3.9125E-01,3.7016E-01,3.5134E-01,3.3054E-01,3.0571E-01/
36683       DATA (XDEF_L(K),K=  913, 1026) /
36684      &2.8005E-01,2.5463E-01,2.3186E-01,2.1230E-01,1.9311E-01,1.7422E-01,
36685      &1.5985E-01,1.5187E-01,1.5138E-01,1.5783E-01,1.7178E-01,1.9543E-01,
36686      &2.2331E-01,2.4162E-01,2.5415E-01,2.5666E-01,2.4964E-01,2.3438E-01,
36687      &2.1293E-01,1.8681E-01,1.5680E-01,1.2430E-01,9.0488E-02,5.7352E-02,
36688      &2.7942E-02,7.0995E-03,2.4780E-03,5.7612E-02,3.8138E-02,2.4057E-02,
36689      &1.4329E-02,7.9111E-03,3.4566E-03,1.8603E-03,7.3347E-04,0.0000E+00,
36690      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.0709E-01,6.9744E-01,
36691      &6.8784E-01,6.7803E-01,6.6830E-01,6.5763E-01,6.4678E-01,6.3540E-01,
36692      &6.2360E-01,6.1071E-01,5.9715E-01,5.8240E-01,5.6710E-01,5.5722E-01,
36693      &5.4625E-01,5.3291E-01,5.1856E-01,5.0380E-01,4.8797E-01,4.7363E-01,
36694      &4.5801E-01,4.3900E-01,4.1917E-01,3.9846E-01,3.7656E-01,3.5717E-01,
36695      &3.3564E-01,3.1017E-01,2.8397E-01,2.5816E-01,2.3508E-01,2.1538E-01,
36696      &1.9615E-01,1.7737E-01,1.6324E-01,1.5559E-01,1.5535E-01,1.6175E-01,
36697      &1.7537E-01,1.9793E-01,2.2384E-01,2.4005E-01,2.5009E-01,2.5051E-01,
36698      &2.4150E-01,2.2495E-01,2.0291E-01,1.7668E-01,1.4739E-01,1.1625E-01,
36699      &8.4583E-02,5.4470E-02,2.9013E-02,1.3147E-02,1.4553E-02,5.2777E-02,
36700      &3.4672E-02,2.1686E-02,1.2821E-02,7.0105E-03,3.0093E-03,1.6226E-03,
36701      &6.3321E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36702      &7.2796E-01,7.1795E-01,7.0799E-01,6.9776E-01,6.8760E-01,6.7649E-01/
36703       DATA (XDEF_L(K),K= 1027, 1140) /
36704      &6.6523E-01,6.5299E-01,6.4099E-01,6.2720E-01,6.1289E-01,5.9763E-01,
36705      &5.8140E-01,5.7108E-01,5.5954E-01,5.4555E-01,5.3082E-01,5.1501E-01,
36706      &4.9841E-01,4.8352E-01,4.6718E-01,4.4758E-01,4.2678E-01,4.0543E-01,
36707      &3.8267E-01,3.6267E-01,3.4052E-01,3.1445E-01,2.8771E-01,2.6154E-01,
36708      &2.3817E-01,2.1835E-01,1.9910E-01,1.8043E-01,1.6662E-01,1.5905E-01,
36709      &1.5900E-01,1.6548E-01,1.7871E-01,2.0015E-01,2.2403E-01,2.3835E-01,
36710      &2.4610E-01,2.4469E-01,2.3394E-01,2.1634E-01,1.9372E-01,1.6761E-01,
36711      &1.3910E-01,1.0920E-01,7.9530E-02,5.2165E-02,3.0250E-02,1.8723E-02,
36712      &2.5275E-02,4.8575E-02,3.1676E-02,1.9677E-02,1.1540E-02,6.2533E-03,
36713      &2.6411E-03,1.4253E-03,5.5072E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36714      &0.0000E+00,0.0000E+00,7.4788E-01,7.3751E-01,7.2708E-01,7.1644E-01,
36715      &7.0580E-01,6.9430E-01,6.8256E-01,6.6975E-01,6.5712E-01,6.4276E-01,
36716      &6.2791E-01,6.1180E-01,5.9490E-01,5.8409E-01,5.7199E-01,5.5739E-01,
36717      &5.4166E-01,5.2544E-01,5.0821E-01,4.9288E-01,4.7590E-01,4.5544E-01,
36718      &4.3393E-01,4.1178E-01,3.8837E-01,3.6775E-01,3.4513E-01,3.1844E-01,
36719      &2.9125E-01,2.6472E-01,2.4110E-01,2.2115E-01,2.0189E-01,1.8330E-01,
36720      &1.6955E-01,1.6237E-01,1.6243E-01,1.6875E-01,1.8164E-01,2.0201E-01,
36721      &2.2410E-01,2.3665E-01,2.4236E-01,2.3927E-01,2.2710E-01,2.0852E-01,
36722      &1.8563E-01,1.5962E-01,1.3170E-01,1.0314E-01,7.5292E-02,5.0347E-02/
36723       DATA (XDEF_L(K),K= 1141, 1254) /
36724      &3.1513E-02,2.3688E-02,3.4520E-02,4.4988E-02,2.9140E-02,1.7975E-02,
36725      &1.0472E-02,5.6268E-03,2.3442E-03,1.2646E-03,4.8432E-04,0.0000E+00,
36726      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,7.6812E-01,7.5731E-01,
36727      &7.4653E-01,7.3551E-01,7.2440E-01,7.1234E-01,6.9989E-01,6.8692E-01,
36728      &6.7357E-01,6.5855E-01,6.4312E-01,6.2624E-01,6.0850E-01,5.9719E-01,
36729      &5.8457E-01,5.6934E-01,5.5297E-01,5.3626E-01,5.1802E-01,5.0223E-01,
36730      &4.8440E-01,4.6329E-01,4.4109E-01,4.1826E-01,3.9408E-01,3.7291E-01,
36731      &3.4966E-01,3.2243E-01,2.9475E-01,2.6790E-01,2.4406E-01,2.2399E-01,
36732      &2.0470E-01,1.8621E-01,1.7262E-01,1.6558E-01,1.6576E-01,1.7201E-01,
36733      &1.8441E-01,2.0372E-01,2.2403E-01,2.3482E-01,2.3856E-01,2.3398E-01,
36734      &2.2040E-01,2.0103E-01,1.7782E-01,1.5205E-01,1.2492E-01,9.7540E-02,
36735      &7.1452E-02,4.8817E-02,3.2832E-02,2.8412E-02,4.3068E-02,4.1684E-02,
36736      &2.6819E-02,1.6431E-02,9.5049E-03,5.0674E-03,2.0840E-03,1.1231E-03,
36737      &4.2643E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36738      &7.8709E-01,7.7617E-01,7.6509E-01,7.5353E-01,7.4210E-01,7.2955E-01,
36739      &7.1666E-01,7.0326E-01,6.8906E-01,6.7364E-01,6.5743E-01,6.3988E-01,
36740      &6.2140E-01,6.0962E-01,5.9645E-01,5.8083E-01,5.6382E-01,5.4630E-01,
36741      &5.2750E-01,5.1079E-01,4.9267E-01,4.7078E-01,4.4780E-01,4.2425E-01,
36742      &3.9948E-01,3.7773E-01,3.5398E-01,3.2619E-01,2.9811E-01,2.7093E-01/
36743       DATA (XDEF_L(K),K= 1255, 1368) /
36744      &2.4686E-01,2.2668E-01,2.0735E-01,1.8888E-01,1.7555E-01,1.6865E-01,
36745      &1.6887E-01,1.7500E-01,1.8693E-01,2.0522E-01,2.2377E-01,2.3300E-01,
36746      &2.3501E-01,2.2902E-01,2.1428E-01,1.9427E-01,1.7084E-01,1.4533E-01,
36747      &1.1889E-01,9.2655E-02,6.8174E-02,4.7575E-02,3.4123E-02,3.2605E-02,
36748      &5.0454E-02,3.8820E-02,2.4822E-02,1.5113E-02,8.6857E-03,4.5962E-03,
36749      &1.8704E-03,1.0050E-03,3.7856E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36750      &0.0000E+00,0.0000E+00,8.0606E-01,7.9455E-01,7.8312E-01,7.7128E-01,
36751      &7.5940E-01,7.4610E-01,7.3287E-01,7.1917E-01,7.0456E-01,6.8825E-01,
36752      &6.7140E-01,6.5313E-01,6.3390E-01,6.2170E-01,6.0798E-01,5.9180E-01,
36753      &5.7419E-01,5.5596E-01,5.3636E-01,5.1934E-01,5.0050E-01,4.7790E-01,
36754      &4.5436E-01,4.3012E-01,4.0458E-01,3.8238E-01,3.5808E-01,3.2984E-01,
36755      &3.0133E-01,2.7388E-01,2.4957E-01,2.2930E-01,2.0996E-01,1.9168E-01,
36756      &1.7832E-01,1.7159E-01,1.7177E-01,1.7770E-01,1.8921E-01,2.0651E-01,
36757      &2.2344E-01,2.3117E-01,2.3152E-01,2.2426E-01,2.0844E-01,1.8790E-01,
36758      &1.6440E-01,1.3914E-01,1.1342E-01,8.8280E-02,6.5276E-02,4.6578E-02,
36759      &3.5360E-02,3.6411E-02,5.6986E-02,3.6256E-02,2.3040E-02,1.3948E-02,
36760      &7.9676E-03,4.1856E-03,1.6876E-03,9.0394E-04,3.3789E-04,0.0000E+00,
36761      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.2409E-01,8.1223E-01,
36762      &8.0027E-01,7.8810E-01,7.7580E-01,7.6250E-01,7.4852E-01,7.3383E-01/
36763       DATA (XDEF_L(K),K= 1369, 1482) /
36764      &7.1879E-01,7.0216E-01,6.8466E-01,6.6571E-01,6.4580E-01,6.3303E-01,
36765      &6.1887E-01,6.0161E-01,5.8362E-01,5.6485E-01,5.4490E-01,5.2736E-01,
36766      &5.0788E-01,4.8465E-01,4.6048E-01,4.3549E-01,4.0949E-01,3.8678E-01,
36767      &3.6198E-01,3.3325E-01,3.0435E-01,2.7667E-01,2.5212E-01,2.3179E-01,
36768      &2.1241E-01,1.9410E-01,1.8093E-01,1.7428E-01,1.7445E-01,1.8022E-01,
36769      &1.9133E-01,2.0758E-01,2.2299E-01,2.2941E-01,2.2823E-01,2.1990E-01,
36770      &2.0319E-01,1.8211E-01,1.5852E-01,1.3371E-01,1.0856E-01,8.4430E-02,
36771      &6.2776E-02,4.5758E-02,3.6514E-02,3.9756E-02,6.2597E-02,3.4019E-02,
36772      &2.1502E-02,1.2943E-02,7.3506E-03,3.8366E-03,1.5351E-03,8.1923E-04,
36773      &3.0383E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36774      &8.4844E-01,8.3627E-01,8.2378E-01,8.1114E-01,7.9820E-01,7.8411E-01,
36775      &7.6977E-01,7.5436E-01,7.3871E-01,7.2101E-01,7.0269E-01,6.8280E-01,
36776      &6.6180E-01,6.4849E-01,6.3365E-01,6.1605E-01,5.9682E-01,5.7721E-01,
36777      &5.5628E-01,5.3805E-01,5.1772E-01,4.9378E-01,4.6868E-01,4.4295E-01,
36778      &4.1599E-01,3.9262E-01,3.6722E-01,3.3788E-01,3.0847E-01,2.8040E-01,
36779      &2.5562E-01,2.3513E-01,2.1572E-01,1.9746E-01,1.8447E-01,1.7787E-01,
36780      &1.7810E-01,1.8358E-01,1.9394E-01,2.0894E-01,2.2227E-01,2.2689E-01,
36781      &2.2385E-01,2.1408E-01,1.9620E-01,1.7461E-01,1.5108E-01,1.2667E-01,
36782      &1.0243E-01,7.9635E-02,5.9715E-02,4.4804E-02,3.7997E-02,4.3894E-02/
36783       DATA (XDEF_L(K),K= 1483, 1596) /
36784      &6.9391E-02,3.1240E-02,1.9603E-02,1.1712E-02,6.6036E-03,3.4150E-03,
36785      &1.3549E-03,7.1812E-04,2.6373E-04,0.0000E+00,0.0000E+00,0.0000E+00,
36786      &0.0000E+00,0.0000E+00,8.7089E-01,8.5819E-01,8.4535E-01,8.3207E-01,
36787      &8.1860E-01,8.0424E-01,7.8877E-01,7.7320E-01,7.5642E-01,7.3822E-01,
36788      &7.1895E-01,6.9816E-01,6.7640E-01,6.6244E-01,6.4701E-01,6.2817E-01,
36789      &6.0860E-01,5.8841E-01,5.6672E-01,5.4767E-01,5.2667E-01,5.0182E-01,
36790      &4.7599E-01,4.4955E-01,4.2190E-01,3.9787E-01,3.7196E-01,3.4199E-01,
36791      &3.1220E-01,2.8382E-01,2.5874E-01,2.3816E-01,2.1874E-01,2.0063E-01,
36792      &1.8770E-01,1.8107E-01,1.8121E-01,1.8638E-01,1.9622E-01,2.0994E-01,
36793      &2.2156E-01,2.2456E-01,2.1986E-01,2.0892E-01,1.9015E-01,1.6817E-01,
36794      &1.4465E-01,1.2070E-01,9.7309E-02,7.5665E-02,5.7234E-02,4.4095E-02,
36795      &3.9289E-02,4.7307E-02,7.4739E-02,2.8958E-02,1.8046E-02,1.0716E-02,
36796      &6.0010E-03,3.0801E-03,1.2145E-03,6.3833E-04,2.3251E-04,0.0000E+00,
36797      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,8.9366E-01,8.8058E-01,
36798      &8.6727E-01,8.5353E-01,8.3950E-01,8.2436E-01,8.0890E-01,7.9205E-01,
36799      &7.7476E-01,7.5566E-01,7.3557E-01,7.1393E-01,6.9120E-01,6.7672E-01,
36800      &6.6059E-01,6.4145E-01,6.2086E-01,5.9962E-01,5.7716E-01,5.5756E-01,
36801      &5.3584E-01,5.1022E-01,4.8344E-01,4.5615E-01,4.2780E-01,4.0320E-01,
36802      &3.7671E-01,3.4621E-01,3.1594E-01,2.8727E-01,2.6196E-01,2.4126E-01/
36803       DATA (XDEF_L(K),K= 1597, 1710) /
36804      &2.2177E-01,2.0361E-01,1.9078E-01,1.8427E-01,1.8432E-01,1.8918E-01,
36805      &1.9834E-01,2.1079E-01,2.2065E-01,2.2210E-01,2.1587E-01,2.0383E-01,
36806      &1.8424E-01,1.6197E-01,1.3849E-01,1.1505E-01,9.2463E-02,7.1949E-02,
36807      &5.4952E-02,4.3474E-02,4.0525E-02,5.0376E-02,7.9517E-02,2.6835E-02,
36808      &1.6616E-02,9.8004E-03,5.4489E-03,2.7768E-03,1.0900E-03,5.6728E-04,
36809      &2.0489E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36810      &9.1643E-01,9.0298E-01,8.8901E-01,8.7472E-01,8.6030E-01,8.4449E-01,
36811      &8.2790E-01,8.1090E-01,7.9278E-01,7.7287E-01,7.5201E-01,7.2942E-01,
36812      &7.0580E-01,6.9067E-01,6.7395E-01,6.5357E-01,6.3264E-01,6.1082E-01,
36813      &5.8728E-01,5.6718E-01,5.4478E-01,5.1825E-01,4.9075E-01,4.6263E-01,
36814      &4.3360E-01,4.0844E-01,3.8138E-01,3.5032E-01,3.1963E-01,2.9065E-01,
36815      &2.6511E-01,2.4428E-01,2.2479E-01,2.0678E-01,1.9385E-01,1.8735E-01,
36816      &1.8722E-01,1.9179E-01,2.0029E-01,2.1158E-01,2.1961E-01,2.1971E-01,
36817      &2.1194E-01,1.9894E-01,1.7862E-01,1.5609E-01,1.3279E-01,1.0972E-01,
36818      &8.8007E-02,6.8578E-02,5.2905E-02,4.2942E-02,4.1624E-02,5.3065E-02,
36819      &8.3506E-02,2.4920E-02,1.5334E-02,8.9876E-03,4.9653E-03,2.5112E-03,
36820      &9.8300E-04,5.0629E-04,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,
36821      &0.0000E+00,0.0000E+00,9.3762E-01,9.2325E-01,9.0916E-01,8.9432E-01,
36822      &8.7930E-01,8.6312E-01,8.4579E-01,8.2807E-01,8.0954E-01,7.8866E-01/
36823       DATA (XDEF_L(K),K= 1711, 1824) /
36824      &7.6704E-01,7.4360E-01,7.1911E-01,7.0343E-01,6.8612E-01,6.6512E-01,
36825      &6.4349E-01,6.2048E-01,5.9676E-01,5.7574E-01,5.5261E-01,5.2556E-01,
36826      &4.9731E-01,4.6862E-01,4.3881E-01,4.1318E-01,3.8556E-01,3.5408E-01,
36827      &3.2299E-01,2.9375E-01,2.6794E-01,2.4706E-01,2.2744E-01,2.0939E-01,
36828      &1.9662E-01,1.9016E-01,1.8990E-01,1.9412E-01,2.0192E-01,2.1208E-01,
36829      &2.1863E-01,2.1745E-01,2.0845E-01,1.9458E-01,1.7365E-01,1.5094E-01,
36830      &1.2783E-01,1.0526E-01,8.4228E-02,6.5746E-02,5.1203E-02,4.2521E-02,
36831      &4.2531E-02,5.5238E-02,8.6619E-02,2.3321E-02,1.4266E-02,8.3142E-03,
36832      &4.5684E-03,2.2945E-03,8.9721E-04,4.5700E-04,0.0000E+00,0.0000E+00,
36833      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,9.5912E-01,9.4446E-01,
36834      &9.2967E-01,9.1446E-01,8.9890E-01,8.8176E-01,8.6424E-01,8.4567E-01,
36835      &8.2630E-01,8.0492E-01,7.8242E-01,7.5817E-01,7.3271E-01,7.1653E-01,
36836      &6.9849E-01,6.7725E-01,6.5433E-01,6.3091E-01,6.0625E-01,5.8456E-01,
36837      &5.6088E-01,5.3305E-01,5.0402E-01,4.7461E-01,4.4411E-01,4.1800E-01,
36838      &3.8988E-01,3.5790E-01,3.2644E-01,2.9690E-01,2.7087E-01,2.4987E-01,
36839      &2.3039E-01,2.1219E-01,1.9955E-01,1.9298E-01,1.9248E-01,1.9636E-01,
36840      &2.0355E-01,2.1258E-01,2.1752E-01,2.1512E-01,2.0490E-01,1.9021E-01,
36841      &1.6876E-01,1.4586E-01,1.2296E-01,1.0090E-01,8.0587E-02,6.3034E-02,
36842      &4.9591E-02,4.2122E-02,4.3355E-02,5.7203E-02,8.9336E-02,2.1802E-02/
36843       DATA (XDEF_L(K),K= 1825, 1836) /
36844      &1.3258E-02,7.6843E-03,4.1967E-03,2.0952E-03,8.1932E-04,4.1202E-04,
36845      &0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00,0.0000E+00/
36846       DATA (XUDF_L(K),K=    1,  114) /
36847      &1.8987E-02,1.9947E-02,2.0980E-02,2.2068E-02,2.3225E-02,2.4540E-02,
36848      &2.5957E-02,2.7526E-02,2.9229E-02,3.1232E-02,3.3453E-02,3.6003E-02,
36849      &3.8855E-02,4.0763E-02,4.2980E-02,4.5778E-02,4.8895E-02,5.2320E-02,
36850      &5.6174E-02,5.9765E-02,6.3980E-02,6.9315E-02,7.5299E-02,8.1888E-02,
36851      &8.9292E-02,9.6162E-02,1.0414E-01,1.1410E-01,1.2505E-01,1.3674E-01,
36852      &1.4937E-01,1.6060E-01,1.7296E-01,1.8730E-01,2.0166E-01,2.1531E-01,
36853      &2.2821E-01,2.3833E-01,2.4848E-01,2.6049E-01,2.7586E-01,2.9166E-01,
36854      &3.1456E-01,3.3942E-01,3.7230E-01,4.0597E-01,4.3921E-01,4.7071E-01,
36855      &4.9846E-01,5.2057E-01,5.3433E-01,5.3610E-01,5.2141E-01,4.8433E-01,
36856      &4.1719E-01,6.3794E-01,6.7411E-01,7.2040E-01,7.8812E-01,8.9495E-01,
36857      &1.0702E+00,1.3629E+00,1.8763E+00,2.8399E+00,4.8968E+00,1.0506E+01,
36858      &3.7793E+01,0.0000E+00,3.1111E-02,3.2336E-02,3.3580E-02,3.4906E-02,
36859      &3.6247E-02,3.7773E-02,3.9337E-02,4.1056E-02,4.2876E-02,4.5001E-02,
36860      &4.7299E-02,4.9897E-02,5.2761E-02,5.4666E-02,5.6867E-02,5.9620E-02,
36861      &6.2679E-02,6.6018E-02,6.9775E-02,7.3275E-02,7.7353E-02,8.2522E-02,
36862      &8.8327E-02,9.4694E-02,1.0184E-01,1.0846E-01,1.1615E-01,1.2575E-01,
36863      &1.3628E-01,1.4752E-01,1.5964E-01,1.7036E-01,1.8215E-01,1.9580E-01,
36864      &2.0933E-01,2.2213E-01,2.3411E-01,2.4341E-01,2.5275E-01,2.6387E-01,
36865      &2.7831E-01,2.9333E-01,3.1510E-01,3.3876E-01,3.6995E-01,4.0170E-01/
36866       DATA (XUDF_L(K),K=  115,  228) /
36867      &4.3298E-01,4.6172E-01,4.8742E-01,5.0700E-01,5.1856E-01,5.1873E-01,
36868      &5.0352E-01,4.6746E-01,4.0418E-01,6.1801E-01,6.5339E-01,6.9923E-01,
36869      &7.6627E-01,8.7125E-01,1.0408E+00,1.3199E+00,1.8020E+00,2.6920E+00,
36870      &4.5574E+00,9.5310E+00,3.2877E+01,0.0000E+00,5.1176E-02,5.2640E-02,
36871      &5.4100E-02,5.5603E-02,5.7095E-02,5.8737E-02,6.0416E-02,6.2154E-02,
36872      &6.4016E-02,6.6046E-02,6.8273E-02,7.0765E-02,7.3444E-02,7.5182E-02,
36873      &7.7263E-02,7.9781E-02,8.2626E-02,8.5707E-02,8.9176E-02,9.2402E-02,
36874      &9.6182E-02,1.0098E-01,1.0635E-01,1.1227E-01,1.1893E-01,1.2513E-01,
36875      &1.3230E-01,1.4128E-01,1.5115E-01,1.6164E-01,1.7300E-01,1.8301E-01,
36876      &1.9397E-01,2.0660E-01,2.1907E-01,2.3072E-01,2.4154E-01,2.4985E-01,
36877      &2.5817E-01,2.6810E-01,2.8136E-01,2.9535E-01,3.1585E-01,3.3824E-01,
36878      &3.6743E-01,3.9701E-01,4.2565E-01,4.5205E-01,4.7460E-01,4.9184E-01,
36879      &5.0110E-01,4.9954E-01,4.8363E-01,4.4878E-01,3.8940E-01,5.9452E-01,
36880      &6.2820E-01,6.7181E-01,7.3612E-01,8.3598E-01,9.9560E-01,1.2543E+00,
36881      &1.6953E+00,2.4947E+00,4.1415E+00,8.4275E+00,2.7797E+01,0.0000E+00,
36882      &8.6266E-02,8.7847E-02,8.9380E-02,9.0869E-02,9.2337E-02,9.3826E-02,
36883      &9.5315E-02,9.6842E-02,9.8333E-02,1.0003E-01,1.0178E-01,1.0370E-01,
36884      &1.0575E-01,1.0710E-01,1.0872E-01,1.1075E-01,1.1295E-01,1.1538E-01,
36885      &1.1821E-01,1.2088E-01,1.2396E-01,1.2796E-01,1.3252E-01,1.3756E-01/
36886       DATA (XUDF_L(K),K=  229,  342) /
36887      &1.4331E-01,1.4870E-01,1.5500E-01,1.6291E-01,1.7166E-01,1.8100E-01,
36888      &1.9111E-01,2.0002E-01,2.0977E-01,2.2095E-01,2.3189E-01,2.4200E-01,
36889      &2.5123E-01,2.5821E-01,2.6512E-01,2.7351E-01,2.8514E-01,2.9789E-01,
36890      &3.1683E-01,3.3731E-01,3.6424E-01,3.9124E-01,4.1697E-01,4.4030E-01,
36891      &4.6002E-01,4.7419E-01,4.8085E-01,4.7740E-01,4.6086E-01,4.2728E-01,
36892      &3.7241E-01,5.6656E-01,5.9684E-01,6.3694E-01,6.9622E-01,7.8804E-01,
36893      &9.3343E-01,1.1653E+00,1.5545E+00,2.2504E+00,3.6537E+00,7.2124E+00,
36894      &2.2653E+01,0.0000E+00,1.4838E-01,1.4960E-01,1.5068E-01,1.5161E-01,
36895      &1.5242E-01,1.5316E-01,1.5373E-01,1.5426E-01,1.5470E-01,1.5511E-01,
36896      &1.5554E-01,1.5602E-01,1.5660E-01,1.5698E-01,1.5750E-01,1.5830E-01,
36897      &1.5923E-01,1.6034E-01,1.6181E-01,1.6324E-01,1.6509E-01,1.6746E-01,
36898      &1.7054E-01,1.7402E-01,1.7811E-01,1.8208E-01,1.8687E-01,1.9296E-01,
36899      &1.9986E-01,2.0734E-01,2.1554E-01,2.2281E-01,2.3075E-01,2.3983E-01,
36900      &2.4863E-01,2.5660E-01,2.6366E-01,2.6883E-01,2.7387E-01,2.8026E-01,
36901      &2.8982E-01,3.0088E-01,3.1780E-01,3.3626E-01,3.6021E-01,3.8399E-01,
36902      &4.0666E-01,4.2682E-01,4.4278E-01,4.5386E-01,4.5774E-01,4.5230E-01,
36903      &4.3509E-01,4.0314E-01,3.5321E-01,5.3325E-01,5.5916E-01,5.9448E-01,
36904      &6.4707E-01,7.2797E-01,8.5557E-01,1.0563E+00,1.3882E+00,1.9717E+00,
36905      &3.1223E+00,5.9601E+00,1.7750E+01,0.0000E+00,2.3139E-01,2.3138E-01/
36906       DATA (XUDF_L(K),K=  343,  456) /
36907      &2.3120E-01,2.3076E-01,2.3006E-01,2.2907E-01,2.2788E-01,2.2645E-01,
36908      &2.2489E-01,2.2308E-01,2.2120E-01,2.1929E-01,2.1743E-01,2.1630E-01,
36909      &2.1526E-01,2.1411E-01,2.1311E-01,2.1231E-01,2.1171E-01,2.1148E-01,
36910      &2.1150E-01,2.1182E-01,2.1271E-01,2.1412E-01,2.1601E-01,2.1822E-01,
36911      &2.2096E-01,2.2496E-01,2.2961E-01,2.3481E-01,2.4086E-01,2.4622E-01,
36912      &2.5214E-01,2.5891E-01,2.6537E-01,2.7104E-01,2.7588E-01,2.7922E-01,
36913      &2.8235E-01,2.8664E-01,2.9413E-01,3.0352E-01,3.1845E-01,3.3481E-01,
36914      &3.5617E-01,3.7737E-01,3.9689E-01,4.1403E-01,4.2736E-01,4.3558E-01,
36915      &4.3712E-01,4.3016E-01,4.1245E-01,3.8197E-01,3.3645E-01,5.0322E-01,
36916      &5.2507E-01,5.5559E-01,6.0172E-01,6.7286E-01,7.8413E-01,9.5797E-01,
36917      &1.2422E+00,1.7341E+00,2.6883E+00,4.9868E+00,1.4177E+01,0.0000E+00,
36918      &3.6389E-01,3.6098E-01,3.5780E-01,3.5400E-01,3.5016E-01,3.4553E-01,
36919      &3.4044E-01,3.3521E-01,3.2971E-01,3.2369E-01,3.1755E-01,3.1120E-01,
36920      &3.0494E-01,3.0120E-01,2.9724E-01,2.9287E-01,2.8855E-01,2.8449E-01,
36921      &2.8072E-01,2.7770E-01,2.7469E-01,2.7175E-01,2.6933E-01,2.6740E-01,
36922      &2.6613E-01,2.6556E-01,2.6563E-01,2.6631E-01,2.6763E-01,2.6975E-01,
36923      &2.7268E-01,2.7539E-01,2.7857E-01,2.8224E-01,2.8565E-01,2.8841E-01,
36924      &2.9040E-01,2.9139E-01,2.9220E-01,2.9395E-01,2.9888E-01,3.0633E-01,
36925      &3.1877E-01,3.3296E-01,3.5147E-01,3.6947E-01,3.8604E-01,3.9986E-01/
36926       DATA (XUDF_L(K),K=  457,  570) /
36927      &4.1008E-01,4.1548E-01,4.1467E-01,4.0620E-01,3.8830E-01,3.5965E-01,
36928      &3.1902E-01,4.7020E-01,4.8772E-01,5.1303E-01,5.5185E-01,6.1224E-01,
36929      &7.0699E-01,8.5323E-01,1.0903E+00,1.4950E+00,2.2640E+00,4.0723E+00,
36930      &0.0000E+00,0.0000E+00,5.2666E-01,5.1909E-01,5.1100E-01,5.0238E-01,
36931      &4.9333E-01,4.8312E-01,4.7293E-01,4.6180E-01,4.5066E-01,4.3890E-01,
36932      &4.2692E-01,4.1467E-01,4.0262E-01,3.9542E-01,3.8784E-01,3.7925E-01,
36933      &3.7080E-01,3.6267E-01,3.5482E-01,3.4841E-01,3.4190E-01,3.3492E-01,
36934      &3.2852E-01,3.2287E-01,3.1768E-01,3.1409E-01,3.1066E-01,3.0785E-01,
36935      &3.0564E-01,3.0446E-01,3.0380E-01,3.0388E-01,3.0402E-01,3.0458E-01,
36936      &3.0488E-01,3.0475E-01,3.0386E-01,3.0263E-01,3.0116E-01,3.0045E-01,
36937      &3.0296E-01,3.0852E-01,3.1888E-01,3.3085E-01,3.4677E-01,3.6222E-01,
36938      &3.7600E-01,3.8707E-01,3.9488E-01,3.9799E-01,3.9530E-01,3.8568E-01,
36939      &3.6791E-01,3.4080E-01,3.0424E-01,4.4195E-01,4.5570E-01,4.7648E-01,
36940      &5.0935E-01,5.6099E-01,6.4225E-01,7.6680E-01,9.6736E-01,1.3053E+00,
36941      &1.9393E+00,3.3976E+00,0.0000E+00,0.0000E+00,7.4015E-01,7.2498E-01,
36942      &7.0940E-01,6.9297E-01,6.7620E-01,6.5800E-01,6.3935E-01,6.2047E-01,
36943      &6.0114E-01,5.8076E-01,5.6065E-01,5.4030E-01,5.2035E-01,5.0839E-01,
36944      &4.9583E-01,4.8167E-01,4.6773E-01,4.5434E-01,4.4113E-01,4.3035E-01,
36945      &4.1922E-01,4.0719E-01,3.9582E-01,3.8536E-01,3.7557E-01,3.6805E-01/
36946       DATA (XUDF_L(K),K=  571,  684) /
36947      &3.6079E-01,3.5336E-01,3.4710E-01,3.4173E-01,3.3719E-01,3.3400E-01,
36948      &3.3124E-01,3.2819E-01,3.2494E-01,3.2158E-01,3.1765E-01,3.1400E-01,
36949      &3.1011E-01,3.0684E-01,3.0682E-01,3.1046E-01,3.1856E-01,3.2861E-01,
36950      &3.4189E-01,3.5475E-01,3.6597E-01,3.7463E-01,3.8003E-01,3.8108E-01,
36951      &3.7681E-01,3.6631E-01,3.4865E-01,3.2327E-01,2.9078E-01,4.1488E-01,
36952      &4.2529E-01,4.4193E-01,4.6945E-01,5.1322E-01,5.8236E-01,6.8846E-01,
36953      &8.5739E-01,1.1394E+00,1.6617E+00,2.8395E+00,0.0000E+00,0.0000E+00,
36954      &9.8501E-01,9.5975E-01,9.3420E-01,9.0757E-01,8.8092E-01,8.5237E-01,
36955      &8.2383E-01,7.9445E-01,7.6556E-01,7.3524E-01,7.0484E-01,6.7495E-01,
36956      &6.4547E-01,6.2798E-01,6.0969E-01,5.8904E-01,5.6882E-01,5.4932E-01,
36957      &5.3014E-01,5.1443E-01,4.9826E-01,4.8058E-01,4.6380E-01,4.4815E-01,
36958      &4.3330E-01,4.2167E-01,4.1020E-01,3.9827E-01,3.8748E-01,3.7784E-01,
36959      &3.6931E-01,3.6303E-01,3.5669E-01,3.4992E-01,3.4358E-01,3.3710E-01,
36960      &3.3025E-01,3.2429E-01,3.1817E-01,3.1242E-01,3.1001E-01,3.1195E-01,
36961      &3.1802E-01,3.2610E-01,3.3719E-01,3.4770E-01,3.5674E-01,3.6357E-01,
36962      &3.6695E-01,3.6631E-01,3.6075E-01,3.4960E-01,3.3214E-01,3.0855E-01,
36963      &2.7931E-01,3.9198E-01,3.9931E-01,4.1263E-01,4.3550E-01,4.7310E-01,
36964      &5.3259E-01,6.2375E-01,7.6876E-01,1.0087E+00,1.4464E+00,2.4185E+00,
36965      &0.0000E+00,0.0000E+00,1.2917E+00,1.2523E+00,1.2128E+00,1.1722E+00/
36966       DATA (XUDF_L(K),K=  685,  798) /
36967      &1.1321E+00,1.0894E+00,1.0473E+00,1.0044E+00,9.6262E-01,9.1838E-01,
36968      &8.7565E-01,8.3283E-01,7.9186E-01,7.6734E-01,7.4146E-01,7.1300E-01,
36969      &6.8484E-01,6.5787E-01,6.3134E-01,6.0963E-01,5.8730E-01,5.6294E-01,
36970      &5.3947E-01,5.1767E-01,4.9689E-01,4.8039E-01,4.6398E-01,4.4675E-01,
36971      &4.3087E-01,4.1650E-01,4.0371E-01,3.9342E-01,3.8361E-01,3.7293E-01,
36972      &3.6284E-01,3.5305E-01,3.4307E-01,3.3468E-01,3.2613E-01,3.1788E-01,
36973      &3.1306E-01,3.1309E-01,3.1715E-01,3.2346E-01,3.3232E-01,3.4066E-01,
36974      &3.4779E-01,3.5251E-01,3.5401E-01,3.5184E-01,3.4519E-01,3.3347E-01,
36975      &3.1650E-01,2.9433E-01,2.6872E-01,3.6968E-01,3.7446E-01,3.8477E-01,
36976      &4.0368E-01,4.3551E-01,4.8654E-01,5.6457E-01,6.8832E-01,8.9135E-01,
36977      &1.2583E+00,2.0601E+00,0.0000E+00,0.0000E+00,1.6499E+00,1.5928E+00,
36978      &1.5356E+00,1.4773E+00,1.4202E+00,1.3601E+00,1.3009E+00,1.2413E+00,
36979      &1.1836E+00,1.1235E+00,1.0650E+00,1.0076E+00,9.5212E-01,9.1919E-01,
36980      &8.8569E-01,8.4733E-01,8.1006E-01,7.7436E-01,7.3955E-01,7.1104E-01,
36981      &6.8173E-01,6.4966E-01,6.1893E-01,5.9026E-01,5.6287E-01,5.4114E-01,
36982      &5.1941E-01,4.9621E-01,4.7490E-01,4.5564E-01,4.3786E-01,4.2408E-01,
36983      &4.1024E-01,3.9562E-01,3.8175E-01,3.6853E-01,3.5541E-01,3.4455E-01,
36984      &3.3366E-01,3.2286E-01,3.1565E-01,3.1397E-01,3.1618E-01,3.2069E-01,
36985      &3.2744E-01,3.3383E-01,3.3911E-01,3.4194E-01,3.4194E-01,3.3844E-01/
36986       DATA (XUDF_L(K),K=  799,  912) /
36987      &3.3088E-01,3.1887E-01,3.0224E-01,2.8177E-01,2.5901E-01,3.4945E-01,
36988      &3.5200E-01,3.5959E-01,3.7518E-01,4.0212E-01,4.4590E-01,5.1305E-01,
36989      &6.1934E-01,7.9273E-01,1.1025E+00,1.7693E+00,0.0000E+00,0.0000E+00,
36990      &2.0413E+00,1.9626E+00,1.8840E+00,1.8053E+00,1.7284E+00,1.6480E+00,
36991      &1.5697E+00,1.4911E+00,1.4157E+00,1.3375E+00,1.2620E+00,1.1875E+00,
36992      &1.1168E+00,1.0751E+00,1.0321E+00,9.8410E-01,9.3682E-01,8.9196E-01,
36993      &8.4816E-01,8.1245E-01,7.7582E-01,7.3576E-01,6.9745E-01,6.6154E-01,
36994      &6.2742E-01,6.0036E-01,5.7319E-01,5.4409E-01,5.1721E-01,4.9291E-01,
36995      &4.7049E-01,4.5284E-01,4.3541E-01,4.1671E-01,3.9926E-01,3.8274E-01,
36996      &3.6660E-01,3.5348E-01,3.4035E-01,3.2727E-01,3.1788E-01,3.1459E-01,
36997      &3.1499E-01,3.1792E-01,3.2291E-01,3.2764E-01,3.3124E-01,3.3250E-01,
36998      &3.3120E-01,3.2663E-01,3.1834E-01,3.0608E-01,2.8998E-01,2.7085E-01,
36999      &2.5085E-01,3.3191E-01,3.3258E-01,3.3808E-01,3.5072E-01,3.7379E-01,
37000      &4.1182E-01,4.7005E-01,5.6257E-01,7.1233E-01,9.7788E-01,1.5412E+00,
37001      &0.0000E+00,0.0000E+00,2.6325E+00,2.5188E+00,2.4060E+00,2.2942E+00,
37002      &2.1863E+00,2.0740E+00,1.9650E+00,1.8571E+00,1.7537E+00,1.6473E+00,
37003      &1.5453E+00,1.4458E+00,1.3515E+00,1.2965E+00,1.2394E+00,1.1767E+00,
37004      &1.1150E+00,1.0560E+00,9.9927E-01,9.5301E-01,9.0565E-01,8.5400E-01,
37005      &8.0462E-01,7.5858E-01,7.1481E-01,6.7994E-01,6.4502E-01,6.0799E-01/
37006       DATA (XUDF_L(K),K=  913, 1026) /
37007      &5.7349E-01,5.4206E-01,5.1299E-01,4.9028E-01,4.6789E-01,4.4387E-01,
37008      &4.2168E-01,4.0096E-01,3.8070E-01,3.6457E-01,3.4857E-01,3.3249E-01,
37009      &3.2026E-01,3.1503E-01,3.1326E-01,3.1423E-01,3.1703E-01,3.1974E-01,
37010      &3.2120E-01,3.2086E-01,3.1799E-01,3.1221E-01,3.0315E-01,2.9072E-01,
37011      &2.7522E-01,2.5796E-01,2.4114E-01,3.1079E-01,3.0956E-01,3.1267E-01,
37012      &3.2223E-01,3.4089E-01,3.7246E-01,4.2134E-01,4.9853E-01,6.2305E-01,
37013      &8.4191E-01,1.2983E+00,0.0000E+00,0.0000E+00,3.2997E+00,3.1427E+00,
37014      &2.9900E+00,2.8374E+00,2.6927E+00,2.5421E+00,2.3973E+00,2.2549E+00,
37015      &2.1191E+00,1.9809E+00,1.8488E+00,1.7209E+00,1.6001E+00,1.5300E+00,
37016      &1.4576E+00,1.3771E+00,1.2999E+00,1.2268E+00,1.1551E+00,1.0975E+00,
37017      &1.0385E+00,9.7437E-01,9.1327E-01,8.5649E-01,8.0236E-01,7.5952E-01,
37018      &7.1667E-01,6.7091E-01,6.2847E-01,5.9005E-01,5.5422E-01,5.2636E-01,
37019      &4.9890E-01,4.6976E-01,4.4269E-01,4.1752E-01,3.9377E-01,3.7477E-01,
37020      &3.5594E-01,3.3710E-01,3.2226E-01,3.1511E-01,3.1131E-01,3.1067E-01,
37021      &3.1132E-01,3.1227E-01,3.1198E-01,3.1021E-01,3.0606E-01,2.9926E-01,
37022      &2.8958E-01,2.7716E-01,2.6233E-01,2.4655E-01,2.3275E-01,2.9229E-01,
37023      &2.8941E-01,2.9061E-01,2.9753E-01,3.1273E-01,3.3909E-01,3.8034E-01,
37024      &4.4548E-01,5.5028E-01,7.3256E-01,1.1074E+00,0.0000E+00,0.0000E+00,
37025      &4.0557E+00,3.8486E+00,3.6460E+00,3.4480E+00,3.2579E+00,3.0626E+00/
37026       DATA (XUDF_L(K),K= 1027, 1140) /
37027      &2.8756E+00,2.6929E+00,2.5196E+00,2.3441E+00,2.1778E+00,2.0170E+00,
37028      &1.8670E+00,1.7797E+00,1.6902E+00,1.5909E+00,1.4960E+00,1.4058E+00,
37029      &1.3191E+00,1.2484E+00,1.1764E+00,1.0991E+00,1.0253E+00,9.5689E-01,
37030      &8.9197E-01,8.4046E-01,7.8904E-01,7.3442E-01,6.8367E-01,6.3780E-01,
37031      &5.9520E-01,5.6218E-01,5.2934E-01,4.9500E-01,4.6300E-01,4.3370E-01,
37032      &4.0611E-01,3.8431E-01,3.6284E-01,3.4121E-01,3.2389E-01,3.1494E-01,
37033      &3.0926E-01,3.0697E-01,3.0594E-01,3.0501E-01,3.0330E-01,3.0019E-01,
37034      &2.9492E-01,2.8734E-01,2.7718E-01,2.6476E-01,2.5057E-01,2.3646E-01,
37035      &2.2503E-01,2.7558E-01,2.7132E-01,2.7089E-01,2.7569E-01,2.8794E-01,
37036      &3.1000E-01,3.4491E-01,4.0016E-01,4.8886E-01,6.4191E-01,9.5232E-01,
37037      &0.0000E+00,0.0000E+00,4.8799E+00,4.6116E+00,4.3560E+00,4.1035E+00,
37038      &3.8608E+00,3.6163E+00,3.3822E+00,3.1557E+00,2.9412E+00,2.7247E+00,
37039      &2.5209E+00,2.3248E+00,2.1421E+00,2.0368E+00,1.9287E+00,1.8094E+00,
37040      &1.6955E+00,1.5877E+00,1.4841E+00,1.4003E+00,1.3154E+00,1.2237E+00,
37041      &1.1368E+00,1.0563E+00,9.8015E-01,9.2005E-01,8.5978E-01,7.9615E-01,
37042      &7.3715E-01,6.8369E-01,6.3441E-01,5.9609E-01,5.5830E-01,5.1865E-01,
37043      &4.8192E-01,4.4872E-01,4.1747E-01,3.9300E-01,3.6895E-01,3.4483E-01,
37044      &3.2508E-01,3.1459E-01,3.0709E-01,3.0328E-01,3.0056E-01,2.9840E-01,
37045      &2.9543E-01,2.9107E-01,2.8485E-01,2.7655E-01,2.6610E-01,2.5368E-01/
37046       DATA (XUDF_L(K),K= 1141, 1254) /
37047      &2.4019E-01,2.2736E-01,2.1837E-01,2.6080E-01,2.5542E-01,2.5362E-01,
37048      &2.5693E-01,2.6661E-01,2.8505E-01,3.1490E-01,3.6226E-01,4.3798E-01,
37049      &5.6769E-01,8.2836E-01,0.0000E+00,0.0000E+00,5.8340E+00,5.4940E+00,
37050      &5.1700E+00,4.8532E+00,4.5515E+00,4.2463E+00,3.9559E+00,3.6752E+00,
37051      &3.4138E+00,3.1496E+00,2.9022E+00,2.6648E+00,2.4450E+00,2.3189E+00,
37052      &2.1896E+00,2.0476E+00,1.9120E+00,1.7843E+00,1.6621E+00,1.5639E+00,
37053      &1.4648E+00,1.3569E+00,1.2556E+00,1.1618E+00,1.0734E+00,1.0037E+00,
37054      &9.3416E-01,8.6065E-01,7.9257E-01,7.3145E-01,6.7463E-01,6.3082E-01,
37055      &5.8786E-01,5.4262E-01,5.0118E-01,4.6374E-01,4.2883E-01,4.0146E-01,
37056      &3.7490E-01,3.4814E-01,3.2612E-01,3.1397E-01,3.0482E-01,2.9958E-01,
37057      &2.9536E-01,2.9178E-01,2.8756E-01,2.8208E-01,2.7504E-01,2.6611E-01,
37058      &2.5539E-01,2.4319E-01,2.3031E-01,2.1877E-01,2.1195E-01,2.4673E-01,
37059      &2.4036E-01,2.3746E-01,2.3912E-01,2.4677E-01,2.6223E-01,2.8748E-01,
37060      &3.2792E-01,3.9255E-01,5.0271E-01,7.2095E-01,0.0000E+00,0.0000E+00,
37061      &6.8578E+00,6.4388E+00,6.0380E+00,5.6501E+00,5.2825E+00,4.9103E+00,
37062      &4.5613E+00,4.2230E+00,3.9070E+00,3.5911E+00,3.2966E+00,3.0156E+00,
37063      &2.7567E+00,2.6078E+00,2.4563E+00,2.2905E+00,2.1319E+00,1.9837E+00,
37064      &1.8421E+00,1.7287E+00,1.6141E+00,1.4902E+00,1.3730E+00,1.2663E+00,
37065      &1.1652E+00,1.0858E+00,1.0067E+00,9.2337E-01,8.4648E-01,7.7710E-01/
37066       DATA (XUDF_L(K),K= 1255, 1368) /
37067      &7.1333E-01,6.6392E-01,6.1566E-01,5.6531E-01,5.1904E-01,4.7761E-01,
37068      &4.3908E-01,4.0927E-01,3.8022E-01,3.5109E-01,3.2686E-01,3.1318E-01,
37069      &3.0244E-01,2.9602E-01,2.9031E-01,2.8538E-01,2.8024E-01,2.7382E-01,
37070      &2.6607E-01,2.5668E-01,2.4571E-01,2.3364E-01,2.2155E-01,2.1116E-01,
37071      &2.0617E-01,2.3421E-01,2.2704E-01,2.2320E-01,2.2366E-01,2.2952E-01,
37072      &2.4241E-01,2.6402E-01,2.9884E-01,3.5437E-01,4.4860E-01,6.3331E-01,
37073      &0.0000E+00,0.0000E+00,7.9784E+00,7.4673E+00,6.9820E+00,6.5121E+00,
37074      &6.0712E+00,5.6250E+00,5.2080E+00,4.8065E+00,4.4309E+00,4.0590E+00,
37075      &3.7131E+00,3.3843E+00,3.0816E+00,2.9094E+00,2.7332E+00,2.5420E+00,
37076      &2.3595E+00,2.1895E+00,2.0271E+00,1.8966E+00,1.7658E+00,1.6248E+00,
37077      &1.4933E+00,1.3718E+00,1.2579E+00,1.1683E+00,1.0795E+00,9.8589E-01,
37078      &8.9996E-01,8.2253E-01,7.5153E-01,6.9648E-01,6.4287E-01,5.8736E-01,
37079      &5.3655E-01,4.9109E-01,4.4891E-01,4.1655E-01,3.8518E-01,3.5367E-01,
37080      &3.2738E-01,3.1221E-01,3.0006E-01,2.9246E-01,2.8544E-01,2.7940E-01,
37081      &2.7319E-01,2.6601E-01,2.5763E-01,2.4782E-01,2.3676E-01,2.2486E-01,
37082      &2.1329E-01,2.0405E-01,2.0083E-01,2.2267E-01,2.1489E-01,2.1027E-01,
37083      &2.0967E-01,2.1409E-01,2.2473E-01,2.4320E-01,2.7316E-01,3.2113E-01,
37084      &4.0209E-01,5.5899E-01,0.0000E+00,0.0000E+00,9.1575E+00,8.5458E+00,
37085      &7.9700E+00,7.4123E+00,6.8876E+00,6.3653E+00,5.8736E+00,5.4042E+00/
37086       DATA (XUDF_L(K),K= 1369, 1482) /
37087      &4.9684E+00,4.5359E+00,4.1366E+00,3.7576E+00,3.4110E+00,3.2138E+00,
37088      &3.0122E+00,2.7943E+00,2.5871E+00,2.3944E+00,2.2102E+00,2.0646E+00,
37089      &1.9163E+00,1.7581E+00,1.6109E+00,1.4753E+00,1.3483E+00,1.2486E+00,
37090      &1.1500E+00,1.0462E+00,9.5130E-01,8.6585E-01,7.8770E-01,7.2741E-01,
37091      &6.6891E-01,6.0781E-01,5.5266E-01,5.0342E-01,4.5788E-01,4.2322E-01,
37092      &3.8960E-01,3.5594E-01,3.2768E-01,3.1125E-01,2.9779E-01,2.8890E-01,
37093      &2.8091E-01,2.7385E-01,2.6670E-01,2.5886E-01,2.4989E-01,2.3976E-01,
37094      &2.2861E-01,2.1703E-01,2.0604E-01,1.9777E-01,1.9598E-01,2.1238E-01,
37095      &2.0408E-01,1.9879E-01,1.9735E-01,2.0048E-01,2.0933E-01,2.2523E-01,
37096      &2.5120E-01,2.9296E-01,3.6305E-01,4.9711E-01,0.0000E+00,0.0000E+00,
37097      &1.0956E+01,1.0188E+01,9.4660E+00,8.7704E+00,8.1209E+00,7.4727E+00,
37098      &6.8721E+00,6.2972E+00,5.7646E+00,5.2434E+00,4.7595E+00,4.3051E+00,
37099      &3.8911E+00,3.6559E+00,3.4174E+00,3.1598E+00,2.9153E+00,2.6889E+00,
37100      &2.4732E+00,2.3031E+00,2.1311E+00,1.9475E+00,1.7771E+00,1.6202E+00,
37101      &1.4748E+00,1.3609E+00,1.2481E+00,1.1301E+00,1.0222E+00,9.2549E-01,
37102      &8.3728E-01,7.6947E-01,7.0373E-01,6.3561E-01,5.7438E-01,5.1959E-01,
37103      &4.6984E-01,4.3187E-01,3.9529E-01,3.5864E-01,3.2783E-01,3.0967E-01,
37104      &2.9444E-01,2.8428E-01,2.7469E-01,2.6638E-01,2.5813E-01,2.4942E-01,
37105      &2.3986E-01,2.2937E-01,2.1819E-01,2.0682E-01,1.9665E-01,1.8966E-01/
37106       DATA (XUDF_L(K),K= 1483, 1596) /
37107      &1.8971E-01,1.9926E-01,1.9036E-01,1.8442E-01,1.8192E-01,1.8362E-01,
37108      &1.9037E-01,2.0318E-01,2.2459E-01,2.5904E-01,3.1665E-01,4.2407E-01,
37109      &0.0000E+00,0.0000E+00,1.2798E+01,1.1861E+01,1.0986E+01,1.0144E+01,
37110      &9.3643E+00,8.5887E+00,7.8706E+00,7.1866E+00,6.5568E+00,5.9419E+00,
37111      &5.3754E+00,4.8419E+00,4.3593E+00,4.0864E+00,3.8109E+00,3.5127E+00,
37112      &3.2315E+00,2.9714E+00,2.7252E+00,2.5309E+00,2.3356E+00,2.1269E+00,
37113      &1.9338E+00,1.7578E+00,1.5939E+00,1.4656E+00,1.3394E+00,1.2075E+00,
37114      &1.0875E+00,9.8023E-01,8.8256E-01,8.0772E-01,7.3533E-01,6.6054E-01,
37115      &5.9364E-01,5.3423E-01,4.8009E-01,4.3930E-01,4.0003E-01,3.6079E-01,
37116      &3.2768E-01,3.0809E-01,2.9130E-01,2.7993E-01,2.6898E-01,2.5976E-01,
37117      &2.5062E-01,2.4123E-01,2.3116E-01,2.2040E-01,2.0917E-01,1.9814E-01,
37118      &1.8865E-01,1.8272E-01,1.8428E-01,1.8820E-01,1.7883E-01,1.7238E-01,
37119      &1.6914E-01,1.6979E-01,1.7482E-01,1.8534E-01,2.0325E-01,2.3214E-01,
37120      &2.8022E-01,3.6659E-01,0.0000E+00,0.0000E+00,1.4900E+01,1.3767E+01,
37121      &1.2708E+01,1.1700E+01,1.0766E+01,9.8403E+00,8.9832E+00,8.1757E+00,
37122      &7.4366E+00,6.7121E+00,6.0486E+00,5.4300E+00,4.8704E+00,4.5555E+00,
37123      &4.2371E+00,3.8955E+00,3.5734E+00,3.2760E+00,2.9952E+00,2.7738E+00,
37124      &2.5528E+00,2.3175E+00,2.1001E+00,1.9012E+00,1.7176E+00,1.5750E+00,
37125      &1.4344E+00,1.2880E+00,1.1547E+00,1.0364E+00,9.2859E-01,8.4652E-01/
37126       DATA (XUDF_L(K),K= 1597, 1710) /
37127      &7.6723E-01,6.8578E-01,6.1255E-01,5.4848E-01,4.9034E-01,4.4649E-01,
37128      &4.0456E-01,3.6275E-01,3.2738E-01,3.0624E-01,2.8805E-01,2.7544E-01,
37129      &2.6343E-01,2.5315E-01,2.4318E-01,2.3314E-01,2.2263E-01,2.1166E-01,
37130      &2.0051E-01,1.8983E-01,1.8102E-01,1.7610E-01,1.7901E-01,1.7764E-01,
37131      &1.6791E-01,1.6102E-01,1.5715E-01,1.5684E-01,1.6056E-01,1.6899E-01,
37132      &1.8376E-01,2.0786E-01,2.4776E-01,3.1470E-01,0.0000E+00,0.0000E+00,
37133      &1.7212E+01,1.5853E+01,1.4590E+01,1.3390E+01,1.2283E+01,1.1191E+01,
37134      &1.0185E+01,9.2395E+00,8.3762E+00,7.5315E+00,6.7670E+00,6.0503E+00,
37135      &5.4086E+00,5.0481E+00,4.6843E+00,4.2940E+00,3.9280E+00,3.5917E+00,
37136      &3.2752E+00,3.0252E+00,2.7768E+00,2.5132E+00,2.2690E+00,2.0490E+00,
37137      &1.8445E+00,1.6857E+00,1.5301E+00,1.3685E+00,1.2219E+00,1.0920E+00,
37138      &9.7438E-01,8.8478E-01,7.9825E-01,7.1007E-01,6.3111E-01,5.6196E-01,
37139      &5.0016E-01,4.5321E-01,4.0867E-01,3.6435E-01,3.2686E-01,3.0431E-01,
37140      &2.8470E-01,2.7109E-01,2.5789E-01,2.4674E-01,2.3605E-01,2.2547E-01,
37141      &2.1459E-01,2.0348E-01,1.9237E-01,1.8201E-01,1.7376E-01,1.6982E-01,
37142      &1.7398E-01,1.6789E-01,1.5795E-01,1.5065E-01,1.4630E-01,1.4521E-01,
37143      &1.4773E-01,1.5443E-01,1.6659E-01,1.8664E-01,2.1966E-01,2.6878E-01,
37144      &0.0000E+00,0.0000E+00,1.9526E+01,1.7951E+01,1.6470E+01,1.5074E+01,
37145      &1.3790E+01,1.2527E+01,1.1370E+01,1.0282E+01,9.2958E+00,8.3330E+00/
37146       DATA (XUDF_L(K),K= 1711, 1824) /
37147      &7.4603E+00,6.6536E+00,5.9285E+00,5.5219E+00,5.1141E+00,4.6768E+00,
37148      &4.2681E+00,3.8926E+00,3.5402E+00,3.2626E+00,2.9882E+00,2.6963E+00,
37149      &2.4284E+00,2.1851E+00,1.9619E+00,1.7885E+00,1.6187E+00,1.4429E+00,
37150      &1.2838E+00,1.1431E+00,1.0159E+00,9.1924E-01,8.2663E-01,7.3180E-01,
37151      &6.4793E-01,5.7429E-01,5.0828E-01,4.5904E-01,4.1215E-01,3.6558E-01,
37152      &3.2620E-01,3.0238E-01,2.8167E-01,2.6700E-01,2.5302E-01,2.4098E-01,
37153      &2.2975E-01,2.1873E-01,2.0756E-01,1.9633E-01,1.8532E-01,1.7533E-01,
37154      &1.6763E-01,1.6450E-01,1.6959E-01,1.5953E-01,1.4943E-01,1.4185E-01,
37155      &1.3716E-01,1.3545E-01,1.3705E-01,1.4238E-01,1.5258E-01,1.6945E-01,
37156      &1.9705E-01,2.3049E-01,0.0000E+00,0.0000E+00,2.2141E+01,2.0286E+01,
37157      &1.8570E+01,1.6948E+01,1.5466E+01,1.4010E+01,1.2679E+01,1.1431E+01,
37158      &1.0303E+01,9.2106E+00,8.2239E+00,7.3077E+00,6.4926E+00,6.0348E+00,
37159      &5.5765E+00,5.0879E+00,4.6321E+00,4.2138E+00,3.8233E+00,3.5162E+00,
37160      &3.2122E+00,2.8907E+00,2.5960E+00,2.3300E+00,2.0856E+00,1.8954E+00,
37161      &1.7110E+00,1.5199E+00,1.3476E+00,1.1955E+00,1.0584E+00,9.5478E-01,
37162      &8.5531E-01,7.5417E-01,6.6439E-01,5.8623E-01,5.1682E-01,4.6468E-01,
37163      &4.1541E-01,3.6662E-01,3.2538E-01,3.0035E-01,2.7843E-01,2.6291E-01,
37164      &2.4798E-01,2.3522E-01,2.2346E-01,2.1203E-01,2.0062E-01,1.8935E-01,
37165      &1.7843E-01,1.6874E-01,1.6163E-01,1.5920E-01,1.6520E-01,1.5147E-01/
37166       DATA (XUDF_L(K),K= 1825, 1836) /
37167      &1.4120E-01,1.3349E-01,1.2844E-01,1.2620E-01,1.2701E-01,1.3118E-01,
37168      &1.3954E-01,1.5369E-01,1.7631E-01,1.9416E-01,0.0000E+00,0.0000E+00/
37169       DATA (XSF_L(K),K=    1,  114) /
37170      &8.9277E-03,9.2838E-03,9.6380E-03,9.9960E-03,1.0349E-02,1.0719E-02,
37171      &1.1082E-02,1.1442E-02,1.1792E-02,1.2148E-02,1.2489E-02,1.2817E-02,
37172      &1.3124E-02,1.3295E-02,1.3474E-02,1.3661E-02,1.3835E-02,1.3985E-02,
37173      &1.4121E-02,1.4217E-02,1.4303E-02,1.4379E-02,1.4419E-02,1.4434E-02,
37174      &1.4412E-02,1.4366E-02,1.4286E-02,1.4158E-02,1.3991E-02,1.3790E-02,
37175      &1.3553E-02,1.3335E-02,1.3094E-02,1.2821E-02,1.2580E-02,1.2410E-02,
37176      &1.2357E-02,1.2459E-02,1.2790E-02,1.3571E-02,1.5018E-02,1.6665E-02,
37177      &1.9113E-02,2.1832E-02,2.5587E-02,2.9818E-02,3.4535E-02,3.9813E-02,
37178      &4.5737E-02,5.2358E-02,5.9765E-02,6.8021E-02,7.7185E-02,8.7258E-02,
37179      &9.8198E-02,1.1073E-01,1.4216E-01,1.8364E-01,2.3959E-01,3.1758E-01,
37180      &4.3050E-01,6.0203E-01,8.8214E-01,1.3845E+00,2.4294E+00,5.2463E+00,
37181      &1.8903E+01,0.0000E+00,1.4987E-02,1.5468E-02,1.5936E-02,1.6403E-02,
37182      &1.6855E-02,1.7319E-02,1.7760E-02,1.8194E-02,1.8600E-02,1.9008E-02,
37183      &1.9382E-02,1.9730E-02,2.0033E-02,2.0199E-02,2.0359E-02,2.0523E-02,
37184      &2.0654E-02,2.0760E-02,2.0831E-02,2.0870E-02,2.0886E-02,2.0858E-02,
37185      &2.0798E-02,2.0680E-02,2.0523E-02,2.0363E-02,2.0127E-02,1.9825E-02,
37186      &1.9464E-02,1.9060E-02,1.8607E-02,1.8200E-02,1.7750E-02,1.7240E-02,
37187      &1.6759E-02,1.6362E-02,1.6103E-02,1.6050E-02,1.6240E-02,1.6916E-02,
37188      &1.8336E-02,2.0030E-02,2.2586E-02,2.5447E-02,2.9418E-02,3.3874E-02/
37189       DATA (XSF_L(K),K=  115,  228) /
37190      &3.8821E-02,4.4375E-02,5.0509E-02,5.7343E-02,6.4974E-02,7.3385E-02,
37191      &8.2640E-02,9.2732E-02,1.0354E-01,1.1667E-01,1.4809E-01,1.8910E-01,
37192      &2.4387E-01,3.1940E-01,4.2764E-01,5.9054E-01,8.5228E-01,1.3150E+00,
37193      &2.2623E+00,4.7596E+00,1.6445E+01,0.0000E+00,2.5010E-02,2.5616E-02,
37194      &2.6180E-02,2.6758E-02,2.7279E-02,2.7792E-02,2.8274E-02,2.8729E-02,
37195      &2.9134E-02,2.9513E-02,2.9836E-02,3.0110E-02,3.0324E-02,3.0417E-02,
37196      &3.0492E-02,3.0537E-02,3.0551E-02,3.0517E-02,3.0432E-02,3.0326E-02,
37197      &3.0181E-02,2.9954E-02,2.9663E-02,2.9316E-02,2.8913E-02,2.8508E-02,
37198      &2.8021E-02,2.7422E-02,2.6741E-02,2.5997E-02,2.5204E-02,2.4500E-02,
37199      &2.3734E-02,2.2858E-02,2.2019E-02,2.1281E-02,2.0698E-02,2.0402E-02,
37200      &2.0365E-02,2.0844E-02,2.2137E-02,2.3807E-02,2.6404E-02,2.9338E-02,
37201      &3.3433E-02,3.8036E-02,4.3135E-02,4.8799E-02,5.5061E-02,6.1999E-02,
37202      &6.9633E-02,7.8024E-02,8.7156E-02,9.6998E-02,1.0742E-01,1.2099E-01,
37203      &1.5162E-01,1.9121E-01,2.4363E-01,3.1510E-01,4.1638E-01,5.6669E-01,
37204      &8.0557E-01,1.2216E+00,2.0572E+00,4.2084E+00,1.3911E+01,0.0000E+00,
37205      &4.2554E-02,4.3210E-02,4.3820E-02,4.4379E-02,4.4862E-02,4.5317E-02,
37206      &4.5708E-02,4.6037E-02,4.6300E-02,4.6434E-02,4.6540E-02,4.6530E-02,
37207      &4.6426E-02,4.6317E-02,4.6155E-02,4.5919E-02,4.5622E-02,4.5267E-02,
37208      &4.4833E-02,4.4425E-02,4.3932E-02,4.3298E-02,4.2582E-02,4.1785E-02/
37209       DATA (XSF_L(K),K=  229,  342) /
37210      &4.0903E-02,4.0097E-02,3.9179E-02,3.8047E-02,3.6815E-02,3.5547E-02,
37211      &3.4199E-02,3.3020E-02,3.1748E-02,3.0298E-02,2.8905E-02,2.7644E-02,
37212      &2.6563E-02,2.5882E-02,2.5485E-02,2.5614E-02,2.6651E-02,2.8199E-02,
37213      &3.0731E-02,3.3652E-02,3.7768E-02,4.2390E-02,4.7530E-02,5.3188E-02,
37214      &5.9436E-02,6.6257E-02,7.3734E-02,8.1918E-02,9.0696E-02,1.0004E-01,
37215      &1.0978E-01,1.2357E-01,1.5274E-01,1.8999E-01,2.3888E-01,3.0452E-01,
37216      &3.9656E-01,5.3136E-01,7.4246E-01,1.1043E+00,1.8158E+00,3.6023E+00,
37217      &0.0000E+00,0.0000E+00,7.3602E-02,7.4085E-02,7.4460E-02,7.4729E-02,
37218      &7.4904E-02,7.4982E-02,7.4902E-02,7.4713E-02,7.4446E-02,7.3972E-02,
37219      &7.3397E-02,7.2626E-02,7.1803E-02,7.1200E-02,7.0479E-02,6.9610E-02,
37220      &6.8654E-02,6.7624E-02,6.6495E-02,6.5467E-02,6.4313E-02,6.2898E-02,
37221      &6.1380E-02,5.9788E-02,5.8079E-02,5.6557E-02,5.4876E-02,5.2866E-02,
37222      &5.0733E-02,4.8592E-02,4.6341E-02,4.4415E-02,4.2370E-02,4.0073E-02,
37223      &3.7825E-02,3.5778E-02,3.3956E-02,3.2702E-02,3.1749E-02,3.1334E-02,
37224      &3.1922E-02,3.3216E-02,3.5534E-02,3.8322E-02,4.2321E-02,4.6830E-02,
37225      &5.1816E-02,5.7335E-02,6.3369E-02,6.9947E-02,7.7109E-02,8.4752E-02,
37226      &9.2948E-02,1.0153E-01,1.1031E-01,1.2405E-01,1.5100E-01,1.8509E-01,
37227      &2.2905E-01,2.8761E-01,3.6847E-01,4.8537E-01,6.6543E-01,9.6831E-01,
37228      &1.5524E+00,2.9766E+00,0.0000E+00,0.0000E+00,1.1509E-01,1.1500E-01/
37229       DATA (XSF_L(K),K=  343,  456) /
37230      &1.1474E-01,1.1430E-01,1.1371E-01,1.1292E-01,1.1196E-01,1.1079E-01,
37231      &1.0948E-01,1.0791E-01,1.0620E-01,1.0426E-01,1.0215E-01,1.0076E-01,
37232      &9.9224E-02,9.7466E-02,9.5472E-02,9.3507E-02,9.1346E-02,8.9460E-02,
37233      &8.7382E-02,8.4914E-02,8.2326E-02,7.9663E-02,7.6874E-02,7.4459E-02,
37234      &7.1794E-02,6.8694E-02,6.5489E-02,6.2266E-02,5.8964E-02,5.6164E-02,
37235      &5.3226E-02,4.9916E-02,4.6721E-02,4.3794E-02,4.1128E-02,3.9225E-02,
37236      &3.7654E-02,3.6613E-02,3.6666E-02,3.7626E-02,3.9655E-02,4.2227E-02,
37237      &4.6000E-02,5.0288E-02,5.5044E-02,6.0308E-02,6.6020E-02,7.2218E-02,
37238      &7.8943E-02,8.6079E-02,9.3611E-02,1.0141E-01,1.0925E-01,1.2274E-01,
37239      &1.4748E-01,1.7840E-01,2.1791E-01,2.6997E-01,3.4109E-01,4.4280E-01,
37240      &5.9706E-01,8.5325E-01,1.3371E+00,2.4909E+00,0.0000E+00,0.0000E+00,
37241      &1.8131E-01,1.7986E-01,1.7802E-01,1.7597E-01,1.7372E-01,1.7110E-01,
37242      &1.6825E-01,1.6515E-01,1.6187E-01,1.5820E-01,1.5428E-01,1.5016E-01,
37243      &1.4582E-01,1.4314E-01,1.4017E-01,1.3677E-01,1.3315E-01,1.2951E-01,
37244      &1.2571E-01,1.2248E-01,1.1891E-01,1.1472E-01,1.1045E-01,1.0615E-01,
37245      &1.0173E-01,9.7944E-02,9.3854E-02,8.9131E-02,8.4347E-02,7.9597E-02,
37246      &7.4799E-02,7.0788E-02,6.6599E-02,6.1932E-02,5.7438E-02,5.3307E-02,
37247      &4.9546E-02,4.6816E-02,4.4417E-02,4.2536E-02,4.1862E-02,4.2361E-02,
37248      &4.3960E-02,4.6198E-02,4.9612E-02,5.3553E-02,5.7974E-02,6.2830E-02/
37249       DATA (XSF_L(K),K=  457,  570) /
37250      &6.8141E-02,7.3865E-02,7.9970E-02,8.6422E-02,9.3160E-02,1.0006E-01,
37251      &1.0685E-01,1.1989E-01,1.4199E-01,1.6937E-01,2.0407E-01,2.4925E-01,
37252      &3.1029E-01,3.9635E-01,5.2529E-01,7.3579E-01,1.1263E+00,2.0347E+00,
37253      &0.0000E+00,0.0000E+00,2.6278E-01,2.5883E-01,2.5460E-01,2.5007E-01,
37254      &2.4526E-01,2.3995E-01,2.3437E-01,2.2848E-01,2.2242E-01,2.1578E-01,
37255      &2.0894E-01,2.0181E-01,1.9465E-01,1.9018E-01,1.8540E-01,1.7984E-01,
37256      &1.7415E-01,1.6846E-01,1.6261E-01,1.5768E-01,1.5234E-01,1.4615E-01,
37257      &1.3987E-01,1.3368E-01,1.2736E-01,1.2199E-01,1.1628E-01,1.0975E-01,
37258      &1.0321E-01,9.6788E-02,9.0380E-02,8.5059E-02,7.9532E-02,7.3436E-02,
37259      &6.7594E-02,6.2243E-02,5.7363E-02,5.3720E-02,5.0502E-02,4.7772E-02,
37260      &4.6346E-02,4.6358E-02,4.7497E-02,4.9377E-02,5.2401E-02,5.5965E-02,
37261      &6.0009E-02,6.4489E-02,6.9334E-02,7.4546E-02,8.0117E-02,8.5936E-02,
37262      &9.1972E-02,9.8056E-02,1.0398E-01,1.1644E-01,1.3628E-01,1.6068E-01,
37263      &1.9127E-01,2.3085E-01,2.8377E-01,3.5756E-01,4.6698E-01,6.4315E-01,
37264      &9.6485E-01,1.6969E+00,0.0000E+00,0.0000E+00,3.6944E-01,3.6187E-01,
37265      &3.5380E-01,3.4525E-01,3.3659E-01,3.2716E-01,3.1761E-01,3.0767E-01,
37266      &2.9759E-01,2.8675E-01,2.7586E-01,2.6462E-01,2.5339E-01,2.4660E-01,
37267      &2.3933E-01,2.3101E-01,2.2257E-01,2.1415E-01,2.0571E-01,1.9854E-01,
37268      &1.9083E-01,1.8216E-01,1.7338E-01,1.6480E-01,1.5613E-01,1.4885E-01/
37269       DATA (XSF_L(K),K=  571,  684) /
37270      &1.4115E-01,1.3244E-01,1.2380E-01,1.1542E-01,1.0713E-01,1.0031E-01,
37271      &9.3226E-02,8.5515E-02,7.8171E-02,7.1449E-02,6.5307E-02,6.0723E-02,
37272      &5.6523E-02,5.2878E-02,5.0622E-02,5.0109E-02,5.0720E-02,5.2187E-02,
37273      &5.4770E-02,5.7950E-02,6.1582E-02,6.5595E-02,6.9997E-02,7.4716E-02,
37274      &7.9677E-02,8.4886E-02,9.0221E-02,9.5543E-02,1.0065E-01,1.1245E-01,
37275      &1.3012E-01,1.5166E-01,1.7859E-01,2.1305E-01,2.5881E-01,3.2188E-01,
37276      &4.1454E-01,5.6186E-01,8.2718E-01,1.4188E+00,0.0000E+00,0.0000E+00,
37277      &4.9195E-01,4.7916E-01,4.6620E-01,4.5277E-01,4.3908E-01,4.2463E-01,
37278      &4.0985E-01,3.9491E-01,3.7975E-01,3.6377E-01,3.4790E-01,3.3178E-01,
37279      &3.1592E-01,3.0640E-01,2.9622E-01,2.8462E-01,2.7303E-01,2.6160E-01,
37280      &2.5012E-01,2.4047E-01,2.3023E-01,2.1867E-01,2.0717E-01,1.9597E-01,
37281      &1.8477E-01,1.7546E-01,1.6568E-01,1.5468E-01,1.4387E-01,1.3343E-01,
37282      &1.2319E-01,1.1482E-01,1.0622E-01,9.6828E-02,8.7978E-02,7.9884E-02,
37283      &7.2526E-02,6.6973E-02,6.1948E-02,5.7359E-02,5.4304E-02,5.3263E-02,
37284      &5.3381E-02,5.4456E-02,5.6601E-02,5.9380E-02,6.2613E-02,6.6252E-02,
37285      &7.0174E-02,7.4432E-02,7.8943E-02,8.3559E-02,8.8282E-02,9.2963E-02,
37286      &9.7382E-02,1.0858E-01,1.2441E-01,1.4363E-01,1.6745E-01,1.9778E-01,
37287      &2.3771E-01,2.9246E-01,3.7200E-01,4.9738E-01,7.2010E-01,1.2083E+00,
37288      &0.0000E+00,0.0000E+00,6.4521E-01,6.2534E-01,6.0540E-01,5.8499E-01/
37289       DATA (XSF_L(K),K=  685,  798) /
37290      &5.6467E-01,5.4301E-01,5.2143E-01,4.9951E-01,4.7813E-01,4.5538E-01,
37291      &4.3325E-01,4.1083E-01,3.8899E-01,3.7591E-01,3.6210E-01,3.4648E-01,
37292      &3.3091E-01,3.1578E-01,3.0062E-01,2.8797E-01,2.7469E-01,2.5979E-01,
37293      &2.4501E-01,2.3066E-01,2.1649E-01,2.0481E-01,1.9252E-01,1.7884E-01,
37294      &1.6549E-01,1.5274E-01,1.4029E-01,1.3018E-01,1.1985E-01,1.0865E-01,
37295      &9.8135E-02,8.8550E-02,7.9829E-02,7.3318E-02,6.7269E-02,6.1748E-02,
37296      &5.7838E-02,5.6250E-02,5.5826E-02,5.6474E-02,5.8181E-02,6.0533E-02,
37297      &6.3373E-02,6.6563E-02,7.0085E-02,7.3865E-02,7.7842E-02,8.1937E-02,
37298      &8.6092E-02,9.0169E-02,9.3962E-02,1.0448E-01,1.1858E-01,1.3561E-01,
37299      &1.5663E-01,1.8318E-01,2.1803E-01,2.6529E-01,3.3349E-01,4.3985E-01,
37300      &6.2661E-01,1.0291E+00,0.0000E+00,0.0000E+00,8.2462E-01,7.9558E-01,
37301      &7.6680E-01,7.3764E-01,7.0860E-01,6.7834E-01,6.4822E-01,6.1798E-01,
37302      &5.8880E-01,5.5792E-01,5.2800E-01,4.9801E-01,4.6912E-01,4.5197E-01,
37303      &4.3393E-01,4.1360E-01,3.9348E-01,3.7394E-01,3.5462E-01,3.3856E-01,
37304      &3.2180E-01,3.0303E-01,2.8460E-01,2.6681E-01,2.4932E-01,2.3502E-01,
37305      &2.2005E-01,2.0359E-01,1.8747E-01,1.7224E-01,1.5746E-01,1.4551E-01,
37306      &1.3337E-01,1.2028E-01,1.0805E-01,9.6986E-02,8.6877E-02,7.9334E-02,
37307      &7.2326E-02,6.5799E-02,6.1060E-02,5.8911E-02,5.7957E-02,5.8189E-02,
37308      &5.9441E-02,6.1387E-02,6.3834E-02,6.6632E-02,6.9732E-02,7.3070E-02/
37309       DATA (XSF_L(K),K=  799,  912) /
37310      &7.6595E-02,8.0190E-02,8.3816E-02,8.7358E-02,9.0631E-02,1.0046E-01,
37311      &1.1304E-01,1.2815E-01,1.4670E-01,1.7006E-01,2.0049E-01,2.4154E-01,
37312      &3.0039E-01,3.9121E-01,5.4894E-01,8.8378E-01,0.0000E+00,0.0000E+00,
37313      &1.0199E+00,9.8025E-01,9.4100E-01,9.0151E-01,8.6283E-01,8.2243E-01,
37314      &7.8262E-01,7.4321E-01,7.0465E-01,6.6494E-01,6.2647E-01,5.8811E-01,
37315      &5.5152E-01,5.2985E-01,5.0721E-01,4.8183E-01,4.5681E-01,4.3274E-01,
37316      &4.0883E-01,3.8916E-01,3.6878E-01,3.4589E-01,3.2366E-01,3.0238E-01,
37317      &2.8152E-01,2.6437E-01,2.4685E-01,2.2733E-01,2.0858E-01,1.9085E-01,
37318      &1.7375E-01,1.6000E-01,1.4607E-01,1.3115E-01,1.1722E-01,1.0469E-01,
37319      &9.3284E-02,8.4739E-02,7.6803E-02,6.9420E-02,6.3844E-02,6.1178E-02,
37320      &5.9720E-02,5.9561E-02,6.0398E-02,6.1984E-02,6.4051E-02,6.6494E-02,
37321      &6.9202E-02,7.2161E-02,7.5274E-02,7.8453E-02,8.1651E-02,8.4728E-02,
37322      &8.7564E-02,9.6777E-02,1.0806E-01,1.2157E-01,1.3806E-01,1.5882E-01,
37323      &1.8566E-01,2.2170E-01,2.7301E-01,3.5168E-01,4.8696E-01,7.7010E-01,
37324      &0.0000E+00,0.0000E+00,1.3158E+00,1.2585E+00,1.2024E+00,1.1462E+00,
37325      &1.0919E+00,1.0352E+00,9.8042E-01,9.2608E-01,8.7345E-01,8.1987E-01,
37326      &7.6814E-01,7.1724E-01,6.6882E-01,6.4053E-01,6.1093E-01,5.7796E-01,
37327      &5.4572E-01,5.1470E-01,4.8433E-01,4.5934E-01,4.3358E-01,4.0495E-01,
37328      &3.7717E-01,3.5082E-01,3.2513E-01,3.0408E-01,2.8258E-01,2.5918E-01/
37329       DATA (XSF_L(K),K=  913, 1026) /
37330      &2.3648E-01,2.1538E-01,1.9510E-01,1.7888E-01,1.6255E-01,1.4508E-01,
37331      &1.2895E-01,1.1443E-01,1.0131E-01,9.1507E-02,8.2387E-02,7.3778E-02,
37332      &6.7147E-02,6.3813E-02,6.1721E-02,6.1065E-02,6.1373E-02,6.2475E-02,
37333      &6.4105E-02,6.6079E-02,6.8362E-02,7.0856E-02,7.3440E-02,7.6143E-02,
37334      &7.8812E-02,8.1388E-02,8.3726E-02,9.2167E-02,1.0190E-01,1.1355E-01,
37335      &1.2780E-01,1.4554E-01,1.6841E-01,1.9900E-01,2.4223E-01,3.0775E-01,
37336      &4.1920E-01,6.4849E-01,0.0000E+00,0.0000E+00,1.6483E+00,1.5703E+00,
37337      &1.4940E+00,1.4180E+00,1.3449E+00,1.2694E+00,1.1966E+00,1.1250E+00,
37338      &1.0566E+00,9.8644E-01,9.1985E-01,8.5482E-01,7.9312E-01,7.5722E-01,
37339      &7.1986E-01,6.7849E-01,6.3821E-01,5.9972E-01,5.6214E-01,5.3143E-01,
37340      &4.9987E-01,4.6500E-01,4.3136E-01,3.9956E-01,3.6875E-01,3.4379E-01,
37341      &3.1832E-01,2.9044E-01,2.6397E-01,2.3923E-01,2.1580E-01,1.9706E-01,
37342      &1.7829E-01,1.5838E-01,1.3999E-01,1.2356E-01,1.0875E-01,9.7664E-02,
37343      &8.7392E-02,7.7645E-02,7.0035E-02,6.6062E-02,6.3365E-02,6.2239E-02,
37344      &6.2062E-02,6.2731E-02,6.3942E-02,6.5526E-02,6.7390E-02,6.9436E-02,
37345      &7.1635E-02,7.3891E-02,7.6122E-02,7.8246E-02,8.0196E-02,8.7884E-02,
37346      &9.6357E-02,1.0648E-01,1.1880E-01,1.3413E-01,1.5386E-01,1.7993E-01,
37347      &2.1655E-01,2.7189E-01,3.6486E-01,5.5332E-01,0.0000E+00,0.0000E+00,
37348      &2.0271E+00,1.9234E+00,1.8224E+00,1.7226E+00,1.6272E+00,1.5293E+00/
37349       DATA (XSF_L(K),K= 1027, 1140) /
37350      &1.4356E+00,1.3438E+00,1.2568E+00,1.1682E+00,1.0841E+00,1.0026E+00,
37351      &9.2625E-01,8.8207E-01,8.3568E-01,7.8523E-01,7.3607E-01,6.8926E-01,
37352      &6.4385E-01,6.0685E-01,5.6892E-01,5.2730E-01,4.8731E-01,4.4961E-01,
37353      &4.1331E-01,3.8417E-01,3.5441E-01,3.2210E-01,2.9168E-01,2.6323E-01,
37354      &2.3631E-01,2.1500E-01,1.9374E-01,1.7129E-01,1.5067E-01,1.3231E-01,
37355      &1.1579E-01,1.0349E-01,9.2080E-02,8.1205E-02,7.2626E-02,6.8039E-02,
37356      &6.4761E-02,6.3188E-02,6.2549E-02,6.2795E-02,6.3617E-02,6.4835E-02,
37357      &6.6329E-02,6.8017E-02,6.9809E-02,7.1667E-02,7.3520E-02,7.5270E-02,
37358      &7.6864E-02,8.3899E-02,9.1206E-02,1.0002E-01,1.1070E-01,1.2399E-01,
37359      &1.4094E-01,1.6341E-01,1.9474E-01,2.4163E-01,3.1971E-01,4.7587E-01,
37360      &0.0000E+00,0.0000E+00,2.4392E+00,2.3049E+00,2.1760E+00,2.0502E+00,
37361      &1.9296E+00,1.8065E+00,1.6895E+00,1.5750E+00,1.4674E+00,1.3585E+00,
37362      &1.2554E+00,1.1565E+00,1.0638E+00,1.0103E+00,9.5527E-01,8.9449E-01,
37363      &8.3572E-01,7.8018E-01,7.2635E-01,6.8280E-01,6.3819E-01,5.8948E-01,
37364      &5.4299E-01,4.9923E-01,4.5740E-01,4.2371E-01,3.8978E-01,3.5296E-01,
37365      &3.1832E-01,2.8629E-01,2.5599E-01,2.3212E-01,2.0840E-01,1.8346E-01,
37366      &1.6065E-01,1.4043E-01,1.2229E-01,1.0880E-01,9.6294E-02,8.4335E-02,
37367      &7.4905E-02,6.9717E-02,6.5897E-02,6.3914E-02,6.2851E-02,6.2731E-02,
37368      &6.3183E-02,6.4075E-02,6.5225E-02,6.6597E-02,6.8048E-02,6.9577E-02/
37369       DATA (XSF_L(K),K= 1141, 1254) /
37370      &7.1093E-02,7.2525E-02,7.3842E-02,8.0241E-02,8.6615E-02,9.4292E-02,
37371      &1.0360E-01,1.1517E-01,1.2992E-01,1.4936E-01,1.7633E-01,2.1652E-01,
37372      &2.8294E-01,4.1389E-01,0.0000E+00,0.0000E+00,2.9162E+00,2.7470E+00,
37373      &2.5840E+00,2.4244E+00,2.2743E+00,2.1215E+00,1.9764E+00,1.8358E+00,
37374      &1.7035E+00,1.5708E+00,1.4463E+00,1.3268E+00,1.2152E+00,1.1514E+00,
37375      &1.0857E+00,1.0132E+00,9.4449E-01,8.7867E-01,8.1556E-01,7.6453E-01,
37376      &7.1252E-01,6.5602E-01,6.0218E-01,5.5192E-01,5.0387E-01,4.6545E-01,
37377      &4.2679E-01,3.8521E-01,3.4602E-01,3.1005E-01,2.7623E-01,2.4962E-01,
37378      &2.2332E-01,1.9577E-01,1.7070E-01,1.4856E-01,1.2874E-01,1.1402E-01,
37379      &1.0040E-01,8.7343E-02,7.6984E-02,7.1254E-02,6.6892E-02,6.4508E-02,
37380      &6.3019E-02,6.2518E-02,6.2667E-02,6.3211E-02,6.4031E-02,6.5064E-02,
37381      &6.6243E-02,6.7458E-02,6.8679E-02,6.9830E-02,7.0885E-02,7.6672E-02,
37382      &8.2192E-02,8.8844E-02,9.6930E-02,1.0696E-01,1.1972E-01,1.3654E-01,
37383      &1.5978E-01,1.9411E-01,2.5048E-01,3.6023E-01,0.0000E+00,0.0000E+00,
37384      &3.4281E+00,3.2194E+00,3.0180E+00,2.8239E+00,2.6400E+00,2.4537E+00,
37385      &2.2781E+00,2.1087E+00,1.9503E+00,1.7915E+00,1.6433E+00,1.5021E+00,
37386      &1.3711E+00,1.2958E+00,1.2191E+00,1.1350E+00,1.0536E+00,9.7846E-01,
37387      &9.0526E-01,8.4668E-01,7.8697E-01,7.2243E-01,6.6110E-01,6.0402E-01,
37388      &5.4971E-01,5.0652E-01,4.6307E-01,4.1647E-01,3.7287E-01,3.3288E-01/
37389       DATA (XSF_L(K),K= 1255, 1368) /
37390      &2.9545E-01,2.6636E-01,2.3751E-01,2.0740E-01,1.8012E-01,1.5611E-01,
37391      &1.3467E-01,1.1881E-01,1.0414E-01,9.0105E-02,7.8839E-02,7.2563E-02,
37392      &6.7703E-02,6.4930E-02,6.3070E-02,6.2241E-02,6.2071E-02,6.2347E-02,
37393      &6.2882E-02,6.3645E-02,6.4526E-02,6.5473E-02,6.6427E-02,6.7333E-02,
37394      &6.8194E-02,7.3430E-02,7.8217E-02,8.3974E-02,9.1017E-02,9.9745E-02,
37395      &1.1088E-01,1.2552E-01,1.4563E-01,1.7528E-01,2.2351E-01,3.1636E-01,
37396      &0.0000E+00,0.0000E+00,3.9892E+00,3.7328E+00,3.4900E+00,3.2549E+00,
37397      &3.0344E+00,2.8108E+00,2.6014E+00,2.4001E+00,2.2123E+00,2.0253E+00,
37398      &1.8518E+00,1.6860E+00,1.5339E+00,1.4463E+00,1.3575E+00,1.2608E+00,
37399      &1.1678E+00,1.0809E+00,9.9767E-01,9.3087E-01,8.6314E-01,7.8996E-01,
37400      &7.2083E-01,6.5671E-01,5.9602E-01,5.4775E-01,4.9935E-01,4.4773E-01,
37401      &3.9951E-01,3.5571E-01,3.1467E-01,2.8272E-01,2.5135E-01,2.1871E-01,
37402      &1.8923E-01,1.6331E-01,1.4031E-01,1.2332E-01,1.0762E-01,9.2560E-02,
37403      &8.0473E-02,7.3714E-02,6.8385E-02,6.5246E-02,6.3019E-02,6.1878E-02,
37404      &6.1420E-02,6.1413E-02,6.1734E-02,6.2226E-02,6.2861E-02,6.3564E-02,
37405      &6.4288E-02,6.4985E-02,6.5657E-02,7.0367E-02,7.4522E-02,7.9506E-02,
37406      &8.5651E-02,9.3297E-02,1.0298E-01,1.1572E-01,1.3323E-01,1.5884E-01,
37407      &2.0039E-01,2.7925E-01,0.0000E+00,0.0000E+00,4.5788E+00,4.2729E+00,
37408      &3.9840E+00,3.7039E+00,3.4438E+00,3.1812E+00,2.9349E+00,2.6996E+00/
37409       DATA (XSF_L(K),K= 1369, 1482) /
37410      &2.4810E+00,2.2644E+00,2.0633E+00,1.8732E+00,1.6979E+00,1.5988E+00,
37411      &1.4974E+00,1.3865E+00,1.2812E+00,1.1834E+00,1.0891E+00,1.0143E+00,
37412      &9.3839E-01,8.5662E-01,7.7948E-01,7.0838E-01,6.4106E-01,5.8780E-01,
37413      &5.3454E-01,4.7781E-01,4.2528E-01,3.7737E-01,3.3289E-01,2.9818E-01,
37414      &2.6446E-01,2.2932E-01,1.9770E-01,1.7005E-01,1.4552E-01,1.2746E-01,
37415      &1.1078E-01,9.4770E-02,8.1957E-02,7.4689E-02,6.8915E-02,6.5457E-02,
37416      &6.2902E-02,6.1493E-02,6.0768E-02,6.0515E-02,6.0585E-02,6.0863E-02,
37417      &6.1298E-02,6.1789E-02,6.2311E-02,6.2835E-02,6.3340E-02,6.7601E-02,
37418      &7.1162E-02,7.5516E-02,8.0878E-02,8.7566E-02,9.6095E-02,1.0725E-01,
37419      &1.2258E-01,1.4495E-01,1.8090E-01,2.4841E-01,0.0000E+00,0.0000E+00,
37420      &5.4774E+00,5.0929E+00,4.7320E+00,4.3841E+00,4.0592E+00,3.7350E+00,
37421      &3.4329E+00,3.1454E+00,2.8799E+00,2.6172E+00,2.3747E+00,2.1466E+00,
37422      &1.9383E+00,1.8195E+00,1.6996E+00,1.5689E+00,1.4457E+00,1.3301E+00,
37423      &1.2211E+00,1.1339E+00,1.0456E+00,9.5119E-01,8.6259E-01,7.8097E-01,
37424      &7.0419E-01,6.4380E-01,5.8358E-01,5.1955E-01,4.6051E-01,4.0719E-01,
37425      &3.5768E-01,3.1962E-01,2.8220E-01,2.4360E-01,2.0909E-01,1.7895E-01,
37426      &1.5240E-01,1.3282E-01,1.1484E-01,9.7655E-02,8.3739E-02,7.5857E-02,
37427      &6.9509E-02,6.5616E-02,6.2633E-02,6.0853E-02,5.9819E-02,5.9271E-02,
37428      &5.9038E-02,5.9046E-02,5.9192E-02,5.9432E-02,5.9709E-02,6.0008E-02/
37429       DATA (XSF_L(K),K= 1483, 1596) /
37430      &6.0340E-02,6.4032E-02,6.6851E-02,7.0446E-02,7.4870E-02,8.0457E-02,
37431      &8.7554E-02,9.6862E-02,1.0964E-01,1.2821E-01,1.5779E-01,2.1189E-01,
37432      &0.0000E+00,0.0000E+00,6.3982E+00,5.9307E+00,5.4920E+00,5.0710E+00,
37433      &4.6822E+00,4.2915E+00,3.9337E+00,3.5898E+00,3.2756E+00,2.9660E+00,
37434      &2.6817E+00,2.4150E+00,2.1724E+00,2.0348E+00,1.8961E+00,1.7457E+00,
37435      &1.6034E+00,1.4714E+00,1.3471E+00,1.2473E+00,1.1476E+00,1.0408E+00,
37436      &9.4083E-01,8.4932E-01,7.6350E-01,6.9606E-01,6.2897E-01,5.5833E-01,
37437      &4.9315E-01,4.3444E-01,3.8044E-01,3.3861E-01,2.9817E-01,2.5642E-01,
37438      &2.1917E-01,1.8685E-01,1.5838E-01,1.3752E-01,1.1831E-01,9.9987E-02,
37439      &8.5224E-02,7.6762E-02,6.9910E-02,6.5655E-02,6.2297E-02,6.0213E-02,
37440      &5.8897E-02,5.8096E-02,5.7624E-02,5.7400E-02,5.7322E-02,5.7351E-02,
37441      &5.7432E-02,5.7560E-02,5.7758E-02,6.0939E-02,6.3212E-02,6.6167E-02,
37442      &6.9884E-02,7.4560E-02,8.0552E-02,8.8432E-02,9.9242E-02,1.1491E-01,
37443      &1.3966E-01,1.8320E-01,0.0000E+00,0.0000E+00,7.4490E+00,6.8826E+00,
37444      &6.3540E+00,5.8477E+00,5.3805E+00,4.9187E+00,4.4884E+00,4.0843E+00,
37445      &3.7147E+00,3.3516E+00,3.0193E+00,2.7088E+00,2.4279E+00,2.2696E+00,
37446      &2.1091E+00,1.9368E+00,1.7739E+00,1.6237E+00,1.4821E+00,1.3692E+00,
37447      &1.2557E+00,1.1358E+00,1.0238E+00,9.2133E-01,8.2567E-01,7.5070E-01,
37448      &6.7656E-01,5.9850E-01,5.2688E-01,4.6263E-01,4.0371E-01,3.5842E-01/
37449       DATA (XSF_L(K),K= 1597, 1710) /
37450      &3.1427E-01,2.6933E-01,2.2930E-01,1.9466E-01,1.6427E-01,1.4208E-01,
37451      &1.2168E-01,1.0226E-01,8.6560E-02,7.7553E-02,7.0202E-02,6.5576E-02,
37452      &6.1860E-02,5.9487E-02,5.7920E-02,5.6852E-02,5.6166E-02,5.5736E-02,
37453      &5.5458E-02,5.5289E-02,5.5193E-02,5.5163E-02,5.5243E-02,5.7935E-02,
37454      &5.9740E-02,6.2111E-02,6.5158E-02,6.9050E-02,7.4078E-02,8.0683E-02,
37455      &8.9776E-02,1.0288E-01,1.2351E-01,1.5725E-01,0.0000E+00,0.0000E+00,
37456      &8.6044E+00,7.9255E+00,7.2940E+00,6.6940E+00,6.1391E+00,5.5940E+00,
37457      &5.0907E+00,4.6180E+00,4.1841E+00,3.7622E+00,3.3775E+00,3.0195E+00,
37458      &2.6967E+00,2.5153E+00,2.3331E+00,2.1364E+00,1.9521E+00,1.7815E+00,
37459      &1.6211E+00,1.4944E+00,1.3683E+00,1.2334E+00,1.1084E+00,9.9465E-01,
37460      &8.8864E-01,8.0585E-01,7.2432E-01,6.3866E-01,5.6038E-01,4.9058E-01,
37461      &4.2648E-01,3.7768E-01,3.3036E-01,2.8189E-01,2.3907E-01,2.0214E-01,
37462      &1.6987E-01,1.4635E-01,1.2479E-01,1.0428E-01,8.7748E-02,7.8203E-02,
37463      &7.0386E-02,6.5431E-02,6.1373E-02,5.8719E-02,5.6916E-02,5.5642E-02,
37464      &5.4751E-02,5.4118E-02,5.3653E-02,5.3314E-02,5.3067E-02,5.2897E-02,
37465      &5.2861E-02,5.5140E-02,5.6493E-02,5.8378E-02,6.0860E-02,6.4090E-02,
37466      &6.8261E-02,7.3828E-02,8.1439E-02,9.2423E-02,1.0952E-01,1.3424E-01,
37467      &0.0000E+00,0.0000E+00,9.7645E+00,8.9701E+00,8.2340E+00,7.5357E+00,
37468      &6.8926E+00,6.2607E+00,5.6834E+00,5.1374E+00,4.6459E+00,4.1625E+00/
37469       DATA (XSF_L(K),K= 1711, 1824) /
37470      &3.7261E+00,3.3206E+00,2.9567E+00,2.7529E+00,2.5476E+00,2.3274E+00,
37471      &2.1217E+00,1.9320E+00,1.7541E+00,1.6131E+00,1.4740E+00,1.3257E+00,
37472      &1.1879E+00,1.0631E+00,9.4732E-01,8.5726E-01,7.6844E-01,6.7586E-01,
37473      &5.9131E-01,5.1597E-01,4.4748E-01,3.9504E-01,3.4470E-01,2.9317E-01,
37474      &2.4779E-01,2.0880E-01,1.7478E-01,1.5007E-01,1.2748E-01,1.0600E-01,
37475      &8.8713E-02,7.8704E-02,7.0472E-02,6.5220E-02,6.0885E-02,5.7993E-02,
37476      &5.5967E-02,5.4536E-02,5.3470E-02,5.2665E-02,5.2054E-02,5.1577E-02,
37477      &5.1203E-02,5.0930E-02,5.0809E-02,5.2731E-02,5.3716E-02,5.5192E-02,
37478      &5.7203E-02,5.9902E-02,6.3412E-02,6.8123E-02,7.4602E-02,8.3905E-02,
37479      &9.8185E-02,1.1515E-01,0.0000E+00,0.0000E+00,1.1069E+01,1.0141E+01,
37480      &9.2840E+00,8.4741E+00,7.7316E+00,7.0038E+00,6.3364E+00,5.7137E+00,
37481      &5.1475E+00,4.6031E+00,4.1059E+00,3.6477E+00,3.2381E+00,3.0086E+00,
37482      &2.7788E+00,2.5333E+00,2.3033E+00,2.0926E+00,1.8951E+00,1.7404E+00,
37483      &1.5854E+00,1.4229E+00,1.2715E+00,1.1352E+00,1.0089E+00,9.1089E-01,
37484      &8.1457E-01,7.1424E-01,6.2332E-01,5.4229E-01,4.6872E-01,4.1295E-01,
37485      &3.5903E-01,3.0454E-01,2.5654E-01,2.1539E-01,1.7965E-01,1.5373E-01,
37486      &1.3011E-01,1.0766E-01,8.9530E-02,7.9108E-02,7.0483E-02,6.4943E-02,
37487      &6.0331E-02,5.7203E-02,5.4990E-02,5.3395E-02,5.2144E-02,5.1206E-02,
37488      &5.0454E-02,4.9840E-02,4.9351E-02,4.8978E-02,4.8801E-02,5.0351E-02/
37489       DATA (XSF_L(K),K= 1825, 1836) /
37490      &5.1017E-02,5.2127E-02,5.3737E-02,5.5934E-02,5.8835E-02,6.2800E-02,
37491      &6.8260E-02,7.6135E-02,8.7873E-02,0.0000E+00,0.0000E+00,0.0000E+00/
37492       DATA (XGF_L(K),K=    1,  114) /
37493      &1.0646E+00,1.0934E+00,1.1214E+00,1.1484E+00,1.1741E+00,1.1999E+00,
37494      &1.2242E+00,1.2466E+00,1.2676E+00,1.2873E+00,1.3042E+00,1.3194E+00,
37495      &1.3313E+00,1.3376E+00,1.3430E+00,1.3472E+00,1.3502E+00,1.3504E+00,
37496      &1.3501E+00,1.3478E+00,1.3430E+00,1.3356E+00,1.3267E+00,1.3149E+00,
37497      &1.3003E+00,1.2857E+00,1.2680E+00,1.2451E+00,1.2189E+00,1.1899E+00,
37498      &1.1575E+00,1.1282E+00,1.0947E+00,1.0543E+00,1.0121E+00,9.6983E-01,
37499      &9.2809E-01,8.9556E-01,8.6663E-01,8.4606E-01,8.4971E-01,8.7714E-01,
37500      &9.3569E-01,1.0140E+00,1.1325E+00,1.2706E+00,1.4268E+00,1.6005E+00,
37501      &1.7918E+00,2.0014E+00,2.2301E+00,2.4791E+00,2.7490E+00,3.0404E+00,
37502      &3.3541E+00,3.5718E+00,4.2579E+00,5.0478E+00,5.9674E+00,7.0458E+00,
37503      &8.3375E+00,9.9284E+00,1.1949E+01,1.4650E+01,1.8560E+01,2.5096E+01,
37504      &4.0067E+01,0.0000E+00,1.6404E+00,1.6723E+00,1.7014E+00,1.7287E+00,
37505      &1.7533E+00,1.7768E+00,1.7973E+00,1.8152E+00,1.8297E+00,1.8417E+00,
37506      &1.8498E+00,1.8540E+00,1.8544E+00,1.8526E+00,1.8489E+00,1.8424E+00,
37507      &1.8335E+00,1.8221E+00,1.8091E+00,1.7949E+00,1.7784E+00,1.7555E+00,
37508      &1.7310E+00,1.7034E+00,1.6713E+00,1.6428E+00,1.6093E+00,1.5680E+00,
37509      &1.5230E+00,1.4754E+00,1.4241E+00,1.3785E+00,1.3278E+00,1.2681E+00,
37510      &1.2068E+00,1.1462E+00,1.0867E+00,1.0400E+00,9.9665E-01,9.6041E-01,
37511      &9.4923E-01,9.6563E-01,1.0117E+00,1.0781E+00,1.1816E+00,1.3028E+00/
37512       DATA (XGF_L(K),K=  115,  228) /
37513      &1.4397E+00,1.5912E+00,1.7573E+00,1.9376E+00,2.1326E+00,2.3425E+00,
37514      &2.5677E+00,2.8078E+00,3.0611E+00,3.2398E+00,3.7904E+00,4.4126E+00,
37515      &5.1162E+00,5.9322E+00,6.8841E+00,8.0278E+00,9.4403E+00,1.1276E+01,
37516      &1.3844E+01,1.7948E+01,2.6821E+01,0.0000E+00,2.5295E+00,2.5563E+00,
37517      &2.5800E+00,2.5995E+00,2.6174E+00,2.6286E+00,2.6363E+00,2.6395E+00,
37518      &2.6379E+00,2.6306E+00,2.6184E+00,2.6000E+00,2.5768E+00,2.5598E+00,
37519      &2.5397E+00,2.5137E+00,2.4839E+00,2.4516E+00,2.4161E+00,2.3833E+00,
37520      &2.3459E+00,2.3000E+00,2.2499E+00,2.1966E+00,2.1407E+00,2.0900E+00,
37521      &2.0320E+00,1.9647E+00,1.8929E+00,1.8190E+00,1.7411E+00,1.6734E+00,
37522      &1.5997E+00,1.5142E+00,1.4279E+00,1.3438E+00,1.2617E+00,1.1967E+00,
37523      &1.1353E+00,1.0800E+00,1.0501E+00,1.0526E+00,1.0849E+00,1.1369E+00,
37524      &1.2228E+00,1.3250E+00,1.4410E+00,1.5691E+00,1.7085E+00,1.8587E+00,
37525      &2.0200E+00,2.1915E+00,2.3728E+00,2.5633E+00,2.7603E+00,2.9047E+00,
37526      &3.3315E+00,3.8026E+00,4.3243E+00,4.9121E+00,5.5828E+00,6.3648E+00,
37527      &7.3038E+00,8.4817E+00,1.0068E+01,1.2484E+01,1.7398E+01,0.0000E+00,
37528      &3.9781E+00,3.9859E+00,3.9880E+00,3.9845E+00,3.9763E+00,3.9582E+00,
37529      &3.9337E+00,3.9028E+00,3.8636E+00,3.8159E+00,3.7613E+00,3.6984E+00,
37530      &3.6287E+00,3.5836E+00,3.5326E+00,3.4703E+00,3.4046E+00,3.3350E+00,
37531      &3.2612E+00,3.1962E+00,3.1248E+00,3.0388E+00,2.9485E+00,2.8565E+00/
37532       DATA (XGF_L(K),K=  229,  342) /
37533      &2.7591E+00,2.6752E+00,2.5823E+00,2.4756E+00,2.3627E+00,2.2510E+00,
37534      &2.1352E+00,2.0365E+00,1.9308E+00,1.8097E+00,1.6896E+00,1.5737E+00,
37535      &1.4618E+00,1.3735E+00,1.2886E+00,1.2087E+00,1.1551E+00,1.1411E+00,
37536      &1.1545E+00,1.1903E+00,1.2550E+00,1.3356E+00,1.4282E+00,1.5306E+00,
37537      &1.6419E+00,1.7606E+00,1.8869E+00,2.0194E+00,2.1574E+00,2.2992E+00,
37538      &2.4432E+00,2.5568E+00,2.8674E+00,3.2008E+00,3.5626E+00,3.9572E+00,
37539      &4.3932E+00,4.8857E+00,5.4544E+00,6.1386E+00,7.0188E+00,8.2895E+00,
37540      &1.0709E+01,0.0000E+00,6.3697E+00,6.3265E+00,6.2740E+00,6.2091E+00,
37541      &6.1391E+00,6.0517E+00,5.9560E+00,5.8525E+00,5.7367E+00,5.6106E+00,
37542      &5.4709E+00,5.3235E+00,5.1695E+00,5.0724E+00,4.9662E+00,4.8411E+00,
37543      &4.7105E+00,4.5784E+00,4.4412E+00,4.3226E+00,4.1943E+00,4.0442E+00,
37544      &3.8903E+00,3.7360E+00,3.5773E+00,3.4420E+00,3.2967E+00,3.1301E+00,
37545      &2.9593E+00,2.7916E+00,2.6229E+00,2.4802E+00,2.3301E+00,2.1613E+00,
37546      &1.9957E+00,1.8382E+00,1.6875E+00,1.5691E+00,1.4545E+00,1.3433E+00,
37547      &1.2614E+00,1.2264E+00,1.2177E+00,1.2342E+00,1.2749E+00,1.3313E+00,
37548      &1.3987E+00,1.4740E+00,1.5559E+00,1.6431E+00,1.7346E+00,1.8295E+00,
37549      &1.9260E+00,2.0232E+00,2.1174E+00,2.2034E+00,2.4118E+00,2.6289E+00,
37550      &2.8563E+00,3.0948E+00,3.3486E+00,3.6231E+00,3.9250E+00,4.2677E+00,
37551      &4.6847E+00,5.2492E+00,6.2650E+00,0.0000E+00,9.3778E+00,9.2428E+00/
37552       DATA (XGF_L(K),K=  343,  456) /
37553      &9.0960E+00,8.9365E+00,8.7665E+00,8.5746E+00,8.3714E+00,8.1544E+00,
37554      &7.9343E+00,7.6882E+00,7.4352E+00,7.1724E+00,6.9027E+00,6.7360E+00,
37555      &6.5571E+00,6.3494E+00,6.1374E+00,5.9260E+00,5.7093E+00,5.5249E+00,
37556      &5.3270E+00,5.0995E+00,4.8700E+00,4.6419E+00,4.4114E+00,4.2173E+00,
37557      &4.0129E+00,3.7786E+00,3.5451E+00,3.3173E+00,3.0900E+00,2.9004E+00,
37558      &2.7040E+00,2.4853E+00,2.2734E+00,2.0742E+00,1.8851E+00,1.7372E+00,
37559      &1.5941E+00,1.4536E+00,1.3433E+00,1.2893E+00,1.2607E+00,1.2587E+00,
37560      &1.2792E+00,1.3153E+00,1.3616E+00,1.4149E+00,1.4736E+00,1.5361E+00,
37561      &1.6012E+00,1.6677E+00,1.7344E+00,1.7990E+00,1.8589E+00,1.9261E+00,
37562      &2.0646E+00,2.2044E+00,2.3456E+00,2.4882E+00,2.6342E+00,2.7823E+00,
37563      &2.9370E+00,3.1022E+00,3.2902E+00,3.5288E+00,3.9528E+00,0.0000E+00,
37564      &1.3926E+01,1.3617E+01,1.3298E+01,1.2959E+01,1.2612E+01,1.2230E+01,
37565      &1.1845E+01,1.1442E+01,1.1036E+01,1.0599E+01,1.0158E+01,9.7041E+00,
37566      &9.2562E+00,8.9827E+00,8.6974E+00,8.3632E+00,8.0255E+00,7.6946E+00,
37567      &7.3614E+00,7.0802E+00,6.7814E+00,6.4439E+00,6.1064E+00,5.7775E+00,
37568      &5.4468E+00,5.1723E+00,4.8858E+00,4.5617E+00,4.2425E+00,3.9361E+00,
37569      &3.6353E+00,3.3874E+00,3.1301E+00,2.8506E+00,2.5816E+00,2.3318E+00,
37570      &2.0965E+00,1.9136E+00,1.7368E+00,1.5622E+00,1.4211E+00,1.3452E+00,
37571      &1.2937E+00,1.2737E+00,1.2719E+00,1.2868E+00,1.3119E+00,1.3437E+00/
37572       DATA (XGF_L(K),K=  457,  570) /
37573      &1.3799E+00,1.4189E+00,1.4596E+00,1.5003E+00,1.5401E+00,1.5761E+00,
37574      &1.6073E+00,1.6574E+00,1.7377E+00,1.8158E+00,1.8902E+00,1.9601E+00,
37575      &2.0263E+00,2.0884E+00,2.1452E+00,2.1990E+00,2.2512E+00,2.3118E+00,
37576      &2.4354E+00,0.0000E+00,1.9256E+01,1.8699E+01,1.8142E+01,1.7563E+01,
37577      &1.6980E+01,1.6355E+01,1.5725E+01,1.5081E+01,1.4443E+01,1.3769E+01,
37578      &1.3097E+01,1.2422E+01,1.1755E+01,1.1358E+01,1.0937E+01,1.0454E+01,
37579      &9.9818E+00,9.5167E+00,9.0465E+00,8.6570E+00,8.2473E+00,7.7870E+00,
37580      &7.3320E+00,6.8911E+00,6.4569E+00,6.0969E+00,5.7223E+00,5.3051E+00,
37581      &4.8992E+00,4.5131E+00,4.1351E+00,3.8285E+00,3.5148E+00,3.1749E+00,
37582      &2.8517E+00,2.5534E+00,2.2748E+00,2.0598E+00,1.8527E+00,1.6465E+00,
37583      &1.4780E+00,1.3832E+00,1.3129E+00,1.2758E+00,1.2566E+00,1.2544E+00,
37584      &1.2628E+00,1.2778E+00,1.2971E+00,1.3186E+00,1.3412E+00,1.3637E+00,
37585      &1.3845E+00,1.4021E+00,1.4142E+00,1.4518E+00,1.4945E+00,1.5327E+00,
37586      &1.5661E+00,1.5941E+00,1.6160E+00,1.6309E+00,1.6386E+00,1.6381E+00,
37587      &1.6291E+00,1.6176E+00,1.6271E+00,0.0000E+00,2.5945E+01,2.5063E+01,
37588      &2.4160E+01,2.3234E+01,2.2336E+01,2.1370E+01,2.0417E+01,1.9450E+01,
37589      &1.8508E+01,1.7517E+01,1.6548E+01,1.5580E+01,1.4645E+01,1.4085E+01,
37590      &1.3496E+01,1.2836E+01,1.2181E+01,1.1547E+01,1.0921E+01,1.0404E+01,
37591      &9.8614E+00,9.2547E+00,8.6616E+00,8.0926E+00,7.5352E+00,7.0774E+00/
37592       DATA (XGF_L(K),K=  571,  684) /
37593      &6.6043E+00,6.0842E+00,5.5816E+00,5.1040E+00,4.6450E+00,4.2749E+00,
37594      &3.8995E+00,3.4941E+00,3.1134E+00,2.7651E+00,2.4423E+00,2.1941E+00,
37595      &1.9564E+00,1.7198E+00,1.5241E+00,1.4112E+00,1.3220E+00,1.2705E+00,
37596      &1.2348E+00,1.2175E+00,1.2113E+00,1.2119E+00,1.2167E+00,1.2238E+00,
37597      &1.2321E+00,1.2398E+00,1.2460E+00,1.2491E+00,1.2470E+00,1.2752E+00,
37598      &1.2894E+00,1.2998E+00,1.3055E+00,1.3049E+00,1.2991E+00,1.2860E+00,
37599      &1.2655E+00,1.2370E+00,1.1998E+00,1.1564E+00,1.1181E+00,0.0000E+00,
37600      &3.3362E+01,3.2051E+01,3.0740E+01,2.9429E+01,2.8133E+01,2.6758E+01,
37601      &2.5422E+01,2.4082E+01,2.2784E+01,2.1435E+01,2.0130E+01,1.8839E+01,
37602      &1.7597E+01,1.6865E+01,1.6098E+01,1.5241E+01,1.4397E+01,1.3587E+01,
37603      &1.2791E+01,1.2130E+01,1.1444E+01,1.0687E+01,9.9507E+00,9.2501E+00,
37604      &8.5659E+00,8.0104E+00,7.4390E+00,6.8118E+00,6.2125E+00,5.6506E+00,
37605      &5.1096E+00,4.6780E+00,4.2434E+00,3.7769E+00,3.3424E+00,2.9475E+00,
37606      &2.5842E+00,2.3061E+00,2.0409E+00,1.7770E+00,1.5572E+00,1.4290E+00,
37607      &1.3248E+00,1.2609E+00,1.2112E+00,1.1814E+00,1.1636E+00,1.1530E+00,
37608      &1.1469E+00,1.1433E+00,1.1407E+00,1.1378E+00,1.1337E+00,1.1269E+00,
37609      &1.1152E+00,1.1360E+00,1.1320E+00,1.1243E+00,1.1127E+00,1.0960E+00,
37610      &1.0739E+00,1.0461E+00,1.0122E+00,9.7100E-01,9.2292E-01,8.6909E-01,
37611      &8.1432E-01,0.0000E+00,4.2364E+01,4.0483E+01,3.8640E+01,3.6792E+01/
37612       DATA (XGF_L(K),K=  685,  798) /
37613      &3.4991E+01,3.3112E+01,3.1295E+01,2.9487E+01,2.7748E+01,2.5953E+01,
37614      &2.4235E+01,2.2543E+01,2.0935E+01,1.9990E+01,1.9011E+01,1.7921E+01,
37615      &1.6852E+01,1.5830E+01,1.4831E+01,1.4013E+01,1.3165E+01,1.2236E+01,
37616      &1.1337E+01,1.0485E+01,9.6616E+00,8.9943E+00,8.3137E+00,7.5711E+00,
37617      &6.8670E+00,6.2090E+00,5.5842E+00,5.0866E+00,4.5873E+00,4.0564E+00,
37618      &3.5646E+00,3.1234E+00,2.7185E+00,2.4107E+00,2.1172E+00,1.8273E+00,
37619      &1.5836E+00,1.4407E+00,1.3211E+00,1.2459E+00,1.1839E+00,1.1433E+00,
37620      &1.1153E+00,1.0949E+00,1.0794E+00,1.0667E+00,1.0555E+00,1.0443E+00,
37621      &1.0317E+00,1.0172E+00,9.9883E-01,1.0131E+00,9.9503E-01,9.7446E-01,
37622      &9.5064E-01,9.2316E-01,8.9156E-01,8.5528E-01,8.1439E-01,7.6837E-01,
37623      &7.1718E-01,6.6210E-01,6.0243E-01,0.0000E+00,5.2603E+01,5.0038E+01,
37624      &4.7540E+01,4.5053E+01,4.2652E+01,4.0175E+01,3.7784E+01,3.5407E+01,
37625      &3.3154E+01,3.0851E+01,2.8651E+01,2.6507E+01,2.4488E+01,2.3310E+01,
37626      &2.2084E+01,2.0735E+01,1.9418E+01,1.8166E+01,1.6951E+01,1.5960E+01,
37627      &1.4935E+01,1.3817E+01,1.2742E+01,1.1732E+01,1.0759E+01,9.9749E+00,
37628      &9.1794E+00,8.3186E+00,7.5044E+00,6.7510E+00,6.0386E+00,5.4762E+00,
37629      &4.9137E+00,4.3200E+00,3.7728E+00,3.2842E+00,2.8391E+00,2.5026E+00,
37630      &2.1835E+00,1.8677E+00,1.6033E+00,1.4461E+00,1.3138E+00,1.2277E+00,
37631      &1.1557E+00,1.1057E+00,1.0689E+00,1.0407E+00,1.0176E+00,9.9768E-01/
37632       DATA (XGF_L(K),K=  799,  912) /
37633      &9.7951E-01,9.6199E-01,9.4331E-01,9.2359E-01,9.0058E-01,9.0921E-01,
37634      &8.8156E-01,8.5244E-01,8.2081E-01,7.8702E-01,7.5025E-01,7.1005E-01,
37635      &6.6667E-01,6.1984E-01,5.6969E-01,5.1748E-01,4.5895E-01,0.0000E+00,
37636      &6.3459E+01,6.0127E+01,5.6900E+01,5.3695E+01,5.0615E+01,4.7464E+01,
37637      &4.4440E+01,4.1483E+01,3.8684E+01,3.5826E+01,3.3122E+01,3.0500E+01,
37638      &2.8040E+01,2.6617E+01,2.5143E+01,2.3518E+01,2.1950E+01,2.0455E+01,
37639      &1.9011E+01,1.7842E+01,1.6646E+01,1.5337E+01,1.4094E+01,1.2920E+01,
37640      &1.1799E+01,1.0903E+01,9.9940E+00,9.0166E+00,8.0967E+00,7.2512E+00,
37641      &6.4551E+00,5.8279E+00,5.2081E+00,4.5519E+00,3.9568E+00,3.4237E+00,
37642      &2.9425E+00,2.5798E+00,2.2371E+00,1.8995E+00,1.6161E+00,1.4477E+00,
37643      &1.3046E+00,1.2096E+00,1.1285E+00,1.0709E+00,1.0274E+00,9.9290E-01,
37644      &9.6399E-01,9.3860E-01,9.1550E-01,8.9324E-01,8.7036E-01,8.4674E-01,
37645      &8.2129E-01,8.2506E-01,7.9094E-01,7.5633E-01,7.2031E-01,6.8307E-01,
37646      &6.4387E-01,6.0237E-01,5.5907E-01,5.1344E-01,4.6618E-01,4.1810E-01,
37647      &3.6329E-01,0.0000E+00,7.9498E+01,7.4941E+01,7.0580E+01,6.6266E+01,
37648      &6.2169E+01,5.8002E+01,5.4045E+01,5.0164E+01,4.6539E+01,4.2847E+01,
37649      &3.9386E+01,3.6065E+01,3.2968E+01,3.1180E+01,2.9347E+01,2.7330E+01,
37650      &2.5394E+01,2.3566E+01,2.1811E+01,2.0388E+01,1.8944E+01,1.7368E+01,
37651      &1.5877E+01,1.4488E+01,1.3164E+01,1.2111E+01,1.1051E+01,9.9162E+00/
37652       DATA (XGF_L(K),K=  913, 1026) /
37653      &8.8542E+00,7.8839E+00,6.9777E+00,6.2689E+00,5.5695E+00,4.8410E+00,
37654      &4.1789E+00,3.5909E+00,3.0635E+00,2.6689E+00,2.2973E+00,1.9324E+00,
37655      &1.6270E+00,1.4446E+00,1.2882E+00,1.1839E+00,1.0926E+00,1.0266E+00,
37656      &9.7585E-01,9.3473E-01,8.9976E-01,8.6898E-01,8.4068E-01,8.1374E-01,
37657      &7.8714E-01,7.6011E-01,7.3262E-01,7.3148E-01,6.9170E-01,6.5270E-01,
37658      &6.1357E-01,5.7426E-01,5.3417E-01,4.9316E-01,4.5166E-01,4.0914E-01,
37659      &3.6649E-01,3.2429E-01,2.7651E-01,0.0000E+00,9.7091E+01,9.1127E+01,
37660      &8.5440E+01,7.9869E+01,7.4603E+01,6.9275E+01,6.4220E+01,5.9343E+01,
37661      &5.4780E+01,5.0195E+01,4.5912E+01,4.1816E+01,3.8028E+01,3.5857E+01,
37662      &3.3637E+01,3.1205E+01,2.8880E+01,2.6695E+01,2.4601E+01,2.2923E+01,
37663      &2.1219E+01,1.9374E+01,1.7634E+01,1.6009E+01,1.4488E+01,1.3276E+01,
37664      &1.2064E+01,1.0772E+01,9.5709E+00,8.4795E+00,7.4649E+00,6.6775E+00,
37665      &5.9046E+00,5.1015E+00,4.3733E+00,3.7372E+00,3.1677E+00,2.7434E+00,
37666      &2.3459E+00,1.9566E+00,1.6317E+00,1.4368E+00,1.2699E+00,1.1572E+00,
37667      &1.0581E+00,9.8558E-01,9.2913E-01,8.8297E-01,8.4349E-01,8.0862E-01,
37668      &7.7667E-01,7.4686E-01,7.1760E-01,6.8906E-01,6.6005E-01,6.5493E-01,
37669      &6.1209E-01,5.7080E-01,5.3038E-01,4.9085E-01,4.5137E-01,4.1231E-01,
37670      &3.7316E-01,3.3442E-01,2.9613E-01,2.5928E-01,2.1912E-01,0.0000E+00,
37671      &1.1660E+02,1.0899E+02,1.0178E+02,9.4752E+01,8.8142E+01,8.1480E+01/
37672       DATA (XGF_L(K),K= 1027, 1140) /
37673      &7.5219E+01,6.9198E+01,6.3578E+01,5.7986E+01,5.2800E+01,4.7867E+01,
37674      &4.3328E+01,4.0736E+01,3.8088E+01,3.5213E+01,3.2469E+01,2.9907E+01,
37675      &2.7451E+01,2.5501E+01,2.3516E+01,2.1392E+01,1.9391E+01,1.7546E+01,
37676      &1.5800E+01,1.4426E+01,1.3057E+01,1.1607E+01,1.0266E+01,9.0517E+00,
37677      &7.9294E+00,7.0617E+00,6.2165E+00,5.3397E+00,4.5572E+00,3.8687E+00,
37678      &3.2598E+00,2.8078E+00,2.3859E+00,1.9745E+00,1.6317E+00,1.4267E+00,
37679      &1.2497E+00,1.1305E+00,1.0247E+00,9.4657E-01,8.8556E-01,8.3542E-01,
37680      &7.9253E-01,7.5465E-01,7.2037E-01,6.8840E-01,6.5775E-01,6.2793E-01,
37681      &5.9852E-01,5.9015E-01,5.4553E-01,5.0339E-01,4.6306E-01,4.2411E-01,
37682      &3.8622E-01,3.4909E-01,3.1294E-01,2.7773E-01,2.4373E-01,2.1150E-01,
37683      &1.7848E-01,0.0000E+00,1.3738E+02,1.2796E+02,1.1904E+02,1.1042E+02,
37684      &1.0233E+02,9.4222E+01,8.6662E+01,7.9409E+01,7.2655E+01,6.6001E+01,
37685      &5.9833E+01,5.4007E+01,4.8672E+01,4.5642E+01,4.2552E+01,3.9214E+01,
37686      &3.6040E+01,3.3082E+01,3.0272E+01,2.8026E+01,2.5779E+01,2.3361E+01,
37687      &2.1093E+01,1.9009E+01,1.7062E+01,1.5526E+01,1.4003E+01,1.2396E+01,
37688      &1.0916E+01,9.5845E+00,8.3611E+00,7.4188E+00,6.5021E+00,5.5589E+00,
37689      &4.7169E+00,3.9865E+00,3.3389E+00,2.8617E+00,2.4178E+00,1.9872E+00,
37690      &1.6283E+00,1.4143E+00,1.2296E+00,1.1049E+00,9.9315E-01,9.1079E-01,
37691      &8.4623E-01,7.9317E-01,7.4768E-01,7.0802E-01,6.7178E-01,6.3836E-01/
37692       DATA (XGF_L(K),K= 1141, 1254) /
37693      &6.0703E-01,5.7658E-01,5.4733E-01,5.3630E-01,4.9100E-01,4.4879E-01,
37694      &4.0920E-01,3.7138E-01,3.3521E-01,3.0054E-01,2.6721E-01,2.3523E-01,
37695      &2.0485E-01,1.7634E-01,1.4852E-01,0.0000E+00,1.6103E+02,1.4938E+02,
37696      &1.3848E+02,1.2798E+02,1.1818E+02,1.0840E+02,9.9309E+01,9.0651E+01,
37697      &8.2647E+01,7.4733E+01,6.7469E+01,6.0672E+01,5.4433E+01,5.0913E+01,
37698      &4.7343E+01,4.3482E+01,3.9833E+01,3.6452E+01,3.3242E+01,3.0689E+01,
37699      &2.8134E+01,2.5404E+01,2.2863E+01,2.0531E+01,1.8362E+01,1.6652E+01,
37700      &1.4967E+01,1.3197E+01,1.1573E+01,1.0120E+01,8.7877E+00,7.7679E+00,
37701      &6.7819E+00,5.7685E+00,4.8731E+00,4.0967E+00,3.4122E+00,2.9097E+00,
37702      &2.4451E+00,1.9953E+00,1.6222E+00,1.3995E+00,1.2076E+00,1.0771E+00,
37703      &9.6151E-01,8.7563E-01,8.0819E-01,7.5269E-01,7.0548E-01,6.6395E-01,
37704      &6.2666E-01,5.9253E-01,5.6034E-01,5.3005E-01,5.0122E-01,4.8790E-01,
37705      &4.4273E-01,4.0115E-01,3.6251E-01,3.2632E-01,2.9224E-01,2.5988E-01,
37706      &2.2931E-01,2.0039E-01,1.7324E-01,1.4805E-01,1.2201E-01,0.0000E+00,
37707      &1.8591E+02,1.7193E+02,1.5886E+02,1.4632E+02,1.3469E+02,1.2310E+02,
37708      &1.1237E+02,1.0218E+02,9.2839E+01,8.3643E+01,7.5256E+01,6.7382E+01,
37709      &6.0231E+01,5.6204E+01,5.2127E+01,4.7743E+01,4.3601E+01,3.9784E+01,
37710      &3.6172E+01,3.3310E+01,3.0455E+01,2.7410E+01,2.4579E+01,2.2009E+01,
37711      &1.9599E+01,1.7727E+01,1.5886E+01,1.3956E+01,1.2193E+01,1.0620E+01/
37712       DATA (XGF_L(K),K= 1255, 1368) /
37713      &9.1866E+00,8.0925E+00,7.0383E+00,5.9623E+00,5.0119E+00,4.1917E+00,
37714      &3.4750E+00,2.9503E+00,2.4663E+00,1.9999E+00,1.6141E+00,1.3840E+00,
37715      &1.1856E+00,1.0518E+00,9.3192E-01,8.4324E-01,7.7348E-01,7.1642E-01,
37716      &6.6779E-01,6.2531E-01,5.8732E-01,5.5231E-01,5.2039E-01,4.9037E-01,
37717      &4.6218E-01,4.4711E-01,4.0225E-01,3.6159E-01,3.2438E-01,2.8982E-01,
37718      &2.5765E-01,2.2765E-01,1.9954E-01,1.7331E-01,1.4889E-01,1.2621E-01,
37719      &9.6984E-02,0.0000E+00,2.1269E+02,1.9609E+02,1.8060E+02,1.6582E+02,
37720      &1.5214E+02,1.3863E+02,1.2613E+02,1.1431E+02,1.0351E+02,9.2957E+01,
37721      &8.3294E+01,7.4318E+01,6.6188E+01,6.1617E+01,5.7019E+01,5.2073E+01,
37722      &4.7428E+01,4.3153E+01,3.9122E+01,3.5941E+01,3.2764E+01,2.9404E+01,
37723      &2.6282E+01,2.3458E+01,2.0836E+01,1.8796E+01,1.6786E+01,1.4693E+01,
37724      &1.2792E+01,1.1101E+01,9.5678E+00,8.4010E+00,7.2773E+00,6.1402E+00,
37725      &5.1403E+00,4.2791E+00,3.5311E+00,2.9851E+00,2.4835E+00,2.0017E+00,
37726      &1.6039E+00,1.3677E+00,1.1646E+00,1.0265E+00,9.0375E-01,8.1271E-01,
37727      &7.4135E-01,6.8280E-01,6.3328E-01,5.9018E-01,5.5184E-01,5.1677E-01,
37728      &4.8494E-01,4.5537E-01,4.2797E-01,4.1146E-01,3.6736E-01,3.2788E-01,
37729      &2.9207E-01,2.5923E-01,2.2901E-01,2.0110E-01,1.7527E-01,1.5131E-01,
37730      &1.2926E-01,1.0839E-01,6.9776E-02,0.0000E+00,2.4043E+02,2.2104E+02,
37731      &2.0300E+02,1.8582E+02,1.7003E+02,1.5443E+02,1.4007E+02,1.2658E+02/
37732       DATA (XGF_L(K),K= 1369, 1482) /
37733      &1.1426E+02,1.0227E+02,9.1332E+01,8.1197E+01,7.2119E+01,6.6989E+01,
37734      &6.1846E+01,5.6342E+01,5.1188E+01,4.6448E+01,4.2002E+01,3.8498E+01,
37735      &3.5016E+01,3.1335E+01,2.7931E+01,2.4848E+01,2.2009E+01,1.9797E+01,
37736      &1.7637E+01,1.5389E+01,1.3354E+01,1.1550E+01,9.9187E+00,8.6824E+00,
37737      &7.4988E+00,6.3022E+00,5.2549E+00,4.3589E+00,3.5788E+00,3.0139E+00,
37738      &2.4962E+00,2.0005E+00,1.5931E+00,1.3514E+00,1.1435E+00,1.0028E+00,
37739      &8.7751E-01,7.8479E-01,7.1218E-01,6.5272E-01,6.0250E-01,5.5920E-01,
37740      &5.2061E-01,4.8590E-01,4.5422E-01,4.2519E-01,3.9858E-01,3.8094E-01,
37741      &3.3789E-01,2.9975E-01,2.6524E-01,2.3401E-01,2.0560E-01,1.7956E-01,
37742      &1.5565E-01,1.3374E-01,1.1354E-01,9.4096E-02,3.9275E-02,0.0000E+00,
37743      &2.8195E+02,2.5830E+02,2.3640E+02,2.1554E+02,1.9645E+02,1.7774E+02,
37744      &1.6058E+02,1.4448E+02,1.2990E+02,1.1575E+02,1.0299E+02,9.1121E+01,
37745      &8.0574E+01,7.4642E+01,6.8724E+01,6.2402E+01,5.6498E+01,5.1101E+01,
37746      &4.6042E+01,4.2081E+01,3.8152E+01,3.4014E+01,3.0201E+01,2.6780E+01,
37747      &2.3611E+01,2.1171E+01,1.8789E+01,1.6329E+01,1.4107E+01,1.2148E+01,
37748      &1.0386E+01,9.0557E+00,7.7874E+00,6.5118E+00,5.4006E+00,4.4539E+00,
37749      &3.6370E+00,3.0467E+00,2.5088E+00,1.9959E+00,1.5762E+00,1.3274E+00,
37750      &1.1142E+00,9.7065E-01,8.4265E-01,7.4825E-01,6.7451E-01,6.1445E-01,
37751      &5.6374E-01,5.2024E-01,4.8166E-01,4.4741E-01,4.1643E-01,3.8830E-01/
37752       DATA (XGF_L(K),K= 1483, 1596) /
37753      &3.6282E-01,3.4411E-01,3.0249E-01,2.6607E-01,2.3369E-01,2.0474E-01,
37754      &1.7852E-01,1.5489E-01,1.3341E-01,1.1384E-01,9.5862E-02,7.7509E-02,
37755      &0.0000E+00,0.0000E+00,3.2379E+02,2.9556E+02,2.6960E+02,2.4513E+02,
37756      &2.2265E+02,2.0073E+02,1.8071E+02,1.6202E+02,1.4515E+02,1.2887E+02,
37757      &1.1419E+02,1.0071E+02,8.8650E+01,8.1931E+01,7.5233E+01,6.8140E+01,
37758      &6.1510E+01,5.5467E+01,4.9832E+01,4.5419E+01,4.1070E+01,3.6493E+01,
37759      &3.2295E+01,2.8536E+01,2.5086E+01,2.2426E+01,1.9846E+01,1.7175E+01,
37760      &1.4781E+01,1.2681E+01,1.0797E+01,9.3831E+00,8.0380E+00,6.6897E+00,
37761      &5.5221E+00,4.5337E+00,3.6831E+00,3.0714E+00,2.5159E+00,1.9884E+00,
37762      &1.5586E+00,1.3048E+00,1.0886E+00,9.4191E-01,8.1217E-01,7.1679E-01,
37763      &6.4238E-01,5.8194E-01,5.3136E-01,4.8766E-01,4.4965E-01,4.1594E-01,
37764      &3.8570E-01,3.5847E-01,3.3403E-01,3.1456E-01,2.7454E-01,2.3977E-01,
37765      &2.0922E-01,1.8216E-01,1.5795E-01,1.3622E-01,1.1669E-01,9.9012E-02,
37766      &8.2668E-02,6.4604E-02,0.0000E+00,0.0000E+00,3.7071E+02,3.3727E+02,
37767      &3.0660E+02,2.7790E+02,2.5169E+02,2.2608E+02,2.0283E+02,1.8123E+02,
37768      &1.6179E+02,1.4311E+02,1.2635E+02,1.1097E+02,9.7357E+01,8.9759E+01,
37769      &8.2263E+01,7.4239E+01,6.6821E+01,6.0073E+01,5.3813E+01,4.8927E+01,
37770      &4.4114E+01,3.9072E+01,3.4471E+01,3.0351E+01,2.6592E+01,2.3699E+01,
37771      &2.0903E+01,1.8031E+01,1.5459E+01,1.3211E+01,1.1204E+01,9.7024E+00/
37772       DATA (XGF_L(K),K= 1597, 1710) /
37773      &8.2828E+00,6.8644E+00,5.6367E+00,4.6059E+00,3.7241E+00,3.0915E+00,
37774      &2.5189E+00,1.9786E+00,1.5396E+00,1.2816E+00,1.0611E+00,9.1306E-01,
37775      &7.8207E-01,6.8594E-01,6.1118E-01,5.5075E-01,5.0031E-01,4.5732E-01,
37776      &4.1996E-01,3.8671E-01,3.5732E-01,3.3101E-01,3.0775E-01,2.8769E-01,
37777      &2.4931E-01,2.1637E-01,1.8763E-01,1.6241E-01,1.4002E-01,1.2013E-01,
37778      &1.0238E-01,8.6311E-02,7.1348E-02,5.2982E-02,0.0000E+00,0.0000E+00,
37779      &4.2142E+02,3.8237E+02,3.4660E+02,3.1292E+02,2.8259E+02,2.5300E+02,
37780      &2.2626E+02,2.0148E+02,1.7927E+02,1.5797E+02,1.3896E+02,1.2163E+02,
37781      &1.0632E+02,9.7858E+01,8.9366E+01,8.0488E+01,7.2234E+01,6.4771E+01,
37782      &5.7843E+01,5.2468E+01,4.7182E+01,4.1663E+01,3.6633E+01,3.2165E+01,
37783      &2.8082E+01,2.4971E+01,2.1960E+01,1.8866E+01,1.6118E+01,1.3723E+01,
37784      &1.1595E+01,1.0008E+01,8.5101E+00,7.0232E+00,5.7443E+00,4.6705E+00,
37785      &3.7584E+00,3.1066E+00,2.5189E+00,1.9659E+00,1.5193E+00,1.2575E+00,
37786      &1.0346E+00,8.8517E-01,7.5338E-01,6.5695E-01,5.8219E-01,5.2200E-01,
37787      &4.7218E-01,4.2954E-01,3.9258E-01,3.6043E-01,3.3190E-01,3.0663E-01,
37788      &2.8431E-01,2.6413E-01,2.2746E-01,1.9612E-01,1.6912E-01,1.4557E-01,
37789      &1.2488E-01,1.0660E-01,9.0362E-02,7.5731E-02,6.1890E-02,4.2720E-02,
37790      &0.0000E+00,0.0000E+00,4.7166E+02,4.2676E+02,3.8580E+02,3.4749E+02,
37791      &3.1273E+02,2.7927E+02,2.4899E+02,2.2108E+02,1.9611E+02,1.7230E+02/
37792       DATA (XGF_L(K),K= 1711, 1824) /
37793      &1.5107E+02,1.3178E+02,1.1483E+02,1.0548E+02,9.6179E+01,8.6383E+01,
37794      &7.7331E+01,6.9156E+01,6.1613E+01,5.5763E+01,5.0019E+01,4.4056E+01,
37795      &3.8633E+01,3.3819E+01,2.9446E+01,2.6108E+01,2.2889E+01,1.9617E+01,
37796      &1.6706E+01,1.4179E+01,1.1938E+01,1.0276E+01,8.7112E+00,7.1630E+00,
37797      &5.8345E+00,4.7275E+00,3.7856E+00,3.1171E+00,2.5164E+00,1.9532E+00,
37798      &1.4997E+00,1.2350E+00,1.0108E+00,8.6027E-01,7.2804E-01,6.3166E-01,
37799      &5.5726E-01,4.9745E-01,4.4802E-01,4.0623E-01,3.7002E-01,3.3850E-01,
37800      &3.1081E-01,2.8644E-01,2.6509E-01,2.4476E-01,2.0951E-01,1.7979E-01,
37801      &1.5426E-01,1.3217E-01,1.1290E-01,9.5951E-02,8.0975E-02,6.7483E-02,
37802      &5.4483E-02,3.4309E-02,0.0000E+00,0.0000E+00,5.2745E+02,4.7595E+02,
37803      &4.2900E+02,3.8543E+02,3.4589E+02,3.0795E+02,2.7377E+02,2.4235E+02,
37804      &2.1434E+02,1.8771E+02,1.6408E+02,1.4266E+02,1.2392E+02,1.1358E+02,
37805      &1.0335E+02,9.2593E+01,8.2702E+01,7.3780E+01,6.5553E+01,5.9207E+01,
37806      &5.2983E+01,4.6535E+01,4.0700E+01,3.5531E+01,3.0842E+01,2.7278E+01,
37807      &2.3855E+01,2.0386E+01,1.7301E+01,1.4635E+01,1.2282E+01,1.0538E+01,
37808      &8.9065E+00,7.2932E+00,5.9178E+00,4.7769E+00,3.8086E+00,3.1240E+00,
37809      &2.5114E+00,1.9387E+00,1.4794E+00,1.2125E+00,9.8604E-01,8.3538E-01,
37810      &7.0309E-01,6.0683E-01,5.3289E-01,4.7378E-01,4.2493E-01,3.8387E-01,
37811      &3.4846E-01,3.1778E-01,2.9097E-01,2.6744E-01,2.4699E-01,2.2688E-01/
37812       DATA (XGF_L(K),K= 1825, 1836) /
37813      &1.9308E-01,1.6489E-01,1.4079E-01,1.2009E-01,1.0214E-01,8.6447E-02,
37814      &7.2603E-02,6.0131E-02,4.7893E-02,2.6613E-02,0.0000E+00,0.0000E+00/
37815
37816 *
37817       X = Xinp
37818 *...CHECK OF X AND Q2 VALUES :
37819       IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
37820 *        WRITE(LO,91) X
37821   91     FORMAT (2X,'GRV98: x out of range',1p,E12.4)
37822          X = 0.99D-9
37823 *        STOP
37824       ENDIF
37825
37826       Q2 = Q2inp
37827       IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
37828 *        WRITE(LO,92) Q2
37829   92     FORMAT (2X,'GRV98: Q2 out of range',1p,E12.4)
37830          Q2 = 0.99E6
37831 *        STOP
37832       ENDIF
37833
37834 *
37835 *...INTERPOLATION :
37836       NA(1) = NX
37837       NA(2) = NQ
37838       XT(1) = DLOG(X)
37839       XT(2) = DLOG(Q2)
37840       X1 = 1.- X
37841       XV = X**0.5
37842       XS = X**(-0.2)
37843       UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
37844       DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
37845       DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
37846       UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
37847       US = 0.5 * (UD - DE)
37848       DS = 0.5 * (UD + DE)
37849       SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF)  * X1**7 * XS
37850       GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF)  * X1**5 * XS
37851
37852       END
37853
37854 *$ CREATE PHO_DOR98SC.FOR
37855 *COPY PHO_DOR98SC
37856 CDECK  ID>, PHO_DOR98SC
37857       SUBROUTINE PHO_DOR98SC (Xinp, Q2inp, UV, DV, US, DS, SS, GL)
37858 C***********************************************************************
37859 C
37860 C   GRV98 parton densities, leading order set
37861 C
37862 C                  For a detailed explanation see
37863 C                   M. Glueck, E. Reya, A. Vogt :
37864 C        hep-ph/9806404  =  DO-TH 98/07  =  WUE-ITP-98-019
37865 C                  (To appear in Eur. Phys. J. C)
37866 C
37867 C   interpolation routine based on the original GRV98PA routine,
37868 C   adapted to define interpolation table as DATA statements
37869 C
37870 C                                                   (R.Engel, 09/98)
37871 C
37872 C   CAUTION: this is a version with gluon shadowing corrections
37873 C                                                   (R.Engel, 09/99)
37874 C
37875 C
37876 C   INPUT:   X  =  Bjorken-x        (between  1.E-9 and 1.)
37877 C            Q2 =  scale in GeV**2  (between  0.8 and 1.E6)
37878 C
37879 C   OUTPUT:  UV = u - u(bar),  DV = d - d(bar),  US = u(bar),
37880 C            DS = d(bar),  SS = s = s(bar),  GL = gluon.
37881 C            Always x times the distribution is returned.
37882 C
37883 C******************************************************i****************
37884       IMPLICIT DOUBLE PRECISION (A-H, O-Z)
37885       SAVE
37886
37887 C  input/output channels
37888       INTEGER LI,LO
37889       COMMON /POINOU/ LI,LO
37890
37891       PARAMETER (NPART=6, NX=68, NQ=27, NARG=2)
37892       DIMENSION XUVF(NX,NQ), XDVF(NX,NQ), XDEF(NX,NQ), XUDF(NX,NQ),
37893      1          XSF(NX,NQ), XGF(NX,NQ),
37894      2          XT(NARG), NA(NARG), ARRF(NX+NQ)
37895
37896       DIMENSION XUVF_L(NX*NQ), XDVF_L(NX*NQ), XDEF_L(NX*NQ),
37897      &  XUDF_L(NX*NQ), XSF_L(NX*NQ), XGF_L(NX*NQ)
37898
37899       EQUIVALENCE (XUVF(1,1),XUVF_L(1))
37900       EQUIVALENCE (XDVF(1,1),XDVF_L(1))
37901       EQUIVALENCE (XDEF(1,1),XDEF_L(1))
37902       EQUIVALENCE (XUDF(1,1),XUDF_L(1))
37903       EQUIVALENCE (XSF(1,1),XSF_L(1))
37904       EQUIVALENCE (XGF(1,1),XGF_L(1))
37905
37906 *#################### data statements for shadowed LO PDF ##############
37907 C  ... deleted ...
37908 *#######################################################################
37909
37910       X = Xinp
37911 *...CHECK OF X AND Q2 VALUES :
37912       IF ( (X.LT.0.99D-9) .OR. (X.GT.1.D0) ) THEN
37913 *        WRITE(LO,91) X
37914   91     FORMAT (2X,'GRV98_SC: x out of range',1p,E12.4)
37915          X = 0.99D-9
37916 *        STOP
37917       ENDIF
37918
37919       Q2 = Q2inp
37920       IF ( (Q2.LT.0.799) .OR. (Q2.GT.1.E6) ) THEN
37921 *        WRITE(LO,92) Q2
37922   92     FORMAT (2X,'GRV98_SC: Q2 out of range',1p,E12.4)
37923          Q2 = 0.99E6
37924 *        STOP
37925       ENDIF
37926
37927 *
37928 *...INTERPOLATION :
37929       NA(1) = NX
37930       NA(2) = NQ
37931       XT(1) = DLOG(X)
37932       XT(2) = DLOG(Q2)
37933       X1 = 1.- X
37934       XV = X**0.5
37935       XS = X**(-0.2)
37936       UV = PHO_DBFINT(NARG,XT,NA,ARRF,XUVF) * X1**3 * XV
37937       DV = PHO_DBFINT(NARG,XT,NA,ARRF,XDVF) * X1**4 * XV
37938       DE = PHO_DBFINT(NARG,XT,NA,ARRF,XDEF) * X1**7 * XV
37939       UD = PHO_DBFINT(NARG,XT,NA,ARRF,XUDF) * X1**7 * XS
37940       US = 0.5 * (UD - DE)
37941       DS = 0.5 * (UD + DE)
37942       SS = PHO_DBFINT(NARG,XT,NA,ARRF,XSF)  * X1**7 * XS
37943       GL = PHO_DBFINT(NARG,XT,NA,ARRF,XGF)  * X1**5 * XS
37944
37945       END
37946
37947 *$ CREATE PHO_DOR94LO.FOR
37948 *COPY PHO_DOR94LO
37949 CDECK  ID>, PHO_DOR94LO
37950 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
37951 *                                                                 *
37952 *    G R V  -  P R O T O N  - P A R A M E T R I Z A T I O N S     *
37953 *                                                                 *
37954 *                         1994 UPDATE                             *
37955 *                                                                 *
37956 *                 FOR A DETAILED EXPLANATION SEE                  *
37957 *                   M. GLUECK, E.REYA, A.VOGT :                   *
37958 *                   DO-TH 94/24  =  DESY 94-206                   *
37959 *                    (TO APPEAR IN Z. PHYS. C)                    *
37960 *                                                                 *
37961 *   THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR    *
37962 *        Q**2 / GEV**2  BETWEEN   0.4   AND  1.E6                 *
37963 *             X         BETWEEN  1.E-5  AND   1.                  *
37964 *   LARGE-X REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION   *
37965 *   IS NEGLIGIBLY SMALL, WERE EXCLUDED FROM THE FIT.              *
37966 *                                                                 *
37967 *   HEAVY QUARK THRESHOLDS  Q(H) = M(H)  IN THE BETA FUNCTION :   *
37968 *                   M(C)  =  1.5,  M(B)  =  4.5                   *
37969 *   CORRESPONDING LAMBDA(F) VALUES IN GEV FOR  Q**2 > M(H)**2 :   *
37970 *      LO :   LAMBDA(3)  =  0.232,   LAMBDA(4)  =  0.200,         *
37971 *             LAMBDA(5)  =  0.153,                                *
37972 *      NLO :  LAMBDA(3)  =  0.248,   LAMBDA(4)  =  0.200,         *
37973 *             LAMBDA(5)  =  0.131.                                *
37974 *   THE NUMBER OF ACTIVE QUARK FLAVOURS IS  NF = 3  EVERYWHERE    *
37975 *   EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,...    *
37976 *   ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION.               *
37977 *   IF NEEDED, HEAVY QUARK DENSITIES CAN BE TAKEN FROM THE 1991   *
37978 *   GRV PARAMETRIZATION.                                          *
37979 *                                                                 *
37980 *   NLO DISTRIBUTIONS ARE GIVEN IN MS-BAR FACTORIZATION SCHEME    *
37981 *   (SUBROUTINE GRV94HO) AS WELL AS IN THE DIS SCHEME (GRV94DI),  *
37982 *   THE LEADING ORDER PARAMETRIZATION IS PROVIDED BY "GRV94LO".   *
37983 *                                                                 *
37984 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
37985 *
37986 *...INPUT PARAMETERS :
37987 *
37988 *    X   = MOMENTUM FRACTION
37989 *    Q2  = SCALE Q**2 IN GEV**2
37990 *
37991 *...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION) :
37992 *
37993 *    UV  = U(VAL) = U - U(BAR)
37994 *    DV  = D(VAL) = D - D(BAR)
37995 *    DEL = D(BAR) - U(BAR)
37996 *    UDB = U(BAR) + D(BAR)
37997 *    SB  = S = S(BAR)
37998 *    GL  = GLUON
37999 *
38000 *...LO PARAMETRIZATION :
38001 *
38002       SUBROUTINE PHO_DOR94LO (X, Q2, UV, DV, DEL, UDB, SB, GL)
38003       IMPLICIT DOUBLE PRECISION (A - Z)
38004       SAVE
38005
38006        MU2  = 0.23
38007        LAM2 = 0.2322 * 0.2322
38008        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38009        DS = SQRT (S)
38010        S2 = S * S
38011        S3 = S2 * S
38012 *...UV :
38013        NU  =  2.284 + 0.802 * S + 0.055 * S2
38014        AKU =  0.590 - 0.024 * S
38015        BKU =  0.131 + 0.063 * S
38016        AU  = -0.449 - 0.138 * S - 0.076 * S2
38017        BU  =  0.213 + 2.669 * S - 0.728 * S2
38018        CU  =  8.854 - 9.135 * S + 1.979 * S2
38019        DU  =  2.997 + 0.753 * S - 0.076 * S2
38020        UV  = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38021 *...DV :
38022        ND  =  0.371 + 0.083 * S + 0.039 * S2
38023        AKD =  0.376
38024        BKD =  0.486 + 0.062 * S
38025        AD  = -0.509 + 3.310 * S - 1.248 * S2
38026        BD  =  12.41 - 10.52 * S + 2.267 * S2
38027        CD  =  6.373 - 6.208 * S + 1.418 * S2
38028        DD  =  3.691 + 0.799 * S - 0.071 * S2
38029        DV  = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38030 *...DEL :
38031        NE  =  0.082 + 0.014 * S + 0.008 * S2
38032        AKE =  0.409 - 0.005 * S
38033        BKE =  0.799 + 0.071 * S
38034        AE  = -38.07 + 36.13 * S - 0.656 * S2
38035        BE  =  90.31 - 74.15 * S + 7.645 * S2
38036        CE  =  0.0
38037        DE  =  7.486 + 1.217 * S - 0.159 * S2
38038        DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38039 *...UDB :
38040        ALX =  1.451
38041        BEX =  0.271
38042        AKX =  0.410 - 0.232 * S
38043        BKX =  0.534 - 0.457 * S
38044        AGX =  0.890 - 0.140 * S
38045        BGX = -0.981
38046        CX  =  0.320 + 0.683 * S
38047        DX  =  4.752 + 1.164 * S + 0.286 * S2
38048        EX  =  4.119 + 1.713 * S
38049        ESX =  0.682 + 2.978 * S
38050        UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38051 *...SB :
38052        ALS =  0.914
38053        BES =  0.577
38054        AKS =  1.798 - 0.596 * S
38055        AS  = -5.548 + 3.669 * DS - 0.616 * S
38056        BS  =  18.92 - 16.73 * DS + 5.168 * S
38057        DST =  6.379 - 0.350 * S  + 0.142 * S2
38058        EST =  3.981 + 1.638 * S
38059        ESS =  6.402
38060        SB  = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38061 *...GL :
38062        ALG =  0.524
38063        BEG =  1.088
38064        AKG =  1.742 - 0.930 * S
38065        BKG =        - 0.399 * S2
38066        AG  =  7.486 - 2.185 * S
38067        BG  =  16.69 - 22.74 * S  + 5.779 * S2
38068        CG  = -25.59 + 29.71 * S  - 7.296 * S2
38069        DG  =  2.792 + 2.215 * S  + 0.422 * S2 - 0.104 * S3
38070        EG  =  0.807 + 2.005 * S
38071        ESG =  3.841 + 0.316 * S
38072        GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38073
38074        END
38075
38076 *
38077 *...NLO PARAMETRIZATION (MS(BAR)) :
38078 *
38079 *$ CREATE PHO_DOR94HO.FOR
38080 *COPY PHO_DOR94HO
38081 CDECK  ID>, PHO_DOR94HO
38082       SUBROUTINE PHO_DOR94HO (X, Q2, UV, DV, DEL, UDB, SB, GL)
38083       IMPLICIT DOUBLE PRECISION (A - Z)
38084       SAVE
38085
38086        MU2  = 0.34
38087        LAM2 = 0.248 * 0.248
38088        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38089        DS = SQRT (S)
38090        S2 = S * S
38091        S3 = S2 * S
38092 *...UV :
38093        NU  =  1.304 + 0.863 * S
38094        AKU =  0.558 - 0.020 * S
38095        BKU =          0.183 * S
38096        AU  = -0.113 + 0.283 * S - 0.321 * S2
38097        BU  =  6.843 - 5.089 * S + 2.647 * S2 - 0.527 * S3
38098        CU  =  7.771 - 10.09 * S + 2.630 * S2
38099        DU  =  3.315 + 1.145 * S - 0.583 * S2 + 0.154 * S3
38100        UV  = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38101 *...DV :
38102        ND  =  0.102 - 0.017 * S + 0.005 * S2
38103        AKD =  0.270 - 0.019 * S
38104        BKD =  0.260
38105        AD  =  2.393 + 6.228 * S - 0.881 * S2
38106        BD  =  46.06 + 4.673 * S - 14.98 * S2 + 1.331 * S3
38107        CD  =  17.83 - 53.47 * S + 21.24 * S2
38108        DD  =  4.081 + 0.976 * S - 0.485 * S2 + 0.152 * S3
38109        DV  = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38110 *...DEL :
38111        NE  =  0.070 + 0.042 * S - 0.011 * S2 + 0.004 * S3
38112        AKE =  0.409 - 0.007 * S
38113        BKE =  0.782 + 0.082 * S
38114        AE  = -29.65 + 26.49 * S + 5.429 * S2
38115        BE  =  90.20 - 74.97 * S + 4.526 * S2
38116        CE  =  0.0
38117        DE  =  8.122 + 2.120 * S - 1.088 * S2 + 0.231 * S3
38118        DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38119 *...UDB :
38120        ALX =  0.877
38121        BEX =  0.561
38122        AKX =  0.275
38123        BKX =  0.0
38124        AGX =  0.997
38125        BGX =  3.210 - 1.866 * S
38126        CX  =  7.300
38127        DX  =  9.010 + 0.896 * DS + 0.222 * S2
38128        EX  =  3.077 + 1.446 * S
38129        ESX =  3.173 - 2.445 * DS + 2.207 * S
38130        UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38131 *...SB :
38132        ALS =  0.756
38133        BES =  0.216
38134        AKS =  1.690 + 0.650 * DS - 0.922 * S
38135        AS  = -4.329 + 1.131 * S
38136        BS  =  9.568 - 1.744 * S
38137        DST =  9.377 + 1.088 * DS - 1.320 * S + 0.130 * S2
38138        EST =  3.031 + 1.639 * S
38139        ESS =  5.837 + 0.815 * S
38140        SB  = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38141 *...GL :
38142        ALG =  1.014
38143        BEG =  1.738
38144        AKG =  1.724 + 0.157 * S
38145        BKG =  0.800 + 1.016 * S
38146        AG  =  7.517 - 2.547 * S
38147        BG  =  34.09 - 52.21 * DS + 17.47 * S
38148        CG  =  4.039 + 1.491 * S
38149        DG  =  3.404 + 0.830 * S
38150        EG  = -1.112 + 3.438 * S  - 0.302 * S2
38151        ESG =  3.256 - 0.436 * S
38152        GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38153
38154        END
38155
38156 *$ CREATE PHO_DOR94DI.FOR
38157 *COPY PHO_DOR94DI
38158 CDECK  ID>, PHO_DOR94DI
38159 *
38160 *...NLO PARAMETRIZATION (DIS) :
38161 *
38162       SUBROUTINE PHO_DOR94DI (X, Q2, UV, DV, DEL, UDB, SB, GL)
38163       IMPLICIT DOUBLE PRECISION (A - Z)
38164       SAVE
38165
38166        MU2  = 0.34
38167        LAM2 = 0.248 * 0.248
38168        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38169        DS = SQRT (S)
38170        S2 = S * S
38171        S3 = S2 * S
38172 *...UV :
38173        NU  =  2.484 + 0.116 * S + 0.093 * S2
38174        AKU =  0.563 - 0.025 * S
38175        BKU =  0.054 + 0.154 * S
38176        AU  = -0.326 - 0.058 * S - 0.135 * S2
38177        BU  = -3.322 + 8.259 * S - 3.119 * S2 + 0.291 * S3
38178        CU  =  11.52 - 12.99 * S + 3.161 * S2
38179        DU  =  2.808 + 1.400 * S - 0.557 * S2 + 0.119 * S3
38180        UV  = PHO_DOR94FV (X, NU, AKU, BKU, AU, BU, CU, DU)
38181 *...DV :
38182        ND  =  0.156 - 0.017 * S
38183        AKD =  0.299 - 0.022 * S
38184        BKD =  0.259 - 0.015 * S
38185        AD  =  3.445 + 1.278 * S + 0.326 * S2
38186        BD  = -6.934 + 37.45 * S - 18.95 * S2 + 1.463 * S3
38187        CD  =  55.45 - 69.92 * S + 20.78 * S2
38188        DD  =  3.577 + 1.441 * S - 0.683 * S2 + 0.179 * S3
38189        DV  = PHO_DOR94FV (X, ND, AKD, BKD, AD, BD, CD, DD)
38190 *...DEL :
38191        NE  =  0.099 + 0.019 * S + 0.002 * S2
38192        AKE =  0.419 - 0.013 * S
38193        BKE =  1.064 - 0.038 * S
38194        AE  = -44.00 + 98.70 * S - 14.79 * S2
38195        BE  =  28.59 - 40.94 * S - 13.66 * S2 + 2.523 * S3
38196        CE  =  84.57 - 108.8 * S + 31.52 * S2
38197        DE  =  7.469 + 2.480 * S - 0.866 * S2
38198        DEL = PHO_DOR94FV (X, NE, AKE, BKE, AE, BE, CE, DE)
38199 *...UDB :
38200        ALX =  1.215
38201        BEX =  0.466
38202        AKX =  0.326 + 0.150 * S
38203        BKX =  0.956 + 0.405 * S
38204        AGX =  0.272
38205        BGX =  3.794 - 2.359 * DS
38206        CX  =  2.014
38207        DX  =  7.941 + 0.534 * DS - 0.940 * S + 0.410 * S2
38208        EX  =  3.049 + 1.597 * S
38209        ESX =  4.396 - 4.594 * DS + 3.268 * S
38210        UDB = PHO_DOR94FW(X,S,ALX,BEX,AKX,BKX,AGX,BGX,CX,DX,EX,ESX)
38211 *...SB :
38212        ALS =  0.175
38213        BES =  0.344
38214        AKS =  1.415 - 0.641 * DS
38215        AS  =  0.580 - 9.763 * DS + 6.795 * S  - 0.558 * S2
38216        BS  =  5.617 + 5.709 * DS - 3.972 * S
38217        DST =  13.78 - 9.581 * S  + 5.370 * S2 - 0.996 * S3
38218        EST =  4.546 + 0.372 * S2
38219        ESS =  5.053 - 1.070 * S  + 0.805 * S2
38220        SB  = PHO_DOR94FS (X, S, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38221 *...GL :
38222        ALG =  1.258
38223        BEG =  1.846
38224        AKG =  2.423
38225        BKG =  2.427 + 1.311 * S  - 0.153 * S2
38226        AG  =  25.09 - 7.935 * S
38227        BG  = -14.84 - 124.3 * DS + 72.18 * S
38228        CG  =  590.3 - 173.8 * S
38229        DG  =  5.196 + 1.857 * S
38230        EG  = -1.648 + 3.988 * S  - 0.432 * S2
38231        ESG =  3.232 - 0.542 * S
38232        GL = PHO_DOR94FW(X,S,ALG,BEG,AKG,BKG,AG,BG,CG,DG,EG,ESG)
38233
38234        END
38235
38236 *
38237 *...FUNCTIONAL FORMS OF THE PARAMETRIZATIONS :
38238 *
38239 *$ CREATE PHO_DOR94FV.FOR
38240 *COPY PHO_DOR94FV
38241 CDECK  ID>, PHO_DOR94FV
38242       DOUBLE PRECISION FUNCTION PHO_DOR94FV (X,N,AK,BK,A,B,C,D)
38243       IMPLICIT DOUBLE PRECISION (A - Z)
38244       SAVE
38245
38246        DX = SQRT (X)
38247        PHO_DOR94FV = N*X**AK*(1.D0+A*X**BK+X*(B+C*DX))*(1.D0-X)**D
38248
38249       END
38250
38251 *$ CREATE PHO_DOR94FW.FOR
38252 *COPY PHO_DOR94FW
38253 CDECK  ID>, PHO_DOR94FW
38254       DOUBLE PRECISION FUNCTION PHO_DOR94FW(X,S,AL,BE,AK,BK,
38255      &                                      A,B,C,D,E,ES)
38256       IMPLICIT DOUBLE PRECISION (A - Z)
38257       SAVE
38258
38259       LX = LOG (1./X)
38260       PHO_DOR94FW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
38261      1     * DEXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38262
38263       END
38264
38265 *$ CREATE PHO_DOR94FS.FOR
38266 *COPY PHO_DOR94FS
38267 CDECK  ID>, PHO_DOR94FS
38268       DOUBLE PRECISION FUNCTION PHO_DOR94FS (X,S,AL,BE,AK,AG,B,D,E,ES)
38269       IMPLICIT DOUBLE PRECISION (A - Z)
38270       SAVE
38271
38272       DX = SQRT (X)
38273       LX = LOG (1./X)
38274       PHO_DOR94FS = S**AL / LX**AK * (1.+ AG*DX + B*X) * (1.- X)**D
38275      1      * DEXP (-E + SQRT (ES * S**BE * LX))
38276
38277       END
38278
38279 *$ CREATE PHO_DOR92LO.FOR
38280 *COPY PHO_DOR92LO
38281 CDECK  ID>, PHO_DOR92LO
38282 *
38283 *
38284 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38285 *                                                                 *
38286 *    G R V  -  P R O T O N  - P A R A M E T R I Z A T I O N S     *
38287 *                                                                 *
38288 *                 FOR A DETAILED EXPLANATION SEE :                *
38289 *              M. GLUECK, E.REYA, A.VOGT: DO-TH 91/07             *
38290 *                                                                 *
38291 *   THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS   *
38292 *   FOR Q ** 2 BETWEEN MU ** 2 (=  0.25 / 0.30  GEV ** 2  IN LO   *
38293 *   / HO) AND  1.E8 GEV ** 2  AND FOR X BETWEEN  1.E-5  AND  1.   *
38294 *   REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG-   *
38295 *   LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT.  *
38296 *                                                                 *
38297 *              HEAVY QUARK THRESHOLDS  Q(H) = M(H) :              *
38298 *         M(C)  =  1.5,  M(B)  =  4.5,  M(T)  =  100  GEV         *
38299 *                                                                 *
38300 *      CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS :     *
38301 *      LO :   LAMBDA(3)  =  0.232,   LAMBDA(4)  =  0.200,         *
38302 *             LAMBDA(5)  =  0.153,   LAMBDA(6)  =  0.082  GEV     *
38303 *      HO :   LAMBDA(3)  =  0.248,   LAMBDA(4)  =  0.200,         *
38304 *             LAMBDA(5)  =  0.131,   LAMBDA(6)  =  0.053  GEV     *
38305 *                                                                 *
38306 *   HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL.  *
38307 *                                                                 *
38308 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38309 C
38310       SUBROUTINE PHO_DOR92LO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
38311       IMPLICIT DOUBLE PRECISION (A - Z)
38312       SAVE
38313
38314        MU2  = 0.25
38315        LAM2 = 0.232 * 0.232
38316        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38317        S2 = S * S
38318        S3 = S2 * S
38319 C...X * (UV + DV) :
38320        NUD  = 0.663 + 0.191 * S - 0.041 * S2 + 0.031 * S3
38321        AKUD = 0.326
38322        AGUD = -1.97 +  6.74 * S -  1.96 * S2
38323        BUD  =  24.4 -  20.7 * S +  4.08 * S2
38324        DUD  =  2.86 +  0.70 * S -  0.02 * S2
38325        UDV  = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
38326 C...X * DV :
38327        ND  = 0.579 + 0.283 * S + 0.047 * S2
38328        AKD = 0.523 - 0.015 * S
38329        AGD =  2.22 -  0.59 * S -  0.27 * S2
38330        BD  =  5.95 -  6.19 * S +  1.55 * S2
38331        DD  =  3.57 +  0.94 * S -  0.16 * S2
38332        DV  = PHO_DOR92FV (X,ND,AKD,AGD,BD,DD)
38333 C...X * G :
38334        ALG =  0.558
38335        BEG =  1.218
38336        AKG =   1.00 -  0.17 * S
38337        BKG =   0.0
38338        AGG =   0.0  + 4.879 * S - 1.383 * S2
38339        BGG =  25.92 - 28.97 * S + 5.596 * S2
38340        CG  = -25.69 + 23.68 * S - 1.975 * S2
38341        DG  =  2.537 + 1.718 * S + 0.353 * S2
38342        EG  =  0.595 + 2.138 * S
38343        ESG =  4.066
38344        GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38345 C...X * UBAR = X * DBAR :
38346        ALU =  1.396
38347        BEU =  1.331
38348        AKU =  0.412 - 0.171 * S
38349        BKU =  0.566 - 0.496 * S
38350        AGU =  0.363
38351        BGU = -1.196
38352        CU  =  1.029 + 1.785 * S - 0.459 * S2
38353        DU  =  4.696 + 2.109 * S
38354        EU  =  3.838 + 1.944 * S
38355        ESU =  2.845
38356        UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
38357 C...X * SBAR = X * S :
38358        SS  =   0.0
38359        ALS =  0.803
38360        BES =  0.563
38361        AKS =  2.082 - 0.577 * S
38362        AGS = -3.055 + 1.024 * S **  0.67
38363        BS  =   27.4 -  20.0 * S ** 0.154
38364        DS  =   6.22
38365        EST =   4.33 + 1.408 * S
38366        ESS =   8.27 - 0.437 * S
38367        SB = PHO_DOR92FS(X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38368 C...X * CBAR = X * C :
38369        SC  =  0.888
38370        ALC =   1.01
38371        BEC =   0.37
38372        AKC =   0.0
38373        AGC =   0.0
38374        BC  =   4.24 - 0.804 * S
38375        DC  =   3.46 + 1.076 * S
38376        EC  =   4.61 + 1.490 * S
38377        ESC =  2.555 + 1.961 * S
38378        CB  = PHO_DOR92FS(X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38379 C...X * BBAR = X * B :
38380        SBO =  1.351
38381        ALB =   1.00
38382        BEB =   0.51
38383        AKB =   0.0
38384        AGB =   0.0
38385        BBO =  1.848
38386        DB  =  2.929 + 1.396 * S
38387        EB  =   4.71 + 1.514 * S
38388        ESB =   4.02 + 1.239 * S
38389        BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38390
38391       END
38392
38393 *$ CREATE PHO_DOR92HO.FOR
38394 *COPY PHO_DOR92HO
38395 CDECK  ID>, PHO_DOR92HO
38396       SUBROUTINE PHO_DOR92HO (X, Q2, UDV, DV, GL, UDB, SB, CB, BB)
38397       IMPLICIT DOUBLE PRECISION (A - Z)
38398       SAVE
38399
38400        MU2  = 0.3
38401        LAM2 = 0.248 * 0.248
38402        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38403        DS = SQRT (S)
38404        S2 = S * S
38405        S3 = S2 * S
38406 C...X * (UV + DV) :
38407        NUD  = 0.330 + 0.151 * S - 0.059 * S2 + 0.027 * S3
38408        AKUD = 0.285
38409        AGUD = -2.28 + 15.73 * S -  4.58 * S2
38410        BUD  =  56.7 -  53.6 * S + 11.21 * S2
38411        DUD  =  3.17 +  1.17 * S -  0.47 * S2 +  0.09 * S3
38412        UDV  = PHO_DOR92FV (X, NUD, AKUD, AGUD, BUD, DUD)
38413 C...X * DV :
38414        ND  = 0.459 + 0.315 * DS + 0.515 * S
38415        AKD = 0.624              - 0.031 * S
38416        AGD =  8.13 -  6.77 * DS +  0.46 * S
38417        BD  =  6.59 - 12.83 * DS +  5.65 * S
38418        DD  =  3.98              +  1.04 * S  -  0.34 * S2
38419        DV  = PHO_DOR92FV (X, ND, AKD, AGD, BD, DD)
38420 C...X * G :
38421        ALG =  1.128
38422        BEG =  1.575
38423        AKG =  0.323 + 1.653 * S
38424        BKG =  0.811 + 2.044 * S
38425        AGG =   0.0  + 1.963 * S - 0.519 * S2
38426        BGG =  0.078 +  6.24 * S
38427        CG  =  30.77 - 24.19 * S
38428        DG  =  3.188 + 0.720 * S
38429        EG  = -0.881 + 2.687 * S
38430        ESG =  2.466
38431        GL = PHO_DOR92FW(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38432 C...X * UBAR = X * DBAR :
38433        ALU =  0.594
38434        BEU =  0.614
38435        AKU =  0.636 - 0.084 * S
38436        BKU =   0.0
38437        AGU =  1.121 - 0.193 * S
38438        BGU =  0.751 - 0.785 * S
38439        CU  =   8.57 - 1.763 * S
38440        DU  =  10.22 + 0.668 * S
38441        EU  =  3.784 + 1.280 * S
38442        ESU =  1.808 + 0.980 * S
38443        UDB = PHO_DOR92FW(X,S,ALU,BEU,AKU,BKU,AGU,BGU,CU,DU,EU,ESU)
38444 C...X * SBAR = X * S :
38445        SS  =   0.0
38446        ALS =  0.756
38447        BES =  0.101
38448        AKS =  2.942 - 1.016 * S
38449        AGS =  -4.60 + 1.167 * S
38450        BS  =   9.31 - 1.324 * S
38451        DS  =  11.49 - 1.198 * S + 0.053 * S2
38452        EST =  2.630 + 1.729 * S
38453        ESS =   8.12
38454        SB  = PHO_DOR92FS (X,S,SS,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38455 C...X * CBAR = X * C :
38456        SC  =  0.820
38457        ALC =   0.98
38458        BEC =   0.0
38459        AKC = -0.625 - 0.523 * S
38460        AGC =   0.0
38461        BC  =  1.896 + 1.616 * S
38462        DC  =   4.12 + 0.683 * S
38463        EC  =   4.36 + 1.328 * S
38464        ESC =  0.677 + 0.679 * S
38465        CB  = PHO_DOR92FS (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38466 C...X * BBAR = X * B :
38467        SBO =  1.297
38468        ALB =   0.99
38469        BEB =   0.0
38470        AKB =   0.0  - 0.193 * S
38471        AGB =   0.0
38472        BBO =   0.0
38473        DB  =  3.447 + 0.927 * S
38474        EB  =   4.68 + 1.259 * S
38475        ESB =  1.892 + 2.199 * S
38476        BB  = PHO_DOR92FS(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38477
38478       END
38479
38480 *$ CREATE PHO_DOR92FV.FOR
38481 *COPY PHO_DOR92FV
38482 CDECK  ID>, PHO_DOR92FV
38483       DOUBLE PRECISION FUNCTION PHO_DOR92FV(X,N,AK,AG,B,D)
38484       IMPLICIT DOUBLE PRECISION (A - Z)
38485       SAVE
38486        DX = SQRT (X)
38487        PHO_DOR92FV = N * X**AK * (1.+ AG*DX + B*X) * (1.- X)**D
38488
38489       END
38490
38491 *$ CREATE PHO_DOR92FW.FOR
38492 *COPY PHO_DOR92FW
38493 CDECK  ID>, PHO_DOR92FW
38494       DOUBLE PRECISION FUNCTION PHO_DOR92FW(X,S,
38495      &                                      AL,BE,AK,BK,AG,BG,C,D,E,ES)
38496       IMPLICIT DOUBLE PRECISION (A - Z)
38497       SAVE
38498        LX = LOG (1./X)
38499        PHO_DOR92FW = (X**AK * (AG + X * (BG + X*C)) * LX**BK + S**AL
38500      1      * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38501
38502       END
38503
38504 *$ CREATE PHO_DOR92FS.FOR
38505 *COPY PHO_DOR92FS
38506 CDECK  ID>, PHO_DOR92FS
38507       DOUBLE PRECISION FUNCTION PHO_DOR92FS(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
38508       IMPLICIT DOUBLE PRECISION (A - Z)
38509       SAVE
38510
38511        DX = SQRT (X)
38512        LX = LOG (1./X)
38513        IF (S .LE. ST) THEN
38514          PHO_DOR92FS = 0.D0
38515        ELSE
38516          PHO_DOR92FS = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
38517      1          * EXP (-E + SQRT (ES * S**BE * LX))
38518        END IF
38519
38520       END
38521
38522 *$ CREATE PHO_DORPLO.FOR
38523 *COPY PHO_DORPLO
38524 CDECK  ID>, PHO_DORPLO
38525 *
38526 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38527 *                                                                 *
38528 *         G R V - P I O N - P A R A M E T R I Z A T I O N S       *
38529 *                                                                 *
38530 *                 FOR A DETAILED EXPLANATION SEE :                *
38531 *              M. GLUECK, E.REYA, A.VOGT: DO-TH 91/16             *
38532 *                                                                 *
38533 *   THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS   *
38534 *   FOR Q ** 2 BETWEEN MU ** 2 (=  0.25 / 0.30  GEV ** 2  IN LO   *
38535 *   / HO) AND  1.E8 GEV ** 2  AND FOR X BETWEEN  1.E-5  AND  1.   *
38536 *   REGIONS, WHERE THE DISTRIBUTION UNDER CONSIDERATION IS NEG-   *
38537 *   LIGIBLE, I.E. BELOW ABOUT 1.E-4, WERE EXCLUDED FROM THE FIT.  *
38538 *                                                                 *
38539 *              HEAVY QUARK THRESHOLDS  Q(H) = M(H) :              *
38540 *         M(C)  =  1.5,  M(B)  =  4.5,  M(T)  =  100  GEV         *
38541 *                                                                 *
38542 *      CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS :     *
38543 *      LO :   LAMBDA(3)  =  0.232,   LAMBDA(4)  =  0.200,         *
38544 *             LAMBDA(5)  =  0.153,   LAMBDA(6)  =  0.082  GEV     *
38545 *      HO :   LAMBDA(3)  =  0.248,   LAMBDA(4)  =  0.200,         *
38546 *             LAMBDA(5)  =  0.131,   LAMBDA(6)  =  0.053  GEV     *
38547 *                                                                 *
38548 *   HO DISTRIBUTION REFER TO THE MS-BAR SCHEME OF BARDEEN ET AL.  *
38549 *                                                                 *
38550 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38551 C
38552       SUBROUTINE PHO_DORPLO (X, Q2, VAP, GLP, QBP, CBP, BBP)
38553       IMPLICIT DOUBLE PRECISION (A - Z)
38554       SAVE
38555
38556        MU2  = 0.25
38557        LAM2 = 0.232 * 0.232
38558        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38559        DS = SQRT (S)
38560        S2 = S * S
38561 C...X * VALENCE :
38562        NV  =  0.519 + 0.180 * S - 0.011 * S2
38563        AKV =  0.499 - 0.027 * S
38564        AGV =  0.381 - 0.419 * S
38565        DV  =  0.367 + 0.563 * S
38566        VAP =  PHO_DORFVP (X, NV, AKV, AGV, DV)
38567 C...X * GLUON :
38568        ALG =  0.599
38569        BEG =  1.263
38570        AKG =  0.482 + 0.341 * DS
38571        BKG =   0.0
38572        AGG =  0.678 + 0.877 * S  - 0.175 * S2
38573        BGG =  0.338 - 1.597 * S
38574        CG  =   0.0  - 0.233 * S  + 0.406 * S2
38575        DG  =  0.390 + 1.053 * S
38576        EG  =  0.618 + 2.070 * S
38577        ESG =  3.676
38578        GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38579 C...X * QBAR (SU(3)-SYMMETRIC SEA) :
38580        SL  =   0.0
38581        ALS =   0.55
38582        BES =   0.56
38583        AKS =  2.538 - 0.763 * S
38584        AGS = -0.748
38585        BS  =  0.313 + 0.935 * S
38586        DS  =  3.359
38587        EST =  4.433 + 1.301 * S
38588        ESS =   9.30 - 0.887 * S
38589        QBP =  PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38590 C...X * CBAR = X * C :
38591        SC  =  0.888
38592        ALC =   1.02
38593        BEC =   0.39
38594        AKC =   0.0
38595        AGC =   0.0
38596        BC  =  1.008
38597        DC  =  1.208 + 0.771 * S
38598        EC  =   4.40 + 1.493 * S
38599        ESC =  2.032 + 1.901 * S
38600        CBP =  PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38601 C...X * BBAR = X * B :
38602        SBO =  1.351
38603        ALB =   1.03
38604        BEB =   0.39
38605        AKB =   0.0
38606        AGB =   0.0
38607        BBO =   0.0
38608        DB  =  0.697 + 0.855 * S
38609        EB  =   4.51 + 1.490 * S
38610        ESB =  3.056 + 1.694 * S
38611        BBP =  PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38612
38613        END
38614
38615 *$ CREATE PHO_DORPHO.FOR
38616 *COPY PHO_DORPHO
38617 CDECK  ID>, PHO_DORPHO
38618       SUBROUTINE PHO_DORPHO (X, Q2, VAP, GLP, QBP, CBP, BBP)
38619       IMPLICIT DOUBLE PRECISION (A - Z)
38620       SAVE
38621
38622        MU2  = 0.3
38623        LAM2 = 0.248 * 0.248
38624        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38625        DS = SQRT (S)
38626        S2 = S * S
38627 C...X * VALENCE :
38628        NV  =  0.456 + 0.150 * DS + 0.112 * S - 0.019 * S2
38629        AKV =  0.505 - 0.033 * S
38630        AGV =  0.748 - 0.669 * DS - 0.133 * S
38631        DV  =  0.365 + 0.197 * DS + 0.394 * S
38632        VAP =  PHO_DORFVP (X, NV, AKV, AGV, DV)
38633 C...X * GLUON :
38634        ALG =  1.096
38635        BEG =  1.371
38636        AKG =  0.437 - 0.689 * DS
38637        BKG = -0.631
38638        AGG =  1.324 - 0.441 * DS - 0.130 * S
38639        BGG = -0.955 + 0.259 * S
38640        CG  =  1.075 - 0.302 * S
38641        DG  =  1.158 + 1.229 * S
38642        EG  =   0.0  + 2.510 * S
38643        ESG =  2.604 + 0.165 * S
38644        GLP = PHO_DORFGP(X,S,ALG,BEG,AKG,BKG,AGG,BGG,CG,DG,EG,ESG)
38645 C...X * QBAR (SU(3)-SYMMETRIC SEA) :
38646        SL  =   0.0
38647        ALS =   0.85
38648        BES =   0.96
38649        AKS = -0.350 + 0.806 * S
38650        AGS = -1.663
38651        BS  =  3.148
38652        DS  =  2.273 + 1.438 * S
38653        EST =  3.214 + 1.545 * S
38654        ESS =  1.341 + 1.938 * S
38655        QBP =  PHO_DORFQP (X,S,SL,ALS,BES,AKS,AGS,BS,DS,EST,ESS)
38656 C...X * CBAR = X * C :
38657        SC  =  0.820
38658        ALC =   0.98
38659        BEC =   0.0
38660        AKC =   0.0  - 0.457 * S
38661        AGC =   0.0
38662        BC  =  -1.00 +  1.40 * S
38663        DC  =  1.318 + 0.584 * S
38664        EC  =   4.45 + 1.235 * S
38665        ESC =  1.496 + 1.010 * S
38666        CBP =  PHO_DORFQP (X,S,SC,ALC,BEC,AKC,AGC,BC,DC,EC,ESC)
38667 C...X * BBAR = X * B :
38668        SBO =  1.297
38669        ALB =   0.99
38670        BEB =   0.0
38671        AKB =   0.0  - 0.172 * S
38672        AGB =   0.0
38673        BBO =   0.0
38674        DB  =  1.447 + 0.485 * S
38675        EB  =   4.79 + 1.164 * S
38676        ESB =  1.724 + 2.121 * S
38677        BBP =  PHO_DORFQP(X,S,SBO,ALB,BEB,AKB,AGB,BBO,DB,EB,ESB)
38678
38679       END
38680
38681 *$ CREATE PHO_DORFVP.FOR
38682 *COPY PHO_DORFVP
38683 CDECK  ID>, PHO_DORFVP
38684       DOUBLE PRECISION FUNCTION PHO_DORFVP(X,N,AK,AG,D)
38685       IMPLICIT DOUBLE PRECISION (A - Z)
38686       SAVE
38687
38688        DX = SQRT (X)
38689        PHO_DORFVP = N * X**AK * (1.+ AG*DX) * (1.- X)**D
38690
38691       END
38692
38693 *$ CREATE PHO_DORFGP.FOR
38694 *COPY PHO_DORFGP
38695 CDECK  ID>, PHO_DORFGP
38696       DOUBLE PRECISION FUNCTION PHO_DORFGP(X,S,AL,BE,AK,BK,AG,
38697      &                                    BG,C,D,E,ES)
38698       IMPLICIT DOUBLE PRECISION (A - Z)
38699       SAVE
38700
38701        DX = SQRT (X)
38702        LX = LOG (1./X)
38703        PHO_DORFGP = (X**AK * (AG + BG*DX + C*X) * LX**BK + S**AL
38704      1       * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
38705
38706       END
38707
38708 *$ CREATE PHO_DORFQP.FOR
38709 *COPY PHO_DORFQP
38710 CDECK  ID>, PHO_DORFQP
38711       DOUBLE PRECISION FUNCTION PHO_DORFQP(X,S,ST,AL,BE,AK,AG,B,D,E,ES)
38712       IMPLICIT DOUBLE PRECISION (A - Z)
38713       SAVE
38714
38715        DX = SQRT (X)
38716        LX = LOG (1./X)
38717        IF (S .LE. ST) THEN
38718           PHO_DORFQP = 0.0
38719        ELSE
38720           PHO_DORFQP = (S-ST)**AL/LX**AK*(1.D0+AG*DX+B*X)*(1.D0-X)**D
38721      1           * EXP (-E + SQRT (ES * S**BE * LX))
38722        END IF
38723
38724       END
38725
38726 *$ CREATE PHO_DORGLO.FOR
38727 *COPY PHO_DORGLO
38728 CDECK  ID>, PHO_DORGLO
38729 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38730 *                                                                 *
38731 *      G R V - P H O T O N - P A R A M E T R I Z A T I O N S      *
38732 *                                                                 *
38733 *                 FOR A DETAILED EXPLANATION SEE :                *
38734 *              M. GLUECK, E.REYA, A.VOGT: DO-TH 91/31             *
38735 *                                                                 *
38736 *    THE OUTPUT IS ALWAYS   1./ ALPHA(EM) * X * PARTON DENSITY    *
38737 *                                                                 *
38738 *   THE PARAMETRIZATIONS ARE FITTED TO THE PARTON DISTRIBUTIONS   *
38739 *   FOR Q ** 2 BETWEEN MU ** 2 (=  0.25 / 0.30  GEV ** 2  IN LO   *
38740 *   / HO) AND  1.E6 GEV ** 2  AND FOR X BETWEEN  1.E-5  AND  1.   *
38741 *                                                                 *
38742 *              HEAVY QUARK THRESHOLDS  Q(H) = M(H) :              *
38743 *         M(C)  =  1.5,  M(B)  =  4.5,  M(T)  =  100  GEV         *
38744 *                                                                 *
38745 *      CORRESPONDING LAMBDA(F) VALUES FOR F ACTIVE FLAVOURS :     *
38746 *      LO :   LAMBDA(3)  =  0.232,   LAMBDA(4)  =  0.200,         *
38747 *             LAMBDA(5)  =  0.153,   LAMBDA(6)  =  0.082  GEV     *
38748 *      HO :   LAMBDA(3)  =  0.248,   LAMBDA(4)  =  0.200,         *
38749 *             LAMBDA(5)  =  0.131,   LAMBDA(6)  =  0.053  GEV     *
38750 *                                                                 *
38751 *      HO DISTRIBUTIONS REFER TO THE DIS(GAMMA) SCHEME, SEE :     *
38752 *              M. GLUECK, E.REYA, A.VOGT: DO-TH 91/26             *
38753 *                                                                 *
38754 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
38755 C
38756       SUBROUTINE PHO_DORGLO (X, Q2, UL, DL, SL, CL, BL, GL)
38757       IMPLICIT DOUBLE PRECISION (A - Z)
38758       SAVE
38759
38760        MU2  = 0.25
38761        LAM2 = 0.232 * 0.232
38762        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38763        SS = SQRT (S)
38764        S2 = S * S
38765 C...X * U = X * UBAR :
38766        AL =  1.717
38767        BE =  0.641
38768        AK =  0.500 - 0.176 * S
38769        BK = 15.00  - 5.687 * SS - 0.552 * S2
38770        AG =  0.235 + 0.046 * SS
38771        BG =  0.082 - 0.051 * S  + 0.168 * S2
38772        C  =   0.0  + 0.459 * S
38773        D  =  0.354 - 0.061 * S
38774        E  =  4.899 + 1.678 * S
38775        ES =  2.046 + 1.389 * S
38776        UL =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38777 C...X * D = X * DBAR :
38778        AL =  1.549
38779        BE =  0.782
38780        AK =  0.496 + 0.026 * S
38781        BK =  0.685 - 0.580 * SS + 0.608 * S2
38782        AG =  0.233 + 0.302 * S
38783        BG =   0.0  - 0.818 * S  + 0.198 * S2
38784        C  =  0.114 + 0.154 * S
38785        D  =  0.405 - 0.195 * S  + 0.046 * S2
38786        E  =  4.807 + 1.226 * S
38787        ES =  2.166 + 0.664 * S
38788        DL  =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38789 C...X * G :
38790        AL =  0.676
38791        BE =  1.089
38792        AK =  0.462 - 0.524 * SS
38793        BK =  5.451              - 0.804 * S2
38794        AG =  0.535 - 0.504 * SS + 0.288 * S2
38795        BG =  0.364 - 0.520 * S
38796        C  = -0.323              + 0.115 * S2
38797        D  =  0.233 + 0.790 * S  - 0.139 * S2
38798        E  =  0.893 + 1.968 * S
38799        ES =  3.432 + 0.392 * S
38800        GL =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38801 C...X * S = X * SBAR :
38802        SF =   0.0
38803        AL =  1.609
38804        BE =  0.962
38805        AK =  0.470              - 0.099 * S2
38806        BK =  3.246
38807        AG =  0.121 - 0.068 * SS
38808        BG = -0.090 + 0.074 * S
38809        C  =  0.062 + 0.034 * S
38810        D  =   0.0  + 0.226 * S  - 0.060 * S2
38811        E  =  4.288 + 1.707 * S
38812        ES =  2.122 + 0.656 * S
38813        SL =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38814 C...X * C = X * CBAR :
38815        SF =  0.888
38816        AL =  0.970
38817        BE =  0.545
38818        AK =  1.254 - 0.251 * S
38819        BK =  3.932              - 0.327 * S2
38820        AG =  0.658 + 0.202 * S
38821        BG = -0.699
38822        C  =  0.965
38823        D  =   0.0  + 0.141 * S  - 0.027 * S2
38824        E  =  4.911 + 0.969 * S
38825        ES =  2.796 + 0.952 * S
38826        CL =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38827 C...X * B = X * BBAR :
38828        SF =  1.351
38829        AL =  1.016
38830        BE =  0.338
38831        AK =  1.961 - 0.370 * S
38832        BK =  0.923 + 0.119 * S
38833        AG =  0.815 + 0.207 * S
38834        BG = -2.275
38835        C  =  1.480
38836        D  = -0.223 + 0.173 * S
38837        E  =  5.426 + 0.623 * S
38838        ES =  3.819 + 0.901 * S
38839        BL =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38840
38841        END
38842
38843 *$ CREATE PHO_DORGHO.FOR
38844 *COPY PHO_DORGHO
38845 CDECK  ID>, PHO_DORGHO
38846       SUBROUTINE PHO_DORGHO (X, Q2, UH, DH, SH, CH, BH, GH)
38847       IMPLICIT DOUBLE PRECISION (A - Z)
38848       SAVE
38849
38850        MU2  = 0.3
38851        LAM2 = 0.248 * 0.248
38852        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38853        SS = SQRT (S)
38854        S2 = S * S
38855 C...X * U = X * UBAR :
38856        AL =  0.583
38857        BE =  0.688
38858        AK =  0.449 - 0.025 * S  - 0.071 * S2
38859        BK =  5.060 - 1.116 * SS
38860        AG =  0.103
38861        BG =  0.319 + 0.422 * S
38862        C  =  1.508 + 4.792 * S  - 1.963 * S2
38863        D  =  1.075 + 0.222 * SS - 0.193 * S2
38864        E  =  4.147 + 1.131 * S
38865        ES =  1.661 + 0.874 * S
38866        UH =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38867 C...X * D = X * DBAR :
38868        AL =  0.591
38869        BE =  0.698
38870        AK =  0.442 - 0.132 * S  - 0.058 * S2
38871        BK =  5.437 - 1.916 * SS
38872        AG =  0.099
38873        BG =  0.311 - 0.059 * S
38874        C  =  0.800 + 0.078 * S  - 0.100 * S2
38875        D  =  0.862 + 0.294 * SS - 0.184 * S2
38876        E  =  4.202 + 1.352 * S
38877        ES =  1.841 + 0.990 * S
38878        DH  =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38879 C...X * G :
38880        AL =  1.161
38881        BE =  1.591
38882        AK =  0.530 - 0.742 * SS + 0.025 * S2
38883        BK =  5.662
38884        AG =  0.533 - 0.281 * SS + 0.218 * S2
38885        BG =  0.025 - 0.518 * S  + 0.156 * S2
38886        C  = -0.282              + 0.209 * S2
38887        D  =  0.107 + 1.058 * S  - 0.218 * S2
38888        E  =   0.0  + 2.704 * S
38889        ES =  3.071 - 0.378 * S
38890        GH =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38891 C...X * S = X * SBAR :
38892        SF =   0.0
38893        AL =  0.635
38894        BE =  0.456
38895        AK =  1.770 - 0.735 * SS - 0.079 * S2
38896        BK =  3.832
38897        AG =  0.084 - 0.023 * S
38898        BG =  0.136
38899        C  =  2.119 - 0.942 * S  + 0.063 * S2
38900        D  =  1.271 + 0.076 * S  - 0.190 * S2
38901        E  =  4.604 + 0.737 * S
38902        ES =  1.641 + 0.976 * S
38903        SH =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38904 C...X * C = X * CBAR :
38905        SF =  0.820
38906        AL =  0.926
38907        BE =  0.152
38908        AK =  1.142 - 0.175 * S
38909        BK =  3.276
38910        AG =  0.504 + 0.317 * S
38911        BG = -0.433
38912        C  =  3.334
38913        D  =  0.398 + 0.326 * S  - 0.107 * S2
38914        E  =  5.493 + 0.408 * S
38915        ES =  2.426 + 1.277 * S
38916        CH =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38917 C...X * B = X * BBAR :
38918        SF =  1.297
38919        AL =  0.969
38920        BE =  0.266
38921        AK =  1.953 - 0.391 * S
38922        BK =  1.657 - 0.161 * S
38923        AG =  1.076 + 0.034 * S
38924        BG = -2.015
38925        C  =  1.662
38926        D  =  0.353 + 0.016 * S
38927        E  =  5.713 + 0.249 * S
38928        ES =  3.456 + 0.673 * S
38929        BH =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38930
38931       END
38932
38933 *$ CREATE PHO_DORGH0.FOR
38934 *COPY PHO_DORGH0
38935 CDECK  ID>, PHO_DORGH0
38936       SUBROUTINE PHO_DORGH0 (X, Q2, U0, D0, S0, C0, B0, G0)
38937       IMPLICIT DOUBLE PRECISION (A - Z)
38938       SAVE
38939
38940        MU2  = 0.3
38941        LAM2 = 0.248 * 0.248
38942        S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38943        SS = SQRT (S)
38944        S2 = S * S
38945 C...X * U = X * UBAR :
38946        AL =  1.447
38947        BE =  0.848
38948        AK =  0.527 + 0.200 * S  - 0.107 * S2
38949        BK =  7.106 - 0.310 * SS - 0.786 * S2
38950        AG =  0.197 + 0.533 * S
38951        BG =  0.062 - 0.398 * S  + 0.109 * S2
38952        C  =          0.755 * S  - 0.112 * S2
38953        D  =  0.318 - 0.059 * S
38954        E  =  4.225 + 1.708 * S
38955        ES =  1.752 + 0.866 * S
38956        U0 =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38957 C...X * D = X * DBAR :
38958        AL =  1.424
38959        BE =  0.770
38960        AK =  0.500 + 0.067 * SS - 0.055 * S2
38961        BK =  0.376 - 0.453 * SS + 0.405 * S2
38962        AG =  0.156 + 0.184 * S
38963        BG =   0.0  - 0.528 * S  + 0.146 * S2
38964        C  =  0.121 + 0.092 * S
38965        D  =  0.379 - 0.301 * S  + 0.081 * S2
38966        E  =  4.346 + 1.638 * S
38967        ES =  1.645 + 1.016 * S
38968        D0  =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38969 C...X * G :
38970        AL =  0.661
38971        BE =  0.793
38972        AK =  0.537 - 0.600 * SS
38973        BK =  6.389              - 0.953 * S2
38974        AG =  0.558 - 0.383 * SS + 0.261 * S2
38975        BG =   0.0  - 0.305 * S
38976        C  = -0.222              + 0.078 * S2
38977        D  =  0.153 + 0.978 * S  - 0.209 * S2
38978        E  =  1.429 + 1.772 * S
38979        ES =  3.331 + 0.806 * S
38980        G0 =  PHO_DORGF (X, S, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38981 C...X * S = X * SBAR :
38982        SF =   0.0
38983        AL =  1.578
38984        BE =  0.863
38985        AK =  0.622 + 0.332 * S  - 0.300 * S2
38986        BK =  2.469
38987        AG =  0.211 - 0.064 * SS - 0.018 * S2
38988        BG = -0.215 + 0.122 * S
38989        C  =  0.153
38990        D  =   0.0  + 0.253 * S  - 0.081 * S2
38991        E  =  3.990 + 2.014 * S
38992        ES =  1.720 + 0.986 * S
38993        S0 =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
38994 C...X * C = X * CBAR :
38995        SF =  0.820
38996        AL =  0.929
38997        BE =  0.381
38998        AK =  1.228 - 0.231 * S
38999        BK =  3.806             - 0.337 * S2
39000        AG =  0.932 + 0.150 * S
39001        BG = -0.906
39002        C  =  1.133
39003        D  =   0.0  + 0.138 * S  - 0.028 * S2
39004        E  =  5.588 + 0.628 * S
39005        ES =  2.665 + 1.054 * S
39006        C0 =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39007 C...X * B = X * BBAR :
39008        SF =  1.297
39009        AL =  0.970
39010        BE =  0.207
39011        AK =  1.719 - 0.292 * S
39012        BK =  0.928 + 0.096 * S
39013        AG =  0.845 + 0.178 * S
39014        BG = -2.310
39015        C  =  1.558
39016        D  = -0.191 + 0.151 * S
39017        E  =  6.089 + 0.282 * S
39018        ES =  3.379 + 1.062 * S
39019        B0 =  PHO_DORGFS (X, S, SF, AL, BE, AK, BK, AG, BG, C, D, E, ES)
39020
39021       END
39022
39023 *$ CREATE PHO_DORGF.FOR
39024 *COPY PHO_DORGF
39025 CDECK  ID>, PHO_DORGF
39026       DOUBLE PRECISION FUNCTION PHO_DORGF(X,S,AL,BE,AK,BK,
39027      &                                   AG,BG,C,D,E,ES)
39028       IMPLICIT DOUBLE PRECISION (A - Z)
39029       SAVE
39030
39031        SX = SQRT (X)
39032        LX = LOG (1./X)
39033        PHO_DORGF  = (X**AK * (AG + BG * SX + C * X**BK)  +  S**AL
39034      1       * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
39035
39036       END
39037
39038 *$ CREATE PHO_DORGFS.FOR
39039 *COPY PHO_DORGFS
39040 CDECK  ID>, PHO_DORGFS
39041       DOUBLE PRECISION FUNCTION PHO_DORGFS(X,S,SF,AL,BE,AK,BK,AG,BG,
39042      &                                     C,D,E,ES)
39043       IMPLICIT DOUBLE PRECISION (A - Z)
39044       SAVE
39045
39046        IF (S .LE. SF) THEN
39047           PHO_DORGFS = 0.0
39048        ELSE
39049           SX = SQRT (X)
39050           LX = LOG (1./X)
39051           DS = S - SF
39052           PHO_DORGFS = (DS * X**AK * (AG + BG * SX + C * X**BK) + DS**AL
39053      1         * EXP (-E + SQRT (ES * S**BE * LX))) * (1.- X)**D
39054        END IF
39055
39056       END
39057
39058 *$ CREATE PHO_DORGLV.FOR
39059 *COPY PHO_DORGLV
39060 CDECK  ID>, PHO_DORGLV
39061 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39062 *                                                                 *
39063 *           G R S - LO - VIRTUAL PHOTON PARAMETRIZATIONS          *
39064 *                                                                 *
39065 *                 FOR A DETAILED EXPLANATION SEE                  *
39066 *                M. GLUECK, E.REYA, M. STRATMANN :                *
39067 *                    PHYS. REV. D51 (1995) 3220                   *
39068 *                                                                 *
39069 *   THE PARAMETRIZATIONS ARE FITTED TO THE EVOLVED PARTONS FOR    *
39070 *        Q**2 / GEV**2  BETWEEN   0.6   AND  5.E4                 *
39071 *                       AND (!)  Q**2 > 5 P**2                    *
39072 *        P**2 / GEV**2  BETWEEN   0.0   AND  10.                  *
39073 *                       P**2 = 0  <=> REAL PHOTON                 *
39074 *             X         BETWEEN  1.E-4  AND   1.                  *
39075 *                                                                 *
39076 *   HEAVY QUARK THRESHOLDS  Q(H) = M(H)  IN THE BETA FUNCTION :   *
39077 *                   M(C)  =  1.5,  M(B)  =  4.5                   *
39078 *   CORRESPONDING LAMBDA(F) VALUES IN GEV FOR  Q**2 > M(H)**2 :   *
39079 *      LO :   LAMBDA(3)  =  0.232,   LAMBDA(4)  =  0.200,         *
39080 *             LAMBDA(5)  =  0.153,                                *
39081 *   THE NUMBER OF ACTIVE QUARK FLAVOURS IS  NF = 3  EVERYWHERE    *
39082 *   EXCEPT IN THE BETA FUNCTION, I.E. THE HEAVY QUARKS C,B,...    *
39083 *   ARE NOT PRESENT AS PARTONS IN THE Q2-EVOLUTION.               *
39084 *                                                                 *
39085 *   PLEASE REPORT ANY STRANGE BEHAVIOUR TO :                      *
39086 *                  Marco.Stratmann@durham.ac.uk                   *
39087 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
39088 *
39089 *...INPUT PARAMETERS :
39090 *
39091 *    X   = MOMENTUM FRACTION
39092 *    Q2  = SCALE Q**2 IN GEV**2
39093 *    P2  = VIRTUALITY OF THE PHOTON IN GEV**2
39094 *
39095 *...OUTPUT (ALWAYS X TIMES THE DISTRIBUTION DIVIDED BY ALPHA_EM) :
39096 *
39097 ********************************************************
39098 *     subroutine grspar(x,q2,p2,ugam,dgam,sgam,ggam)
39099       subroutine PHO_DORGLV(x,q2,p2,ugam,dgam,sgam,ggam)
39100       implicit double precision (a-z)
39101       save
39102
39103 C  input/output channels
39104       INTEGER LI,LO
39105       COMMON /POINOU/ LI,LO
39106
39107       integer check
39108 c
39109 c     check limits :
39110 c
39111       check=0
39112       if(x.lt.0.0001d0) check=1
39113       if((q2.lt.0.6d0).or.(q2.gt.50000.d0))  check=1
39114       if(q2.lt.5.d0*p2) check=1
39115 c
39116 c     calculate distributions
39117 c
39118       if(check.eq.0) then
39119          call PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
39120       else
39121          WRITE(LO,*) 'GRS PDF parametrization: x/q2/p2 limits exceeded'
39122          WRITE(LO,'(1X,A,1P,3E12.3)') 'current X, Q2, P2:',x,q2,p2
39123       endif
39124
39125       end
39126
39127 *$ CREATE PHO_grscalc.FOR
39128 *COPY PHO_grscalc
39129 CDECK  ID>, PHO_grscalc
39130       subroutine PHO_grscalc(x,q2,p2,ugam,dgam,sgam,ggam)
39131       implicit double precision (a-z)
39132       save
39133
39134       dimension u1(40),ds1(40),g1(40)
39135       dimension ud2(20),s2(20),g2(20)
39136       dimension up0(20),dsp0(20),gp0(20)
39137 CPH      save u1,ds1,g1,ud2,s2,g2,up0,dsp0,gp0
39138 c
39139       data u1/-0.139d0,0.783d0,0.132d0,0.087d0,0.003d0,-0.0134d0,
39140      &   0.009d0,-0.017d0,0.092d0,-0.516d0,-0.085d0,0.439d0,
39141      &   0.013d0,0.108d0,-0.019d0,-0.272d0,-0.167d0,0.138d0,
39142      &   0.076d0,0.026d0,-0.013d0,0.27d0,0.107d0,-0.097d0,0.04d0,
39143      &   0.064d0,0.011d0,0.002d0,0.057d0,-0.057d0,0.162d0,
39144      &   -0.172d0,0.124d0,-0.016d0,-0.065d0,0.044d0,-1.009d0,
39145      &   0.622d0,0.227d0,-0.184d0/
39146       data ds1/0.033d0,0.007d0,-0.0516d0,0.12d0,0.001d0,-0.013d0,
39147      &   0.018d0,-0.028d0,0.102d0,-0.595d0,-0.114d0,0.669d0,
39148      &   0.022d0,0.001d0,-0.003d0,-0.0583d0,-0.041d0,0.035d0,
39149      &   0.009d0,0.009d0,0.004d0,0.054d0,0.025d0,-0.02d0,
39150      &   0.007d0,0.021d0,0.01d0,0.004d0,-0.067d0,0.06d0,-0.148d0,
39151      &   0.13d0,0.032d0,-0.009d0,-0.06d0,0.036d0,-0.39d0,0.033d0,
39152      &   0.245d0,-0.171d0/
39153       data g1/0.025d0,0.d0,-0.018d0,0.112d0,-0.025d0,0.177d0,
39154      &   -0.022d0,0.024d0,0.001d0,-0.0104d0,0.d0,0.d0,-1.082d0,
39155      &   -1.666d0,0.d0,0.086d0,0.d0,0.053d0,0.005d0,-0.058d0,
39156      &   0.034d0,0.073d0,1.08d0,1.63d0,-0.0256d0,-0.088d0,0.d0,
39157      &   0.d0,-0.004d0,0.016d0,0.007d0,-0.012d0,0.01d0,-0.673d0,
39158      &   0.126d0,-0.167d0,0.032d0,-0.227d0,0.086d0,-0.159d0/
39159       data ud2/0.756d0,0.187d0,0.109d0,-0.163d0,0.002d0,0.004d0,
39160      &   0.054d0,-0.039d0,22.53d0,-21.02d0,5.608d0,0.332d0,
39161      &   -0.008d0,-0.021d0,0.381d0,0.572d0,4.774d0,1.436d0,
39162      &   -0.614d0,3.548d0/
39163       data s2/0.902d0,0.182d0,0.271d0,-0.346d0,0.017d0,-0.01d0,
39164      &   -0.011d0,0.0065d0,17.1d0,-13.29d0,6.519d0,0.031d0,
39165      &   -0.0176d0,0.003d0,1.243d0,0.804d0,4.709d0,1.499d0,
39166      &   -0.48d0,3.401d0/
39167       data g2/0.364d0,1.31d0,0.86d0,-0.254d0,0.611d0,0.008d0,
39168      &   -0.097d0,-2.412d0,-0.843d0,2.248d0,-0.201d0,1.33d0,
39169      &   0.572d0,0.44d0,1.233d0,0.009d0,0.954d0,1.862d0,3.791d0,
39170      &   -0.079d0/
39171       data up0/1.551d0,0.105d0,1.089d0,-0.172d0,3.822d0,-2.162d0,
39172      &   0.533d0,-0.467d0,-0.412d0,0.2d0,0.377d0,0.299d0,0.487d0,
39173      &   0.0766d0,0.119d0,0.063d0,7.605d0,0.234d0,-0.567d0,
39174      &   2.294d0/
39175       data dsp0/2.484d0,1.214d0,1.088d0,-0.1735d0,4.293d0,
39176      &   -2.802d0,0.5975d0,-0.1193d0,-0.0872d0,0.0418d0,0.128d0,
39177      &   0.0337d0,0.127d0,0.0135d0,0.14d0,0.0423d0,6.946d0,
39178      &   0.814d0,1.531d0,0.124d0/
39179       data gp0/1.682d0,1.1d0,0.5888d0,-0.4714d0,0.5362d0,0.0127d0,
39180      &   -2.438d0,0.03399d0,0.07825d0,0.05842d0,0.08393d0,2.348d0,
39181      &   -0.07182d0,1.084d0,0.3098d0,-0.07514d0,3.327d0,1.1d0,
39182      &   2.264d0,0.2675d0/
39183 c
39184       mu2=0.25d0
39185       lam2=0.232d0*0.232d0
39186 c
39187       if(p2.le.0.25d0) then
39188          s=log(log(q2/lam2)/log(mu2/lam2))
39189          lp1=0.d0
39190          lp2=0.d0
39191       else
39192          s=log(log(q2/lam2)/log(p2/lam2))
39193          lp1=log(p2/mu2)*log(p2/mu2)
39194          lp2=log(p2/mu2+log(p2/mu2))
39195       endif
39196 c
39197       alp=up0(1)+lp1*u1(1)+lp2*u1(2)
39198       bet=up0(2)+lp1*u1(3)+lp2*u1(4)
39199       a=up0(3)+lp1*u1(5)+lp2*u1(6)+
39200      &  (up0(4)+lp1*u1(7)+lp2*u1(8))*s
39201       b=up0(5)+lp1*u1(9)+lp2*u1(10)+
39202      &  (up0(6)+lp1*u1(11)+lp2*u1(12))*s**0.5+
39203      &  (up0(7)+lp1*u1(13)+lp2*u1(14))*s**2
39204       gb=up0(8)+lp1*u1(15)+lp2*u1(16)+
39205      &  (up0(9)+lp1*u1(17)+lp2*u1(18))*s+
39206      &  (up0(10)+lp1*u1(19)+lp2*u1(20))*s**2
39207       ga=up0(11)+lp1*u1(21)+lp2*u1(22)+
39208      &  (up0(12)+lp1*u1(23)+lp2*u1(24))*s**0.5
39209       gc=up0(13)+lp1*u1(25)+lp2*u1(33)+
39210      &  (up0(14)+lp1*u1(26)+lp2*u1(34))*s
39211       gd=up0(15)+lp1*u1(27)+lp2*u1(35)+
39212      &  (up0(16)+lp1*u1(28)+lp2*u1(36))*s
39213       ge=up0(17)+lp1*u1(29)+lp2*u1(37)+
39214      &  (up0(18)+lp1*u1(30)+lp2*u1(38))*s
39215       gep=up0(19)+lp1*u1(31)+lp2*u1(39)+
39216      &  (up0(20)+lp1*u1(32)+lp2*u1(40))*s
39217       upart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39218 c
39219       alp=dsp0(1)+lp1*ds1(1)+lp2*ds1(2)
39220       bet=dsp0(2)+lp1*ds1(3)+lp2*ds1(4)
39221       a=dsp0(3)+lp1*ds1(5)+lp2*ds1(6)+
39222      &  (dsp0(4)+lp1*ds1(7)+lp2*ds1(8))*s
39223       b=dsp0(5)+lp1*ds1(9)+lp2*ds1(10)+
39224      &  (dsp0(6)+lp1*ds1(11)+lp2*ds1(12))*s**0.5+
39225      &  (dsp0(7)+lp1*ds1(13)+lp2*ds1(14))*s**2
39226       gb=dsp0(8)+lp1*ds1(15)+lp2*ds1(16)+
39227      &  (dsp0(9)+lp1*ds1(17)+lp2*ds1(18))*s+
39228      &  (dsp0(10)+lp1*ds1(19)+lp2*ds1(20))*s**2
39229       ga=dsp0(11)+lp1*ds1(21)+lp2*ds1(22)+
39230      &  (dsp0(12)+lp1*ds1(23)+lp2*ds1(24))*s
39231       gc=dsp0(13)+lp1*ds1(25)+lp2*ds1(33)+
39232      &  (dsp0(14)+lp1*ds1(26)+lp2*ds1(34))*s
39233       gd=dsp0(15)+lp1*ds1(27)+lp2*ds1(35)+
39234      &  (dsp0(16)+lp1*ds1(28)+lp2*ds1(36))*s
39235       ge=dsp0(17)+lp1*ds1(29)+lp2*ds1(37)+
39236      &  (dsp0(18)+lp1*ds1(30)+lp2*ds1(38))*s
39237       gep=dsp0(19)+lp1*ds1(31)+lp2*ds1(39)+
39238      &  (dsp0(20)+lp1*ds1(32)+lp2*ds1(40))*s
39239       dspart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39240 c
39241       alp=gp0(1)+lp1*g1(1)+lp2*g1(2)
39242       bet=gp0(2)+lp1*g1(3)+lp2*g1(4)
39243       a=gp0(3)+lp1*g1(5)+lp2*g1(6)+
39244      &  (gp0(4)+lp1*g1(7)+lp2*g1(8))*s**0.5
39245       b=gp0(5)+lp1*g1(9)+lp2*g1(10)+
39246      &  (gp0(6)+lp1*g1(11)+lp2*g1(12))*s**2
39247       gb=gp0(7)+lp1*g1(13)+lp2*g1(14)+
39248      &  (gp0(8)+lp1*g1(15)+lp2*g1(16))*s
39249       ga=gp0(9)+lp1*g1(17)+lp2*g1(18)+
39250      &  (gp0(10)+lp1*g1(19)+lp2*g1(20))*s**0.5+
39251      &  (gp0(11)+lp1*g1(21)+lp2*g1(22))*s**2
39252       gc=gp0(12)+lp1*g1(23)+lp2*g1(24)+
39253      &  (gp0(13)+lp1*g1(25)+lp2*g1(26))*s**2
39254       gd=gp0(14)+lp1*g1(27)+lp2*g1(28)+
39255      &  (gp0(15)+lp1*g1(29)+lp2*g1(30))*s+
39256      &  (gp0(16)+lp1*g1(31)+lp2*g1(32))*s**2
39257       ge=gp0(17)+lp1*g1(33)+lp2*g1(34)+
39258      &  (gp0(18)+lp1*g1(35)+lp2*g1(36))*s
39259       gep=gp0(19)+lp1*g1(37)+lp2*g1(38)+
39260      &  (gp0(20)+lp1*g1(39)+lp2*g1(40))*s
39261       gpart1=PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39262 c
39263       s=log(log(q2/lam2)/log(mu2/lam2))
39264       suppr=1.d0/(1.d0+p2/0.59d0)**2
39265 c
39266       alp=ud2(1)
39267       bet=ud2(2)
39268       a=ud2(3)+ud2(4)*s
39269       ga=ud2(5)+ud2(6)*s**0.5
39270       gc=ud2(7)+ud2(8)*s
39271       b=ud2(9)+ud2(10)*s+ud2(11)*s**2
39272       gb=ud2(12)+ud2(13)*s+ud2(14)*s**2
39273       gd=ud2(15)+ud2(16)*s
39274       ge=ud2(17)+ud2(18)*s
39275       gep=ud2(19)+ud2(20)*s
39276       udpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39277 c
39278       alp=s2(1)
39279       bet=s2(2)
39280       a=s2(3)+s2(4)*s
39281       ga=s2(5)+s2(6)*s**0.5
39282       gc=s2(7)+s2(8)*s
39283       b=s2(9)+s2(10)*s+s2(11)*s**2
39284       gb=s2(12)+s2(13)*s+s2(14)*s**2
39285       gd=s2(15)+s2(16)*s
39286       ge=s2(17)+s2(18)*s
39287       gep=s2(19)+s2(20)*s
39288       spart2=suppr*PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39289 c
39290       alp=g2(1)
39291       bet=g2(2)
39292       a=g2(3)+g2(4)*s**0.5
39293       b=g2(5)+g2(6)*s**2
39294       gb=g2(7)+g2(8)*s
39295       ga=g2(9)+g2(10)*s**0.5+g2(11)*s**2
39296       gc=g2(12)+g2(13)*s**2
39297       gd=g2(14)+g2(15)*s+g2(16)*s**2
39298       ge=g2(17)+g2(18)*s
39299       gep=g2(19)+g2(20)*s
39300       gpart2=suppr*PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,ge,gep)
39301 c
39302       ugam=upart1+udpart2
39303       dgam=dspart1+udpart2
39304       sgam=dspart1+spart2
39305       ggam=gpart1+gpart2
39306 c
39307       end
39308
39309 *$ CREATE PHO_grsf1.FOR
39310 *COPY PHO_grsf1
39311 CDECK  ID>, PHO_grsf1
39312       DOUBLE PRECISION FUNCTION PHO_grsf1(x,s,alp,bet,a,b,ga,gb,gc,gd,
39313      &                                ge,gep)
39314       implicit double precision (a-z)
39315       save
39316
39317       PHO_grsf1=(x**a*(ga+gb*sqrt(x)+gc*x**b)+
39318      &      s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
39319      &      (1.d0-x)**gd
39320
39321       end
39322
39323 *$ CREATE PHO_grsf2.FOR
39324 *COPY PHO_grsf2
39325 CDECK  ID>, PHO_grsf2
39326       DOUBLE PRECISION FUNCTION PHO_grsf2(x,s,alp,bet,a,b,ga,gb,gc,gd,
39327      &                                ge,gep)
39328       implicit double precision (a-z)
39329       save
39330
39331       PHO_grsf2=(s*x**a*(ga+gb*sqrt(x)+gc*x**b)+
39332      &      s**alp*exp(-ge+sqrt(gep*s**bet*log(1.d0/x))))*
39333      &      (1.d0-x)**gd
39334
39335       end
39336
39337 *$ CREATE PHO_CKMTPA.FOR
39338 *COPY PHO_CKMTPA
39339 CDECK  ID>, PHO_CKMTPA
39340       SUBROUTINE PHO_CKMTPA(IPA,XMI,XMA,ALA,Q2MI,Q2MA,PDFNA)
39341 C**********************************************************************
39342 C
39343 C     PDF based on Regge theory, evolved with .... by ....
39344 C
39345 C     input: IPAR     2212   proton (not installed)
39346 C                      990   Pomeron
39347 C
39348 C     output: parameters of parametrization
39349 C
39350 C**********************************************************************
39351       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39352       SAVE
39353
39354       CHARACTER*8 PDFNA
39355
39356 C  input/output channels
39357       INTEGER LI,LO
39358       COMMON /POINOU/ LI,LO
39359
39360       REAL PROP(40),POMP(40)
39361       DATA PROP /
39362      & .230000E+00, .200000E+01, .150200E+00, .120000E+01, .263100E+00,
39363      & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
39364      & .100000E+00, .330000E-01, .352102E-01, .200000E+01, .200000E+01,
39365      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39366      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39367      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39368      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39369      & .000000E+00, .000000E+00, .100000E+00, .200000E+01, .100000E+09/
39370       DATA POMP /
39371      & .230000E+00, .500000E+01, .150200E+00, .120000E+01, .263100E+00,
39372      & .645200E+00, .354890E+01, .111700E+01, .415000E+00, .768400E-01,
39373      & .700000E-01, .700000E-01, .137161E+00, .300000E+01, .200000E+01,
39374      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39375      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39376      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39377      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39378      & .000000E+00, .000000E+00, .100000E+00, .500000E+01, .100000E+09/
39379
39380       IF(IPA.EQ.2212) THEN
39381         ALA  =PROP(1)
39382         Q2MI = PROP(39)
39383         Q2MA = PROP(40)
39384         PDFNA = 'CKMT-PRO'
39385       ELSE IF(IPA.EQ.990) THEN
39386         ALA  = POMP(1)
39387         Q2MI = POMP(39)
39388         Q2MA = POMP(40)
39389         PDFNA = 'CKMT-POM'
39390       ELSE
39391         WRITE(LO,'(1X,A,I7)')
39392      &    'PHO_CKMTPA:ERROR: invalid particle code',IPA
39393         STOP
39394       ENDIF
39395       XMI = 1.D-4
39396       XMA = 1.D0
39397       END
39398
39399 *$ CREATE PHO_CKMTPD.FOR
39400 *COPY PHO_CKMTPD
39401 CDECK  ID>, PHO_CKMTPD
39402       SUBROUTINE PHO_CKMTPD(IPAR,X,SCALE2,PD)
39403 C**********************************************************************
39404 C
39405 C     PDF based on Regge theory, evolved with .... by ....
39406 C
39407 C     input: IPAR     2212   proton (not installed)
39408 C                      990   Pomeron
39409 C
39410 C     output: PD(-6:6) x*f(x)  parton distribution functions
39411 C            (PDFLIB convention: d = PD(1), u = PD(2) )
39412 C
39413 C**********************************************************************
39414       SAVE
39415
39416 C  input/output channels
39417       INTEGER LI,LO
39418       COMMON /POINOU/ LI,LO
39419
39420       DOUBLE PRECISION  X,SCALE2,PD(-6:6),CDN,CUP
39421       DIMENSION QQ(7)
39422
39423       Q2=SNGL(SCALE2)
39424       Q1S=Q2
39425       XX=SNGL(X)
39426 C  QCD lambda for evolution
39427       OWLAM = 0.23D0
39428       OWLAM2=OWLAM**2
39429 C  Q0**2 for evolution
39430       Q02 = 2.D0
39431 C
39432 C
39433 C  the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
39434 C                        q(6)=x*charm, q(7)=x*gluon
39435 C
39436       SB=0.
39437       IF(Q2-Q02) 1,1,2
39438     2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
39439     1 CONTINUE
39440       IF(IPAR.EQ.2212) THEN
39441 *       CALL PHO_CKMTPR(XX,SB,QQ
39442         WRITE(LO,'(/1X,A,I6)') 'PHO_CKMTPD:ERROR: invalid particle',IPAR
39443         CALL PHO_ABORT
39444       ELSE
39445         CALL PHO_CKMTPO(XX,SB,QQ)
39446       ENDIF
39447 C
39448       PD(-6) = 0.D0
39449       PD(-5) = 0.D0
39450       PD(-4) = DBLE(QQ(6))
39451       PD(-3) = DBLE(QQ(3))
39452       PD(-2) = DBLE(QQ(4))
39453       PD(-1) = DBLE(QQ(5))
39454       PD(0)  = DBLE(QQ(7))
39455       PD(1)  = DBLE(QQ(2))
39456       PD(2)  = DBLE(QQ(1))
39457       PD(3)  = DBLE(QQ(3))
39458       PD(4)  = DBLE(QQ(6))
39459       PD(5)  = 0.D0
39460       PD(6)  = 0.D0
39461       IF(IPAR.EQ.990) THEN
39462         CDN = (PD(1)-PD(-1))/2.D0
39463         CUP = (PD(2)-PD(-2))/2.D0
39464         PD(-1) = PD(-1) + CDN
39465         PD(-2) = PD(-2) + CUP
39466         PD(1) = PD(-1)
39467         PD(2) = PD(-2)
39468       ENDIF
39469       END
39470
39471 *$ CREATE PHO_CKMTPO.FOR
39472 *COPY PHO_CKMTPO
39473 CDECK  ID>, PHO_CKMTPO
39474       SUBROUTINE PHO_CKMTPO(X,S,QQ)
39475 C**********************************************************************
39476 C
39477 C    calculation partons in Pomeron
39478 C
39479 C**********************************************************************
39480       SAVE
39481
39482       DIMENSION QQ(7)
39483
39484 C  input/output channels
39485       INTEGER LI,LO
39486       COMMON /POINOU/ LI,LO
39487
39488       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
39489       EQUIVALENCE (GF(1,1,1),DL(1))
39490       DATA DELTA/.10/
39491
39492 C  RNG=  -.5
39493 C  DEU.NORM. QUARKS,GLUONS,NEW NORM   .6223E+00   .2754E+00   .1372E+01
39494 C  POM.NORM. QUARKS,GLUONS,ALL    .132E+00    .275E+00    .407E+00
39495       DATA (DL(K),K=    1,   85) /
39496      & .324159E-01, .324159E-01, .298895E-01, .298895E-01, .298895E-01,
39497      & .298895E-01, .486150E+00,-.867362E-18, .362035E-01, .362035E-01,
39498      & .335142E-01, .335151E-01, .335151E-01, .335142E-01, .745381E+00,
39499      & .399157E-02, .417146E-01, .417146E-01, .388545E-01, .388564E-01,
39500      & .388564E-01, .388545E-01, .107588E+01, .969559E-02, .493208E-01,
39501      & .493208E-01, .462819E-01, .462849E-01, .462849E-01, .462819E-01,
39502      & .148168E+01, .174837E-01, .593251E-01, .593251E-01, .560991E-01,
39503      & .561035E-01, .561035E-01, .560991E-01, .196422E+01, .276588E-01,
39504      & .720220E-01, .720220E-01, .686007E-01, .686065E-01, .686065E-01,
39505      & .686007E-01, .252331E+01, .405154E-01, .876695E-01, .876695E-01,
39506      & .840445E-01, .840520E-01, .840520E-01, .840445E-01, .315730E+01,
39507      & .563115E-01, .106489E+00, .106489E+00, .102652E+00, .102662E+00,
39508      & .102662E+00, .102652E+00, .386313E+01, .752690E-01, .128662E+00,
39509      & .128662E+00, .124605E+00, .124616E+00, .124616E+00, .124605E+00,
39510      & .463661E+01, .975686E-01, .154326E+00, .154326E+00, .150039E+00,
39511      & .150053E+00, .150053E+00, .150039E+00, .547247E+01, .123348E+00,
39512      & .183571E+00, .183571E+00, .179048E+00, .179063E+00, .179063E+00/
39513       DATA (DL(K),K=   86,  170) /
39514      & .179048E+00, .636464E+01, .152698E+00, .216445E+00, .216445E+00,
39515      & .211676E+00, .211694E+00, .211694E+00, .211676E+00, .730631E+01,
39516      & .185666E+00, .252948E+00, .252948E+00, .247925E+00, .247946E+00,
39517      & .247946E+00, .247925E+00, .829017E+01, .222252E+00, .293037E+00,
39518      & .293037E+00, .287752E+00, .287776E+00, .287776E+00, .287752E+00,
39519      & .930850E+01, .262414E+00, .336625E+00, .336625E+00, .331070E+00,
39520      & .331097E+00, .331097E+00, .331070E+00, .103534E+02, .306065E+00,
39521      & .383587E+00, .383587E+00, .377754E+00, .377785E+00, .377785E+00,
39522      & .377754E+00, .114166E+02, .353079E+00, .433760E+00, .433760E+00,
39523      & .427641E+00, .427675E+00, .427675E+00, .427641E+00, .124903E+02,
39524      & .403294E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39525      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39526      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39527      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39528      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39529      & .296507E-01, .296507E-01, .258624E-01, .258624E-01, .258624E-01,
39530      & .258624E-01, .422709E+00,-.173472E-17, .330029E-01, .330029E-01/
39531       DATA (DL(K),K=  171,  255) /
39532      & .289773E-01, .289787E-01, .289787E-01, .289773E-01, .642996E+00,
39533      & .344499E-02, .377610E-01, .377610E-01, .334880E-01, .334910E-01,
39534      & .334910E-01, .334880E-01, .914159E+00, .828363E-02, .441590E-01,
39535      & .441590E-01, .396285E-01, .396333E-01, .396333E-01, .396285E-01,
39536      & .123635E+01, .147501E-01, .523710E-01, .523710E-01, .475730E-01,
39537      & .475798E-01, .475798E-01, .475730E-01, .160820E+01, .230185E-01,
39538      & .625514E-01, .625514E-01, .574758E-01, .574848E-01, .574848E-01,
39539      & .574758E-01, .202705E+01, .332433E-01, .748195E-01, .748195E-01,
39540      & .694563E-01, .694678E-01, .694678E-01, .694563E-01, .248945E+01,
39541      & .455440E-01, .892611E-01, .892611E-01, .836006E-01, .836147E-01,
39542      & .836147E-01, .836006E-01, .299114E+01, .600067E-01, .105928E+00,
39543      & .105928E+00, .999607E-01, .999776E-01, .999776E-01, .999607E-01,
39544      & .352735E+01, .766833E-01, .124839E+00, .124839E+00, .118555E+00,
39545      & .118575E+00, .118575E+00, .118555E+00, .409288E+01, .955921E-01,
39546      & .145978E+00, .145978E+00, .139368E+00, .139391E+00, .139391E+00,
39547      & .139368E+00, .468226E+01, .116719E+00, .169300E+00, .169300E+00,
39548      & .162355E+00, .162382E+00, .162382E+00, .162355E+00, .528987E+01/
39549       DATA (DL(K),K=  256,  340) /
39550      & .140017E+00, .194730E+00, .194730E+00, .187441E+00, .187471E+00,
39551      & .187471E+00, .187441E+00, .591007E+01, .165413E+00, .222167E+00,
39552      & .222167E+00, .214525E+00, .214559E+00, .214559E+00, .214525E+00,
39553      & .653724E+01, .192806E+00, .251486E+00, .251486E+00, .243482E+00,
39554      & .243521E+00, .243521E+00, .243482E+00, .716591E+01, .222070E+00,
39555      & .282539E+00, .282539E+00, .274165E+00, .274208E+00, .274208E+00,
39556      & .274165E+00, .779082E+01, .253058E+00, .315161E+00, .315161E+00,
39557      & .306410E+00, .306458E+00, .306458E+00, .306410E+00, .840695E+01,
39558      & .285608E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39559      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39560      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39561      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39562      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39563      & .279581E-01, .279581E-01, .222797E-01, .222797E-01, .222797E-01,
39564      & .222797E-01, .367732E+00, .867362E-18, .309604E-01, .309604E-01,
39565      & .249419E-01, .249441E-01, .249441E-01, .249419E-01, .552053E+00,
39566      & .296633E-02, .350831E-01, .350831E-01, .287126E-01, .287173E-01/
39567       DATA (DL(K),K=  341,  425) /
39568      & .287173E-01, .287126E-01, .770476E+00, .704001E-02, .404554E-01,
39569      & .404554E-01, .337212E-01, .337286E-01, .337286E-01, .337212E-01,
39570      & .102096E+01, .123504E-01, .471588E-01, .471588E-01, .400495E-01,
39571      & .400599E-01, .400599E-01, .400495E-01, .130079E+01, .189795E-01,
39572      & .552518E-01, .552518E-01, .477564E-01, .477700E-01, .477700E-01,
39573      & .477564E-01, .160637E+01, .269860E-01, .647649E-01, .647649E-01,
39574      & .568725E-01, .568897E-01, .568897E-01, .568725E-01, .193388E+01,
39575      & .364007E-01, .757021E-01, .757021E-01, .674022E-01, .674232E-01,
39576      & .674232E-01, .674022E-01, .227916E+01, .472280E-01, .880430E-01,
39577      & .880430E-01, .793257E-01, .793507E-01, .793507E-01, .793257E-01,
39578      & .263802E+01, .594481E-01, .101745E+00, .101745E+00, .926005E-01,
39579      & .926297E-01, .926297E-01, .926005E-01, .300628E+01, .730184E-01,
39580      & .116745E+00, .116745E+00, .107164E+00, .107198E+00, .107198E+00,
39581      & .107164E+00, .337982E+01, .878765E-01, .132961E+00, .132961E+00,
39582      & .122936E+00, .122974E+00, .122974E+00, .122936E+00, .375469E+01,
39583      & .103942E+00, .150298E+00, .150298E+00, .139820E+00, .139863E+00,
39584      & .139863E+00, .139820E+00, .412714E+01, .121118E+00, .168645E+00/
39585       DATA (DL(K),K=  426,  510) /
39586      & .168645E+00, .157706E+00, .157754E+00, .157754E+00, .157706E+00,
39587      & .449366E+01, .139296E+00, .187883E+00, .187883E+00, .176476E+00,
39588      & .176529E+00, .176529E+00, .176476E+00, .485100E+01, .158356E+00,
39589      & .207882E+00, .207882E+00, .196000E+00, .196059E+00, .196059E+00,
39590      & .196000E+00, .519622E+01, .178170E+00, .228506E+00, .228506E+00,
39591      & .216145E+00, .216209E+00, .216209E+00, .216145E+00, .552665E+01,
39592      & .198603E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39593      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39594      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39595      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39596      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39597      & .275294E-01, .275294E-01, .190245E-01, .190245E-01, .190245E-01,
39598      & .190245E-01, .320228E+00, .000000E+00, .302671E-01, .302671E-01,
39599      & .212851E-01, .212884E-01, .212884E-01, .212851E-01, .470861E+00,
39600      & .255059E-02, .338703E-01, .338703E-01, .243988E-01, .244059E-01,
39601      & .244059E-01, .243988E-01, .642452E+00, .595399E-02, .383922E-01,
39602      & .383922E-01, .284195E-01, .284305E-01, .284305E-01, .284195E-01/
39603       DATA (DL(K),K=  511,  595) /
39604      & .831913E+00, .102638E-01, .438519E-01, .438519E-01, .333669E-01,
39605      & .333821E-01, .333821E-01, .333669E-01, .103618E+01, .155000E-01,
39606      & .502475E-01, .502475E-01, .392399E-01, .392595E-01, .392595E-01,
39607      & .392399E-01, .125172E+01, .216612E-01, .575580E-01, .575580E-01,
39608      & .460181E-01, .460425E-01, .460425E-01, .460181E-01, .147519E+01,
39609      & .287272E-01, .657445E-01, .657445E-01, .536635E-01, .536929E-01,
39610      & .536929E-01, .536635E-01, .170330E+01, .366597E-01, .747539E-01,
39611      & .747539E-01, .621238E-01, .621582E-01, .621582E-01, .621238E-01,
39612      & .193297E+01, .454066E-01, .845205E-01, .845205E-01, .713340E-01,
39613      & .713738E-01, .713738E-01, .713340E-01, .216133E+01, .549027E-01,
39614      & .949687E-01, .949687E-01, .812194E-01, .812646E-01, .812646E-01,
39615      & .812194E-01, .238578E+01, .650733E-01, .106015E+00, .106015E+00,
39616      & .916972E-01, .917480E-01, .917480E-01, .916972E-01, .260395E+01,
39617      & .758355E-01, .117569E+00, .117569E+00, .102678E+00, .102735E+00,
39618      & .102735E+00, .102678E+00, .281373E+01, .871004E-01, .129537E+00,
39619      & .129537E+00, .114070E+00, .114133E+00, .114133E+00, .114070E+00,
39620      & .301327E+01, .987750E-01, .141824E+00, .141824E+00, .125777E+00/
39621       DATA (DL(K),K=  596,  680) /
39622      & .125846E+00, .125846E+00, .125777E+00, .320098E+01, .110764E+00,
39623      & .154331E+00, .154331E+00, .137703E+00, .137778E+00, .137778E+00,
39624      & .137703E+00, .337553E+01, .122970E+00, .166962E+00, .166962E+00,
39625      & .149753E+00, .149833E+00, .149833E+00, .149753E+00, .353582E+01,
39626      & .135299E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39627      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39628      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39629      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39630      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39631      & .286766E-01, .286766E-01, .159579E-01, .159579E-01, .159579E-01,
39632      & .159579E-01, .279430E+00,-.867362E-18, .312327E-01, .312327E-01,
39633      & .178644E-01, .178691E-01, .178691E-01, .178644E-01, .399186E+00,
39634      & .219459E-02, .344289E-01, .344289E-01, .204015E-01, .204111E-01,
39635      & .204111E-01, .204015E-01, .529978E+00, .501953E-02, .382657E-01,
39636      & .382657E-01, .235713E-01, .235860E-01, .235860E-01, .235713E-01,
39637      & .668515E+00, .847682E-02, .427243E-01, .427243E-01, .273559E-01,
39638      & .273758E-01, .273758E-01, .273559E-01, .812075E+00, .125486E-01/
39639       DATA (DL(K),K=  681,  765) /
39640      & .477691E-01, .477691E-01, .317212E-01, .317465E-01, .317465E-01,
39641      & .317212E-01, .957801E+00, .172006E-01, .533547E-01, .533547E-01,
39642      & .366231E-01, .366539E-01, .366539E-01, .366231E-01, .110327E+01,
39643      & .223886E-01, .594259E-01, .594259E-01, .420076E-01, .420441E-01,
39644      & .420441E-01, .420076E-01, .124628E+01, .280584E-01, .659213E-01,
39645      & .659213E-01, .478149E-01, .478570E-01, .478570E-01, .478149E-01,
39646      & .138496E+01, .341502E-01, .727749E-01, .727749E-01, .539803E-01,
39647      & .540280E-01, .540280E-01, .539803E-01, .151767E+01, .405990E-01,
39648      & .799178E-01, .799178E-01, .604361E-01, .604895E-01, .604895E-01,
39649      & .604361E-01, .164304E+01, .473372E-01, .872796E-01, .872796E-01,
39650      & .671134E-01, .671724E-01, .671724E-01, .671134E-01, .175992E+01,
39651      & .542955E-01, .947896E-01, .947896E-01, .739429E-01, .740075E-01,
39652      & .740075E-01, .739429E-01, .186739E+01, .614047E-01, .102378E+00,
39653      & .102378E+00, .808565E-01, .809266E-01, .809266E-01, .808565E-01,
39654      & .196473E+01, .685965E-01, .109978E+00, .109978E+00, .877881E-01,
39655      & .878637E-01, .878637E-01, .877881E-01, .205141E+01, .758045E-01,
39656      & .117525E+00, .117525E+00, .946745E-01, .947553E-01, .947553E-01/
39657       DATA (DL(K),K=  766,  850) /
39658      & .946745E-01, .212709E+01, .829655E-01, .124958E+00, .124958E+00,
39659      & .101456E+00, .101542E+00, .101542E+00, .101456E+00, .219159E+01,
39660      & .900196E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39661      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39662      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39663      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39664      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39665      & .318691E-01, .318691E-01, .129081E-01, .129081E-01, .129081E-01,
39666      & .129081E-01, .244842E+00,-.867362E-18, .343104E-01, .343104E-01,
39667      & .145076E-01, .145124E-01, .145124E-01, .145076E-01, .337040E+00,
39668      & .189443E-02, .371900E-01, .371900E-01, .165461E-01, .165557E-01,
39669      & .165557E-01, .165461E-01, .433081E+00, .422691E-02, .404763E-01,
39670      & .404763E-01, .189941E-01, .190085E-01, .190085E-01, .189941E-01,
39671      & .530109E+00, .696769E-02, .441304E-01, .441304E-01, .218150E-01,
39672      & .218342E-01, .218342E-01, .218150E-01, .626129E+00, .100799E-01,
39673      & .481031E-01, .481031E-01, .249615E-01, .249853E-01, .249853E-01,
39674      & .249615E-01, .719221E+00, .135159E-01, .523426E-01, .523426E-01/
39675       DATA (DL(K),K=  851,  935) /
39676      & .283837E-01, .284122E-01, .284122E-01, .283837E-01, .807951E+00,
39677      & .172259E-01, .567940E-01, .567940E-01, .320288E-01, .320619E-01,
39678      & .320619E-01, .320288E-01, .891154E+00, .211568E-01, .614022E-01,
39679      & .614022E-01, .358436E-01, .358811E-01, .358811E-01, .358436E-01,
39680      & .967928E+00, .252549E-01, .661122E-01, .661122E-01, .397750E-01,
39681      & .398169E-01, .398169E-01, .397750E-01, .103759E+01, .294673E-01,
39682      & .708708E-01, .708708E-01, .437716E-01, .438176E-01, .438176E-01,
39683      & .437716E-01, .109966E+01, .337422E-01, .756269E-01, .756269E-01,
39684      & .477840E-01, .478342E-01, .478342E-01, .477840E-01, .115380E+01,
39685      & .380302E-01, .803322E-01, .803322E-01, .517659E-01, .518200E-01,
39686      & .518200E-01, .517659E-01, .119986E+01, .422846E-01, .849423E-01,
39687      & .849423E-01, .556743E-01, .557322E-01, .557322E-01, .556743E-01,
39688      & .123782E+01, .464624E-01, .894164E-01, .894164E-01, .594701E-01,
39689      & .595315E-01, .595315E-01, .594701E-01, .126777E+01, .505242E-01,
39690      & .937178E-01, .937178E-01, .631181E-01, .631829E-01, .631829E-01,
39691      & .631181E-01, .128993E+01, .544348E-01, .978144E-01, .978144E-01,
39692      & .665876E-01, .666556E-01, .666556E-01, .665876E-01, .130457E+01/
39693       DATA (DL(K),K=  936, 1020) /
39694      & .581632E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39695      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39696      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39697      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39698      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39699      & .377668E-01, .377668E-01, .968304E-02, .968304E-02, .968304E-02,
39700      & .968304E-02, .216392E+00,-.130104E-17, .401066E-01, .401066E-01,
39701      & .110266E-01, .110291E-01, .110291E-01, .110266E-01, .284113E+00,
39702      & .164283E-02, .426983E-01, .426983E-01, .126461E-01, .126510E-01,
39703      & .126510E-01, .126461E-01, .350879E+00, .355790E-02, .454940E-01,
39704      & .454940E-01, .144965E-01, .145039E-01, .145039E-01, .144965E-01,
39705      & .414611E+00, .570002E-02, .484493E-01, .484493E-01, .165364E-01,
39706      & .165462E-01, .165462E-01, .165364E-01, .474149E+00, .802739E-02,
39707      & .515153E-01, .515153E-01, .187191E-01, .187313E-01, .187313E-01,
39708      & .187191E-01, .528511E+00, .104932E-01, .546458E-01, .546458E-01,
39709      & .210009E-01, .210154E-01, .210154E-01, .210009E-01, .577107E+00,
39710      & .130535E-01, .577962E-01, .577962E-01, .233395E-01, .233563E-01/
39711       DATA (DL(K),K= 1021, 1105) /
39712      & .233563E-01, .233395E-01, .619574E+00, .156658E-01, .609249E-01,
39713      & .609249E-01, .256954E-01, .257143E-01, .257143E-01, .256954E-01,
39714      & .655725E+00, .182905E-01, .639938E-01, .639938E-01, .280322E-01,
39715      & .280532E-01, .280532E-01, .280322E-01, .685523E+00, .208909E-01,
39716      & .669681E-01, .669681E-01, .303170E-01, .303399E-01, .303399E-01,
39717      & .303170E-01, .709053E+00, .234341E-01, .698172E-01, .698172E-01,
39718      & .325206E-01, .325454E-01, .325454E-01, .325206E-01, .726501E+00,
39719      & .258907E-01, .725141E-01, .725141E-01, .346176E-01, .346442E-01,
39720      & .346442E-01, .346176E-01, .738139E+00, .282352E-01, .750364E-01,
39721      & .750364E-01, .365866E-01, .366148E-01, .366148E-01, .365866E-01,
39722      & .744304E+00, .304461E-01, .773653E-01, .773653E-01, .384099E-01,
39723      & .384396E-01, .384396E-01, .384099E-01, .745388E+00, .325056E-01,
39724      & .794860E-01, .794860E-01, .400736E-01, .401046E-01, .401046E-01,
39725      & .400736E-01, .741819E+00, .343996E-01, .813873E-01, .813873E-01,
39726      & .415670E-01, .415993E-01, .415993E-01, .415670E-01, .734051E+00,
39727      & .361177E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39728      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
39729       DATA (DL(K),K= 1106, 1190) /
39730      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39731      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39732      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39733      & .433773E-01, .433773E-01, .745094E-02, .745094E-02, .745094E-02,
39734      & .745094E-02, .201612E+00,-.130104E-17, .455998E-01, .455998E-01,
39735      & .866239E-02, .866443E-02, .866443E-02, .866239E-02, .255046E+00,
39736      & .149977E-02, .479569E-01, .479569E-01, .100584E-01, .100624E-01,
39737      & .100624E-01, .100584E-01, .305549E+00, .317779E-02, .503976E-01,
39738      & .503976E-01, .115911E-01, .115970E-01, .115970E-01, .115911E-01,
39739      & .351606E+00, .498612E-02, .528804E-01, .528804E-01, .132216E-01,
39740      & .132293E-01, .132293E-01, .132216E-01, .392560E+00, .688553E-02,
39741      & .553621E-01, .553621E-01, .149087E-01, .149181E-01, .149181E-01,
39742      & .149087E-01, .427948E+00, .883486E-02, .578049E-01, .578049E-01,
39743      & .166165E-01, .166276E-01, .166276E-01, .166165E-01, .457612E+00,
39744      & .107980E-01, .601739E-01, .601739E-01, .183120E-01, .183246E-01,
39745      & .183246E-01, .183120E-01, .481565E+00, .127419E-01, .624390E-01,
39746      & .624390E-01, .199661E-01, .199801E-01, .199801E-01, .199661E-01/
39747       DATA (DL(K),K= 1191, 1275) /
39748      & .499943E+00, .146375E-01, .645736E-01, .645736E-01, .215535E-01,
39749      & .215688E-01, .215688E-01, .215535E-01, .512983E+00, .164593E-01,
39750      & .665556E-01, .665556E-01, .230528E-01, .230693E-01, .230693E-01,
39751      & .230528E-01, .520995E+00, .181859E-01, .683669E-01, .683669E-01,
39752      & .244463E-01, .244639E-01, .244639E-01, .244463E-01, .524347E+00,
39753      & .197998E-01, .699932E-01, .699932E-01, .257201E-01, .257387E-01,
39754      & .257387E-01, .257201E-01, .523447E+00, .212869E-01, .714240E-01,
39755      & .714240E-01, .268637E-01, .268832E-01, .268832E-01, .268637E-01,
39756      & .518729E+00, .226367E-01, .726523E-01, .726523E-01, .278697E-01,
39757      & .278900E-01, .278900E-01, .278697E-01, .510641E+00, .238420E-01,
39758      & .736741E-01, .736741E-01, .287338E-01, .287547E-01, .287547E-01,
39759      & .287338E-01, .499630E+00, .248984E-01, .744886E-01, .744886E-01,
39760      & .294542E-01, .294757E-01, .294757E-01, .294542E-01, .486140E+00,
39761      & .258043E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39762      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39763      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39764      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
39765       DATA (DL(K),K= 1276, 1360) /
39766      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39767      & .499162E-01, .499162E-01, .534441E-02, .534441E-02, .534441E-02,
39768      & .534441E-02, .191108E+00,-.151788E-17, .519197E-01, .519197E-01,
39769      & .646285E-02, .646402E-02, .646402E-02, .646285E-02, .232539E+00,
39770      & .137669E-02, .539504E-01, .539504E-01, .769150E-02, .769377E-02,
39771      & .769377E-02, .769150E-02, .269907E+00, .285489E-02, .559598E-01,
39772      & .559598E-01, .898389E-02, .898721E-02, .898721E-02, .898389E-02,
39773      & .302186E+00, .438814E-02, .579130E-01, .579130E-01, .103061E-01,
39774      & .103104E-01, .103104E-01, .103061E-01, .329124E+00, .594258E-02,
39775      & .597754E-01, .597754E-01, .116245E-01, .116297E-01, .116297E-01,
39776      & .116245E-01, .350643E+00, .748452E-02, .615191E-01, .615191E-01,
39777      & .129113E-01, .129174E-01, .129174E-01, .129113E-01, .366890E+00,
39778      & .898645E-02, .631204E-01, .631204E-01, .141428E-01, .141497E-01,
39779      & .141497E-01, .141428E-01, .378134E+00, .104247E-01, .645601E-01,
39780      & .645601E-01, .152995E-01, .153071E-01, .153071E-01, .152995E-01,
39781      & .384719E+00, .117798E-01, .658236E-01, .658236E-01, .163657E-01,
39782      & .163739E-01, .163739E-01, .163657E-01, .387045E+00, .130362E-01/
39783       DATA (DL(K),K= 1361, 1445) /
39784      & .669000E-01, .669000E-01, .173294E-01, .173381E-01, .173381E-01,
39785      & .173294E-01, .385547E+00, .141821E-01, .677824E-01, .677824E-01,
39786      & .181820E-01, .181912E-01, .181912E-01, .181820E-01, .380677E+00,
39787      & .152091E-01, .684672E-01, .684672E-01, .189180E-01, .189277E-01,
39788      & .189277E-01, .189180E-01, .372894E+00, .161119E-01, .689539E-01,
39789      & .689539E-01, .195349E-01, .195449E-01, .195449E-01, .195349E-01,
39790      & .362650E+00, .168880E-01, .692447E-01, .692447E-01, .200324E-01,
39791      & .200427E-01, .200427E-01, .200324E-01, .350383E+00, .175374E-01,
39792      & .693442E-01, .693442E-01, .204123E-01, .204229E-01, .204229E-01,
39793      & .204123E-01, .336505E+00, .180622E-01, .692590E-01, .692590E-01,
39794      & .206783E-01, .206891E-01, .206891E-01, .206783E-01, .321403E+00,
39795      & .184661E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39796      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39797      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39798      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39799      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39800      & .554152E-01, .554152E-01, .386683E-02, .386683E-02, .386683E-02/
39801       DATA (DL(K),K= 1446, 1530) /
39802      & .386683E-02, .185844E+00,-.151788E-17, .571372E-01, .571372E-01,
39803      & .493623E-02, .493704E-02, .493704E-02, .493623E-02, .219342E+00,
39804      & .129037E-02, .588098E-01, .588098E-01, .606768E-02, .606924E-02,
39805      & .606924E-02, .606768E-02, .248288E+00, .263296E-02, .603896E-01,
39806      & .603896E-01, .721747E-02, .721973E-02, .721973E-02, .721747E-02,
39807      & .271974E+00, .398431E-02, .618484E-01, .618484E-01, .835658E-02,
39808      & .835949E-02, .835949E-02, .835658E-02, .290397E+00, .531560E-02,
39809      & .631600E-01, .631600E-01, .945726E-02, .946074E-02, .946074E-02,
39810      & .945726E-02, .303702E+00, .659930E-02, .643051E-01, .643051E-01,
39811      & .104983E-01, .105023E-01, .105023E-01, .104983E-01, .312209E+00,
39812      & .781443E-02, .652691E-01, .652691E-01, .114624E-01, .114669E-01,
39813      & .114669E-01, .114624E-01, .316328E+00, .894407E-02, .660416E-01,
39814      & .660416E-01, .123367E-01, .123416E-01, .123416E-01, .123367E-01,
39815      & .316509E+00, .997546E-02, .666169E-01, .666169E-01, .131119E-01,
39816      & .131171E-01, .131171E-01, .131119E-01, .313229E+00, .108996E-01,
39817      & .669925E-01, .669925E-01, .137818E-01, .137874E-01, .137874E-01,
39818      & .137818E-01, .306974E+00, .117107E-01, .671695E-01, .671695E-01/
39819       DATA (DL(K),K= 1531, 1615) /
39820      & .143437E-01, .143495E-01, .143495E-01, .143437E-01, .298224E+00,
39821      & .124061E-01, .671517E-01, .671517E-01, .147970E-01, .148031E-01,
39822      & .148031E-01, .147970E-01, .287441E+00, .129858E-01, .669454E-01,
39823      & .669454E-01, .151437E-01, .151499E-01, .151499E-01, .151437E-01,
39824      & .275064E+00, .134517E-01, .665590E-01, .665590E-01, .153872E-01,
39825      & .153935E-01, .153935E-01, .153872E-01, .261497E+00, .138078E-01,
39826      & .660023E-01, .660023E-01, .155327E-01, .155391E-01, .155391E-01,
39827      & .155327E-01, .247105E+00, .140595E-01, .652865E-01, .652865E-01,
39828      & .155864E-01, .155929E-01, .155929E-01, .155864E-01, .232218E+00,
39829      & .142131E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39830      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39831      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39832      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39833      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39834      & .601098E-01, .601098E-01, .278641E-02, .278641E-02, .278641E-02,
39835      & .278641E-02, .183460E+00, .130104E-17, .614949E-01, .614949E-01,
39836      & .382710E-02, .382771E-02, .382771E-02, .382710E-02, .211150E+00/
39837       DATA (DL(K),K= 1616, 1700) /
39838      & .122320E-02, .627722E-01, .627722E-01, .489465E-02, .489580E-02,
39839      & .489580E-02, .489465E-02, .234040E+00, .246333E-02, .639042E-01,
39840      & .639042E-01, .594825E-02, .594990E-02, .594990E-02, .594825E-02,
39841      & .251649E+00, .367998E-02, .648697E-01, .648697E-01, .696315E-02,
39842      & .696526E-02, .696526E-02, .696315E-02, .264143E+00, .484875E-02,
39843      & .656502E-01, .656502E-01, .791658E-02, .791907E-02, .791907E-02,
39844      & .791658E-02, .271822E+00, .594722E-02, .662343E-01, .662343E-01,
39845      & .879236E-02, .879520E-02, .879520E-02, .879236E-02, .275124E+00,
39846      & .695957E-02, .666152E-01, .666152E-01, .957846E-02, .958160E-02,
39847      & .958160E-02, .957846E-02, .274549E+00, .787413E-02, .667905E-01,
39848      & .667905E-01, .102668E-01, .102702E-01, .102702E-01, .102668E-01,
39849      & .270615E+00, .868318E-02, .667616E-01, .667616E-01, .108528E-01,
39850      & .108564E-01, .108564E-01, .108528E-01, .263847E+00, .938250E-02,
39851      & .665331E-01, .665331E-01, .113349E-01, .113387E-01, .113387E-01,
39852      & .113349E-01, .254756E+00, .997082E-02, .661123E-01, .661123E-01,
39853      & .117139E-01, .117179E-01, .117179E-01, .117139E-01, .243828E+00,
39854      & .104494E-01, .655090E-01, .655090E-01, .119931E-01, .119971E-01/
39855       DATA (DL(K),K= 1701, 1785) /
39856      & .119971E-01, .119931E-01, .231518E+00, .108217E-01, .647345E-01,
39857      & .647345E-01, .121770E-01, .121811E-01, .121811E-01, .121770E-01,
39858      & .218237E+00, .110927E-01, .638017E-01, .638017E-01, .122717E-01,
39859      & .122759E-01, .122759E-01, .122717E-01, .204353E+00, .112689E-01,
39860      & .627241E-01, .627241E-01, .122842E-01, .122884E-01, .122884E-01,
39861      & .122842E-01, .190187E+00, .113573E-01, .615161E-01, .615161E-01,
39862      & .122221E-01, .122262E-01, .122262E-01, .122221E-01, .176012E+00,
39863      & .113659E-01, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39864      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39865      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39866      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39867      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39868      & .641221E-01, .641221E-01, .198544E-02, .198544E-02, .198544E-02,
39869      & .198544E-02, .183018E+00, .184314E-17, .651208E-01, .651208E-01,
39870      & .300778E-02, .300823E-02, .300823E-02, .300778E-02, .206180E+00,
39871      & .116844E-02, .659664E-01, .659664E-01, .402903E-02, .402989E-02,
39872      & .402989E-02, .402903E-02, .224390E+00, .232648E-02, .666277E-01/
39873       DATA (DL(K),K= 1786, 1870) /
39874      & .666277E-01, .501117E-02, .501238E-02, .501238E-02, .501117E-02,
39875      & .237332E+00, .343657E-02, .670904E-01, .670904E-01, .593321E-02,
39876      & .593473E-02, .593473E-02, .593321E-02, .245310E+00, .447818E-02,
39877      & .673435E-01, .673435E-01, .677663E-02, .677843E-02, .677843E-02,
39878      & .677663E-02, .248743E+00, .543320E-02, .673832E-01, .673832E-01,
39879      & .752958E-02, .753161E-02, .753161E-02, .752958E-02, .248162E+00,
39880      & .629021E-02, .672099E-01, .672099E-01, .818432E-02, .818655E-02,
39881      & .818655E-02, .818432E-02, .244140E+00, .704188E-02, .668281E-01,
39882      & .668281E-01, .873688E-02, .873927E-02, .873927E-02, .873688E-02,
39883      & .237247E+00, .768463E-02, .662457E-01, .662457E-01, .918650E-02,
39884      & .918903E-02, .918903E-02, .918650E-02, .228043E+00, .821808E-02,
39885      & .654734E-01, .654734E-01, .953502E-02, .953766E-02, .953766E-02,
39886      & .953502E-02, .217054E+00, .864446E-02, .645238E-01, .645238E-01,
39887      & .978645E-02, .978915E-02, .978915E-02, .978645E-02, .204766E+00,
39888      & .896811E-02, .634114E-01, .634114E-01, .994639E-02, .994915E-02,
39889      & .994915E-02, .994639E-02, .191614E+00, .919500E-02, .621515E-01,
39890      & .621515E-01, .100217E-01, .100245E-01, .100245E-01, .100217E-01/
39891       DATA (DL(K),K= 1871, 1955) /
39892      & .177983E+00, .933229E-02, .607602E-01, .607602E-01, .100200E-01,
39893      & .100228E-01, .100228E-01, .100200E-01, .164201E+00, .938793E-02,
39894      & .592539E-01, .592539E-01, .994938E-02, .995217E-02, .995217E-02,
39895      & .994938E-02, .150544E+00, .937032E-02, .576488E-01, .576488E-01,
39896      & .981814E-02, .982091E-02, .982091E-02, .981814E-02, .137234E+00,
39897      & .928803E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39898      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39899      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39900      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39901      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39902      & .675167E-01, .675167E-01, .139130E-02, .139130E-02, .139130E-02,
39903      & .139130E-02, .184090E+00, .113841E-17, .680840E-01, .680840E-01,
39904      & .240061E-02, .240097E-02, .240097E-02, .240061E-02, .203559E+00,
39905      & .112278E-02, .684634E-01, .684634E-01, .338513E-02, .338580E-02,
39906      & .338580E-02, .338513E-02, .217944E+00, .221249E-02, .686304E-01,
39907      & .686304E-01, .430938E-02, .431032E-02, .431032E-02, .430938E-02,
39908      & .227068E+00, .323420E-02, .685779E-01, .685779E-01, .515589E-02/
39909       DATA (DL(K),K= 1956, 2040) /
39910      & .515707E-02, .515707E-02, .515589E-02, .231353E+00, .417091E-02,
39911      & .683023E-01, .683023E-01, .591002E-02, .591140E-02, .591140E-02,
39912      & .591002E-02, .231327E+00, .500843E-02, .678068E-01, .678068E-01,
39913      & .656383E-02, .656537E-02, .656537E-02, .656383E-02, .227606E+00,
39914      & .573925E-02, .670989E-01, .670989E-01, .711344E-02, .711513E-02,
39915      & .711513E-02, .711344E-02, .220833E+00, .635992E-02, .661895E-01,
39916      & .661895E-01, .755852E-02, .756031E-02, .756031E-02, .755852E-02,
39917      & .211624E+00, .687048E-02, .650923E-01, .650923E-01, .790162E-02,
39918      & .790350E-02, .790350E-02, .790162E-02, .200567E+00, .727387E-02,
39919      & .638232E-01, .638232E-01, .814753E-02, .814946E-02, .814946E-02,
39920      & .814753E-02, .188197E+00, .757524E-02, .623994E-01, .623994E-01,
39921      & .830271E-02, .830469E-02, .830469E-02, .830271E-02, .174994E+00,
39922      & .778139E-02, .608390E-01, .608390E-01, .837482E-02, .837682E-02,
39923      & .837682E-02, .837482E-02, .161373E+00, .790029E-02, .591605E-01,
39924      & .591605E-01, .837226E-02, .837426E-02, .837426E-02, .837226E-02,
39925      & .147685E+00, .794065E-02, .573824E-01, .573824E-01, .830376E-02,
39926      & .830575E-02, .830575E-02, .830376E-02, .134218E+00, .791148E-02/
39927       DATA (DL(K),K= 2041, 2125) /
39928      & .555224E-01, .555224E-01, .817811E-02, .818008E-02, .818008E-02,
39929      & .817811E-02, .121200E+00, .782185E-02, .535980E-01, .535980E-01,
39930      & .800390E-02, .800584E-02, .800584E-02, .800390E-02, .108803E+00,
39931      & .768059E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39932      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39933      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39934      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39935      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39936      & .703249E-01, .703249E-01, .953926E-03, .953926E-03, .953926E-03,
39937      & .953926E-03, .186497E+00, .108420E-18, .704188E-01, .704188E-01,
39938      & .195267E-02, .195297E-02, .195297E-02, .195267E-02, .202831E+00,
39939      & .108414E-02, .702995E-01, .702995E-01, .290528E-02, .290582E-02,
39940      & .290582E-02, .290528E-02, .213933E+00, .211514E-02, .699499E-01,
39941      & .699499E-01, .377873E-02, .377950E-02, .377950E-02, .377873E-02,
39942      & .219748E+00, .306054E-02, .693699E-01, .693699E-01, .455903E-02,
39943      & .455997E-02, .455997E-02, .455903E-02, .220821E+00, .390679E-02,
39944      & .685634E-01, .685634E-01, .523531E-02, .523640E-02, .523640E-02/
39945       DATA (DL(K),K= 2126, 2210) /
39946      & .523531E-02, .217787E+00, .464347E-02, .675406E-01, .675406E-01,
39947      & .580340E-02, .580462E-02, .580462E-02, .580340E-02, .211353E+00,
39948      & .526681E-02, .663155E-01, .663155E-01, .626315E-02, .626446E-02,
39949      & .626446E-02, .626315E-02, .202230E+00, .577705E-02, .649052E-01,
39950      & .649052E-01, .661759E-02, .661897E-02, .661897E-02, .661759E-02,
39951      & .191081E+00, .617758E-02, .633285E-01, .633285E-01, .687230E-02,
39952      & .687373E-02, .687373E-02, .687230E-02, .178518E+00, .647434E-02,
39953      & .616058E-01, .616058E-01, .703464E-02, .703611E-02, .703611E-02,
39954      & .703464E-02, .165082E+00, .667499E-02, .597580E-01, .597580E-01,
39955      & .711320E-02, .711468E-02, .711468E-02, .711320E-02, .151241E+00,
39956      & .678842E-02, .578059E-01, .578059E-01, .711723E-02, .711872E-02,
39957      & .711872E-02, .711723E-02, .137382E+00, .682417E-02, .557702E-01,
39958      & .557702E-01, .705628E-02, .705776E-02, .705776E-02, .705628E-02,
39959      & .123821E+00, .679205E-02, .536704E-01, .536704E-01, .693979E-02,
39960      & .694125E-02, .694125E-02, .693979E-02, .110798E+00, .670173E-02,
39961      & .515252E-01, .515252E-01, .677689E-02, .677832E-02, .677832E-02,
39962      & .677689E-02, .984933E-01, .656256E-02, .493519E-01, .493519E-01/
39963       DATA (DL(K),K= 2211, 2295) /
39964      & .657614E-02, .657753E-02, .657753E-02, .657614E-02, .870270E-01,
39965      & .638332E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39966      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39967      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39968      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39969      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
39970      & .725555E-01, .725555E-01, .636424E-03, .636424E-03, .636424E-03,
39971      & .636424E-03, .190200E+00,-.271051E-17, .721364E-01, .721364E-01,
39972      & .162522E-02, .162546E-02, .162546E-02, .162522E-02, .203770E+00,
39973      & .105090E-02, .714881E-01, .714881E-01, .254763E-02, .254807E-02,
39974      & .254807E-02, .254763E-02, .211914E+00, .202976E-02, .706012E-01,
39975      & .706012E-01, .337323E-02, .337384E-02, .337384E-02, .337323E-02,
39976      & .214704E+00, .290668E-02, .694832E-01, .694832E-01, .409164E-02,
39977      & .409240E-02, .409240E-02, .409164E-02, .212817E+00, .367169E-02,
39978      & .681454E-01, .681454E-01, .469593E-02, .469679E-02, .469679E-02,
39979      & .469593E-02, .207013E+00, .431823E-02, .666048E-01, .666048E-01,
39980      & .518578E-02, .518673E-02, .518673E-02, .518578E-02, .198095E+00/
39981       DATA (DL(K),K= 2296, 2380) /
39982      & .484637E-02, .648819E-01, .648819E-01, .556473E-02, .556575E-02,
39983      & .556575E-02, .556473E-02, .186850E+00, .525997E-02, .629989E-01,
39984      & .629989E-01, .583908E-02, .584014E-02, .584014E-02, .583908E-02,
39985      & .173986E+00, .556566E-02, .609795E-01, .609795E-01, .601725E-02,
39986      & .601834E-02, .601834E-02, .601725E-02, .160140E+00, .577215E-02,
39987      & .588474E-01, .588474E-01, .610889E-02, .611000E-02, .611000E-02,
39988      & .610889E-02, .145850E+00, .588934E-02, .566261E-01, .566261E-01,
39989      & .612435E-02, .612547E-02, .612547E-02, .612435E-02, .131564E+00,
39990      & .592785E-02, .543385E-01, .543385E-01, .607415E-02, .607526E-02,
39991      & .607526E-02, .607415E-02, .117636E+00, .589841E-02, .520060E-01,
39992      & .520060E-01, .596861E-02, .596970E-02, .596970E-02, .596861E-02,
39993      & .104336E+00, .581156E-02, .496485E-01, .496485E-01, .581753E-02,
39994      & .581860E-02, .581860E-02, .581753E-02, .918563E-01, .567728E-02,
39995      & .472842E-01, .472842E-01, .563002E-02, .563105E-02, .563105E-02,
39996      & .563002E-02, .803205E-01, .550487E-02, .449295E-01, .449295E-01,
39997      & .541435E-02, .541535E-02, .541535E-02, .541435E-02, .697975E-01,
39998      & .530276E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
39999       DATA (DL(K),K= 2381, 2465) /
40000      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40001      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40002      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40003      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40004      & .742000E-01, .742000E-01, .410482E-03, .410482E-03, .410482E-03,
40005      & .410482E-03, .195273E+00,-.143657E-17, .732296E-01, .732296E-01,
40006      & .138854E-02, .138874E-02, .138874E-02, .138854E-02, .206298E+00,
40007      & .102151E-02, .720241E-01, .720241E-01, .228017E-02, .228054E-02,
40008      & .228054E-02, .228017E-02, .211639E+00, .195225E-02, .705820E-01,
40009      & .705820E-01, .305794E-02, .305844E-02, .305844E-02, .305794E-02,
40010      & .211509E+00, .276522E-02, .689187E-01, .689187E-01, .371549E-02,
40011      & .371609E-02, .371609E-02, .371549E-02, .206745E+00, .345441E-02,
40012      & .670527E-01, .670527E-01, .425016E-02, .425084E-02, .425084E-02,
40013      & .425016E-02, .198254E+00, .401749E-02, .650080E-01, .650080E-01,
40014      & .466572E-02, .466647E-02, .466647E-02, .466572E-02, .186950E+00,
40015      & .445856E-02, .628107E-01, .628107E-01, .496948E-02, .497027E-02,
40016      & .497027E-02, .496948E-02, .173701E+00, .478517E-02, .604878E-01/
40017       DATA (DL(K),K= 2466, 2550) /
40018      & .604878E-01, .517094E-02, .517175E-02, .517175E-02, .517094E-02,
40019      & .159263E+00, .500709E-02, .580665E-01, .580665E-01, .528116E-02,
40020      & .528199E-02, .528199E-02, .528116E-02, .144287E+00, .513562E-02,
40021      & .555730E-01, .555730E-01, .531181E-02, .531265E-02, .531265E-02,
40022      & .531181E-02, .129304E+00, .518264E-02, .530325E-01, .530325E-01,
40023      & .527468E-02, .527550E-02, .527550E-02, .527468E-02, .114731E+00,
40024      & .516012E-02, .504682E-01, .504682E-01, .518116E-02, .518198E-02,
40025      & .518198E-02, .518116E-02, .100877E+00, .507964E-02, .479014E-01,
40026      & .479014E-01, .504198E-02, .504278E-02, .504278E-02, .504198E-02,
40027      & .879578E-01, .495209E-02, .453511E-01, .453511E-01, .486695E-02,
40028      & .486772E-02, .486772E-02, .486695E-02, .761077E-01, .478741E-02,
40029      & .428340E-01, .428340E-01, .466486E-02, .466560E-02, .466560E-02,
40030      & .466486E-02, .653932E-01, .459453E-02, .403645E-01, .403645E-01,
40031      & .444342E-02, .444413E-02, .444413E-02, .444342E-02, .558281E-01,
40032      & .438128E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40033      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40034      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40035       DATA (DL(K),K= 2551, 2635) /
40036      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40037      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40038      & .752337E-01, .752337E-01, .253875E-03, .253875E-03, .253875E-03,
40039      & .253875E-03, .201902E+00,-.159920E-17, .736752E-01, .736752E-01,
40040      & .121909E-02, .121925E-02, .121925E-02, .121909E-02, .210465E+00,
40041      & .994282E-03, .718865E-01, .718865E-01, .207747E-02, .207776E-02,
40042      & .207776E-02, .207747E-02, .212997E+00, .187854E-02, .698746E-01,
40043      & .698746E-01, .280521E-02, .280560E-02, .280560E-02, .280521E-02,
40044      & .209895E+00, .262933E-02, .676629E-01, .676629E-01, .340063E-02,
40045      & .340109E-02, .340109E-02, .340063E-02, .202191E+00, .324527E-02,
40046      & .652775E-01, .652775E-01, .386588E-02, .386641E-02, .386641E-02,
40047      & .386588E-02, .190971E+00, .372876E-02, .627483E-01, .627483E-01,
40048      & .420910E-02, .420967E-02, .420967E-02, .420910E-02, .177278E+00,
40049      & .408818E-02, .601066E-01, .601066E-01, .444148E-02, .444208E-02,
40050      & .444208E-02, .444148E-02, .162071E+00, .433493E-02, .573831E-01,
40051      & .573831E-01, .457564E-02, .457625E-02, .457625E-02, .457564E-02,
40052      & .146148E+00, .448183E-02, .546072E-01, .546072E-01, .462506E-02/
40053       DATA (DL(K),K= 2636, 2720) /
40054      & .462567E-02, .462567E-02, .462506E-02, .130166E+00, .454252E-02,
40055      & .518065E-01, .518065E-01, .460307E-02, .460368E-02, .460368E-02,
40056      & .460307E-02, .114632E+00, .453052E-02, .490062E-01, .490062E-01,
40057      & .452252E-02, .452312E-02, .452312E-02, .452252E-02, .999175E-01,
40058      & .445880E-02, .462287E-01, .462287E-01, .439529E-02, .439588E-02,
40059      & .439588E-02, .439529E-02, .862750E-01, .433936E-02, .434937E-01,
40060      & .434937E-01, .423211E-02, .423268E-02, .423268E-02, .423211E-02,
40061      & .738542E-01, .418306E-02, .408180E-01, .408180E-01, .404245E-02,
40062      & .404299E-02, .404299E-02, .404245E-02, .627228E-01, .399946E-02,
40063      & .382157E-01, .382157E-01, .383446E-02, .383498E-02, .383498E-02,
40064      & .383446E-02, .528847E-01, .379682E-02, .356980E-01, .356980E-01,
40065      & .361508E-02, .361557E-02, .361557E-02, .361508E-02, .442963E-01,
40066      & .358213E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40067      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40068      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40069      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40070      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40071       DATA (DL(K),K= 2721, 2805) /
40072      & .756149E-01, .756149E-01, .148956E-03, .148956E-03, .148956E-03,
40073      & .148956E-03, .210410E+00,-.149078E-18, .734321E-01, .734321E-01,
40074      & .109779E-02, .109791E-02, .109791E-02, .109779E-02, .216444E+00,
40075      & .967243E-03, .710369E-01, .710369E-01, .191860E-02, .191882E-02,
40076      & .191882E-02, .191860E-02, .215992E+00, .180426E-02, .684452E-01,
40077      & .684452E-01, .259230E-02, .259259E-02, .259259E-02, .259230E-02,
40078      & .209697E+00, .249224E-02, .656884E-01, .656884E-01, .312270E-02,
40079      & .312305E-02, .312305E-02, .312270E-02, .198844E+00, .303522E-02,
40080      & .627994E-01, .627994E-01, .351747E-02, .351786E-02, .351786E-02,
40081      & .351747E-02, .184740E+00, .344105E-02, .598138E-01, .598138E-01,
40082      & .378940E-02, .378981E-02, .378981E-02, .378940E-02, .168578E+00,
40083      & .372269E-02, .567666E-01, .567666E-01, .395362E-02, .395405E-02,
40084      & .395405E-02, .395362E-02, .151409E+00, .389544E-02, .536907E-01,
40085      & .536907E-01, .402569E-02, .402613E-02, .402613E-02, .402569E-02,
40086      & .134065E+00, .397499E-02, .506163E-01, .506163E-01, .402117E-02,
40087      & .402161E-02, .402161E-02, .402117E-02, .117191E+00, .397702E-02,
40088      & .475706E-01, .475706E-01, .395467E-02, .395511E-02, .395511E-02/
40089       DATA (DL(K),K= 2806, 2890) /
40090      & .395467E-02, .101250E+00, .391626E-02, .445771E-01, .445771E-01,
40091      & .383961E-02, .384003E-02, .384003E-02, .383961E-02, .865500E-01,
40092      & .380621E-02, .416559E-01, .416559E-01, .368789E-02, .368830E-02,
40093      & .368830E-02, .368789E-02, .732657E-01, .365888E-02, .388235E-01,
40094      & .388235E-01, .350985E-02, .351025E-02, .351025E-02, .350985E-02,
40095      & .614686E-01, .348466E-02, .360931E-01, .360931E-01, .331425E-02,
40096      & .331462E-02, .331462E-02, .331425E-02, .511511E-01, .329240E-02,
40097      & .334751E-01, .334751E-01, .310835E-02, .310870E-02, .310870E-02,
40098      & .310835E-02, .422485E-01, .308941E-02, .309768E-01, .309768E-01,
40099      & .289805E-02, .289838E-02, .289838E-02, .289805E-02, .346590E-01,
40100      & .288164E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40101      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40102      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40103      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40104      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40105      & .752796E-01, .752796E-01, .816906E-04, .816906E-04, .816906E-04,
40106      & .816906E-04, .221322E+00, .298156E-18, .724376E-01, .724376E-01/
40107       DATA (DL(K),K= 2891, 2975) /
40108      & .100884E-02, .100894E-02, .100894E-02, .100884E-02, .224569E+00,
40109      & .938046E-03, .694166E-01, .694166E-01, .178592E-02, .178609E-02,
40110      & .178609E-02, .178592E-02, .220745E+00, .172460E-02, .662414E-01,
40111      & .662414E-01, .240001E-02, .240024E-02, .240024E-02, .240001E-02,
40112      & .210839E+00, .234694E-02, .629511E-01, .629511E-01, .286144E-02,
40113      & .286171E-02, .286171E-02, .286144E-02, .196463E+00, .281556E-02,
40114      & .595849E-01, .595849E-01, .318412E-02, .318441E-02, .318441E-02,
40115      & .318412E-02, .179204E+00, .314448E-02, .561822E-01, .561822E-01,
40116      & .338573E-02, .338605E-02, .338605E-02, .338573E-02, .160420E+00,
40117      & .335151E-02, .527801E-01, .527801E-01, .348530E-02, .348562E-02,
40118      & .348562E-02, .348530E-02, .141254E+00, .345578E-02, .494117E-01,
40119      & .494117E-01, .350098E-02, .350131E-02, .350131E-02, .350098E-02,
40120      & .122547E+00, .347555E-02, .461061E-01, .461061E-01, .344994E-02,
40121      & .345026E-02, .345026E-02, .344994E-02, .104908E+00, .342804E-02,
40122      & .428876E-01, .428876E-01, .334753E-02, .334784E-02, .334784E-02,
40123      & .334753E-02, .887264E-01, .332868E-02, .397764E-01, .397764E-01,
40124      & .320718E-02, .320748E-02, .320748E-02, .320718E-02, .742160E-01/
40125       DATA (DL(K),K= 2976, 3060) /
40126      & .319097E-02, .367882E-01, .367882E-01, .304033E-02, .304062E-02,
40127      & .304062E-02, .304033E-02, .614556E-01, .302641E-02, .339348E-01,
40128      & .339348E-01, .285650E-02, .285677E-02, .285677E-02, .285650E-02,
40129      & .504214E-01, .284454E-02, .312247E-01, .312247E-01, .266337E-02,
40130      & .266363E-02, .266363E-02, .266337E-02, .410205E-01, .265311E-02,
40131      & .286629E-01, .286629E-01, .246705E-02, .246730E-02, .246730E-02,
40132      & .246705E-02, .331166E-01, .245826E-02, .262521E-01, .262521E-01,
40133      & .227226E-02, .227248E-02, .227248E-02, .227226E-02, .265498E-01,
40134      & .226473E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40135      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40136      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40137      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40138      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40139      & .741335E-01, .741335E-01, .409835E-04, .409835E-04, .409835E-04,
40140      & .409835E-04, .235495E+00,-.158395E-17, .705990E-01, .705990E-01,
40141      & .938808E-03, .938883E-03, .938883E-03, .938808E-03, .235413E+00,
40142      & .903728E-03, .669383E-01, .669383E-01, .166382E-02, .166395E-02/
40143       DATA (DL(K),K= 3061, 3145) /
40144      & .166395E-02, .166382E-02, .227523E+00, .163381E-02, .631853E-01,
40145      & .631853E-01, .221128E-02, .221145E-02, .221145E-02, .221128E-02,
40146      & .213316E+00, .218562E-02, .593855E-01, .593855E-01, .259911E-02,
40147      & .259931E-02, .259931E-02, .259911E-02, .194833E+00, .257720E-02,
40148      & .555825E-01, .555825E-01, .284819E-02, .284841E-02, .284841E-02,
40149      & .284819E-02, .174012E+00, .282950E-02, .518174E-01, .518174E-01,
40150      & .298117E-02, .298140E-02, .298140E-02, .298117E-02, .152385E+00,
40151      & .296523E-02, .481268E-01, .481268E-01, .302067E-02, .302090E-02,
40152      & .302090E-02, .302067E-02, .131168E+00, .300708E-02, .445413E-01,
40153      & .445413E-01, .298689E-02, .298712E-02, .298712E-02, .298689E-02,
40154      & .111177E+00, .297532E-02, .410859E-01, .410859E-01, .289793E-02,
40155      & .289815E-02, .289815E-02, .289793E-02, .929352E-01, .288809E-02,
40156      & .377798E-01, .377798E-01, .276920E-02, .276941E-02, .276941E-02,
40157      & .276920E-02, .767178E-01, .276084E-02, .346372E-01, .346372E-01,
40158      & .261353E-02, .261373E-02, .261373E-02, .261353E-02, .626102E-01,
40159      & .260643E-02, .316676E-01, .316676E-01, .244134E-02, .244154E-02,
40160      & .244154E-02, .244134E-02, .505665E-01, .243531E-02, .288765E-01/
40161       DATA (DL(K),K= 3146, 3230) /
40162      & .288765E-01, .226087E-02, .226105E-02, .226105E-02, .226087E-02,
40163      & .404527E-01, .225576E-02, .262660E-01, .262660E-01, .207845E-02,
40164      & .207862E-02, .207862E-02, .207845E-02, .320820E-01, .207412E-02,
40165      & .238351E-01, .238351E-01, .189881E-02, .189897E-02, .189897E-02,
40166      & .189881E-02, .252422E-01, .189514E-02, .215808E-01, .215808E-01,
40167      & .172536E-02, .172551E-02, .172551E-02, .172536E-02, .197186E-01,
40168      & .172225E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40169      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40170      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40171      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40172      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40173      & .720339E-01, .720339E-01, .181946E-04, .181946E-04, .181946E-04,
40174      & .181946E-04, .254393E+00, .469256E-18, .677768E-01, .677768E-01,
40175      & .875835E-03, .875888E-03, .875888E-03, .875835E-03, .249966E+00,
40176      & .860480E-03, .634725E-01, .634725E-01, .153792E-02, .153801E-02,
40177      & .153801E-02, .153792E-02, .236824E+00, .152496E-02, .591619E-01,
40178      & .591619E-01, .201036E-02, .201048E-02, .201048E-02, .201036E-02/
40179       DATA (DL(K),K= 3231, 3315) /
40180      & .217211E+00, .199944E-02, .548948E-01, .548948E-01, .231978E-02,
40181      & .231992E-02, .231992E-02, .231978E-02, .193739E+00, .231058E-02,
40182      & .507162E-01, .507162E-01, .249460E-02, .249475E-02, .249475E-02,
40183      & .249460E-02, .168773E+00, .248686E-02, .466653E-01, .466653E-01,
40184      & .256217E-02, .256232E-02, .256232E-02, .256217E-02, .144012E+00,
40185      & .255566E-02, .427744E-01, .427744E-01, .254804E-02, .254820E-02,
40186      & .254820E-02, .254804E-02, .120695E+00, .254258E-02, .390676E-01,
40187      & .390676E-01, .247365E-02, .247380E-02, .247380E-02, .247365E-02,
40188      & .995452E-01, .246906E-02, .355626E-01, .355626E-01, .235710E-02,
40189      & .235725E-02, .235725E-02, .235710E-02, .809281E-01, .235325E-02,
40190      & .322703E-01, .322703E-01, .221303E-02, .221317E-02, .221317E-02,
40191      & .221303E-02, .649429E-01, .220980E-02, .291963E-01, .291963E-01,
40192      & .205294E-02, .205307E-02, .205307E-02, .205294E-02, .515039E-01,
40193      & .205024E-02, .263419E-01, .263419E-01, .188569E-02, .188581E-02,
40194      & .188581E-02, .188569E-02, .404102E-01, .188343E-02, .237044E-01,
40195      & .237044E-01, .171783E-02, .171795E-02, .171795E-02, .171783E-02,
40196      & .313959E-01, .171594E-02, .212782E-01, .212782E-01, .155409E-02/
40197       DATA (DL(K),K= 3316, 3400) /
40198      & .155419E-02, .155419E-02, .155409E-02, .241750E-01, .155251E-02,
40199      & .190555E-01, .190555E-01, .139767E-02, .139777E-02, .139777E-02,
40200      & .139767E-02, .184646E-01, .139635E-02, .170270E-01, .170270E-01,
40201      & .125065E-02, .125074E-02, .125074E-02, .125065E-02, .139996E-01,
40202      & .124955E-02, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40203      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40204      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40205      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40206      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40207      & .687547E-01, .687547E-01, .676181E-05, .676181E-05, .676181E-05,
40208      & .676181E-05, .280728E+00,-.145838E-17, .637529E-01, .637529E-01,
40209      & .808781E-03, .808818E-03, .808818E-03, .808781E-03, .270033E+00,
40210      & .803169E-03, .588180E-01, .588180E-01, .139388E-02, .139394E-02,
40211      & .139394E-02, .139388E-02, .249568E+00, .138922E-02, .539945E-01,
40212      & .539945E-01, .178168E-02, .178176E-02, .178176E-02, .178168E-02,
40213      & .222743E+00, .177782E-02, .493317E-01, .493317E-01, .200838E-02,
40214      & .200848E-02, .200848E-02, .200838E-02, .192919E+00, .200519E-02/
40215       DATA (DL(K),K= 3401, 3485) /
40216      & .448709E-01, .448709E-01, .211009E-02, .211019E-02, .211019E-02,
40217      & .211009E-02, .162975E+00, .210745E-02, .406433E-01, .406433E-01,
40218      & .211805E-02, .211815E-02, .211815E-02, .211805E-02, .134716E+00,
40219      & .211586E-02, .366716E-01, .366716E-01, .205957E-02, .205968E-02,
40220      & .205968E-02, .205957E-02, .109289E+00, .205776E-02, .329687E-01,
40221      & .329687E-01, .195606E-02, .195616E-02, .195616E-02, .195606E-02,
40222      & .871955E-01, .195457E-02, .295400E-01, .295400E-01, .182447E-02,
40223      & .182456E-02, .182456E-02, .182447E-02, .685399E-01, .182323E-02,
40224      & .263849E-01, .263849E-01, .167765E-02, .167774E-02, .167774E-02,
40225      & .167765E-02, .531615E-01, .167663E-02, .234975E-01, .234975E-01,
40226      & .152505E-02, .152514E-02, .152514E-02, .152505E-02, .407334E-01,
40227      & .152421E-02, .208683E-01, .208683E-01, .137342E-02, .137350E-02,
40228      & .137350E-02, .137342E-02, .308674E-01, .137273E-02, .184852E-01,
40229      & .184852E-01, .122732E-02, .122739E-02, .122739E-02, .122732E-02,
40230      & .231578E-01, .122675E-02, .163340E-01, .163340E-01, .108968E-02,
40231      & .108975E-02, .108975E-02, .108968E-02, .172149E-01, .108921E-02,
40232      & .143996E-01, .143996E-01, .962198E-03, .962260E-03, .962260E-03/
40233       DATA (DL(K),K= 3486, 3570) /
40234      & .962198E-03, .126908E-01, .961815E-03, .126661E-01, .126661E-01,
40235      & .845675E-03, .845732E-03, .845732E-03, .845675E-03, .928555E-02,
40236      & .845361E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40237      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40238      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40239      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40240      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40241      & .639050E-01, .639050E-01, .189600E-05, .189600E-05, .189600E-05,
40242      & .189600E-05, .320203E+00, .545701E-18, .581555E-01, .581555E-01,
40243      & .725861E-03, .725886E-03, .725886E-03, .725861E-03, .299305E+00,
40244      & .724320E-03, .526376E-01, .526376E-01, .121568E-02, .121572E-02,
40245      & .121572E-02, .121568E-02, .267591E+00, .121442E-02, .473911E-01,
40246      & .473911E-01, .150820E-02, .150825E-02, .150825E-02, .150820E-02,
40247      & .230364E+00, .150718E-02, .424558E-01, .424558E-01, .164949E-02,
40248      & .164955E-02, .164955E-02, .164949E-02, .191972E+00, .164867E-02,
40249      & .378600E-01, .378600E-01, .168256E-02, .168262E-02, .168262E-02,
40250      & .168256E-02, .155818E+00, .168189E-02, .336181E-01, .336181E-01/
40251       DATA (DL(K),K= 3571, 3655) /
40252      & .164080E-02, .164086E-02, .164086E-02, .164080E-02, .123609E+00,
40253      & .164026E-02, .297349E-01, .297349E-01, .155136E-02, .155142E-02,
40254      & .155142E-02, .155136E-02, .961680E-01, .155092E-02, .262052E-01,
40255      & .262052E-01, .143382E-02, .143388E-02, .143388E-02, .143382E-02,
40256      & .735522E-01, .143346E-02, .230171E-01, .230171E-01, .130247E-02,
40257      & .130253E-02, .130253E-02, .130247E-02, .553916E-01, .130218E-02,
40258      & .201539E-01, .201539E-01, .116733E-02, .116739E-02, .116739E-02,
40259      & .116733E-02, .411453E-01, .116710E-02, .175955E-01, .175955E-01,
40260      & .103505E-02, .103510E-02, .103510E-02, .103505E-02, .301858E-01,
40261      & .103486E-02, .153199E-01, .153199E-01, .909828E-03, .909880E-03,
40262      & .909880E-03, .909828E-03, .218957E-01, .909677E-03, .133043E-01,
40263      & .133043E-01, .794097E-03, .794146E-03, .794146E-03, .794097E-03,
40264      & .157204E-01, .793976E-03, .115259E-01, .115259E-01, .689012E-03,
40265      & .689057E-03, .689057E-03, .689012E-03, .111816E-01, .688913E-03,
40266      & .996208E-02, .996208E-02, .594880E-03, .594922E-03, .594922E-03,
40267      & .594880E-03, .788559E-02, .594801E-03, .859151E-02, .859151E-02,
40268      & .511455E-03, .511493E-03, .511493E-03, .511455E-03, .551865E-02/
40269       DATA (DL(K),K= 3656, 3740) /
40270      & .511392E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40271      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40272      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40273      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40274      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40275      & .567030E-01, .567030E-01, .317692E-06, .317692E-06, .317692E-06,
40276      & .317692E-06, .387655E+00,-.196551E-18, .502560E-01, .502560E-01,
40277      & .611827E-03, .611838E-03, .611838E-03, .611827E-03, .346975E+00,
40278      & .611576E-03, .442838E-01, .442838E-01, .981907E-03, .981929E-03,
40279      & .981929E-03, .981907E-03, .295290E+00, .981708E-03, .388018E-01,
40280      & .388018E-01, .116826E-02, .116829E-02, .116829E-02, .116826E-02,
40281      & .241157E+00, .116810E-02, .338227E-01, .338227E-01, .122537E-02,
40282      & .122541E-02, .122541E-02, .122537E-02, .190062E+00, .122525E-02,
40283      & .293442E-01, .293442E-01, .120047E-02, .120052E-02, .120052E-02,
40284      & .120047E-02, .145706E+00, .120037E-02, .253494E-01, .253494E-01,
40285      & .112580E-02, .112585E-02, .112585E-02, .112580E-02, .109110E+00,
40286      & .112572E-02, .218132E-01, .218132E-01, .102498E-02, .102503E-02/
40287       DATA (DL(K),K= 3741, 3825) /
40288      & .102503E-02, .102498E-02, .800661E-01, .102492E-02, .187030E-01,
40289      & .187030E-01, .913395E-03, .913450E-03, .913450E-03, .913395E-03,
40290      & .577342E-01, .913348E-03, .159833E-01, .159833E-01, .800935E-03,
40291      & .800990E-03, .800990E-03, .800935E-03, .409782E-01, .800898E-03,
40292      & .136172E-01, .136172E-01, .693698E-03, .693751E-03, .693751E-03,
40293      & .693698E-03, .286780E-01, .693669E-03, .115681E-01, .115681E-01,
40294      & .595013E-03, .595064E-03, .595064E-03, .595013E-03, .198197E-01,
40295      & .594990E-03, .980105E-02, .980105E-02, .506423E-03, .506471E-03,
40296      & .506471E-03, .506423E-03, .135410E-01, .506405E-03, .828286E-02,
40297      & .828286E-02, .428323E-03, .428368E-03, .428368E-03, .428323E-03,
40298      & .915498E-02, .428309E-03, .698303E-02, .698303E-02, .360397E-03,
40299      & .360439E-03, .360439E-03, .360397E-03, .613133E-02, .360386E-03,
40300      & .587373E-02, .587373E-02, .301934E-03, .301973E-03, .301973E-03,
40301      & .301934E-03, .407092E-02, .301925E-03, .492985E-02, .492985E-02,
40302      & .252029E-03, .252064E-03, .252064E-03, .252029E-03, .268179E-02,
40303      & .252022E-03, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40304      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40305       DATA (DL(K),K= 3826, 3910) /
40306      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40307      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40308      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40309      & .450567E-01, .450567E-01, .151200E-07, .151200E-07, .151200E-07,
40310      & .151200E-07, .542258E+00,-.767310E-18, .381624E-01, .381624E-01,
40311      & .438685E-03, .438751E-03, .438751E-03, .438685E-03, .447480E+00,
40312      & .438674E-03, .321250E-01, .321250E-01, .653465E-03, .653574E-03,
40313      & .653574E-03, .653465E-03, .347952E+00, .653456E-03, .268827E-01,
40314      & .268827E-01, .724735E-03, .724868E-03, .724868E-03, .724735E-03,
40315      & .258636E+00, .724728E-03, .223751E-01, .223751E-01, .709421E-03,
40316      & .709567E-03, .709567E-03, .709421E-03, .185088E+00, .709417E-03,
40317      & .185359E-01, .185359E-01, .650478E-03, .650626E-03, .650626E-03,
40318      & .650478E-03, .128686E+00, .650474E-03, .152906E-01, .152906E-01,
40319      & .572423E-03, .572567E-03, .572567E-03, .572423E-03, .873875E-01,
40320      & .572420E-03, .125654E-01, .125654E-01, .490165E-03, .490302E-03,
40321      & .490302E-03, .490165E-03, .581141E-01, .490163E-03, .102901E-01,
40322      & .102901E-01, .411740E-03, .411866E-03, .411866E-03, .411740E-03/
40323       DATA (DL(K),K= 3911, 3995) /
40324      & .379596E-01, .411738E-03, .839975E-02, .839975E-02, .340986E-03,
40325      & .341101E-03, .341101E-03, .340986E-03, .244073E-01, .340985E-03,
40326      & .683634E-02, .683634E-02, .279417E-03, .279520E-03, .279520E-03,
40327      & .279417E-03, .154717E-01, .279416E-03, .554846E-02, .554846E-02,
40328      & .227114E-03, .227204E-03, .227204E-03, .227114E-03, .968450E-02,
40329      & .227113E-03, .449143E-02, .449143E-02, .183425E-03, .183504E-03,
40330      & .183504E-03, .183425E-03, .599306E-02, .183425E-03, .362676E-02,
40331      & .362676E-02, .147387E-03, .147455E-03, .147455E-03, .147387E-03,
40332      & .366977E-02, .147387E-03, .292164E-02, .292164E-02, .117936E-03,
40333      & .117995E-03, .117995E-03, .117936E-03, .222583E-02, .117936E-03,
40334      & .234830E-02, .234830E-02, .940414E-04, .940914E-04, .940914E-04,
40335      & .940414E-04, .133844E-02, .940412E-04, .188339E-02, .188339E-02,
40336      & .747651E-04, .748074E-04, .748074E-04, .747651E-04, .798451E-03,
40337      & .747649E-04, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40338      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40339      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00,
40340      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40341       DATA (DL(K),K= 3996, 4000) /
40342      & .000000E+00, .000000E+00, .000000E+00, .000000E+00, .000000E+00/
40343
40344       DO 10 I=1,7
40345         QQ(I) = 0.
40346  10   CONTINUE
40347       IF(X.GT.0.9985) RETURN
40348
40349       IS = S/DELTA+1
40350       IS = MIN(IS,19)
40351       IS1 = IS+1
40352       DO 20 I=1,7
40353         IF(I.EQ.3.AND.X.GT.0.95) GOTO 19
40354         IF(I.EQ.8.AND.X.GT.0.95) GOTO 19
40355         DO 30 L=1,25
40356           F1(L)=GF(I,IS,L)
40357           F2(L)=GF(I,IS1,L)
40358  30     CONTINUE
40359         S1=(IS-1)*DELTA
40360         S2=S1+DELTA
40361         A1 = PHO_CKMTFV(X,F1)
40362         A2 = PHO_CKMTFV(X,F2)
40363         QQ(I)=A1*(S2-S)/DELTA+A2*(S-S1)/DELTA
40364  19     CONTINUE
40365  20   CONTINUE
40366
40367       END
40368
40369 *$ CREATE PHO_CKMTFV.FOR
40370 *COPY PHO_CKMTFV
40371 CDECK  ID>, PHO_CKMTFV
40372       REAL FUNCTION PHO_CKMTFV(X,FVL)
40373 C**********************************************************************
40374 C
40375 C     LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
40376 C     FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
40377 C     NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
40378 C     IN MAIN ROUTINE.
40379 C
40380 C**********************************************************************
40381       SAVE
40382
40383       DIMENSION FVL(25),XGRID(25)
40384
40385 C  input/output channels
40386       INTEGER LI,LO
40387       COMMON /POINOU/ LI,LO
40388
40389       DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
40390      *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
40391
40392       PHO_CKMTFV=0.
40393       DO 1 I=1,NX
40394       IF(X.LT.XGRID(I)) GO TO 2
40395     1 CONTINUE
40396     2 I=I-1
40397       IF(I.EQ.0) THEN
40398          I=I+1
40399       ELSE IF(I.GT.23) THEN
40400          I=23
40401       ENDIF
40402       J=I+1
40403       K=J+1
40404       AXI=LOG(XGRID(I))
40405       BXI=LOG(1.-XGRID(I))
40406       AXJ=LOG(XGRID(J))
40407       BXJ=LOG(1.-XGRID(J))
40408       AXK=LOG(XGRID(K))
40409       BXK=LOG(1.-XGRID(K))
40410       FI=LOG(ABS(FVL(I)) +1.E-15)
40411       FJ=LOG(ABS(FVL(J)) +1.E-16)
40412       FK=LOG(ABS(FVL(K)) +1.E-17)
40413       DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
40414       ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
40415      $ BXI))/DET
40416       ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
40417       BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
40418       IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
40419      1RETURN
40420 C      IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
40421 C         WRITE(LO,2001) X,FVL
40422 C 2001    FORMAT(8E12.4)
40423 C         WRITE(LO,2001) ALPHA,BETA,ALOGA,DET
40424 C      ENDIF
40425       PHO_CKMTFV=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
40426
40427       END
40428
40429 *$ CREATE PHO_SASGAM.FOR
40430 *COPY PHO_SASGAM
40431 CDECK  ID>, PHO_SASGAM
40432 C***********************************************************************
40433 C...SaSgam version 2 - parton distributions of the photon
40434 C...by Gerhard A. Schuler and Torbjorn Sjostrand
40435 C...For further information see Z. Phys. C68 (1995) 607
40436 C...and Phys. Lett. B376 (1996) 193.
40437
40438 C...18 January 1996: original code.
40439 C...22 July 1996: calculation of BETA moved in SASBEH.
40440
40441 C!!!Note that one further call parameter - IP2 - has been added
40442 C!!!to the SASGAM argument list compared with version 1.
40443
40444 C...The user should only need to call the SASGAM routine,
40445 C...which in turn calls the auxiliary routines SASVMD, SASANO,
40446 C...SASBEH and SASDIR. The package is self-contained.
40447
40448 C...One particular aspect of these parametrizations is that F2 for
40449 C...the photon is not obtained just as the charge-squared-weighted
40450 C...sum of quark distributions, but differ in the treatment of
40451 C...heavy flavours (in F2 the DIS relation W2 = Q2*(1-x)/x restricts
40452 C...the kinematics range of heavy-flavour production, but the same
40453 C...kinematics is not relevant e.g. for jet production) and, for the
40454 C...'MSbar' fits, in the addition of a Cgamma term related to the
40455 C...separation of direct processes. Schematically:
40456 C...PDF = VMD (rho, omega, phi) + anomalous (d, u, s, c, b).
40457 C...F2  = VMD (rho, omega, phi) + anomalous (d, u, s) +
40458 C...      Bethe-Heitler (c, b) (+ Cgamma (d, u, s)).
40459 C...The J/psi and Upsilon states have not been included in the VMD sum,
40460 C...but low c and b masses in the other components should compensate
40461 C...for this in a duality sense.
40462
40463 C...The calling sequence is the following:
40464 C     CALL SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40465 C...with the following declaration statement:
40466 C     DIMENSION XPDFGM(-6:6)
40467 C...and, optionally, further information in:
40468 C     COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
40469 C    &XPDIR(-6:6)
40470 C     COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
40471 C...Input:  ISET = 1 : SaS set 1D ('DIS',   Q0 = 0.6 GeV)
40472 C                = 2 : SaS set 1M ('MSbar', Q0 = 0.6 GeV)
40473 C                = 3 : SaS set 2D ('DIS',   Q0 =  2  GeV)
40474 C                = 4 : SaS set 2M ('MSbar', Q0 =  2  GeV)
40475 C           X : x value.
40476 C           Q2 : Q2 value.
40477 C           P2 : P2 value; should be = 0. for an on-shell photon.
40478 C           IP2 : scheme used to evaluate off-shell anomalous component.
40479 C               = 0 : recommended default, see = 7.
40480 C               = 1 : dipole dampening by integration; very time-consuming.
40481 C               = 2 : P_0^2 = max( Q_0^2, P^2 )
40482 C               = 3 : P_0^2 = Q_0^2 + P^2.
40483 C               = 4 : P_{eff} that preserves momentum sum.
40484 C               = 5 : P_{int} that preserves momentum and average
40485 C                     evolution range.
40486 C               = 6 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
40487 C               = 7 : P_{eff}, matched to P_0 in P2 -> Q2 limit.
40488 C...Output: F2GM : F2 value of the photon (including factors of alpha_em).
40489 C           XPFDGM :  x times parton distribution functions of the photon,
40490 C               with elements 0 = g, 1 = d, 2 = u, 3 = s, 4 = c, 5 = b,
40491 C               6 = t (always empty!), - for antiquarks (result is same).
40492 C...The breakdown by component is stored in the commonblock SASCOM,
40493 C               with elements as above.
40494 C           XPVMD : rho, omega, phi VMD part only of output.
40495 C           XPANL : d, u, s anomalous part only of output.
40496 C           XPANH : c, b anomalous part only of output.
40497 C           XPBEH : c, b Bethe-Heitler part only of output.
40498 C           XPDIR : Cgamma (direct contribution) part only of output.
40499 C...The above arrays do not distinguish valence and sea contributions,
40500 C...although this information is available internally. The additional
40501 C...commonblock SASVAL provides the valence part only of the above
40502 C...distributions. Array names VXPVMD, VXPANL and VXPANH correspond
40503 C...to XPVMD, XPANL and XPANH, while XPBEH and XPDIR are valence only
40504 C...and therefore not given doubly. VXPDGM gives the sum of valence
40505 C...parts, and so matches XPDFGM. The difference, i.e. XPVMD-VXPVMD
40506 C...and so on, gives the sea part only.
40507 C***********************************************************************
40508
40509       SUBROUTINE PHO_SASGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40510 C...Purpose: to construct the F2 and parton distributions of the photon
40511 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
40512 C...For F2, c and b are included by the Bethe-Heitler formula;
40513 C...in the 'MSbar' scheme additionally a Cgamma term is added.
40514       SAVE
40515       DIMENSION XPDFGM(-6:6)
40516
40517 C  input/output channels
40518       INTEGER LI,LO
40519       COMMON /POINOU/ LI,LO
40520
40521       COMMON/SASCOM/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
40522      &XPDIR(-6:6)
40523       COMMON/SASVAL/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
40524 CPH      SAVE /SASCOM/,/SASVAL/
40525
40526 C...Temporary array.
40527       DIMENSION XPGA(-6:6), VXPGA(-6:6)
40528 C...Charm and bottom masses (low to compensate for J/psi etc.).
40529       DATA PMC/1.3/, PMB/4.6/
40530 C...alpha_em and alpha_em/(2*pi).
40531       DATA AEM/0.007297/, AEM2PI/0.0011614/
40532 C...Lambda value for 4 flavours.
40533       DATA ALAM/0.20/
40534 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
40535       DATA FRACU/0.8/
40536 C...VMD couplings f_V**2/(4*pi).
40537       DATA FRHO/2.20/, FOMEGA/23.6/, FPHI/18.4/
40538 C...Masses for rho (=omega) and phi.
40539       DATA PMRHO/0.770/, PMPHI/1.020/
40540 C...Number of points in integration for IP2=1.
40541       DATA NSTEP/100/
40542
40543 C...Reset output.
40544       F2GM=0.
40545       DO 100 KFL=-6,6
40546       XPDFGM(KFL)=0.
40547       XPVMD(KFL)=0.
40548       XPANL(KFL)=0.
40549       XPANH(KFL)=0.
40550       XPBEH(KFL)=0.
40551       XPDIR(KFL)=0.
40552       VXPVMD(KFL)=0.
40553       VXPANL(KFL)=0.
40554       VXPANH(KFL)=0.
40555       VXPDGM(KFL)=0.
40556   100 CONTINUE
40557
40558 C...Check that input sensible.
40559       IF(ISET.LE.0.OR.ISET.GE.5) THEN
40560         WRITE(LO,*) ' FATAL ERROR: SaSgam called for unknown set'
40561         WRITE(LO,*) ' ISET = ',ISET
40562         STOP
40563       ENDIF
40564       IF(X.LE.0..OR.X.GT.1.) THEN
40565         WRITE(LO,*) ' FATAL ERROR: SaSgam called for unphysical x'
40566         WRITE(LO,*) ' X = ',X
40567         STOP
40568       ENDIF
40569
40570 C...Set Q0 cut-off parameter as function of set used.
40571       IF(ISET.LE.2) THEN
40572         Q0=0.6
40573       ELSE
40574         Q0=2.
40575       ENDIF
40576       Q02=Q0**2
40577
40578 C...Scale choice for off-shell photon; common factors.
40579       Q2A=Q2
40580       FACNOR=1.
40581       IF(IP2.EQ.1) THEN
40582         P2MX=P2+Q02
40583         Q2A=Q2+P2*Q02/MAX(Q02,Q2)
40584         FACNOR=LOG(Q2/Q02)/NSTEP
40585       ELSEIF(IP2.EQ.2) THEN
40586         P2MX=MAX(P2,Q02)
40587       ELSEIF(IP2.EQ.3) THEN
40588         P2MX=P2+Q02
40589         Q2A=Q2+P2*Q02/MAX(Q02,Q2)
40590       ELSEIF(IP2.EQ.4) THEN
40591         P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40592      &  ((Q2+P2)*(Q02+P2)))
40593       ELSEIF(IP2.EQ.5) THEN
40594         P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40595      &  ((Q2+P2)*(Q02+P2)))
40596         P2MX=Q0*SQRT(P2MXA)
40597         FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
40598       ELSEIF(IP2.EQ.6) THEN
40599         P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40600      &  ((Q2+P2)*(Q02+P2)))
40601         P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
40602       ELSE
40603         P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40604      &  ((Q2+P2)*(Q02+P2)))
40605         P2MX=Q0*SQRT(P2MXA)
40606         P2MXB=P2MX
40607         P2MX=MAX(0.,1.-P2/Q2)*P2MX+MIN(1.,P2/Q2)*MAX(P2,Q02)
40608         P2MXB=MAX(0.,1.-P2/Q2)*P2MXB+MIN(1.,P2/Q2)*P2MXA
40609         FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
40610       ENDIF
40611
40612 C...Call VMD parametrization for d quark and use to give rho, omega,
40613 C...phi. Note dipole dampening for off-shell photon.
40614       CALL PHO_SASVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40615       XFVAL=VXPGA(1)
40616       XPGA(1)=XPGA(2)
40617       XPGA(-1)=XPGA(-2)
40618       FACUD=AEM*(1./FRHO+1./FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
40619       FACS=AEM*(1./FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
40620       DO 110 KFL=-5,5
40621       XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
40622   110 CONTINUE
40623       XPVMD(1)=XPVMD(1)+(1.-FRACU)*FACUD*XFVAL
40624       XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
40625       XPVMD(3)=XPVMD(3)+FACS*XFVAL
40626       XPVMD(-1)=XPVMD(-1)+(1.-FRACU)*FACUD*XFVAL
40627       XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
40628       XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
40629       VXPVMD(1)=(1.-FRACU)*FACUD*XFVAL
40630       VXPVMD(2)=FRACU*FACUD*XFVAL
40631       VXPVMD(3)=FACS*XFVAL
40632       VXPVMD(-1)=(1.-FRACU)*FACUD*XFVAL
40633       VXPVMD(-2)=FRACU*FACUD*XFVAL
40634       VXPVMD(-3)=FACS*XFVAL
40635
40636       IF(IP2.NE.1) THEN
40637 C...Anomalous parametrizations for different strategies
40638 C...for off-shell photons; except full integration.
40639
40640 C...Call anomalous parametrization for d + u + s.
40641         CALL PHO_SASANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40642         DO 120 KFL=-5,5
40643         XPANL(KFL)=FACNOR*XPGA(KFL)
40644         VXPANL(KFL)=FACNOR*VXPGA(KFL)
40645   120   CONTINUE
40646
40647 C...Call anomalous parametrization for c and b.
40648         CALL PHO_SASANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40649         DO 130 KFL=-5,5
40650         XPANH(KFL)=FACNOR*XPGA(KFL)
40651         VXPANH(KFL)=FACNOR*VXPGA(KFL)
40652   130   CONTINUE
40653         CALL PHO_SASANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40654         DO 140 KFL=-5,5
40655         XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
40656         VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
40657   140   CONTINUE
40658
40659       ELSE
40660 C...Special option: loop over flavours and integrate over k2.
40661         DO 170 KF=1,5
40662         DO 160 ISTEP=1,NSTEP
40663         Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5)/NSTEP)
40664         IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
40665      &  (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
40666         CALL PHO_SASVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
40667         FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
40668         IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8./9.)
40669         IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2./9.)
40670         DO 150 KFL=-5,5
40671         IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
40672         IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
40673         IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
40674         IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
40675   150   CONTINUE
40676   160   CONTINUE
40677   170   CONTINUE
40678       ENDIF
40679
40680 C...Call Bethe-Heitler term expression for charm and bottom.
40681       CALL PHO_SASBEH(4,X,Q2,P2,PMC**2,XPBH)
40682       XPBEH(4)=XPBH
40683       XPBEH(-4)=XPBH
40684       CALL PHO_SASBEH(5,X,Q2,P2,PMB**2,XPBH)
40685       XPBEH(5)=XPBH
40686       XPBEH(-5)=XPBH
40687
40688 C...For MSbar subtraction call C^gamma term expression for d, u, s.
40689       IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
40690         CALL PHO_SASDIR(X,Q2,P2,Q02,XPGA)
40691         DO 180 KFL=-5,5
40692         XPDIR(KFL)=XPGA(KFL)
40693   180   CONTINUE
40694       ENDIF
40695
40696 C...Store result in output array.
40697       DO 190 KFL=-5,5
40698       CHSQ=1./9.
40699       IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4./9.
40700       XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
40701       IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
40702       XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
40703       VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
40704   190 CONTINUE
40705
40706       RETURN
40707       END
40708
40709 C*********************************************************************
40710
40711 *$ CREATE PHO_SASVMD.FOR
40712 *COPY PHO_SASVMD
40713 CDECK  ID>, PHO_SASVMD
40714       SUBROUTINE PHO_SASVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40715 C...Purpose: to evaluate the VMD parton distributions of a photon,
40716 C...evolved homogeneously from an initial scale P2 to Q2.
40717 C...Does not include dipole suppression factor.
40718 C...ISET is parton distribution set, see above;
40719 C...additionally ISET=0 is used for the evolution of an anomalous photon
40720 C...which branched at a scale P2 and then evolved homogeneously to Q2.
40721 C...ALAM is the 4-flavour Lambda, which is automatically converted
40722 C...to 3- and 5-flavour equivalents as needed.
40723       SAVE
40724       DIMENSION XPGA(-6:6), VXPGA(-6:6)
40725
40726 C  input/output channels
40727       INTEGER LI,LO
40728       COMMON /POINOU/ LI,LO
40729
40730       DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
40731
40732 C...Reset output.
40733       DO 100 KFL=-6,6
40734       XPGA(KFL)=0.
40735       VXPGA(KFL)=0.
40736   100 CONTINUE
40737       KFA=IABS(KF)
40738
40739 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
40740       ALAM3=ALAM*(PMC/ALAM)**(2./27.)
40741       ALAM5=ALAM*(ALAM/PMB)**(2./23.)
40742       P2EFF=MAX(P2,1.2*ALAM3**2)
40743       IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
40744       IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
40745       Q2EFF=MAX(Q2,P2EFF)
40746
40747 C...Find number of flavours at lower and upper scale.
40748       NFP=4
40749       IF(P2EFF.LT.PMC**2) NFP=3
40750       IF(P2EFF.GT.PMB**2) NFP=5
40751       NFQ=4
40752       IF(Q2EFF.LT.PMC**2) NFQ=3
40753       IF(Q2EFF.GT.PMB**2) NFQ=5
40754
40755 C...Find s as sum of 3-, 4- and 5-flavour parts.
40756       S=0.
40757       IF(NFP.EQ.3) THEN
40758         Q2DIV=PMC**2
40759         IF(NFQ.EQ.3) Q2DIV=Q2EFF
40760         S=S+(6./27.)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
40761       ENDIF
40762       IF(NFP.LE.4.AND.NFQ.GE.4) THEN
40763         P2DIV=P2EFF
40764         IF(NFP.EQ.3) P2DIV=PMC**2
40765         Q2DIV=Q2EFF
40766         IF(NFQ.EQ.5) Q2DIV=PMB**2
40767         S=S+(6./25.)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
40768       ENDIF
40769       IF(NFQ.EQ.5) THEN
40770         P2DIV=PMB**2
40771         IF(NFP.EQ.5) P2DIV=P2EFF
40772         S=S+(6./23.)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
40773       ENDIF
40774
40775 C...Calculate frequent combinations of x and s.
40776       X1=1.-X
40777       XL=-LOG(X)
40778       S2=S**2
40779       S3=S**3
40780       S4=S**4
40781
40782 C...Evaluate homogeneous anomalous parton distributions below or
40783 C...above threshold.
40784       IF(ISET.EQ.0) THEN
40785       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40786      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40787         XVAL = X * 1.5 * (X**2+X1**2)
40788         XGLU = 0.
40789         XSEA = 0.
40790       ELSE
40791         XVAL = (1.5/(1.-0.197*S+4.33*S2)*X**2 + (1.5+2.10*S)/
40792      &  (1.+3.29*S)*X1**2 + 5.23*S/(1.+1.17*S+19.9*S3)*X*X1) *
40793      &  X**(1./(1.+1.5*S)) * (1.-X**2)**(2.667*S)
40794         XGLU = 4.*S/(1.+4.76*S+15.2*S2+29.3*S4) *
40795      &  X**(-2.03*S/(1.+2.44*S)) * (X1*XL)**(1.333*S) *
40796      &  ((4.*X**2+7.*X+4.)*X1/3. - 2.*X*(1.+X)*XL)
40797         XSEA = S2/(1.+4.54*S+8.19*S2+8.05*S3) *
40798      &  X**(-1.54*S/(1.+1.29*S)) * X1**(2.667*S) *
40799      &  ((8.-73.*X+62.*X**2)*X1/9. + (3.-8.*X**2/3.)*X*XL +
40800      &  (2.*X-1.)*X*XL**2)
40801       ENDIF
40802
40803 C...Evaluate set 1D parton distributions below or above threshold.
40804       ELSEIF(ISET.EQ.1) THEN
40805       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40806      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40807         XVAL = 1.294 * X**0.80 * X1**0.76
40808         XGLU = 1.273 * X**0.40 * X1**1.76
40809         XSEA = 0.100 * X1**3.76
40810       ELSE
40811         XVAL = 1.294/(1.+0.252*S+3.079*S2) * X**(0.80-0.13*S) *
40812      &  X1**(0.76+0.667*S) * XL**(2.*S)
40813         XGLU = 7.90*S/(1.+5.50*S) * EXP(-5.16*S) *
40814      &  X**(-1.90*S/(1.+3.60*S)) * X1**1.30 * XL**(0.50+3.*S) +
40815      &  1.273 * EXP(-10.*S) * X**0.40 * X1**(1.76+3.*S)
40816         XSEA = (0.1-0.397*S2+1.121*S3)/(1.+5.61*S2+5.26*S3) *
40817      &  X**(-7.32*S2/(1.+10.3*S2)) *
40818      &  X1**((3.76+15.*S+12.*S2)/(1.+4.*S))
40819         XSEA0 = 0.100 * X1**3.76
40820       ENDIF
40821
40822 C...Evaluate set 1M parton distributions below or above threshold.
40823       ELSEIF(ISET.EQ.2) THEN
40824       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40825      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40826         XVAL = 0.8477 * X**0.51 * X1**1.37
40827         XGLU = 3.42 * X**0.255 * X1**2.37
40828         XSEA = 0.
40829       ELSE
40830         XVAL = 0.8477/(1.+1.37*S+2.18*S2+3.73*S3) * X**(0.51+0.21*S)
40831      &  * X1**1.37 * XL**(2.667*S)
40832         XGLU = 24.*S/(1.+9.6*S+0.92*S2+14.34*S3) * EXP(-5.94*S) *
40833      &  X**((-0.013-1.80*S)/(1.+3.14*S)) * X1**(2.37+0.4*S) *
40834      &  XL**(0.32+3.6*S) + 3.42 * EXP(-12.*S) * X**0.255 *
40835      &  X1**(2.37+3.*S)
40836         XSEA = 0.842*S/(1.+21.3*S-33.2*S2+229.*S3) *
40837      &  X**((0.13-2.90*S)/(1.+5.44*S)) * X1**(3.45+0.5*S) *
40838      &  XL**(2.8*S)
40839         XSEA0 = 0.
40840       ENDIF
40841
40842 C...Evaluate set 2D parton distributions below or above threshold.
40843       ELSEIF(ISET.EQ.3) THEN
40844       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40845      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40846         XVAL = X**0.46 * X1**0.64 + 0.76 * X
40847         XGLU = 1.925 * X1**2
40848         XSEA = 0.242 * X1**4
40849       ELSE
40850         XVAL = (1.+0.186*S)/(1.-0.209*S+1.495*S2) * X**(0.46+0.25*S)
40851      &  * X1**((0.64+0.14*S+5.*S2)/(1.+S)) * XL**(1.9*S) +
40852      &  (0.76+0.4*S) * X * X1**(2.667*S)
40853         XGLU = (1.925+5.55*S+147.*S2)/(1.-3.59*S+3.32*S2) *
40854      &  EXP(-18.67*S) * X**((-5.81*S-5.34*S2)/(1.+29.*S-4.26*S2))
40855      &  * X1**((2.-5.9*S)/(1.+1.7*S)) * XL**(9.3*S/(1.+1.7*S))
40856         XSEA = (0.242-0.252*S+1.19*S2)/(1.-0.607*S+21.95*S2) *
40857      &  X**(-12.1*S2/(1.+2.62*S+16.7*S2)) * X1**4 * XL**S
40858         XSEA0 = 0.242 * X1**4
40859       ENDIF
40860
40861 C...Evaluate set 2M parton distributions below or above threshold.
40862       ELSEIF(ISET.EQ.4) THEN
40863       IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40864      &(KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40865         XVAL = 1.168 * X**0.50 * X1**2.60 + 0.965 * X
40866         XGLU = 1.808 * X1**2
40867         XSEA = 0.209 * X1**4
40868       ELSE
40869         XVAL = (1.168+1.771*S+29.35*S2) * EXP(-5.776*S) *
40870      &  X**((0.5+0.208*S)/(1.-0.794*S+1.516*S2)) *
40871      &  X1**((2.6+7.6*S)/(1.+5.*S)) * XL**(5.15*S/(1.+2.*S)) +
40872      &  (0.965+22.35*S)/(1.+18.4*S) * X * X1**(2.667*S)
40873         XGLU = (1.808+29.9*S)/(1.+26.4*S) * EXP(-5.28*S) *
40874      &  X**((-5.35*S-10.11*S2)/(1.+31.71*S)) *
40875      &  X1**((2.-7.3*S+4.*S2)/(1.+2.5*S)) *
40876      &  XL**(10.9*S/(1.+2.5*S))
40877         XSEA = (0.209+0.644*S2)/(1.+0.319*S+17.6*S2) *
40878      &  X**((-0.373*S-7.71*S2)/(1.+0.815*S+11.0*S2)) *
40879      &  X1**(4.+S) * XL**(0.45*S)
40880         XSEA0 = 0.209 * X1**4
40881       ENDIF
40882       ENDIF
40883
40884 C...Threshold factors for c and b sea.
40885       SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
40886       XCHM=0.
40887       IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
40888         SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40889         IF(ISET.EQ.0) THEN
40890           XCHM=XSEA*(1.-(SCH/SLL)**2)
40891         ELSE
40892           XCHM=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SCH/SLL)
40893         ENDIF
40894       ENDIF
40895       XBOT=0.
40896       IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
40897         SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40898         IF(ISET.EQ.0) THEN
40899           XBOT=XSEA*(1.-(SBT/SLL)**2)
40900         ELSE
40901           XBOT=MAX(0.,XSEA-XSEA0*X1**(2.667*S))*(1.-SBT/SLL)
40902         ENDIF
40903       ENDIF
40904
40905 C...Fill parton distributions.
40906       XPGA(0)=XGLU
40907       XPGA(1)=XSEA
40908       XPGA(2)=XSEA
40909       XPGA(3)=XSEA
40910       XPGA(4)=XCHM
40911       XPGA(5)=XBOT
40912       XPGA(KFA)=XPGA(KFA)+XVAL
40913       DO 110 KFL=1,5
40914       XPGA(-KFL)=XPGA(KFL)
40915   110 CONTINUE
40916       VXPGA(KFA)=XVAL
40917       VXPGA(-KFA)=XVAL
40918
40919       RETURN
40920       END
40921
40922 C*********************************************************************
40923
40924 *$ CREATE PHO_SASANO.FOR
40925 *COPY PHO_SASANO
40926 CDECK  ID>, PHO_SASANO
40927       SUBROUTINE PHO_SASANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40928 C...Purpose: to evaluate the parton distributions of the anomalous
40929 C...photon, inhomogeneously evolved from a scale P2 (where it vanishes)
40930 C...to Q2.
40931 C...KF=0 gives the sum over (up to) 5 flavours,
40932 C...KF<0 limits to flavours up to abs(KF),
40933 C...KF>0 is for flavour KF only.
40934 C...ALAM is the 4-flavour Lambda, which is automatically converted
40935 C...to 3- and 5-flavour equivalents as needed.
40936       SAVE
40937
40938 C  input/output channels
40939       INTEGER LI,LO
40940       COMMON /POINOU/ LI,LO
40941
40942       DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
40943       DATA PMC/1.3/, PMB/4.6/, AEM/0.007297/, AEM2PI/0.0011614/
40944
40945 C...Reset output.
40946       DO 100 KFL=-6,6
40947       XPGA(KFL)=0.
40948       VXPGA(KFL)=0.
40949   100 CONTINUE
40950       IF(Q2.LE.P2) RETURN
40951       KFA=IABS(KF)
40952
40953 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
40954       ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2./27.))**2
40955       ALAMSQ(4)=ALAM**2
40956       ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2./23.))**2
40957       P2EFF=MAX(P2,1.2*ALAMSQ(3))
40958       IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
40959       IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
40960       Q2EFF=MAX(Q2,P2EFF)
40961       XL=-LOG(X)
40962
40963 C...Find number of flavours at lower and upper scale.
40964       NFP=4
40965       IF(P2EFF.LT.PMC**2) NFP=3
40966       IF(P2EFF.GT.PMB**2) NFP=5
40967       NFQ=4
40968       IF(Q2EFF.LT.PMC**2) NFQ=3
40969       IF(Q2EFF.GT.PMB**2) NFQ=5
40970
40971 C...Define range of flavour loop.
40972       IF(KF.EQ.0) THEN
40973         KFLMN=1
40974         KFLMX=5
40975       ELSEIF(KF.LT.0) THEN
40976         KFLMN=1
40977         KFLMX=KFA
40978       ELSE
40979         KFLMN=KFA
40980         KFLMX=KFA
40981       ENDIF
40982
40983 C...Loop over flavours the photon can branch into.
40984       DO 110 KFL=KFLMN,KFLMX
40985
40986 C...Light flavours: calculate t range and (approximate) s range.
40987       IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
40988         TDIFF=LOG(Q2EFF/P2EFF)
40989         S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
40990      &  LOG(P2EFF/ALAMSQ(NFQ)))
40991         IF(NFQ.GT.NFP) THEN
40992           Q2DIV=PMB**2
40993           IF(NFQ.EQ.4) Q2DIV=PMC**2
40994           SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
40995      &    LOG(P2EFF/ALAMSQ(NFQ)))
40996           SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
40997      &    LOG(P2EFF/ALAMSQ(NFQ-1)))
40998           S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
40999         ENDIF
41000         IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
41001           Q2DIV=PMC**2
41002           SNF4=(6./(33.-2.*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
41003      &    LOG(P2EFF/ALAMSQ(4)))
41004           SNF3=(6./(33.-2.*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
41005      &    LOG(P2EFF/ALAMSQ(3)))
41006           S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
41007         ENDIF
41008
41009 C...u and s quark do not need a separate treatment when d has been done.
41010       ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
41011
41012 C...Charm: as above, but only include range above c threshold.
41013       ELSEIF(KFL.EQ.4) THEN
41014         IF(Q2.LE.PMC**2) GOTO 110
41015         P2EFF=MAX(P2EFF,PMC**2)
41016         Q2EFF=MAX(Q2EFF,P2EFF)
41017         TDIFF=LOG(Q2EFF/P2EFF)
41018         S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41019      &  LOG(P2EFF/ALAMSQ(NFQ)))
41020         IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
41021           Q2DIV=PMB**2
41022           SNFQ=(6./(33.-2.*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
41023      &    LOG(P2EFF/ALAMSQ(NFQ)))
41024           SNFP=(6./(33.-2.*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
41025      &    LOG(P2EFF/ALAMSQ(NFQ-1)))
41026           S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
41027         ENDIF
41028
41029 C...Bottom: as above, but only include range above b threshold.
41030       ELSEIF(KFL.EQ.5) THEN
41031         IF(Q2.LE.PMB**2) GOTO 110
41032         P2EFF=MAX(P2EFF,PMB**2)
41033         Q2EFF=MAX(Q2,P2EFF)
41034         TDIFF=LOG(Q2EFF/P2EFF)
41035         S=(6./(33.-2.*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
41036      &  LOG(P2EFF/ALAMSQ(NFQ)))
41037       ENDIF
41038
41039 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
41040       CHSQ=1./9.
41041       IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4./9.
41042       FAC=AEM2PI*2.*CHSQ*TDIFF
41043
41044 C...Evaluate parton distributions (normalized to unit momentum sum).
41045       IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
41046         XVAL= ((1.5+2.49*S+26.9*S**2)/(1.+32.3*S**2)*X**2 +
41047      &  (1.5-0.49*S+7.83*S**2)/(1.+7.68*S**2)*(1.-X)**2 +
41048      &  1.5*S/(1.-3.2*S+7.*S**2)*X*(1.-X)) *
41049      &  X**(1./(1.+0.58*S)) * (1.-X**2)**(2.5*S/(1.+10.*S))
41050         XGLU= 2.*S/(1.+4.*S+7.*S**2) *
41051      &  X**(-1.67*S/(1.+2.*S)) * (1.-X**2)**(1.2*S) *
41052      &  ((4.*X**2+7.*X+4.)*(1.-X)/3. - 2.*X*(1.+X)*XL)
41053         XSEA= 0.333*S**2/(1.+4.90*S+4.69*S**2+21.4*S**3) *
41054      &  X**(-1.18*S/(1.+1.22*S)) * (1.-X)**(1.2*S) *
41055      &  ((8.-73.*X+62.*X**2)*(1.-X)/9. + (3.-8.*X**2/3.)*X*XL +
41056      &  (2.*X-1.)*X*XL**2)
41057
41058 C...Threshold factors for c and b sea.
41059         SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
41060         XCHM=0.
41061         IF(Q2.GT.PMC**2.AND.Q2.GT.1.001*P2EFF) THEN
41062           SCH=MAX(0.,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41063           XCHM=XSEA*(1.-(SCH/SLL)**3)
41064         ENDIF
41065         XBOT=0.
41066         IF(Q2.GT.PMB**2.AND.Q2.GT.1.001*P2EFF) THEN
41067           SBT=MAX(0.,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
41068           XBOT=XSEA*(1.-(SBT/SLL)**3)
41069         ENDIF
41070       ENDIF
41071
41072 C...Add contribution of each valence flavour.
41073       XPGA(0)=XPGA(0)+FAC*XGLU
41074       XPGA(1)=XPGA(1)+FAC*XSEA
41075       XPGA(2)=XPGA(2)+FAC*XSEA
41076       XPGA(3)=XPGA(3)+FAC*XSEA
41077       XPGA(4)=XPGA(4)+FAC*XCHM
41078       XPGA(5)=XPGA(5)+FAC*XBOT
41079       XPGA(KFL)=XPGA(KFL)+FAC*XVAL
41080       VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
41081   110 CONTINUE
41082       DO 120 KFL=1,5
41083       XPGA(-KFL)=XPGA(KFL)
41084       VXPGA(-KFL)=VXPGA(KFL)
41085   120 CONTINUE
41086
41087       END
41088
41089 C*********************************************************************
41090
41091 *$ CREATE PHO_SASBEH.FOR
41092 *COPY PHO_SASBEH
41093 CDECK  ID>, PHO_SASBEH
41094       SUBROUTINE PHO_SASBEH(KF,X,Q2,P2,PM2,XPBH)
41095 C...Purpose: to evaluate the Bethe-Heitler cross section for
41096 C...heavy flavour production.
41097       SAVE
41098       DATA AEM2PI/0.0011614/
41099
41100 C...Reset output.
41101       XPBH=0.
41102       SIGBH=0.
41103
41104 C...Check kinematics limits.
41105       IF(X.GE.Q2/(4.*PM2+Q2+P2)) RETURN
41106       W2=Q2*(1.-X)/X-P2
41107       BETA2=1.-4.*PM2/W2
41108       IF(BETA2.LT.1E-10) RETURN
41109       BETA=SQRT(BETA2)
41110       RMQ=4.*PM2/Q2
41111
41112 C...Simple case: P2 = 0.
41113       IF(P2.LT.1E-4) THEN
41114         IF(BETA.LT.0.99) THEN
41115           XBL=LOG((1.+BETA)/(1.-BETA))
41116         ELSE
41117           XBL=LOG((1.+BETA)**2*W2/(4.*PM2))
41118         ENDIF
41119         SIGBH=BETA*(8.*X*(1.-X)-1.-RMQ*X*(1.-X))+
41120      &  XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)
41121
41122 C...Complicated case: P2 > 0, based on approximation of
41123 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
41124       ELSE
41125         RPQ=1.-4.*X**2*P2/Q2
41126         IF(RPQ.GT.1E-10) THEN
41127           RPBE=SQRT(RPQ*BETA2)
41128           IF(RPBE.LT.0.99) THEN
41129             XBL=LOG((1.+RPBE)/(1.-RPBE))
41130             XBI=2.*RPBE/(1.-RPBE**2)
41131           ELSE
41132             RPBESN=4.*PM2/W2+(4.*X**2*P2/Q2)*BETA2
41133             XBL=LOG((1.+RPBE)**2/RPBESN)
41134             XBI=2.*RPBE/RPBESN
41135           ENDIF
41136           SIGBH=BETA*(6.*X*(1.-X)-1.)+
41137      &    XBL*(X**2+(1.-X)**2+RMQ*X*(1.-3.*X)-0.5*RMQ**2*X**2)+
41138      &    XBI*(2.*X/Q2)*(PM2*X*(2.-RMQ)-P2*X)
41139         ENDIF
41140       ENDIF
41141
41142 C...Multiply by charge-squared etc. to get parton distribution.
41143       CHSQ=1./9.
41144       IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4./9.
41145       XPBH=3.*CHSQ*AEM2PI*X*SIGBH
41146
41147       END
41148
41149 C*********************************************************************
41150
41151 *$ CREATE PHO_SASDIR.FOR
41152 *COPY PHO_SASDIR
41153 CDECK  ID>, PHO_SASDIR
41154       SUBROUTINE PHO_SASDIR(X,Q2,P2,Q02,XPGA)
41155 C...Purpose: to evaluate the direct contribution, i.e. the C^gamma term,
41156 C...as needed in MSbar parametrizations.
41157       SAVE
41158       DIMENSION XPGA(-6:6)
41159       DATA PMC/1.3/, PMB/4.6/, AEM2PI/0.0011614/
41160
41161 C...Reset output.
41162       DO 100 KFL=-6,6
41163       XPGA(KFL)=0.
41164   100 CONTINUE
41165
41166 C...Evaluate common x-dependent expression.
41167       XTMP = (X**2+(1.-X)**2) * (-LOG(X)) - 1.
41168       CGAM = 3.*AEM2PI*X * (XTMP*(1.+P2/(P2+Q02)) + 6.*X*(1.-X))
41169
41170 C...d, u, s part by simple charge factor.
41171       XPGA(1)=(1./9.)*CGAM
41172       XPGA(2)=(4./9.)*CGAM
41173       XPGA(3)=(1./9.)*CGAM
41174
41175 C...Also fill for antiquarks.
41176       DO 110 KF=1,5
41177       XPGA(-KF)=XPGA(KF)
41178   110 CONTINUE
41179
41180       END
41181
41182 *$ CREATE PHO_PHGAL.FOR
41183 *COPY PHO_PHGAL
41184 CDECK  ID>, PHO_PHGAL
41185       SUBROUTINE PHO_PHGAL(X,Q2,XPDF)
41186 C***********************************************************************
41187 C
41188 C     photon parton densities with built-in momentum sum rule and
41189 C     Regge-based low-x behaviour
41190 C
41191 C     H. Abramowicz, E. Gurvich, A. Levy: Phys.Lett.B420:104-108,1998
41192 C     e-Print Archive: hep-ph/9711355
41193 C
41194 C     code submitted by E.Gurvich, slightly modified (R.Engel, 09/1998)
41195 C
41196 C***********************************************************************
41197       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
41198       SAVE
41199
41200       PARAMETER(IX=100,IQ=7,NARG=2,NFUN=4)
41201       DOUBLE PRECISION
41202      &       XT(IX),Q2T(IQ),ARG(NARG),ENT(IX+IQ),
41203      &       XPV(IX,IQ,0:NFUN),XPDF(-6:6)
41204
41205       DIMENSION NA(NARG)
41206
41207       DATA ZEROD/0.D0/
41208
41209 C...100 x values; in (D-4,.77) log spaced (78 points)
41210 C...              in (.78,.995) lineary spaced (22 points)
41211       DATA Q2T/4.D0,10.D0,50.D0,1.D2,1.D3,1.D4,1.D5/
41212       DATA XT/
41213      &0.1000D-03,0.1123D-03,0.1262D-03,0.1417D-03,0.1592D-03,0.1789D-03,
41214      &0.2009D-03,0.2257D-03,0.2535D-03,0.2848D-03,0.3199D-03,0.3593D-03,
41215      &0.4037D-03,0.4534D-03,0.5093D-03,0.5722D-03,0.6427D-03,0.7220D-03,
41216      &0.8110D-03,0.9110D-03,0.1023D-02,0.1150D-02,0.1291D-02,0.1451D-02,
41217      &0.1629D-02,0.1830D-02,0.2056D-02,0.2310D-02,0.2594D-02,0.2914D-02,
41218      &0.3274D-02,0.3677D-02,0.4131D-02,0.4640D-02,0.5212D-02,0.5855D-02,
41219      &0.6577D-02,0.7388D-02,0.8299D-02,0.9323D-02,0.1047D-01,0.1176D-01,
41220      &0.1321D-01,0.1484D-01,0.1667D-01,0.1873D-01,0.2104D-01,0.2363D-01,
41221      &0.2655D-01,0.2982D-01,0.3350D-01,0.3763D-01,0.4227D-01,0.4748D-01,
41222      &0.5334D-01,0.5992D-01,0.6731D-01,0.7560D-01,0.8493D-01,0.9540D-01,
41223      &0.1072D+00,0.1204D+00,0.1352D+00,0.1519D+00,0.1706D+00,0.1917D+00,
41224      &0.2153D+00,0.2419D+00,0.2717D+00,0.3052D+00,0.3428D+00,0.3851D+00,
41225      &0.4326D+00,0.4859D+00,0.5458D+00,0.6131D+00,0.6887D+00,0.7737D+00,
41226      &0.7837D+00,0.7937D+00,0.8037D+00,0.8137D+00,0.8237D+00,0.8337D+00,
41227      &0.8437D+00,0.8537D+00,0.8637D+00,0.8737D+00,0.8837D+00,0.8937D+00,
41228      &0.9037D+00,0.9137D+00,0.9237D+00,0.9337D+00,0.9437D+00,0.9537D+00,
41229      &0.9637D+00,0.9737D+00,0.9837D+00,0.9937D+00/
41230
41231 C...place for DATA blocks
41232       DATA (XPV(I,1,0),I=1,100)/
41233      &0.6632D-01,0.6536D-01,0.6390D-01,0.6196D-01,0.5952D-01,0.5663D-01,
41234      &0.5339D-01,0.5124D-01,0.5029D-01,0.4893D-01,0.4718D-01,0.4505D-01,
41235      &0.4259D-01,0.4038D-01,0.3966D-01,0.3860D-01,0.3721D-01,0.3551D-01,
41236      &0.3354D-01,0.3206D-01,0.3134D-01,0.3031D-01,0.2902D-01,0.2747D-01,
41237      &0.2608D-01,0.2543D-01,0.2451D-01,0.2335D-01,0.2202D-01,0.2132D-01,
41238      &0.2051D-01,0.1950D-01,0.1851D-01,0.1783D-01,0.1696D-01,0.1609D-01,
41239      &0.1539D-01,0.1454D-01,0.1386D-01,0.1310D-01,0.1242D-01,0.1169D-01,
41240      &0.1104D-01,0.1036D-01,0.9694D-02,0.9046D-02,0.8400D-02,0.7792D-02,
41241      &0.7173D-02,0.6573D-02,0.5978D-02,0.5411D-02,0.4853D-02,0.4307D-02,
41242      &0.3791D-02,0.3292D-02,0.2818D-02,0.2382D-02,0.1976D-02,0.1606D-02,
41243      &0.1275D-02,0.9866D-03,0.7403D-03,0.5351D-03,0.3713D-03,0.2450D-03,
41244      &0.1524D-03,0.8849D-04,0.4730D-04,0.2278D-04,0.9707D-05,0.3518D-05,
41245      &0.1041D-05,0.2356D-06,0.3682D-07,0.3365D-08,0.1333D-09,0.1188D-11,
41246      &0.6095D-12,0.3031D-12,0.1457D-12,0.6733D-13,0.2986D-13,0.1262D-13,
41247      &0.5060D-14,0.1912D-14,0.6734D-15,0.2199D-15,0.6498D-16,0.1729D-16,
41248      &0.4059D-17,0.8091D-18,0.1324D-18,0.1691D-19,0.1518D-20,0.8785D-22,
41249      &0.2519D-23,0.2197D-25,0.2840D-28,0.1908D-33/
41250       DATA (XPV(I,1,1),I=1,100)/
41251      &0.5848D-03,0.5838D-03,0.5793D-03,0.5713D-03,0.5597D-03,0.5447D-03,
41252      &0.5270D-03,0.5167D-03,0.5143D-03,0.5087D-03,0.4998D-03,0.4879D-03,
41253      &0.4731D-03,0.4599D-03,0.4584D-03,0.4538D-03,0.4461D-03,0.4355D-03,
41254      &0.4223D-03,0.4133D-03,0.4109D-03,0.4053D-03,0.3970D-03,0.3859D-03,
41255      &0.3763D-03,0.3739D-03,0.3686D-03,0.3605D-03,0.3504D-03,0.3473D-03,
41256      &0.3426D-03,0.3355D-03,0.3286D-03,0.3253D-03,0.3196D-03,0.3138D-03,
41257      &0.3102D-03,0.3047D-03,0.3014D-03,0.2971D-03,0.2939D-03,0.2901D-03,
41258      &0.2875D-03,0.2849D-03,0.2824D-03,0.2805D-03,0.2787D-03,0.2780D-03,
41259      &0.2772D-03,0.2771D-03,0.2773D-03,0.2784D-03,0.2799D-03,0.2820D-03,
41260      &0.2850D-03,0.2886D-03,0.2930D-03,0.2985D-03,0.3050D-03,0.3126D-03,
41261      &0.3215D-03,0.3316D-03,0.3432D-03,0.3564D-03,0.3714D-03,0.3883D-03,
41262      &0.4073D-03,0.4287D-03,0.4526D-03,0.4794D-03,0.5092D-03,0.5425D-03,
41263      &0.5796D-03,0.6207D-03,0.6664D-03,0.7171D-03,0.7733D-03,0.8356D-03,
41264      &0.8429D-03,0.8502D-03,0.8574D-03,0.8647D-03,0.8719D-03,0.8791D-03,
41265      &0.8863D-03,0.8935D-03,0.9007D-03,0.9079D-03,0.9151D-03,0.9222D-03,
41266      &0.9294D-03,0.9365D-03,0.9436D-03,0.9508D-03,0.9579D-03,0.9650D-03,
41267      &0.9720D-03,0.9791D-03,0.9862D-03,0.9932D-03/
41268       DATA (XPV(I,1,2),I=1,100)/
41269      &0.2339D-02,0.2335D-02,0.2317D-02,0.2285D-02,0.2239D-02,0.2179D-02,
41270      &0.2108D-02,0.2067D-02,0.2057D-02,0.2035D-02,0.1999D-02,0.1951D-02,
41271      &0.1892D-02,0.1840D-02,0.1833D-02,0.1815D-02,0.1784D-02,0.1742D-02,
41272      &0.1689D-02,0.1653D-02,0.1643D-02,0.1621D-02,0.1588D-02,0.1544D-02,
41273      &0.1505D-02,0.1496D-02,0.1474D-02,0.1442D-02,0.1402D-02,0.1389D-02,
41274      &0.1370D-02,0.1342D-02,0.1314D-02,0.1301D-02,0.1278D-02,0.1255D-02,
41275      &0.1241D-02,0.1219D-02,0.1205D-02,0.1188D-02,0.1176D-02,0.1160D-02,
41276      &0.1150D-02,0.1139D-02,0.1130D-02,0.1122D-02,0.1115D-02,0.1112D-02,
41277      &0.1109D-02,0.1108D-02,0.1109D-02,0.1114D-02,0.1120D-02,0.1128D-02,
41278      &0.1140D-02,0.1154D-02,0.1172D-02,0.1194D-02,0.1220D-02,0.1251D-02,
41279      &0.1286D-02,0.1326D-02,0.1373D-02,0.1426D-02,0.1485D-02,0.1553D-02,
41280      &0.1629D-02,0.1715D-02,0.1811D-02,0.1917D-02,0.2037D-02,0.2170D-02,
41281      &0.2318D-02,0.2483D-02,0.2666D-02,0.2868D-02,0.3093D-02,0.3342D-02,
41282      &0.3372D-02,0.3401D-02,0.3430D-02,0.3459D-02,0.3488D-02,0.3517D-02,
41283      &0.3545D-02,0.3574D-02,0.3603D-02,0.3632D-02,0.3660D-02,0.3689D-02,
41284      &0.3717D-02,0.3746D-02,0.3775D-02,0.3803D-02,0.3831D-02,0.3860D-02,
41285      &0.3888D-02,0.3916D-02,0.3945D-02,0.3973D-02/
41286       DATA (XPV(I,1,3),I=1,100)/
41287      &0.1755D-03,0.1751D-03,0.1738D-03,0.1714D-03,0.1679D-03,0.1634D-03,
41288      &0.1581D-03,0.1550D-03,0.1543D-03,0.1526D-03,0.1499D-03,0.1464D-03,
41289      &0.1419D-03,0.1380D-03,0.1375D-03,0.1361D-03,0.1338D-03,0.1306D-03,
41290      &0.1267D-03,0.1240D-03,0.1233D-03,0.1216D-03,0.1191D-03,0.1158D-03,
41291      &0.1129D-03,0.1122D-03,0.1106D-03,0.1082D-03,0.1051D-03,0.1042D-03,
41292      &0.1028D-03,0.1006D-03,0.9857D-04,0.9759D-04,0.9587D-04,0.9414D-04,
41293      &0.9305D-04,0.9140D-04,0.9041D-04,0.8912D-04,0.8817D-04,0.8702D-04,
41294      &0.8626D-04,0.8546D-04,0.8472D-04,0.8415D-04,0.8362D-04,0.8339D-04,
41295      &0.8317D-04,0.8312D-04,0.8318D-04,0.8352D-04,0.8398D-04,0.8459D-04,
41296      &0.8550D-04,0.8658D-04,0.8789D-04,0.8956D-04,0.9151D-04,0.9379D-04,
41297      &0.9644D-04,0.9948D-04,0.1030D-03,0.1069D-03,0.1114D-03,0.1165D-03,
41298      &0.1222D-03,0.1286D-03,0.1358D-03,0.1438D-03,0.1528D-03,0.1628D-03,
41299      &0.1739D-03,0.1862D-03,0.1999D-03,0.2151D-03,0.2320D-03,0.2507D-03,
41300      &0.2529D-03,0.2551D-03,0.2572D-03,0.2594D-03,0.2616D-03,0.2637D-03,
41301      &0.2659D-03,0.2681D-03,0.2702D-03,0.2724D-03,0.2745D-03,0.2767D-03,
41302      &0.2788D-03,0.2810D-03,0.2831D-03,0.2852D-03,0.2874D-03,0.2895D-03,
41303      &0.2916D-03,0.2937D-03,0.2959D-03,0.2980D-03/
41304       DATA (XPV(I,1,4),I=1,100)/
41305      &0.7018D-03,0.7006D-03,0.6951D-03,0.6855D-03,0.6716D-03,0.6537D-03,
41306      &0.6324D-03,0.6200D-03,0.6172D-03,0.6104D-03,0.5998D-03,0.5854D-03,
41307      &0.5677D-03,0.5519D-03,0.5500D-03,0.5445D-03,0.5353D-03,0.5226D-03,
41308      &0.5068D-03,0.4960D-03,0.4930D-03,0.4864D-03,0.4764D-03,0.4631D-03,
41309      &0.4516D-03,0.4487D-03,0.4423D-03,0.4326D-03,0.4205D-03,0.4167D-03,
41310      &0.4111D-03,0.4026D-03,0.3943D-03,0.3903D-03,0.3835D-03,0.3765D-03,
41311      &0.3722D-03,0.3656D-03,0.3616D-03,0.3565D-03,0.3527D-03,0.3481D-03,
41312      &0.3450D-03,0.3418D-03,0.3389D-03,0.3366D-03,0.3345D-03,0.3336D-03,
41313      &0.3327D-03,0.3325D-03,0.3327D-03,0.3341D-03,0.3359D-03,0.3383D-03,
41314      &0.3420D-03,0.3463D-03,0.3516D-03,0.3582D-03,0.3660D-03,0.3752D-03,
41315      &0.3858D-03,0.3979D-03,0.4118D-03,0.4277D-03,0.4456D-03,0.4660D-03,
41316      &0.4887D-03,0.5145D-03,0.5432D-03,0.5752D-03,0.6111D-03,0.6510D-03,
41317      &0.6955D-03,0.7448D-03,0.7997D-03,0.8605D-03,0.9280D-03,0.1003D-02,
41318      &0.1011D-02,0.1020D-02,0.1029D-02,0.1038D-02,0.1046D-02,0.1055D-02,
41319      &0.1064D-02,0.1072D-02,0.1081D-02,0.1089D-02,0.1098D-02,0.1107D-02,
41320      &0.1115D-02,0.1124D-02,0.1132D-02,0.1141D-02,0.1149D-02,0.1158D-02,
41321      &0.1166D-02,0.1175D-02,0.1183D-02,0.1192D-02/
41322       DATA (XPV(I,2,0),I=1,100)/
41323      &0.1024D+00,0.1007D+00,0.9821D-01,0.9497D-01,0.9093D-01,0.8617D-01,
41324      &0.8086D-01,0.7731D-01,0.7566D-01,0.7338D-01,0.7048D-01,0.6700D-01,
41325      &0.6300D-01,0.5939D-01,0.5814D-01,0.5638D-01,0.5410D-01,0.5135D-01,
41326      &0.4819D-01,0.4580D-01,0.4460D-01,0.4293D-01,0.4087D-01,0.3843D-01,
41327      &0.3624D-01,0.3517D-01,0.3372D-01,0.3192D-01,0.2988D-01,0.2879D-01,
41328      &0.2755D-01,0.2602D-01,0.2454D-01,0.2352D-01,0.2224D-01,0.2097D-01,
41329      &0.1995D-01,0.1875D-01,0.1779D-01,0.1673D-01,0.1580D-01,0.1480D-01,
41330      &0.1393D-01,0.1305D-01,0.1218D-01,0.1136D-01,0.1055D-01,0.9801D-02,
41331      &0.9052D-02,0.8337D-02,0.7641D-02,0.6989D-02,0.6357D-02,0.5747D-02,
41332      &0.5179D-02,0.4637D-02,0.4127D-02,0.3663D-02,0.3232D-02,0.2840D-02,
41333      &0.2487D-02,0.2174D-02,0.1901D-02,0.1662D-02,0.1459D-02,0.1285D-02,
41334      &0.1137D-02,0.1010D-02,0.9006D-03,0.8023D-03,0.7126D-03,0.6276D-03,
41335      &0.5458D-03,0.4661D-03,0.3876D-03,0.3101D-03,0.2334D-03,0.1570D-03,
41336      &0.1486D-03,0.1404D-03,0.1322D-03,0.1242D-03,0.1162D-03,0.1084D-03,
41337      &0.1007D-03,0.9304D-04,0.8554D-04,0.7817D-04,0.7086D-04,0.6372D-04,
41338      &0.5670D-04,0.4982D-04,0.4307D-04,0.3647D-04,0.3005D-04,0.2382D-04,
41339      &0.1781D-04,0.1208D-04,0.6720D-05,0.1928D-05/
41340       DATA (XPV(I,2,1),I=1,100)/
41341      &0.1449D-02,0.1433D-02,0.1407D-02,0.1370D-02,0.1324D-02,0.1268D-02,
41342      &0.1204D-02,0.1163D-02,0.1147D-02,0.1123D-02,0.1089D-02,0.1048D-02,
41343      &0.1000D-02,0.9567D-03,0.9446D-03,0.9250D-03,0.8981D-03,0.8642D-03,
41344      &0.8244D-03,0.7951D-03,0.7821D-03,0.7623D-03,0.7362D-03,0.7043D-03,
41345      &0.6759D-03,0.6640D-03,0.6459D-03,0.6223D-03,0.5945D-03,0.5817D-03,
41346      &0.5660D-03,0.5455D-03,0.5256D-03,0.5132D-03,0.4963D-03,0.4794D-03,
41347      &0.4669D-03,0.4510D-03,0.4394D-03,0.4261D-03,0.4151D-03,0.4031D-03,
41348      &0.3934D-03,0.3838D-03,0.3747D-03,0.3666D-03,0.3591D-03,0.3533D-03,
41349      &0.3477D-03,0.3433D-03,0.3397D-03,0.3376D-03,0.3364D-03,0.3361D-03,
41350      &0.3375D-03,0.3399D-03,0.3437D-03,0.3492D-03,0.3562D-03,0.3648D-03,
41351      &0.3751D-03,0.3871D-03,0.4009D-03,0.4167D-03,0.4344D-03,0.4543D-03,
41352      &0.4760D-03,0.5003D-03,0.5268D-03,0.5558D-03,0.5876D-03,0.6226D-03,
41353      &0.6610D-03,0.7035D-03,0.7509D-03,0.8041D-03,0.8638D-03,0.9294D-03,
41354      &0.9367D-03,0.9440D-03,0.9511D-03,0.9581D-03,0.9648D-03,0.9714D-03,
41355      &0.9776D-03,0.9836D-03,0.9891D-03,0.9942D-03,0.9987D-03,0.1003D-02,
41356      &0.1006D-02,0.1008D-02,0.1008D-02,0.1007D-02,0.1004D-02,0.9977D-03,
41357      &0.9868D-03,0.9681D-03,0.9347D-03,0.8678D-03/
41358       DATA (XPV(I,2,2),I=1,100)/
41359      &0.3175D-02,0.3156D-02,0.3117D-02,0.3057D-02,0.2976D-02,0.2876D-02,
41360      &0.2760D-02,0.2689D-02,0.2666D-02,0.2625D-02,0.2566D-02,0.2489D-02,
41361      &0.2398D-02,0.2316D-02,0.2299D-02,0.2266D-02,0.2217D-02,0.2152D-02,
41362      &0.2073D-02,0.2018D-02,0.1998D-02,0.1962D-02,0.1911D-02,0.1847D-02,
41363      &0.1791D-02,0.1773D-02,0.1739D-02,0.1692D-02,0.1636D-02,0.1614D-02,
41364      &0.1586D-02,0.1545D-02,0.1506D-02,0.1485D-02,0.1452D-02,0.1420D-02,
41365      &0.1398D-02,0.1368D-02,0.1348D-02,0.1324D-02,0.1306D-02,0.1285D-02,
41366      &0.1271D-02,0.1256D-02,0.1243D-02,0.1233D-02,0.1224D-02,0.1220D-02,
41367      &0.1217D-02,0.1217D-02,0.1220D-02,0.1227D-02,0.1237D-02,0.1249D-02,
41368      &0.1267D-02,0.1288D-02,0.1313D-02,0.1345D-02,0.1381D-02,0.1422D-02,
41369      &0.1469D-02,0.1522D-02,0.1582D-02,0.1648D-02,0.1722D-02,0.1804D-02,
41370      &0.1893D-02,0.1992D-02,0.2099D-02,0.2216D-02,0.2345D-02,0.2486D-02,
41371      &0.2641D-02,0.2812D-02,0.3002D-02,0.3216D-02,0.3455D-02,0.3718D-02,
41372      &0.3748D-02,0.3777D-02,0.3806D-02,0.3833D-02,0.3861D-02,0.3887D-02,
41373      &0.3912D-02,0.3936D-02,0.3958D-02,0.3978D-02,0.3996D-02,0.4012D-02,
41374      &0.4024D-02,0.4032D-02,0.4035D-02,0.4031D-02,0.4018D-02,0.3993D-02,
41375      &0.3949D-02,0.3875D-02,0.3741D-02,0.3474D-02/
41376       DATA (XPV(I,2,3),I=1,100)/
41377      &0.1046D-02,0.1031D-02,0.1008D-02,0.9768D-03,0.9381D-03,0.8923D-03,
41378      &0.8410D-03,0.8074D-03,0.7928D-03,0.7720D-03,0.7450D-03,0.7121D-03,
41379      &0.6741D-03,0.6398D-03,0.6287D-03,0.6123D-03,0.5906D-03,0.5640D-03,
41380      &0.5332D-03,0.5101D-03,0.4988D-03,0.4827D-03,0.4624D-03,0.4380D-03,
41381      &0.4161D-03,0.4059D-03,0.3914D-03,0.3732D-03,0.3524D-03,0.3416D-03,
41382      &0.3290D-03,0.3133D-03,0.2981D-03,0.2878D-03,0.2747D-03,0.2616D-03,
41383      &0.2515D-03,0.2392D-03,0.2296D-03,0.2191D-03,0.2100D-03,0.2004D-03,
41384      &0.1923D-03,0.1842D-03,0.1764D-03,0.1694D-03,0.1627D-03,0.1571D-03,
41385      &0.1517D-03,0.1469D-03,0.1427D-03,0.1394D-03,0.1367D-03,0.1345D-03,
41386      &0.1333D-03,0.1327D-03,0.1329D-03,0.1340D-03,0.1360D-03,0.1387D-03,
41387      &0.1424D-03,0.1469D-03,0.1522D-03,0.1584D-03,0.1654D-03,0.1733D-03,
41388      &0.1819D-03,0.1915D-03,0.2019D-03,0.2132D-03,0.2257D-03,0.2396D-03,
41389      &0.2553D-03,0.2737D-03,0.2956D-03,0.3227D-03,0.3570D-03,0.4009D-03,
41390      &0.4064D-03,0.4119D-03,0.4175D-03,0.4231D-03,0.4287D-03,0.4344D-03,
41391      &0.4400D-03,0.4457D-03,0.4512D-03,0.4567D-03,0.4621D-03,0.4673D-03,
41392      &0.4723D-03,0.4769D-03,0.4811D-03,0.4848D-03,0.4875D-03,0.4891D-03,
41393      &0.4888D-03,0.4853D-03,0.4756D-03,0.4518D-03/
41394       DATA (XPV(I,2,4),I=1,100)/
41395      &0.1564D-02,0.1548D-02,0.1521D-02,0.1483D-02,0.1434D-02,0.1375D-02,
41396      &0.1308D-02,0.1265D-02,0.1249D-02,0.1223D-02,0.1188D-02,0.1145D-02,
41397      &0.1094D-02,0.1048D-02,0.1035D-02,0.1015D-02,0.9868D-03,0.9509D-03,
41398      &0.9086D-03,0.8776D-03,0.8644D-03,0.8436D-03,0.8161D-03,0.7822D-03,
41399      &0.7521D-03,0.7400D-03,0.7212D-03,0.6963D-03,0.6669D-03,0.6538D-03,
41400      &0.6377D-03,0.6163D-03,0.5956D-03,0.5832D-03,0.5658D-03,0.5486D-03,
41401      &0.5363D-03,0.5203D-03,0.5091D-03,0.4962D-03,0.4859D-03,0.4746D-03,
41402      &0.4661D-03,0.4578D-03,0.4502D-03,0.4441D-03,0.4387D-03,0.4355D-03,
41403      &0.4329D-03,0.4318D-03,0.4320D-03,0.4342D-03,0.4379D-03,0.4429D-03,
41404      &0.4503D-03,0.4594D-03,0.4704D-03,0.4839D-03,0.4996D-03,0.5177D-03,
41405      &0.5383D-03,0.5613D-03,0.5869D-03,0.6152D-03,0.6462D-03,0.6802D-03,
41406      &0.7167D-03,0.7565D-03,0.7995D-03,0.8461D-03,0.8972D-03,0.9538D-03,
41407      &0.1018D-02,0.1092D-02,0.1181D-02,0.1290D-02,0.1428D-02,0.1604D-02,
41408      &0.1626D-02,0.1649D-02,0.1671D-02,0.1694D-02,0.1716D-02,0.1739D-02,
41409      &0.1762D-02,0.1784D-02,0.1806D-02,0.1828D-02,0.1850D-02,0.1871D-02,
41410      &0.1891D-02,0.1909D-02,0.1926D-02,0.1941D-02,0.1952D-02,0.1958D-02,
41411      &0.1957D-02,0.1943D-02,0.1905D-02,0.1811D-02/
41412       DATA (XPV(I,3,0),I=1,100)/
41413      &0.1761D+00,0.1728D+00,0.1680D+00,0.1619D+00,0.1544D+00,0.1456D+00,
41414      &0.1358D+00,0.1292D+00,0.1260D+00,0.1218D+00,0.1165D+00,0.1101D+00,
41415      &0.1029D+00,0.9643D-01,0.9409D-01,0.9087D-01,0.8680D-01,0.8192D-01,
41416      &0.7638D-01,0.7217D-01,0.7000D-01,0.6708D-01,0.6352D-01,0.5934D-01,
41417      &0.5561D-01,0.5375D-01,0.5129D-01,0.4829D-01,0.4491D-01,0.4309D-01,
41418      &0.4104D-01,0.3857D-01,0.3618D-01,0.3454D-01,0.3252D-01,0.3053D-01,
41419      &0.2896D-01,0.2712D-01,0.2565D-01,0.2407D-01,0.2268D-01,0.2123D-01,
41420      &0.1997D-01,0.1870D-01,0.1748D-01,0.1634D-01,0.1523D-01,0.1422D-01,
41421      &0.1321D-01,0.1227D-01,0.1137D-01,0.1053D-01,0.9723D-02,0.8952D-02,
41422      &0.8241D-02,0.7563D-02,0.6926D-02,0.6345D-02,0.5801D-02,0.5298D-02,
41423      &0.4833D-02,0.4407D-02,0.4017D-02,0.3657D-02,0.3327D-02,0.3021D-02,
41424      &0.2735D-02,0.2469D-02,0.2217D-02,0.1976D-02,0.1746D-02,0.1522D-02,
41425      &0.1307D-02,0.1098D-02,0.8959D-03,0.7002D-03,0.5112D-03,0.3292D-03,
41426      &0.3097D-03,0.2906D-03,0.2718D-03,0.2534D-03,0.2354D-03,0.2178D-03,
41427      &0.2005D-03,0.1836D-03,0.1672D-03,0.1511D-03,0.1354D-03,0.1203D-03,
41428      &0.1055D-03,0.9128D-04,0.7756D-04,0.6440D-04,0.5185D-04,0.3998D-04,
41429      &0.2891D-04,0.1876D-04,0.9776D-05,0.2464D-05/
41430       DATA (XPV(I,3,1),I=1,100)/
41431      &0.3351D-02,0.3297D-02,0.3217D-02,0.3112D-02,0.2981D-02,0.2828D-02,
41432      &0.2656D-02,0.2543D-02,0.2493D-02,0.2422D-02,0.2332D-02,0.2223D-02,
41433      &0.2097D-02,0.1984D-02,0.1946D-02,0.1892D-02,0.1821D-02,0.1734D-02,
41434      &0.1635D-02,0.1560D-02,0.1523D-02,0.1471D-02,0.1406D-02,0.1329D-02,
41435      &0.1260D-02,0.1228D-02,0.1182D-02,0.1126D-02,0.1061D-02,0.1028D-02,
41436      &0.9902D-03,0.9426D-03,0.8967D-03,0.8664D-03,0.8274D-03,0.7890D-03,
41437      &0.7596D-03,0.7240D-03,0.6969D-03,0.6671D-03,0.6417D-03,0.6149D-03,
41438      &0.5928D-03,0.5708D-03,0.5502D-03,0.5317D-03,0.5144D-03,0.5002D-03,
41439      &0.4867D-03,0.4753D-03,0.4655D-03,0.4582D-03,0.4526D-03,0.4487D-03,
41440      &0.4475D-03,0.4480D-03,0.4506D-03,0.4559D-03,0.4632D-03,0.4729D-03,
41441      &0.4849D-03,0.4991D-03,0.5155D-03,0.5343D-03,0.5552D-03,0.5783D-03,
41442      &0.6033D-03,0.6307D-03,0.6600D-03,0.6915D-03,0.7256D-03,0.7626D-03,
41443      &0.8031D-03,0.8482D-03,0.8993D-03,0.9582D-03,0.1026D-02,0.1099D-02,
41444      &0.1107D-02,0.1115D-02,0.1122D-02,0.1129D-02,0.1136D-02,0.1142D-02,
41445      &0.1148D-02,0.1152D-02,0.1156D-02,0.1159D-02,0.1161D-02,0.1161D-02,
41446      &0.1160D-02,0.1156D-02,0.1150D-02,0.1141D-02,0.1127D-02,0.1107D-02,
41447      &0.1078D-02,0.1036D-02,0.9685D-03,0.8413D-03/
41448       DATA (XPV(I,3,2),I=1,100)/
41449      &0.5039D-02,0.4982D-02,0.4889D-02,0.4761D-02,0.4597D-02,0.4401D-02,
41450      &0.4179D-02,0.4036D-02,0.3979D-02,0.3893D-02,0.3777D-02,0.3634D-02,
41451      &0.3466D-02,0.3315D-02,0.3273D-02,0.3206D-02,0.3114D-02,0.2997D-02,
41452      &0.2860D-02,0.2760D-02,0.2717D-02,0.2650D-02,0.2562D-02,0.2454D-02,
41453      &0.2359D-02,0.2321D-02,0.2262D-02,0.2184D-02,0.2092D-02,0.2052D-02,
41454      &0.2003D-02,0.1938D-02,0.1875D-02,0.1839D-02,0.1787D-02,0.1736D-02,
41455      &0.1700D-02,0.1653D-02,0.1622D-02,0.1585D-02,0.1557D-02,0.1526D-02,
41456      &0.1504D-02,0.1483D-02,0.1464D-02,0.1450D-02,0.1438D-02,0.1433D-02,
41457      &0.1430D-02,0.1432D-02,0.1438D-02,0.1450D-02,0.1466D-02,0.1487D-02,
41458      &0.1515D-02,0.1547D-02,0.1585D-02,0.1631D-02,0.1683D-02,0.1742D-02,
41459      &0.1808D-02,0.1880D-02,0.1960D-02,0.2048D-02,0.2142D-02,0.2245D-02,
41460      &0.2354D-02,0.2471D-02,0.2596D-02,0.2729D-02,0.2872D-02,0.3025D-02,
41461      &0.3193D-02,0.3378D-02,0.3587D-02,0.3827D-02,0.4100D-02,0.4397D-02,
41462      &0.4429D-02,0.4461D-02,0.4490D-02,0.4519D-02,0.4545D-02,0.4570D-02,
41463      &0.4592D-02,0.4611D-02,0.4627D-02,0.4639D-02,0.4646D-02,0.4647D-02,
41464      &0.4642D-02,0.4628D-02,0.4604D-02,0.4566D-02,0.4510D-02,0.4431D-02,
41465      &0.4317D-02,0.4147D-02,0.3877D-02,0.3370D-02/
41466       DATA (XPV(I,3,3),I=1,100)/
41467      &0.2958D-02,0.2904D-02,0.2827D-02,0.2727D-02,0.2604D-02,0.2461D-02,
41468      &0.2301D-02,0.2195D-02,0.2146D-02,0.2079D-02,0.1995D-02,0.1894D-02,
41469      &0.1778D-02,0.1674D-02,0.1637D-02,0.1586D-02,0.1520D-02,0.1440D-02,
41470      &0.1349D-02,0.1280D-02,0.1245D-02,0.1197D-02,0.1138D-02,0.1068D-02,
41471      &0.1005D-02,0.9742D-03,0.9325D-03,0.8812D-03,0.8233D-03,0.7922D-03,
41472      &0.7568D-03,0.7138D-03,0.6722D-03,0.6438D-03,0.6084D-03,0.5735D-03,
41473      &0.5460D-03,0.5138D-03,0.4883D-03,0.4609D-03,0.4371D-03,0.4123D-03,
41474      &0.3912D-03,0.3704D-03,0.3507D-03,0.3327D-03,0.3158D-03,0.3012D-03,
41475      &0.2873D-03,0.2751D-03,0.2641D-03,0.2551D-03,0.2474D-03,0.2410D-03,
41476      &0.2365D-03,0.2334D-03,0.2318D-03,0.2321D-03,0.2339D-03,0.2372D-03,
41477      &0.2421D-03,0.2485D-03,0.2562D-03,0.2652D-03,0.2755D-03,0.2870D-03,
41478      &0.2995D-03,0.3131D-03,0.3278D-03,0.3438D-03,0.3615D-03,0.3814D-03,
41479      &0.4046D-03,0.4328D-03,0.4682D-03,0.5142D-03,0.5747D-03,0.6529D-03,
41480      &0.6625D-03,0.6722D-03,0.6819D-03,0.6916D-03,0.7012D-03,0.7107D-03,
41481      &0.7200D-03,0.7292D-03,0.7380D-03,0.7464D-03,0.7544D-03,0.7617D-03,
41482      &0.7681D-03,0.7735D-03,0.7776D-03,0.7798D-03,0.7796D-03,0.7761D-03,
41483      &0.7676D-03,0.7510D-03,0.7195D-03,0.6522D-03/
41484       DATA (XPV(I,3,4),I=1,100)/
41485      &0.3464D-02,0.3410D-02,0.3329D-02,0.3222D-02,0.3090D-02,0.2933D-02,
41486      &0.2758D-02,0.2643D-02,0.2593D-02,0.2521D-02,0.2430D-02,0.2318D-02,
41487      &0.2190D-02,0.2075D-02,0.2037D-02,0.1982D-02,0.1910D-02,0.1821D-02,
41488      &0.1720D-02,0.1643D-02,0.1607D-02,0.1554D-02,0.1489D-02,0.1410D-02,
41489      &0.1340D-02,0.1308D-02,0.1262D-02,0.1205D-02,0.1140D-02,0.1108D-02,
41490      &0.1070D-02,0.1023D-02,0.9772D-03,0.9482D-03,0.9103D-03,0.8732D-03,
41491      &0.8458D-03,0.8121D-03,0.7877D-03,0.7607D-03,0.7388D-03,0.7157D-03,
41492      &0.6981D-03,0.6812D-03,0.6662D-03,0.6540D-03,0.6438D-03,0.6377D-03,
41493      &0.6331D-03,0.6316D-03,0.6326D-03,0.6376D-03,0.6453D-03,0.6560D-03,
41494      &0.6708D-03,0.6887D-03,0.7102D-03,0.7361D-03,0.7656D-03,0.7991D-03,
41495      &0.8365D-03,0.8777D-03,0.9226D-03,0.9714D-03,0.1024D-02,0.1080D-02,
41496      &0.1138D-02,0.1201D-02,0.1267D-02,0.1338D-02,0.1415D-02,0.1501D-02,
41497      &0.1599D-02,0.1717D-02,0.1863D-02,0.2051D-02,0.2296D-02,0.2612D-02,
41498      &0.2650D-02,0.2689D-02,0.2729D-02,0.2767D-02,0.2806D-02,0.2844D-02,
41499      &0.2882D-02,0.2919D-02,0.2954D-02,0.2988D-02,0.3020D-02,0.3049D-02,
41500      &0.3075D-02,0.3097D-02,0.3114D-02,0.3123D-02,0.3122D-02,0.3108D-02,
41501      &0.3074D-02,0.3008D-02,0.2881D-02,0.2614D-02/
41502       DATA (XPV(I,4,0),I=1,100)/
41503      &0.2113D+00,0.2071D+00,0.2012D+00,0.1936D+00,0.1844D+00,0.1736D+00,
41504      &0.1616D+00,0.1536D+00,0.1497D+00,0.1445D+00,0.1380D+00,0.1303D+00,
41505      &0.1215D+00,0.1136D+00,0.1108D+00,0.1069D+00,0.1019D+00,0.9605D-01,
41506      &0.8939D-01,0.8432D-01,0.8171D-01,0.7821D-01,0.7395D-01,0.6897D-01,
41507      &0.6452D-01,0.6231D-01,0.5938D-01,0.5583D-01,0.5185D-01,0.4969D-01,
41508      &0.4728D-01,0.4438D-01,0.4158D-01,0.3967D-01,0.3731D-01,0.3500D-01,
41509      &0.3318D-01,0.3105D-01,0.2936D-01,0.2754D-01,0.2595D-01,0.2429D-01,
41510      &0.2285D-01,0.2141D-01,0.2003D-01,0.1874D-01,0.1749D-01,0.1635D-01,
41511      &0.1523D-01,0.1418D-01,0.1317D-01,0.1223D-01,0.1134D-01,0.1048D-01,
41512      &0.9692D-02,0.8938D-02,0.8227D-02,0.7578D-02,0.6967D-02,0.6398D-02,
41513      &0.5867D-02,0.5377D-02,0.4922D-02,0.4497D-02,0.4101D-02,0.3730D-02,
41514      &0.3379D-02,0.3048D-02,0.2732D-02,0.2429D-02,0.2139D-02,0.1858D-02,
41515      &0.1588D-02,0.1328D-02,0.1077D-02,0.8361D-03,0.6052D-03,0.3850D-03,
41516      &0.3616D-03,0.3387D-03,0.3162D-03,0.2943D-03,0.2728D-03,0.2518D-03,
41517      &0.2314D-03,0.2114D-03,0.1919D-03,0.1731D-03,0.1546D-03,0.1369D-03,
41518      &0.1197D-03,0.1032D-03,0.8729D-04,0.7214D-04,0.5778D-04,0.4429D-04,
41519      &0.3179D-04,0.2044D-04,0.1053D-04,0.2601D-05/
41520       DATA (XPV(I,4,1),I=1,100)/
41521      &0.4299D-02,0.4223D-02,0.4115D-02,0.3974D-02,0.3799D-02,0.3595D-02,
41522      &0.3367D-02,0.3216D-02,0.3148D-02,0.3054D-02,0.2934D-02,0.2790D-02,
41523      &0.2625D-02,0.2476D-02,0.2426D-02,0.2353D-02,0.2260D-02,0.2147D-02,
41524      &0.2018D-02,0.1920D-02,0.1871D-02,0.1804D-02,0.1720D-02,0.1620D-02,
41525      &0.1532D-02,0.1489D-02,0.1431D-02,0.1359D-02,0.1277D-02,0.1234D-02,
41526      &0.1185D-02,0.1125D-02,0.1067D-02,0.1028D-02,0.9791D-03,0.9308D-03,
41527      &0.8936D-03,0.8491D-03,0.8150D-03,0.7777D-03,0.7459D-03,0.7125D-03,
41528      &0.6849D-03,0.6575D-03,0.6318D-03,0.6088D-03,0.5872D-03,0.5693D-03,
41529      &0.5524D-03,0.5380D-03,0.5254D-03,0.5159D-03,0.5084D-03,0.5028D-03,
41530      &0.5003D-03,0.4998D-03,0.5017D-03,0.5066D-03,0.5139D-03,0.5237D-03,
41531      &0.5360D-03,0.5508D-03,0.5679D-03,0.5875D-03,0.6093D-03,0.6334D-03,
41532      &0.6593D-03,0.6876D-03,0.7177D-03,0.7500D-03,0.7848D-03,0.8225D-03,
41533      &0.8639D-03,0.9103D-03,0.9634D-03,0.1025D-02,0.1097D-02,0.1174D-02,
41534      &0.1183D-02,0.1191D-02,0.1199D-02,0.1206D-02,0.1212D-02,0.1219D-02,
41535      &0.1224D-02,0.1229D-02,0.1232D-02,0.1235D-02,0.1236D-02,0.1235D-02,
41536      &0.1232D-02,0.1227D-02,0.1219D-02,0.1207D-02,0.1190D-02,0.1167D-02,
41537      &0.1133D-02,0.1085D-02,0.1009D-02,0.8680D-03/
41538       DATA (XPV(I,4,2),I=1,100)/
41539      &0.5972D-02,0.5895D-02,0.5773D-02,0.5610D-02,0.5402D-02,0.5156D-02,
41540      &0.4878D-02,0.4698D-02,0.4623D-02,0.4513D-02,0.4369D-02,0.4191D-02,
41541      &0.3984D-02,0.3798D-02,0.3743D-02,0.3659D-02,0.3544D-02,0.3402D-02,
41542      &0.3235D-02,0.3113D-02,0.3058D-02,0.2976D-02,0.2870D-02,0.2740D-02,
41543      &0.2626D-02,0.2578D-02,0.2507D-02,0.2414D-02,0.2305D-02,0.2257D-02,
41544      &0.2198D-02,0.2121D-02,0.2046D-02,0.2003D-02,0.1942D-02,0.1882D-02,
41545      &0.1840D-02,0.1786D-02,0.1749D-02,0.1707D-02,0.1674D-02,0.1639D-02,
41546      &0.1613D-02,0.1589D-02,0.1567D-02,0.1551D-02,0.1538D-02,0.1533D-02,
41547      &0.1530D-02,0.1533D-02,0.1540D-02,0.1554D-02,0.1573D-02,0.1597D-02,
41548      &0.1628D-02,0.1665D-02,0.1709D-02,0.1760D-02,0.1818D-02,0.1884D-02,
41549      &0.1957D-02,0.2038D-02,0.2125D-02,0.2221D-02,0.2324D-02,0.2434D-02,
41550      &0.2551D-02,0.2676D-02,0.2807D-02,0.2946D-02,0.3095D-02,0.3254D-02,
41551      &0.3428D-02,0.3621D-02,0.3839D-02,0.4092D-02,0.4382D-02,0.4698D-02,
41552      &0.4731D-02,0.4764D-02,0.4795D-02,0.4824D-02,0.4851D-02,0.4876D-02,
41553      &0.4898D-02,0.4917D-02,0.4931D-02,0.4941D-02,0.4945D-02,0.4943D-02,
41554      &0.4933D-02,0.4913D-02,0.4881D-02,0.4833D-02,0.4766D-02,0.4671D-02,
41555      &0.4538D-02,0.4344D-02,0.4039D-02,0.3475D-02/
41556       DATA (XPV(I,4,3),I=1,100)/
41557      &0.3908D-02,0.3834D-02,0.3728D-02,0.3592D-02,0.3425D-02,0.3231D-02,
41558      &0.3015D-02,0.2871D-02,0.2804D-02,0.2714D-02,0.2600D-02,0.2464D-02,
41559      &0.2309D-02,0.2169D-02,0.2119D-02,0.2050D-02,0.1962D-02,0.1855D-02,
41560      &0.1735D-02,0.1643D-02,0.1596D-02,0.1532D-02,0.1453D-02,0.1361D-02,
41561      &0.1278D-02,0.1237D-02,0.1183D-02,0.1116D-02,0.1040D-02,0.9992D-03,
41562      &0.9531D-03,0.8972D-03,0.8434D-03,0.8065D-03,0.7608D-03,0.7159D-03,
41563      &0.6806D-03,0.6392D-03,0.6067D-03,0.5717D-03,0.5414D-03,0.5098D-03,
41564      &0.4831D-03,0.4567D-03,0.4317D-03,0.4090D-03,0.3877D-03,0.3693D-03,
41565      &0.3517D-03,0.3363D-03,0.3224D-03,0.3109D-03,0.3010D-03,0.2928D-03,
41566      &0.2869D-03,0.2826D-03,0.2801D-03,0.2799D-03,0.2814D-03,0.2848D-03,
41567      &0.2899D-03,0.2967D-03,0.3051D-03,0.3151D-03,0.3263D-03,0.3390D-03,
41568      &0.3528D-03,0.3678D-03,0.3841D-03,0.4018D-03,0.4214D-03,0.4437D-03,
41569      &0.4700D-03,0.5022D-03,0.5431D-03,0.5965D-03,0.6670D-03,0.7574D-03,
41570      &0.7684D-03,0.7795D-03,0.7905D-03,0.8015D-03,0.8124D-03,0.8230D-03,
41571      &0.8335D-03,0.8436D-03,0.8533D-03,0.8624D-03,0.8708D-03,0.8784D-03,
41572      &0.8849D-03,0.8901D-03,0.8934D-03,0.8945D-03,0.8925D-03,0.8863D-03,
41573      &0.8739D-03,0.8517D-03,0.8113D-03,0.7282D-03/
41574       DATA (XPV(I,4,4),I=1,100)/
41575      &0.4411D-02,0.4336D-02,0.4226D-02,0.4084D-02,0.3907D-02,0.3700D-02,
41576      &0.3469D-02,0.3316D-02,0.3248D-02,0.3153D-02,0.3032D-02,0.2886D-02,
41577      &0.2718D-02,0.2567D-02,0.2516D-02,0.2444D-02,0.2349D-02,0.2235D-02,
41578      &0.2103D-02,0.2004D-02,0.1956D-02,0.1888D-02,0.1804D-02,0.1703D-02,
41579      &0.1613D-02,0.1571D-02,0.1514D-02,0.1441D-02,0.1359D-02,0.1317D-02,
41580      &0.1269D-02,0.1210D-02,0.1153D-02,0.1116D-02,0.1069D-02,0.1022D-02,
41581      &0.9882D-03,0.9465D-03,0.9161D-03,0.8828D-03,0.8558D-03,0.8276D-03,
41582      &0.8060D-03,0.7854D-03,0.7672D-03,0.7526D-03,0.7404D-03,0.7330D-03,
41583      &0.7277D-03,0.7261D-03,0.7277D-03,0.7338D-03,0.7434D-03,0.7565D-03,
41584      &0.7745D-03,0.7963D-03,0.8222D-03,0.8532D-03,0.8886D-03,0.9283D-03,
41585      &0.9728D-03,0.1021D-02,0.1074D-02,0.1131D-02,0.1192D-02,0.1257D-02,
41586      &0.1325D-02,0.1397D-02,0.1473D-02,0.1554D-02,0.1642D-02,0.1739D-02,
41587      &0.1852D-02,0.1988D-02,0.2158D-02,0.2377D-02,0.2664D-02,0.3029D-02,
41588      &0.3074D-02,0.3119D-02,0.3163D-02,0.3207D-02,0.3251D-02,0.3294D-02,
41589      &0.3336D-02,0.3377D-02,0.3416D-02,0.3452D-02,0.3486D-02,0.3517D-02,
41590      &0.3543D-02,0.3564D-02,0.3578D-02,0.3582D-02,0.3574D-02,0.3549D-02,
41591      &0.3500D-02,0.3411D-02,0.3249D-02,0.2916D-02/
41592       DATA (XPV(I,5,0),I=1,100)/
41593      &0.3395D+00,0.3321D+00,0.3219D+00,0.3090D+00,0.2933D+00,0.2751D+00,
41594      &0.2550D+00,0.2414D+00,0.2348D+00,0.2261D+00,0.2153D+00,0.2025D+00,
41595      &0.1881D+00,0.1751D+00,0.1704D+00,0.1640D+00,0.1559D+00,0.1464D+00,
41596      &0.1357D+00,0.1276D+00,0.1233D+00,0.1178D+00,0.1110D+00,0.1032D+00,
41597      &0.9616D-01,0.9268D-01,0.8813D-01,0.8262D-01,0.7648D-01,0.7317D-01,
41598      &0.6948D-01,0.6506D-01,0.6083D-01,0.5795D-01,0.5442D-01,0.5097D-01,
41599      &0.4827D-01,0.4513D-01,0.4265D-01,0.4000D-01,0.3769D-01,0.3529D-01,
41600      &0.3322D-01,0.3117D-01,0.2920D-01,0.2737D-01,0.2561D-01,0.2402D-01,
41601      &0.2245D-01,0.2098D-01,0.1958D-01,0.1829D-01,0.1704D-01,0.1585D-01,
41602      &0.1476D-01,0.1370D-01,0.1270D-01,0.1178D-01,0.1090D-01,0.1007D-01,
41603      &0.9286D-02,0.8547D-02,0.7848D-02,0.7182D-02,0.6551D-02,0.5949D-02,
41604      &0.5372D-02,0.4823D-02,0.4298D-02,0.3794D-02,0.3314D-02,0.2852D-02,
41605      &0.2413D-02,0.1995D-02,0.1599D-02,0.1223D-02,0.8693D-03,0.5397D-03,
41606      &0.5052D-03,0.4716D-03,0.4388D-03,0.4068D-03,0.3757D-03,0.3454D-03,
41607      &0.3160D-03,0.2875D-03,0.2599D-03,0.2332D-03,0.2073D-03,0.1825D-03,
41608      &0.1587D-03,0.1359D-03,0.1142D-03,0.9370D-04,0.7445D-04,0.5655D-04,
41609      &0.4018D-04,0.2553D-04,0.1296D-04,0.3149D-05/
41610       DATA (XPV(I,5,1),I=1,100)/
41611      &0.7886D-02,0.7728D-02,0.7505D-02,0.7221D-02,0.6873D-02,0.6469D-02,
41612      &0.6022D-02,0.5723D-02,0.5585D-02,0.5398D-02,0.5164D-02,0.4885D-02,
41613      &0.4568D-02,0.4283D-02,0.4181D-02,0.4041D-02,0.3864D-02,0.3650D-02,
41614      &0.3408D-02,0.3225D-02,0.3131D-02,0.3005D-02,0.2850D-02,0.2668D-02,
41615      &0.2506D-02,0.2427D-02,0.2321D-02,0.2191D-02,0.2045D-02,0.1968D-02,
41616      &0.1880D-02,0.1774D-02,0.1672D-02,0.1604D-02,0.1519D-02,0.1435D-02,
41617      &0.1371D-02,0.1295D-02,0.1236D-02,0.1172D-02,0.1118D-02,0.1062D-02,
41618      &0.1015D-02,0.9690D-03,0.9257D-03,0.8867D-03,0.8503D-03,0.8197D-03,
41619      &0.7906D-03,0.7655D-03,0.7432D-03,0.7255D-03,0.7107D-03,0.6987D-03,
41620      &0.6911D-03,0.6864D-03,0.6850D-03,0.6876D-03,0.6934D-03,0.7025D-03,
41621      &0.7147D-03,0.7300D-03,0.7482D-03,0.7692D-03,0.7926D-03,0.8187D-03,
41622      &0.8465D-03,0.8768D-03,0.9089D-03,0.9431D-03,0.9801D-03,0.1020D-02,
41623      &0.1065D-02,0.1116D-02,0.1177D-02,0.1250D-02,0.1336D-02,0.1431D-02,
41624      &0.1441D-02,0.1451D-02,0.1460D-02,0.1468D-02,0.1476D-02,0.1483D-02,
41625      &0.1489D-02,0.1494D-02,0.1497D-02,0.1499D-02,0.1499D-02,0.1497D-02,
41626      &0.1492D-02,0.1483D-02,0.1471D-02,0.1454D-02,0.1430D-02,0.1398D-02,
41627      &0.1354D-02,0.1291D-02,0.1195D-02,0.1022D-02/
41628       DATA (XPV(I,5,2),I=1,100)/
41629      &0.9523D-02,0.9362D-02,0.9127D-02,0.8821D-02,0.8442D-02,0.7997D-02,
41630      &0.7501D-02,0.7174D-02,0.7029D-02,0.6828D-02,0.6569D-02,0.6258D-02,
41631      &0.5901D-02,0.5579D-02,0.5475D-02,0.5323D-02,0.5125D-02,0.4884D-02,
41632      &0.4606D-02,0.4399D-02,0.4301D-02,0.4162D-02,0.3986D-02,0.3776D-02,
41633      &0.3590D-02,0.3508D-02,0.3391D-02,0.3242D-02,0.3073D-02,0.2992D-02,
41634      &0.2897D-02,0.2777D-02,0.2663D-02,0.2592D-02,0.2499D-02,0.2408D-02,
41635      &0.2344D-02,0.2263D-02,0.2207D-02,0.2144D-02,0.2095D-02,0.2043D-02,
41636      &0.2005D-02,0.1970D-02,0.1939D-02,0.1917D-02,0.1898D-02,0.1891D-02,
41637      &0.1887D-02,0.1891D-02,0.1901D-02,0.1921D-02,0.1948D-02,0.1981D-02,
41638      &0.2025D-02,0.2076D-02,0.2134D-02,0.2204D-02,0.2281D-02,0.2367D-02,
41639      &0.2463D-02,0.2566D-02,0.2678D-02,0.2798D-02,0.2925D-02,0.3060D-02,
41640      &0.3199D-02,0.3347D-02,0.3500D-02,0.3659D-02,0.3827D-02,0.4007D-02,
41641      &0.4203D-02,0.4424D-02,0.4679D-02,0.4981D-02,0.5336D-02,0.5723D-02,
41642      &0.5764D-02,0.5803D-02,0.5840D-02,0.5875D-02,0.5906D-02,0.5934D-02,
41643      &0.5959D-02,0.5978D-02,0.5992D-02,0.6000D-02,0.6000D-02,0.5991D-02,
41644      &0.5971D-02,0.5938D-02,0.5890D-02,0.5821D-02,0.5726D-02,0.5597D-02,
41645      &0.5419D-02,0.5166D-02,0.4781D-02,0.4089D-02/
41646       DATA (XPV(I,5,3),I=1,100)/
41647      &0.7505D-02,0.7347D-02,0.7127D-02,0.6848D-02,0.6508D-02,0.6113D-02,
41648      &0.5677D-02,0.5385D-02,0.5248D-02,0.5065D-02,0.4837D-02,0.4566D-02,
41649      &0.4259D-02,0.3982D-02,0.3881D-02,0.3744D-02,0.3571D-02,0.3365D-02,
41650      &0.3131D-02,0.2953D-02,0.2861D-02,0.2738D-02,0.2589D-02,0.2414D-02,
41651      &0.2257D-02,0.2179D-02,0.2077D-02,0.1952D-02,0.1812D-02,0.1736D-02,
41652      &0.1651D-02,0.1549D-02,0.1451D-02,0.1384D-02,0.1302D-02,0.1222D-02,
41653      &0.1159D-02,0.1086D-02,0.1028D-02,0.9666D-03,0.9136D-03,0.8587D-03,
41654      &0.8123D-03,0.7666D-03,0.7236D-03,0.6846D-03,0.6479D-03,0.6163D-03,
41655      &0.5861D-03,0.5595D-03,0.5354D-03,0.5152D-03,0.4975D-03,0.4824D-03,
41656      &0.4710D-03,0.4620D-03,0.4558D-03,0.4530D-03,0.4527D-03,0.4552D-03,
41657      &0.4601D-03,0.4675D-03,0.4771D-03,0.4889D-03,0.5026D-03,0.5181D-03,
41658      &0.5351D-03,0.5540D-03,0.5746D-03,0.5972D-03,0.6228D-03,0.6525D-03,
41659      &0.6882D-03,0.7329D-03,0.7908D-03,0.8669D-03,0.9668D-03,0.1092D-02,
41660      &0.1106D-02,0.1121D-02,0.1136D-02,0.1150D-02,0.1164D-02,0.1178D-02,
41661      &0.1191D-02,0.1203D-02,0.1214D-02,0.1225D-02,0.1234D-02,0.1242D-02,
41662      &0.1247D-02,0.1250D-02,0.1251D-02,0.1247D-02,0.1239D-02,0.1224D-02,
41663      &0.1199D-02,0.1159D-02,0.1093D-02,0.9633D-03/
41664       DATA (XPV(I,5,4),I=1,100)/
41665      &0.7997D-02,0.7838D-02,0.7615D-02,0.7329D-02,0.6980D-02,0.6573D-02,
41666      &0.6123D-02,0.5823D-02,0.5684D-02,0.5497D-02,0.5261D-02,0.4981D-02,
41667      &0.4662D-02,0.4375D-02,0.4274D-02,0.4134D-02,0.3955D-02,0.3741D-02,
41668      &0.3497D-02,0.3313D-02,0.3221D-02,0.3095D-02,0.2940D-02,0.2758D-02,
41669      &0.2596D-02,0.2518D-02,0.2414D-02,0.2285D-02,0.2140D-02,0.2065D-02,
41670      &0.1981D-02,0.1877D-02,0.1779D-02,0.1715D-02,0.1634D-02,0.1555D-02,
41671      &0.1497D-02,0.1427D-02,0.1376D-02,0.1320D-02,0.1276D-02,0.1229D-02,
41672      &0.1194D-02,0.1161D-02,0.1131D-02,0.1108D-02,0.1089D-02,0.1077D-02,
41673      &0.1069D-02,0.1067D-02,0.1070D-02,0.1080D-02,0.1095D-02,0.1116D-02,
41674      &0.1144D-02,0.1178D-02,0.1218D-02,0.1265D-02,0.1318D-02,0.1378D-02,
41675      &0.1444D-02,0.1516D-02,0.1594D-02,0.1677D-02,0.1764D-02,0.1858D-02,
41676      &0.1954D-02,0.2056D-02,0.2162D-02,0.2275D-02,0.2398D-02,0.2536D-02,
41677      &0.2696D-02,0.2890D-02,0.3134D-02,0.3450D-02,0.3859D-02,0.4365D-02,
41678      &0.4425D-02,0.4485D-02,0.4544D-02,0.4602D-02,0.4658D-02,0.4713D-02,
41679      &0.4765D-02,0.4815D-02,0.4861D-02,0.4903D-02,0.4940D-02,0.4970D-02,
41680      &0.4993D-02,0.5007D-02,0.5008D-02,0.4994D-02,0.4961D-02,0.4900D-02,
41681      &0.4801D-02,0.4642D-02,0.4373D-02,0.3853D-02/
41682       DATA (XPV(I,6,0),I=1,100)/
41683      &0.4823D+00,0.4713D+00,0.4562D+00,0.4371D+00,0.4141D+00,0.3874D+00,
41684      &0.3580D+00,0.3381D+00,0.3284D+00,0.3157D+00,0.3000D+00,0.2816D+00,
41685      &0.2609D+00,0.2422D+00,0.2354D+00,0.2262D+00,0.2147D+00,0.2012D+00,
41686      &0.1860D+00,0.1744D+00,0.1685D+00,0.1606D+00,0.1511D+00,0.1401D+00,
41687      &0.1304D+00,0.1255D+00,0.1192D+00,0.1116D+00,0.1031D+00,0.9852D-01,
41688      &0.9345D-01,0.8740D-01,0.8162D-01,0.7769D-01,0.7289D-01,0.6822D-01,
41689      &0.6457D-01,0.6033D-01,0.5700D-01,0.5343D-01,0.5035D-01,0.4714D-01,
41690      &0.4439D-01,0.4166D-01,0.3905D-01,0.3663D-01,0.3429D-01,0.3219D-01,
41691      &0.3012D-01,0.2819D-01,0.2634D-01,0.2464D-01,0.2300D-01,0.2142D-01,
41692      &0.1997D-01,0.1857D-01,0.1723D-01,0.1600D-01,0.1482D-01,0.1370D-01,
41693      &0.1263D-01,0.1162D-01,0.1065D-01,0.9734D-02,0.8858D-02,0.8020D-02,
41694      &0.7218D-02,0.6455D-02,0.5727D-02,0.5031D-02,0.4372D-02,0.3743D-02,
41695      &0.3148D-02,0.2587D-02,0.2059D-02,0.1563D-02,0.1101D-02,0.6756D-03,
41696      &0.6315D-03,0.5886D-03,0.5468D-03,0.5062D-03,0.4667D-03,0.4284D-03,
41697      &0.3913D-03,0.3553D-03,0.3206D-03,0.2871D-03,0.2547D-03,0.2238D-03,
41698      &0.1942D-03,0.1660D-03,0.1392D-03,0.1139D-03,0.9030D-04,0.6843D-04,
41699      &0.4849D-04,0.3074D-04,0.1557D-04,0.3784D-05/
41700       DATA (XPV(I,6,1),I=1,100)/
41701      &0.1205D-01,0.1178D-01,0.1142D-01,0.1096D-01,0.1041D-01,0.9763D-02,
41702      &0.9053D-02,0.8577D-02,0.8354D-02,0.8057D-02,0.7688D-02,0.7251D-02,
41703      &0.6756D-02,0.6310D-02,0.6149D-02,0.5929D-02,0.5654D-02,0.5325D-02,
41704      &0.4953D-02,0.4670D-02,0.4526D-02,0.4332D-02,0.4097D-02,0.3822D-02,
41705      &0.3577D-02,0.3456D-02,0.3297D-02,0.3102D-02,0.2885D-02,0.2769D-02,
41706      &0.2639D-02,0.2483D-02,0.2333D-02,0.2232D-02,0.2107D-02,0.1985D-02,
41707      &0.1891D-02,0.1781D-02,0.1696D-02,0.1604D-02,0.1526D-02,0.1445D-02,
41708      &0.1377D-02,0.1310D-02,0.1248D-02,0.1192D-02,0.1139D-02,0.1094D-02,
41709      &0.1052D-02,0.1015D-02,0.9816D-03,0.9544D-03,0.9311D-03,0.9114D-03,
41710      &0.8975D-03,0.8872D-03,0.8810D-03,0.8801D-03,0.8830D-03,0.8899D-03,
41711      &0.9007D-03,0.9151D-03,0.9330D-03,0.9541D-03,0.9781D-03,0.1005D-02,
41712      &0.1034D-02,0.1065D-02,0.1099D-02,0.1135D-02,0.1174D-02,0.1217D-02,
41713      &0.1266D-02,0.1323D-02,0.1392D-02,0.1478D-02,0.1581D-02,0.1696D-02,
41714      &0.1708D-02,0.1720D-02,0.1731D-02,0.1741D-02,0.1751D-02,0.1759D-02,
41715      &0.1766D-02,0.1772D-02,0.1776D-02,0.1778D-02,0.1778D-02,0.1775D-02,
41716      &0.1769D-02,0.1759D-02,0.1744D-02,0.1723D-02,0.1695D-02,0.1657D-02,
41717      &0.1604D-02,0.1530D-02,0.1417D-02,0.1218D-02/
41718       DATA (XPV(I,6,2),I=1,100)/
41719      &0.1365D-01,0.1339D-01,0.1302D-01,0.1254D-01,0.1195D-01,0.1127D-01,
41720      &0.1051D-01,0.1001D-01,0.9777D-02,0.9465D-02,0.9073D-02,0.8604D-02,
41721      &0.8069D-02,0.7589D-02,0.7425D-02,0.7195D-02,0.6900D-02,0.6544D-02,
41722      &0.6138D-02,0.5834D-02,0.5686D-02,0.5481D-02,0.5226D-02,0.4925D-02,
41723      &0.4658D-02,0.4536D-02,0.4367D-02,0.4157D-02,0.3918D-02,0.3801D-02,
41724      &0.3667D-02,0.3499D-02,0.3340D-02,0.3241D-02,0.3112D-02,0.2987D-02,
41725      &0.2897D-02,0.2787D-02,0.2709D-02,0.2624D-02,0.2557D-02,0.2487D-02,
41726      &0.2436D-02,0.2387D-02,0.2346D-02,0.2315D-02,0.2290D-02,0.2279D-02,
41727      &0.2273D-02,0.2277D-02,0.2289D-02,0.2313D-02,0.2346D-02,0.2387D-02,
41728      &0.2441D-02,0.2503D-02,0.2575D-02,0.2660D-02,0.2755D-02,0.2859D-02,
41729      &0.2974D-02,0.3099D-02,0.3232D-02,0.3374D-02,0.3523D-02,0.3680D-02,
41730      &0.3841D-02,0.4010D-02,0.4183D-02,0.4363D-02,0.4552D-02,0.4754D-02,
41731      &0.4976D-02,0.5229D-02,0.5526D-02,0.5885D-02,0.6313D-02,0.6782D-02,
41732      &0.6832D-02,0.6879D-02,0.6924D-02,0.6966D-02,0.7004D-02,0.7038D-02,
41733      &0.7067D-02,0.7091D-02,0.7108D-02,0.7117D-02,0.7116D-02,0.7105D-02,
41734      &0.7081D-02,0.7041D-02,0.6982D-02,0.6899D-02,0.6786D-02,0.6631D-02,
41735      &0.6421D-02,0.6123D-02,0.5672D-02,0.4871D-02/
41736       DATA (XPV(I,6,3),I=1,100)/
41737      &0.1167D-01,0.1141D-01,0.1105D-01,0.1060D-01,0.1005D-01,0.9414D-02,
41738      &0.8715D-02,0.8245D-02,0.8024D-02,0.7730D-02,0.7367D-02,0.6937D-02,
41739      &0.6451D-02,0.6013D-02,0.5853D-02,0.5637D-02,0.5366D-02,0.5044D-02,
41740      &0.4680D-02,0.4403D-02,0.4259D-02,0.4069D-02,0.3839D-02,0.3571D-02,
41741      &0.3331D-02,0.3212D-02,0.3055D-02,0.2866D-02,0.2654D-02,0.2540D-02,
41742      &0.2413D-02,0.2260D-02,0.2114D-02,0.2014D-02,0.1892D-02,0.1773D-02,
41743      &0.1680D-02,0.1572D-02,0.1488D-02,0.1398D-02,0.1320D-02,0.1240D-02,
41744      &0.1173D-02,0.1106D-02,0.1044D-02,0.9874D-03,0.9342D-03,0.8881D-03,
41745      &0.8442D-03,0.8052D-03,0.7698D-03,0.7399D-03,0.7134D-03,0.6903D-03,
41746      &0.6722D-03,0.6574D-03,0.6463D-03,0.6397D-03,0.6365D-03,0.6368D-03,
41747      &0.6405D-03,0.6473D-03,0.6570D-03,0.6695D-03,0.6844D-03,0.7019D-03,
41748      &0.7213D-03,0.7431D-03,0.7673D-03,0.7943D-03,0.8253D-03,0.8617D-03,
41749      &0.9063D-03,0.9627D-03,0.1036D-02,0.1133D-02,0.1259D-02,0.1412D-02,
41750      &0.1430D-02,0.1448D-02,0.1465D-02,0.1482D-02,0.1499D-02,0.1514D-02,
41751      &0.1529D-02,0.1543D-02,0.1556D-02,0.1567D-02,0.1576D-02,0.1583D-02,
41752      &0.1587D-02,0.1588D-02,0.1586D-02,0.1578D-02,0.1563D-02,0.1539D-02,
41753      &0.1504D-02,0.1448D-02,0.1358D-02,0.1189D-02/
41754       DATA (XPV(I,6,4),I=1,100)/
41755      &0.1216D-01,0.1189D-01,0.1153D-01,0.1107D-01,0.1051D-01,0.9868D-02,
41756      &0.9154D-02,0.8677D-02,0.8454D-02,0.8157D-02,0.7787D-02,0.7349D-02,
41757      &0.6851D-02,0.6404D-02,0.6244D-02,0.6025D-02,0.5749D-02,0.5420D-02,
41758      &0.5047D-02,0.4764D-02,0.4621D-02,0.4429D-02,0.4195D-02,0.3920D-02,
41759      &0.3677D-02,0.3559D-02,0.3402D-02,0.3211D-02,0.2996D-02,0.2884D-02,
41760      &0.2759D-02,0.2608D-02,0.2463D-02,0.2369D-02,0.2251D-02,0.2138D-02,
41761      &0.2053D-02,0.1952D-02,0.1879D-02,0.1800D-02,0.1736D-02,0.1670D-02,
41762      &0.1619D-02,0.1572D-02,0.1531D-02,0.1498D-02,0.1470D-02,0.1454D-02,
41763      &0.1442D-02,0.1439D-02,0.1442D-02,0.1455D-02,0.1475D-02,0.1502D-02,
41764      &0.1539D-02,0.1584D-02,0.1637D-02,0.1699D-02,0.1769D-02,0.1847D-02,
41765      &0.1934D-02,0.2027D-02,0.2128D-02,0.2235D-02,0.2348D-02,0.2468D-02,
41766      &0.2591D-02,0.2721D-02,0.2857D-02,0.3001D-02,0.3158D-02,0.3333D-02,
41767      &0.3538D-02,0.3788D-02,0.4102D-02,0.4506D-02,0.5022D-02,0.5648D-02,
41768      &0.5720D-02,0.5792D-02,0.5862D-02,0.5931D-02,0.5997D-02,0.6060D-02,
41769      &0.6120D-02,0.6176D-02,0.6226D-02,0.6271D-02,0.6308D-02,0.6337D-02,
41770      &0.6354D-02,0.6359D-02,0.6348D-02,0.6316D-02,0.6257D-02,0.6163D-02,
41771      &0.6019D-02,0.5797D-02,0.5436D-02,0.4755D-02/
41772       DATA (XPV(I,7,0),I=1,100)/
41773      &0.6367D+00,0.6216D+00,0.6010D+00,0.5752D+00,0.5440D+00,0.5081D+00,
41774      &0.4686D+00,0.4418D+00,0.4287D+00,0.4116D+00,0.3907D+00,0.3662D+00,
41775      &0.3385D+00,0.3137D+00,0.3045D+00,0.2923D+00,0.2772D+00,0.2594D+00,
41776      &0.2393D+00,0.2241D+00,0.2163D+00,0.2060D+00,0.1936D+00,0.1792D+00,
41777      &0.1665D+00,0.1602D+00,0.1520D+00,0.1421D+00,0.1311D+00,0.1252D+00,
41778      &0.1187D+00,0.1109D+00,0.1035D+00,0.9842D-01,0.9228D-01,0.8630D-01,
41779      &0.8164D-01,0.7624D-01,0.7200D-01,0.6747D-01,0.6355D-01,0.5948D-01,
41780      &0.5601D-01,0.5255D-01,0.4926D-01,0.4620D-01,0.4326D-01,0.4061D-01,
41781      &0.3801D-01,0.3557D-01,0.3324D-01,0.3109D-01,0.2903D-01,0.2705D-01,
41782      &0.2521D-01,0.2344D-01,0.2175D-01,0.2018D-01,0.1868D-01,0.1725D-01,
41783      &0.1589D-01,0.1460D-01,0.1337D-01,0.1219D-01,0.1107D-01,0.9999D-02,
41784      &0.8975D-02,0.8003D-02,0.7079D-02,0.6199D-02,0.5369D-02,0.4581D-02,
41785      &0.3839D-02,0.3144D-02,0.2492D-02,0.1883D-02,0.1320D-02,0.8054D-03,
41786      &0.7523D-03,0.7006D-03,0.6504D-03,0.6016D-03,0.5543D-03,0.5084D-03,
41787      &0.4640D-03,0.4210D-03,0.3796D-03,0.3397D-03,0.3011D-03,0.2644D-03,
41788      &0.2292D-03,0.1957D-03,0.1640D-03,0.1342D-03,0.1063D-03,0.8046D-04,
41789      &0.5699D-04,0.3611D-04,0.1829D-04,0.4453D-05/
41790       DATA (XPV(I,7,1),I=1,100)/
41791      &0.1667D-01,0.1629D-01,0.1577D-01,0.1511D-01,0.1431D-01,0.1340D-01,
41792      &0.1239D-01,0.1171D-01,0.1139D-01,0.1097D-01,0.1045D-01,0.9835D-02,
41793      &0.9139D-02,0.8514D-02,0.8286D-02,0.7979D-02,0.7594D-02,0.7137D-02,
41794      &0.6621D-02,0.6230D-02,0.6029D-02,0.5762D-02,0.5438D-02,0.5061D-02,
41795      &0.4726D-02,0.4560D-02,0.4342D-02,0.4078D-02,0.3784D-02,0.3626D-02,
41796      &0.3451D-02,0.3240D-02,0.3038D-02,0.2902D-02,0.2735D-02,0.2572D-02,
41797      &0.2446D-02,0.2299D-02,0.2185D-02,0.2064D-02,0.1960D-02,0.1852D-02,
41798      &0.1762D-02,0.1673D-02,0.1591D-02,0.1516D-02,0.1446D-02,0.1386D-02,
41799      &0.1329D-02,0.1278D-02,0.1233D-02,0.1195D-02,0.1162D-02,0.1134D-02,
41800      &0.1113D-02,0.1096D-02,0.1084D-02,0.1078D-02,0.1077D-02,0.1081D-02,
41801      &0.1090D-02,0.1103D-02,0.1119D-02,0.1140D-02,0.1164D-02,0.1191D-02,
41802      &0.1220D-02,0.1253D-02,0.1288D-02,0.1325D-02,0.1367D-02,0.1413D-02,
41803      &0.1466D-02,0.1530D-02,0.1609D-02,0.1708D-02,0.1830D-02,0.1967D-02,
41804      &0.1981D-02,0.1995D-02,0.2008D-02,0.2021D-02,0.2032D-02,0.2042D-02,
41805      &0.2051D-02,0.2058D-02,0.2063D-02,0.2066D-02,0.2066D-02,0.2063D-02,
41806      &0.2057D-02,0.2045D-02,0.2029D-02,0.2005D-02,0.1973D-02,0.1929D-02,
41807      &0.1869D-02,0.1784D-02,0.1655D-02,0.1427D-02/
41808       DATA (XPV(I,7,2),I=1,100)/
41809      &0.1825D-01,0.1787D-01,0.1734D-01,0.1666D-01,0.1584D-01,0.1488D-01,
41810      &0.1382D-01,0.1312D-01,0.1280D-01,0.1236D-01,0.1182D-01,0.1117D-01,
41811      &0.1044D-01,0.9780D-02,0.9550D-02,0.9233D-02,0.8830D-02,0.8348D-02,
41812      &0.7799D-02,0.7387D-02,0.7184D-02,0.6906D-02,0.6565D-02,0.6163D-02,
41813      &0.5808D-02,0.5642D-02,0.5418D-02,0.5140D-02,0.4827D-02,0.4670D-02,
41814      &0.4493D-02,0.4274D-02,0.4067D-02,0.3936D-02,0.3769D-02,0.3607D-02,
41815      &0.3489D-02,0.3347D-02,0.3246D-02,0.3136D-02,0.3050D-02,0.2959D-02,
41816      &0.2893D-02,0.2830D-02,0.2777D-02,0.2736D-02,0.2703D-02,0.2687D-02,
41817      &0.2678D-02,0.2680D-02,0.2693D-02,0.2720D-02,0.2757D-02,0.2805D-02,
41818      &0.2867D-02,0.2940D-02,0.3024D-02,0.3123D-02,0.3233D-02,0.3355D-02,
41819      &0.3489D-02,0.3632D-02,0.3785D-02,0.3948D-02,0.4118D-02,0.4297D-02,
41820      &0.4479D-02,0.4668D-02,0.4863D-02,0.5063D-02,0.5274D-02,0.5499D-02,
41821      &0.5750D-02,0.6038D-02,0.6381D-02,0.6800D-02,0.7306D-02,0.7864D-02,
41822      &0.7924D-02,0.7980D-02,0.8034D-02,0.8085D-02,0.8131D-02,0.8172D-02,
41823      &0.8208D-02,0.8236D-02,0.8258D-02,0.8270D-02,0.8271D-02,0.8259D-02,
41824      &0.8233D-02,0.8188D-02,0.8122D-02,0.8027D-02,0.7897D-02,0.7721D-02,
41825      &0.7480D-02,0.7139D-02,0.6624D-02,0.5709D-02/
41826       DATA (XPV(I,7,3),I=1,100)/
41827      &0.1630D-01,0.1592D-01,0.1540D-01,0.1475D-01,0.1396D-01,0.1305D-01,
41828      &0.1205D-01,0.1138D-01,0.1107D-01,0.1065D-01,0.1013D-01,0.9526D-02,
41829      &0.8839D-02,0.8222D-02,0.7995D-02,0.7690D-02,0.7310D-02,0.6860D-02,
41830      &0.6352D-02,0.5966D-02,0.5766D-02,0.5502D-02,0.5183D-02,0.4813D-02,
41831      &0.4483D-02,0.4318D-02,0.4103D-02,0.3844D-02,0.3555D-02,0.3399D-02,
41832      &0.3225D-02,0.3018D-02,0.2820D-02,0.2685D-02,0.2521D-02,0.2360D-02,
41833      &0.2235D-02,0.2091D-02,0.1978D-02,0.1857D-02,0.1754D-02,0.1647D-02,
41834      &0.1557D-02,0.1468D-02,0.1385D-02,0.1310D-02,0.1239D-02,0.1177D-02,
41835      &0.1118D-02,0.1066D-02,0.1018D-02,0.9774D-03,0.9411D-03,0.9091D-03,
41836      &0.8835D-03,0.8619D-03,0.8450D-03,0.8338D-03,0.8268D-03,0.8242D-03,
41837      &0.8257D-03,0.8312D-03,0.8403D-03,0.8529D-03,0.8686D-03,0.8875D-03,
41838      &0.9087D-03,0.9331D-03,0.9605D-03,0.9915D-03,0.1028D-02,0.1070D-02,
41839      &0.1124D-02,0.1191D-02,0.1279D-02,0.1395D-02,0.1545D-02,0.1725D-02,
41840      &0.1746D-02,0.1766D-02,0.1786D-02,0.1805D-02,0.1823D-02,0.1841D-02,
41841      &0.1857D-02,0.1872D-02,0.1886D-02,0.1897D-02,0.1907D-02,0.1913D-02,
41842      &0.1916D-02,0.1915D-02,0.1909D-02,0.1897D-02,0.1877D-02,0.1846D-02,
41843      &0.1799D-02,0.1729D-02,0.1618D-02,0.1411D-02/
41844       DATA (XPV(I,7,4),I=1,100)/
41845      &0.1678D-01,0.1640D-01,0.1587D-01,0.1522D-01,0.1442D-01,0.1350D-01,
41846      &0.1249D-01,0.1181D-01,0.1149D-01,0.1107D-01,0.1055D-01,0.9935D-02,
41847      &0.9238D-02,0.8611D-02,0.8385D-02,0.8078D-02,0.7694D-02,0.7237D-02,
41848      &0.6721D-02,0.6331D-02,0.6132D-02,0.5867D-02,0.5545D-02,0.5170D-02,
41849      &0.4837D-02,0.4676D-02,0.4462D-02,0.4202D-02,0.3912D-02,0.3761D-02,
41850      &0.3592D-02,0.3388D-02,0.3194D-02,0.3068D-02,0.2911D-02,0.2759D-02,
41851      &0.2646D-02,0.2513D-02,0.2415D-02,0.2310D-02,0.2226D-02,0.2139D-02,
41852      &0.2072D-02,0.2010D-02,0.1955D-02,0.1911D-02,0.1875D-02,0.1852D-02,
41853      &0.1836D-02,0.1830D-02,0.1833D-02,0.1848D-02,0.1872D-02,0.1905D-02,
41854      &0.1950D-02,0.2004D-02,0.2069D-02,0.2145D-02,0.2231D-02,0.2327D-02,
41855      &0.2432D-02,0.2547D-02,0.2669D-02,0.2800D-02,0.2937D-02,0.3082D-02,
41856      &0.3232D-02,0.3389D-02,0.3553D-02,0.3727D-02,0.3917D-02,0.4130D-02,
41857      &0.4378D-02,0.4681D-02,0.5061D-02,0.5547D-02,0.6163D-02,0.6897D-02,
41858      &0.6981D-02,0.7063D-02,0.7144D-02,0.7221D-02,0.7296D-02,0.7367D-02,
41859      &0.7433D-02,0.7494D-02,0.7548D-02,0.7595D-02,0.7632D-02,0.7658D-02,
41860      &0.7671D-02,0.7667D-02,0.7644D-02,0.7595D-02,0.7513D-02,0.7388D-02,
41861      &0.7203D-02,0.6923D-02,0.6476D-02,0.5646D-02/
41862
41863 C..fetching pdfs
41864       DO  5 IP=-6,6
41865         XPDF(IP)=ZEROD
41866  5    CONTINUE
41867       DO 2 I=1,IX
41868         ENT(I)=LOG10(XT(I))
41869   2   CONTINUE
41870       NA(1)=IX
41871       NA(2)=IQ
41872       DO 3 I=1,IQ
41873         ENT(IX+I)=LOG10(Q2T(I))
41874    3  CONTINUE
41875       ARG(1)=LOG10(X)
41876       ARG(2)=LOG10(Q2)
41877 C..various flavours (u-->2,d-->1)
41878       XPDF(0)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,0))
41879       XPDF(1)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,1))
41880       XPDF(2)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,2))
41881       XPDF(3)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,3))
41882       XPDF(4)=PHO_DBFINT(NARG,ARG,NA,ENT,XPV(1,1,4))
41883       DO 21 JF=1,4
41884         XPDF(-JF)=XPDF(JF)
41885  21   CONTINUE
41886
41887       END
41888
41889 *$ CREATE PHO_DBFINT.FOR
41890 *COPY PHO_DBFINT
41891 CDECK  ID>, PHO_DBFINT
41892       DOUBLE PRECISION FUNCTION PHO_DBFINT(NARG,ARG,NA,ENT,TABLE)
41893 C***********************************************************************
41894 C
41895 C     routine based on CERN library E104
41896 C
41897 C     multi-dimensional interpolation routine, needed for PHOJET
41898 C     internal cross section tables and several PDF sets (GRV98 and AGL)
41899 C
41900 C     changed to avoid recursive function calls (R.Engel, 09/98)
41901 C
41902 C***********************************************************************
41903       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
41904       SAVE
41905
41906       INTEGER NA(NARG), INDEX(32)
41907       DOUBLE PRECISION ARG(NARG),ENT(NARG),TABLE(*),WEIGHT(32)
41908
41909       DATA ZEROD/0.D0/
41910       DATA ONED/1.D0/
41911
41912       DBFINT    =  ZEROD
41913       PHO_DBFINT =  ZEROD
41914       IF(NARG .LT. 1  .OR.  NARG .GT. 5)  RETURN
41915
41916            LMAX      =  0
41917            ISTEP     =  1
41918            KNOTS     =  1
41919            INDEX(1)  =  1
41920            WEIGHT(1) =  ONED
41921            DO 100    N  =  1, NARG
41922               X     =  ARG(N)
41923               NDIM  =  NA(N)
41924               LOCA  =  LMAX
41925               LMIN  =  LMAX + 1
41926               LMAX  =  LMAX + NDIM
41927               IF(NDIM .GT. 2)  GOTO 10
41928               IF(NDIM .EQ. 1)  GOTO 100
41929               H  =  X - ENT(LMIN)
41930               IF(H .EQ. ZEROD)  GOTO 90
41931               ISHIFT  =  ISTEP
41932               IF(X-ENT(LMIN+1) .EQ. ZEROD)  GOTO 21
41933               ISHIFT  =  0
41934               ETA     =  H / (ENT(LMIN+1) - ENT(LMIN))
41935               GOTO 30
41936    10         LOCB  =  LMAX + 1
41937    11         LOCC  =  (LOCA+LOCB) / 2
41938               IF(X-ENT(LOCC))  12, 20, 13
41939    12         LOCB  =  LOCC
41940               GOTO 14
41941    13         LOCA  =  LOCC
41942    14         IF(LOCB-LOCA .GT. 1)  GOTO 11
41943               LOCA    =  MIN ( MAX (LOCA,LMIN), LMAX-1 )
41944               ISHIFT  =  (LOCA - LMIN) * ISTEP
41945               ETA     =  (X - ENT(LOCA)) / (ENT(LOCA+1) - ENT(LOCA))
41946               GOTO 30
41947    20         ISHIFT  =  (LOCC - LMIN) * ISTEP
41948    21         DO 22  K  =  1, KNOTS
41949                  INDEX(K)  =  INDEX(K) + ISHIFT
41950    22         CONTINUE
41951               GOTO 90
41952    30         DO 31  K  =  1, KNOTS
41953                  INDEX(K)         =  INDEX(K) + ISHIFT
41954                  INDEX(K+KNOTS)   =  INDEX(K) + ISTEP
41955                  WEIGHT(K+KNOTS)  =  WEIGHT(K) * ETA
41956                  WEIGHT(K)        =  WEIGHT(K) - WEIGHT(K+KNOTS)
41957    31         CONTINUE
41958               KNOTS  =  2*KNOTS
41959    90         ISTEP  =  ISTEP * NDIM
41960   100      CONTINUE
41961            DO 200    K  =  1, KNOTS
41962               I  =  INDEX(K)
41963               DBFINT =  DBFINT + WEIGHT(K) * TABLE(I)
41964   200      CONTINUE
41965
41966       PHO_DBFINT = DBFINT
41967
41968       END
41969
41970 *$ CREATE PHVAL.FOR
41971 *COPY PHVAL
41972 CDECK  ID>, PHVAL
41973       SUBROUTINE PHVAL(IGRP,ISET,XI,SCALE2,PD,IRET)
41974 C**********************************************************************
41975 C
41976 C   dummy subroutine, remove to link PHOLIB
41977 C
41978 C**********************************************************************
41979       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
41980       DIMENSION PD(-6:6)
41981       END